Program Fractal;

{$ApplName Fractal}
{$R *.bin}

Uses Window, Form, Menu, Rect, Crt, Event, SysEvent, SystemMgr, HSUtils;

Const
  Color = 1;
  NumIts = 30000;
  MaxColor = 65000;
  MaxLines = 4;
  MaxFractal = 5;
  DevXMax = 160;
  DevYMax = 160;
  MenuAbout = 1001;
  AlertAbout  = 1022;
  MenuMain  = 1000;

Type
  String2 = String[2];
  FractalSetRecord =
    Array [ 1 .. MaxLines ] of Record  A, B, C, D, E, F, P : Real;  End;
  WindowRecord =
    Record  X1, Y1, X2, Y2 : Real;  End;
  FractalDataRecord =
    Record
      Lines : Byte;
      Name : String[ 80 ];
      W : WindowRecord;
      FR : FractalSetRecord;
    End;

Var
  FractalData : FractalDataRecord;
  Result, PrevY : Integer;
  WorldX1, WorldY1, WorldX2, WorldY2, WorldXFactor, WorldYFactor : Real;
  FrcX, FrcY : Real;
  FractalNum, PrevFractalNum : Byte;
  CD : Array [ 1 .. MaxFractal ] of FractalDataRecord;
  WorkRect: RectangleType;
  Event: EventType;

{---------------------------------------------------------------------------}

Procedure SetupConstData;
  Begin
    CD[1].Lines := 4;  CD[1].Name := 'COMET';
    CD[1].W.X1 := 0.0; CD[1].W.Y1 := 0.0; CD[1].W.X2 := 18.0; CD[1].W.Y2 := 9.0;
    CD[1].FR[1].A := 0.0; CD[1].FR[1].B := 0.0; CD[1].FR[1].C := 0.0; CD[1].FR[1].D := 0.0; CD[1].FR[1].E := 1.0; CD[1].FR[1].F := 0.0; CD[1].FR[1].P := 0.01;
    CD[1].FR[2].A := 0.85; CD[1].FR[2].B := 0.4; CD[1].FR[2].C := -0.04; CD[1].FR[2].D := 0.85; CD[1].FR[2].E := 0.0; CD[1].FR[2].F := 1.6; CD[1].FR[2].P := 0.85;
    CD[1].FR[3].A := 0.2; CD[1].FR[3].B := -0.26; CD[1].FR[3].C := 0.23; CD[1].FR[3].D := 0.22; CD[1].FR[3].E := 0.0; CD[1].FR[3].F := 1.6; CD[1].FR[3].P := 0.07;
    CD[1].FR[4].A := -0.15; CD[1].FR[4].B := 0.28; CD[1].FR[4].C := 0.26; CD[1].FR[4].D := 0.24; CD[1].FR[4].E := 0.0; CD[1].FR[4].F := 0.44; CD[1].FR[4].P := 0.07;
    CD[2].Lines := 4;  CD[2].Name := 'FERN';
    CD[2].W.X1 := -5.0; CD[2].W.Y1 := 0.0; CD[2].W.X2 := 4.0; CD[2].W.Y2 := 12.0;
    CD[2].FR[1].A := 0.0; CD[2].FR[1].B := 0.0; CD[2].FR[1].C := 0.0; CD[2].FR[1].D := 0.0; CD[2].FR[1].E := 1.0; CD[2].FR[1].F := 0.0; CD[2].FR[1].P := 0.01;
    CD[2].FR[2].A := 0.85; CD[2].FR[2].B := -0.03; CD[2].FR[2].C := 0.03; CD[2].FR[2].D := 0.85; CD[2].FR[2].E := 0.0; CD[2].FR[2].F := 1.6; CD[2].FR[2].P := 0.85;
    CD[2].FR[3].A := 0.2; CD[2].FR[3].B := -0.26; CD[2].FR[3].C := 0.23; CD[2].FR[3].D := 0.22; CD[2].FR[3].E := 0.0; CD[2].FR[3].F := 1.6; CD[2].FR[3].P := 0.07;
    CD[2].FR[4].A := -0.15; CD[2].FR[4].B := 0.28; CD[2].FR[4].C := 0.26; CD[2].FR[4].D := 0.24; CD[2].FR[4].E := 0.0; CD[2].FR[4].F := 0.44; CD[2].FR[4].P := 0.07;
    CD[3].Lines := 4;  CD[3].Name := 'NEBULA';
    CD[3].W.X1 := -0.15; CD[3].W.Y1 := -0.2; CD[3].W.X2 := 0.57; CD[3].W.Y2 := 0.57;
    CD[3].FR[1].A := 0.1; CD[3].FR[1].B := 0.42; CD[3].FR[1].C := -0.42; CD[3].FR[1].D := 0.5; CD[3].FR[1].E := 0.1; CD[3].FR[1].F := 0.0; CD[3].FR[1].P := 0.1;
    CD[3].FR[2].A := 0.42; CD[3].FR[2].B := -0.42; CD[3].FR[2].C := 0.42; CD[3].FR[2].D := 0.42; CD[3].FR[2].E := 0.1; CD[3].FR[2].F := 0.2; CD[3].FR[2].P := 0.42;
    CD[3].FR[3].A := 0.42; CD[3].FR[3].B := 0.42; CD[3].FR[3].C := -0.42; CD[3].FR[3].D := 0.42; CD[3].FR[3].E := 0.2; CD[3].FR[3].F := 0.2; CD[3].FR[3].P := 0.42;
    CD[3].FR[4].A := 0.1; CD[3].FR[4].B := 0.0; CD[3].FR[4].C := 0.0; CD[3].FR[4].D := 0.1; CD[3].FR[4].E := 0.0; CD[3].FR[4].F := 0.2; CD[3].FR[4].P := 0.06;
    CD[4].Lines := 4;  CD[4].Name := 'SNAILS';
    CD[4].W.X1 := -4.5; CD[4].W.Y1 := 0.0; CD[4].W.X2 := 1.5; CD[4].W.Y2 := 4.0;
    CD[4].FR[1].A := 0.0; CD[4].FR[1].B := 0.0; CD[4].FR[1].C := 0.0; CD[4].FR[1].D := 0.0; CD[4].FR[1].E := 1.0; CD[4].FR[1].F := 0.0; CD[4].FR[1].P := 0.01;
    CD[4].FR[2].A := 0.74; CD[4].FR[2].B := -0.43; CD[4].FR[2].C := 0.43; CD[4].FR[2].D := 0.74; CD[4].FR[2].E := 0.0; CD[4].FR[2].F := 1.6; CD[4].FR[2].P := 0.85;
    CD[4].FR[3].A := 0.2; CD[4].FR[3].B := -0.26; CD[4].FR[3].C := 0.23; CD[4].FR[3].D := 0.22; CD[4].FR[3].E := 0.0; CD[4].FR[3].F := 1.6; CD[4].FR[3].P := 0.07;
    CD[4].FR[4].A := -0.15; CD[4].FR[4].B := 0.28; CD[4].FR[4].C := 0.26; CD[4].FR[4].D := 0.24; CD[4].FR[4].E := 0.0; CD[4].FR[4].F := 0.44; CD[4].FR[4].P := 0.07;
    CD[5].Lines := 4;  CD[5].Name := 'TREE';
    CD[5].W.X1 := -0.3; CD[5].W.Y1 := 0.0; CD[5].W.X2 := 0.3; CD[5].W.Y2 := 0.5;
    CD[5].FR[1].A := 0.0; CD[5].FR[1].B := 0.0; CD[5].FR[1].C := 0.0; CD[5].FR[1].D := 0.5; CD[5].FR[1].E := 0.0; CD[5].FR[1].F := 0.0; CD[5].FR[1].P := 0.05;
    CD[5].FR[2].A := 0.42; CD[5].FR[2].B := -0.42; CD[5].FR[2].C := 0.42; CD[5].FR[2].D := 0.42; CD[5].FR[2].E := 0.0; CD[5].FR[2].F := 0.2; CD[5].FR[2].P := 0.4;
    CD[5].FR[3].A := 0.42; CD[5].FR[3].B := 0.42; CD[5].FR[3].C := -0.42; CD[5].FR[3].D := 0.42; CD[5].FR[3].E := 0.0; CD[5].FR[3].F := 0.2; CD[5].FR[3].P := 0.4;
    CD[5].FR[4].A := 0.1; CD[5].FR[4].B := 0.0; CD[5].FR[4].C := 0.0; CD[5].FR[4].D := 0.1; CD[5].FR[4].E := 0.0; CD[5].FR[4].F := 0.2; CD[5].FR[4].P := 0.15;
  End;

{---------------------------------------------------------------------------}

Procedure SetWorld( InX1, InY1, InX2, InY2 : Real );
  Begin
    WorldX1 := InX1;  WorldY1 := InY1;  WorldX2 := InX2;  WorldY2 := InY2;
    WorldXFactor := DevXMax / ( WorldX2 - WorldX1 );
    WorldYFactor := DevYMax / ( WorldY2 - WorldY1 );
  End;

{---------------------------------------------------------------------------}

Procedure Plot( X, Y, C : LongInt );
  Begin
    Result := WinSetForeColor(C);
    WinDrawPixel(X,Y);
  End;

{----------------------------------------------------------------}

Function GetDot( X, Y : LongInt ) : LongInt;
  Begin
    GetDot := WinGetPixel(X,Y);
  End;

{----------------------------------------------------------------}

Procedure SetDot( X, Y : Real );
  Var
    Color : LongInt;
  Begin
    If ( X >= WorldX1 ) and ( X <= WorldX2 ) and
       ( Y >= WorldY1 ) and ( Y <= WorldY2 ) Then
      Begin
        X := ( X - WorldX1 ) * WorldXFactor;
        Y := ( DevYMax - 1 ) - ( Y - WorldY1 ) * WorldYFactor;
        Color := GetDot( Trunc( X ), Trunc( Y ) );
        If Color < MaxColor Then Color := Trunc( (Color + 1) * 1.5 );
        Plot( Trunc( X ), Trunc( Y ), Color )
      End;
  End;

{---------------------------------------------------------------------------}

Procedure Iterate;
  Var
    Delta : Byte;
    R, Prob, NewX, NewY : Real;
  Begin
    With FractalData do
      Begin
        R := Random;  Prob := FR[ 1 ].P;  Delta := 1;
        While ( R > Prob ) and ( Delta < Lines ) do
          Begin
            Inc( Delta );
            Prob := Prob + FR[ Delta ].P;
          End;
        With FR[ Delta ] do
          Begin
            NewX := A * FrcX + B * FrcY + E;
            NewY := C * FrcX + D * FrcY + F;
          End;
        FrcX := NewX;  FrcY := NewY;
        SetDot( FrcX, FrcY );
      End;
  End;

{---------------------------------------------------------------------------}

Procedure Generate;
  Var
    BurstIt : LongInt;
    ItLoop : LongInt;
    BResult : Boolean;
  Const
    BurstSize = 100;
  Begin
    FrcX := 0.0;  FrcY := 0.0;
    SetWorld( FractalData.W.X1, FractalData.W.Y1,
              FractalData.W.X2, FractalData.W.Y2 );
    ItLoop := 1;
    While ( ItLoop <= NumIts ) do
      Begin
        For BurstIt := 1 to BurstSize do Iterate;
        EvtGetEvent(Event, 5);
        if (Event.eType = 21) Then
          Result := FrmAlert(AlertAbout)
        Else
          BResult := SysHandleEvent(Event);
        If (Event.eType = appStopEvent) Then Exit;
        ItLoop := ItLoop + BurstSize;
      End;
  End;

{---------------------------------------------------------------------------}

Resource
(ResTAIN,1000,'Fractal');
(Restver,1000,'1.0');

Begin
  Randomize;
  RctSetRectangle(WorkRect, 0, 0, 160, 160);
  SetupConstData;
  FractalNum := 0;
  While True Do
    Begin
      PrevFractalNum := FractalNum;
      Repeat
        FractalNum := Trunc(1 + ( MaxFractal * Random));
      Until (FractalNum <> PrevFractalNum);
      WinEraseRectangle(WorkRect, 0);
      FractalData := CD[ FractalNum ];
      GotoXY(1,1);
      WriteLn('Fractals by Andrew@Bedno.com');
      GotoXY(16,16);
      Write(FractalData.Name);
      Generate;
      If (Event.eType=appStopEvent) Then Exit;
    End;
End.