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

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.