Советы по Delphi

       

Рисование фрактальных графов


Здравствуйте, Валентин!

...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 1995 год). Теоретически она производит трансляцию L-систем с выводом образовавшихся фрактальных графов, а практически рисует кусты и деревья. Вроде бесполезно, но очень красиво. Эта программа написана для TP7, хотя легко переносится на Delphi (как то я уже переводил ее, но модуль бесследно исчез). Буду надеяться, что она придется Вам по душе.

Uses graph, crt;
Const
GrafType = 1; {1..3}Type
PointPtr = ^Point;Point = RecordX, Y : Word;Angle : Real;Next : PointPtrEnd;GrfLine = Array [0..5000] OfByte;ChangeType = Array [1..30] OfRecordMean : Char;NewString : StringEnd;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) ThenExit;I := 1;While I <= GrafLength DoBeginIf Chr (Stroka [I]) = OldChar ThenBeginFor J := GrafLength DownTo I + 1 DoStroka [J + Length (Repl) - 1] := Stroka [J];For J := 1 To Length (Repl) DoStroka [I + J - 1] := Ord (Repl [J]);I := I + J;GrafLength := GrafLength + Length (Repl) - 1;continueEnd;I := I + 1EndEnd;

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 := PEnd;

Procedure PopCoord (Var Ptr : PointPtr;
Var Res : Point);Begin
If
Ptr <> Nil ThenBeginRes.X := Ptr^.X;Res.Y := Ptr^.Y;Res.Angle := Ptr^.Angle;Ptr := Ptr^.NextEndEnd;

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 ThenAngle := Angle + AngleStepElseAngle := Angle - AngleStep;If Angle >= 4 * Pi ThenAngle := Angle - 4 * Pi;If Angle < 0 ThenAngle := 4 * Pi + AngleEnd;

Procedure Rost (Var Descr : GrfLine;
Cn : Byte;Ch : ChangeType);Var I : Byte;
Begin
For
I := 1 To Cn DoReplace (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] DoBeginMean := '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] DoBeginMean := 'G';NewString := 'GFX[+G][-G]'End;With Changes [2] DoBeginMean := '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] DoBeginMean := 'S';NewString := '[+++G][---G]TS'End;With Changes [2] DoBeginMean := 'G';NewString := '+H[-G]L'End;With Changes [3] DoBeginMean := 'H';NewString := '-G[+H]L'End;With Changes [4] DoBeginMean := 'T';NewString := 'TL'End;With Changes [5] DoBeginMean := 'L';NewString := '[-FFF][+FFF]F'End;End;

Begin
Case
GrafType Of1 : Init1;2 : Init2;3 : Init3;ElseEnd;grDriver := detect;InitGraph (grDriver, grMode, '');ErrCode := GraphResult;If ErrCode <> grOk ThenBeginWriteLn ('Graphics error:', GraphErrorMsg (ErrCode) );Halt (1)End;With CurPosition DoBeginX := GetMaxX Div 2;Y := GetMaxY;Angle := 0;MoveTo (X, Y)End;SetColor (white);For K := 1 To Generation DoBeginRost (Descript, ChangeNumber, Changes);Mark (Mem);For T := 1 To GrafLength DoBeginCase Chr (Descript [T]) Of'F' : BeginFindGrafCoord (Dx, Dy, CurPosition.Angle, StepLength);With CurPosition DoBeginXt := X + Dx;If Xt < 0 ThenX := 0ElseX := Xt;If X > GetMaxX ThenX := GetMaxX;Xt := Y + Dy;If Xt < 0 ThenY := 0ElseY := Xt;If Y > GetMaxY ThenY := GetMaxY;LineTo (X, Y)EndEnd;'f' : BeginFindGrafCoord (Dx, Dy, CurPosition.Angle, StepLength);With CurPosition DoBeginXt := X + Dx;If Xt < 0 ThenX := 0ElseX := Xt;If X > GetMaxX ThenX := GetMaxX;Xt := Y + Dy;If Xt < 0 ThenY := 0ElseY := Xt;If Y > GetMaxY ThenY := GetMaxY;MoveTo (X, Y)EndEnd;'+' : NewAngle (1, CurPosition.Angle, AngleStep);'-' : NewAngle ( - 1, CurPosition.Angle, AngleStep);'I' : NewAngle (1, CurPosition.Angle, 2 * Pi);'[' : PushCoord (CurPosition.Next, CurPosition);']' : BeginPopCoord (CurPosition.Next, CurPosition);With CurPosition DoMoveTo (X, Y)EndEndEnd;Dispose (Mem);Delay (1000)End;RepeatUntil KeyPressed;CloseGraphEnd.

С наилучшими пожеланиями,
Михаил Марковский
[000469]



Содержание раздела