TurboPascal 7

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

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

...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 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;

Dispose (Mem);

Delay (1000)

End;

Repeat

Until KeyPressed;

CloseGraph

End.

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