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.
|
Рисование фрактальных графов