Советы по Delphi
Рисование фрактальных графов
Здравствуйте, Валентин!
...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 1995 год). Теоретически она производит трансляцию L-систем с выводом образовавшихся фрактальных графов, а практически рисует кусты и деревья. Вроде бесполезно, но очень красиво. Эта программа написана для TP7, хотя легко переносится на Delphi (как то я уже переводил ее, но модуль бесследно исчез). Буду надеяться, что она придется Вам по душе.
|
Uses graph, crt; Const GrafType = 1; {1..3} Type PointPtr = ^Point; Point = Record X, Y : Word; Angle : Real; Next : PointPtr End; GrfLine = Array [0..5000] Of Byte; ChangeType = Array [1..30] Of Record Mean : Char; NewString : String End; Var K, T, Dx, Dy, StepLength, GrafLength : Word; grDriver, Xt : Integer; grMode : Integer; ErrCode : Integer; CurPosition : Point; Descript : GrfLine; StartLine : String Absolute Descript; ChangeNumber, Generation : Byte; Changes : ChangeType; AngleStep : Real; Mem : Pointer; Procedure Replace (Var Stroka : GrfLine; OldChar : Char; Repl : String); Var I, J : Word; Begin If (GrafLength = 0) Or (Length (Repl) = 0) Then Exit; I := 1; While I <= GrafLength Do Begin If Chr (Stroka [I]) = OldChar Then Begin For J := GrafLength DownTo I + 1 Do Stroka [J + Length (Repl) - 1] := Stroka [J]; For J := 1 To Length (Repl) Do Stroka [I + J - 1] := Ord (Repl [J]); I := I + J; GrafLength := GrafLength + Length (Repl) - 1; continue End; I := I + 1 End End; Procedure PushCoord (Var Ptr : PointPtr; C : Point); Var P : PointPtr; Begin New (P); P^.X := C.X; P^.Y := C.Y; P^.Angle := C.Angle; P^.Next := Ptr; Ptr := P End; Procedure PopCoord (Var Ptr : PointPtr; Var Res : Point); Begin If Ptr <> Nil Then Begin Res.X := Ptr^.X; Res.Y := Ptr^.Y; Res.Angle := Ptr^.Angle; Ptr := Ptr^.Next End End; Procedure FindGrafCoord (Var Dx, Dy : Word; Angle : Real; StepLength : Word); Begin Dx := Round (Sin (Angle) * StepLength * GetMaxX / GetMaxY); Dy := Round ( - Cos (Angle) * StepLength); End; Procedure NewAngle (Way : ShortInt; Var Angle : Real; AngleStep : Real); Begin If Way >= 0 Then Angle := Angle + AngleStep Else Angle := Angle - AngleStep; If Angle >= 4 * Pi Then Angle := Angle - 4 * Pi; If Angle < 0 Then Angle := 4 * Pi + Angle End; Procedure Rost (Var Descr : GrfLine; Cn : Byte; Ch : ChangeType); Var I : Byte; Begin For I := 1 To Cn Do Replace (Descr, Ch [I] .Mean, Ch [I] .NewString); End; Procedure Init1; Begin AngleStep := Pi / 8; StepLength := 7; Generation := 4; ChangeNumber := 1; CurPosition.Next := Nil; StartLine := 'F'; GrafLength := Length (StartLine); With Changes [1] Do Begin Mean := 'F'; NewString := 'FF+[+F-F-F]-[-F+F+F]' End; End; Procedure Init2; Begin AngleStep := Pi / 4; StepLength := 3; Generation := 5; ChangeNumber := 2; CurPosition.Next := Nil; StartLine := 'G'; GrafLength := Length (StartLine); With Changes [1] Do Begin Mean := 'G'; NewString := 'GFX[+G][-G]' End; With Changes [2] Do Begin Mean := 'X'; NewString := 'X[-FFF][+FFF]FX' End; End; Procedure Init3; Begin AngleStep := Pi / 10; StepLength := 9; Generation := 5; ChangeNumber := 5; CurPosition.Next := Nil; StartLine := 'SLFF'; GrafLength := Length (StartLine); With Changes [1] Do Begin Mean := 'S'; NewString := '[+++G][---G]TS' End; With Changes [2] Do Begin Mean := 'G'; NewString := '+H[-G]L' End; With Changes [3] Do Begin Mean := 'H'; NewString := '-G[+H]L' End; With Changes [4] Do Begin Mean := 'T'; NewString := 'TL' End; With Changes [5] Do Begin Mean := 'L'; NewString := '[-FFF][+FFF]F' End; End; Begin Case GrafType Of 1 : Init1; 2 : Init2; 3 : Init3; Else End; grDriver := detect; InitGraph (grDriver, grMode, ''); ErrCode := GraphResult; If ErrCode <> grOk Then Begin WriteLn ('Graphics error:', GraphErrorMsg (ErrCode) ); Halt (1) End; With CurPosition Do Begin X := GetMaxX Div 2; Y := GetMaxY; Angle := 0; MoveTo (X, Y) End; SetColor (white); For K := 1 To Generation Do Begin Rost (Descript, ChangeNumber, Changes); Mark (Mem); For T := 1 To GrafLength Do Begin Case Chr (Descript [T]) Of 'F' : Begin FindGrafCoord (Dx, Dy, CurPosition.Angle, StepLength); With CurPosition Do Begin Xt := X + Dx; If Xt < 0 Then X := 0 Else X := Xt; If X > GetMaxX Then X := GetMaxX; Xt := Y + Dy; If Xt < 0 Then Y := 0 Else Y := Xt; If Y > GetMaxY Then Y := GetMaxY; LineTo (X, Y) End End; 'f' : Begin FindGrafCoord (Dx, Dy, CurPosition.Angle, StepLength); With CurPosition Do Begin Xt := X + Dx; If Xt < 0 Then X := 0 Else X := Xt; If X > GetMaxX Then X := GetMaxX; Xt := Y + Dy; If Xt < 0 Then Y := 0 Else Y := Xt; If Y > GetMaxY Then Y := GetMaxY; MoveTo (X, Y) End End; '+' : NewAngle (1, CurPosition.Angle, AngleStep); '-' : NewAngle ( - 1, CurPosition.Angle, AngleStep); 'I' : NewAngle (1, CurPosition.Angle, 2 * Pi); '[' : PushCoord (CurPosition.Next, CurPosition); ']' : Begin PopCoord (CurPosition.Next, CurPosition); With CurPosition Do MoveTo (X, Y) End End End; Dispose (Mem); Delay (1000) End; Repeat Until KeyPressed; CloseGraph End. |
С наилучшими пожеланиями,
Михаил Марковский
mrkvsky@chem.kubsu.ru
[000469]
