{$M 65520,0,655360}	{Needed to increase stack size for recursion}

Program Fractal;

(*
 * Jonathan Senning
 * Shepherd College
 * April 26, 1993
 *
 * This program uses the NDC graphics package and displays fractal
 * patterns based on segment replacement to some level.  The default
 * pattern is the Koch Snowflake, but other patterns for the Initiator
 * and the Generator can be entered using the mouse.
 *)

Uses
    NDC;

Const
    SIDE	= 0.8;	{Length of sides of default Koch snowflake}
    MENU	= '(F)ile, (G)enerator, (I)nitiator, (Q)uit or 0 thru 9';

Type
    Vector	= Array [1..3] of Real;
    Matrix	= Array [1..3, 1..3] of Real;

Var
    Device	: DeviceType;
    TrMatrix	: Matrix;
    Generator	: VertexList;
    Initiator	: VertexList;
    KeyMeasure	: KeyboardMeasure;
    LocMeasure	: LocatorMeasure;
    Width	: Coordinate;
    Height	: Coordinate;
    Descent	: Coordinate;
    Done	: Boolean;
    I		: Integer;
    N_Initiator	: Integer;
    N_Generator	: Integer;
    Depth	: Integer;

(*-------------------------------------------------------------------------*)

Procedure Matrix_Multiply (A, B : Matrix ; Var C : Matrix);

(*
 * Forms the matrix product C = A B where A, B and C are 3x3 matrices.
 *)

Var
    I, J, K	: Integer;

Begin
    For I := 1 to 3 do
	For J := 1 to 3 do Begin
	    C[I,J] := 0.0;
	    For K := 1 to 3 do
		C[I,J] := C[I,J] + A[I,K] * B[K,J];
	End; {For}
End; {Matrix_Multiply}

(*-------------------------------------------------------------------------*)

Procedure Initialize_Transformation_Matrix (Var M : Matrix);

(*
 * Produces a 3x3 identity matrix.
 *)

Var
    I, J	: Integer;

Begin
    For J := 1 to 3 do Begin
	For I := 1 to 3 do
	    M[I,J] := 0.0;
	M[J,J] := 1.0;
    End; {For}
End; {Initialize_Transformation_Matrix}

(*-------------------------------------------------------------------------*)

Procedure Accumulate_Transformation_Matrix (
		Xf, Yf, Sx, Sy, Xr, Yr, A, Tx, Ty : Real; Var M : Matrix);

(*
 * Accumulates a transformation matrix as described on page 120 of
 * "Computer Graphics" by Hearn & Baker, Prentice-Hall, 1986.
 *
 * The order of operations is
 *	1. Scale by Sx and Sy about the fixed point (Xf, Yf).
 *	2. Rotate by angle A about (Xr, Yr)
 *			(A > 0 gives counterclockwise rotation).
 *	3. Translate by amount Tx and Ty.
 *)

Var
    Scale	: Matrix;
    Rotate	: Matrix;
    Translate	: Matrix;
    CosA, SinA	: Real;

Begin
    Initialize_Transformation_Matrix (Scale);
    Initialize_Transformation_Matrix (Rotate);
    Initialize_Transformation_Matrix (Translate);
    Scale[1,1] := Sx;
    Scale[2,2] := Sy;
    Scale[3,1] := (1.0 - Sx) * Xf;
    Scale[3,2] := (1.0 - Sy) * Yf;
    CosA := Cos(A);
    SinA := Sin(A);
    Rotate[1,1] := CosA;
    Rotate[2,2] := CosA;
    Rotate[1,2] := SinA;
    Rotate[2,1] := -SinA;
    Rotate[3,1] := (1.0 - CosA) * Xr + SinA * Yr;
    Rotate[3,2] := (1.0 - CosA) * Yr - SinA * Xr;
    Translate[3,1] := Tx;
    Translate[3,2] := Ty;
    Matrix_Multiply (M, Scale, M);
    Matrix_Multiply (M, Rotate, M);
    Matrix_Multiply (M, Translate, M);
End; {Accumulate_Transformation_Matrix}

(*-------------------------------------------------------------------------*)

Procedure Create_Transformation_Matrix (
		Xf, Yf, Sx, Sy, Xr, Yr, A, Tx, Ty : Real; Var M : Matrix);

(*
 * Creates a new transformation matrix.
 * See Accumulate_Transformation_Matrix.
 *)

Begin
    Initialize_Transformation_Matrix (M);
    Accumulate_Transformation_Matrix (Xf, Yf, Sx, Sy, Xr, Yr, A, Tx, Ty, M);
End; {Create_Transformation_Matrix}

(*-------------------------------------------------------------------------*)

Procedure Do_Transformation (Var Pnew : Point; Pold : Point; M : Matrix);

(*
 * Performs the transformation specified by the matrix M on the point Pold
 * yielding the new point Pnew.
 *)

Begin
    Pnew.X := M[1,1] * Pold.X + M[2,1] * Pold.Y + M[3,1];
    Pnew.Y := M[1,2] * Pold.X + M[2,2] * Pold.Y + M[3,2];
End; {Do_Transformation}

(*-------------------------------------------------------------------------*)

Procedure Scale_Generator (N : Integer; Var G : VertexList);

Var
    Dx, Dy	: Real;
    D, A	: Real;
    M		: Matrix;
    I		: Integer;

Begin
    Dx := G[N].X - G[1].X;
    Dy := G[N].Y - G[1].Y;
    D := 1.0/Sqrt(Sqr(Dx) + Sqr(Dy));
    If Dx = 0.0 then
	A := Abs(Dy)*Pi/(2*Dy)
    Else
	A := ArcTan(Dy / Dx);
    If Dx < 0.0 then
	A := Pi + A;
    With G[1] do
	Create_Transformation_Matrix (X, Y, D, D, X, Y, -A, -X, -Y, M);
    For I := 1 to N do
	Do_Transformation (G[I], G[I], M);
End; {Scale_Generator}

(*-------------------------------------------------------------------------*)

Procedure Get_File_Name (Prompt : String; P : Point; Var Name : String);

(*
 * This procedure is crude.  It displays a prompt and then reads a string
 * which may only consist of letters, numbers and a period.  If a backspace
 * (ascii 8) is typed the last character in the string (if any) is removed.
 * Input continues until a carrage return (ascii 13) is entered.
 *)

Var
    OldColor	: Integer;
    Position	: Point;
    Width	: Coordinate;
    Height	: Coordinate;
    Descent	: Coordinate;
    KeyMeasure	: KeyboardMeasure;
    LocMeasure	: LocatorMeasure;

Begin
    NDC_ClearDisplay;
    NDC_SetColor (WHITE);
    NDC_InquireTextExtent (Prompt, Width, Height, Descent);
    NDC_TextCoord (P.X+Width/2, P.Y+Descent+Height/2, Prompt);
    NDC_DefPoint (P.X+Width, P.Y, Position);
    Name := '';
    Repeat
	Repeat
	    NDC_WaitEvent (INDEFINITE, Device);
	    If Device = LOCATOR then
		NDC_GetLocator (LocMeasure);
	Until Device = KEYBOARD;
	NDC_GetKeyboard (KeyMeasure);
	Case KeyMeasure[1] of
	    'a'..'z','A'..'Z','0'..'9','.','/',':':	Begin
		    Name[0] := Chr(Ord(Name[0]) + 1);
		    Name[Ord(Name[0])] := KeyMeasure[1];
		    NDC_InquireTextExtent (Name, Width, Height, Descent);
		    NDC_TextCoord (Position.X+Width/2, Position.Y+Descent+Height/2, Name);
		End;
	    Chr(8):	Begin
		    If Ord(Name[0]) > 0 then Begin
			NDC_GetColor (OldColor);
			NDC_SetColor (0);
			NDC_TextCoord (Position.X+Width/2, Position.Y+Descent+Height/2, Name);
			Name[0] := Chr(Ord(Name[0]) - 1);
			NDC_SetColor (OldColor);
			NDC_InquireTextExtent (Name, Width, Height, Descent);
			NDC_TextCoord (Position.X+Width/2, Position.Y+Descent+Height/2, Name);
		    End;
		End;
	End; {Case}
    Until Ord(KeyMeasure[1]) = 13;
End; {Get_File_Name}

(*-------------------------------------------------------------------------*)

Procedure Get_Data_From_File (Var N_Initiator : Integer;
				Var Initiator : VertexList;
				Var N_Generator : Integer;
				Var Generator : VertexList);
(*
 * This procedure reads the initiator and generator data from a file.  The
 * name of the file is requested and then the data is read in.  No error
 * checking is performed; the routine (and program) will fail if the
 * the file does not exist.
 *)

Var
    FileName	: String;
    DataFile	: Text;
    I		: Integer;
    PromptPosition	: Point;

Begin
    NDC_DefPoint (0.0, 0.0, PromptPosition);
    Get_File_Name ('Filename: ', PromptPosition, FileName);
    Assign (DataFile, FileName);
    Reset (DataFile);
    Readln (DataFile, N_Initiator);
    For I := 1 to N_Initiator do
	Readln (DataFile, Initiator[I].X, Initiator[I].Y);
    Readln (DataFile, N_Generator);
    For I := 1 to N_Generator do
	Readln (DataFile, Generator[I].X, Generator[I].Y);
    Close (DataFile);
    Scale_Generator (N_Generator, Generator);
End; {Get_Data_From_File}

(*-------------------------------------------------------------------------*)

Procedure Get_Locator_Vertex_List (Var N : Integer; Var V : VertexList);

(*
 * Reads a list of vertices from the Locator.  Probably should use
 * rubberbanding once NDC supports it.
 *)

Var
    Done	: Boolean;
    LocMeasure	: LocatorMeasure;
    KeyMeasure	: KeyboardMeasure;
    Origin	: Point;

Begin
    NDC_SetInputMode (LOCATOR, EVENT);
    NDC_SetLocatorButtonMask ([LEFT_BUTTON, RIGHT_BUTTON]);
    NDC_SetLocatorEchoType (CURSOR);
    NDC_DefPoint (0.5, 0.5, Origin);
    NDC_SetLocatorMeasure (Origin);
    N := 0;
    Done := False;
    Repeat
	Repeat
	    NDC_WaitEvent (INDEFINITE, Device);
	    If Device = KEYBOARD then
		NDC_GetKeyboard (KeyMeasure);	{Ignore keyboard events}
	Until Device = LOCATOR;
	NDC_GetLocator (LocMeasure);
	With LocMeasure do
	    If ButtonOfMostRecentTransition = LEFT_BUTTON then Begin
		If ButtonChord[LEFT_BUTTON] = UP then Begin
		    N := N + 1;
		    V[N] := Position;
		    NDC_SetLocatorRubberAnchor (Position);
		    If N = 1 then
			NDC_SetLocatorEchoType (RUBBER_CROSS)
		    Else
			NDC_Line (V[N-1], V[N]);
		End; {If}
	    End Else If ButtonOfMostRecentTransition = RIGHT_BUTTON then
		Done := ButtonChord[RIGHT_BUTTON] = UP;
    Until Done;
    NDC_SetLocatorEchoType (CURSOR);
    NDC_SetInputMode (LOCATOR, INACTIVE);
End; {Get_Locator_Vertex_List}

(*-------------------------------------------------------------------------*)

Procedure Get_Initiator (Var N_Initiator : Integer;
			 Var Initiator : VertexList);

(*
 * Initializes the vertex list for the initiator.
 *)

Var
    Width	: Coordinate;
    Height	: Coordinate;
    Descent	: Coordinate;

Begin
    NDC_ClearDisplay;
    NDC_SetColor (LIGHT_GREEN);
    NDC_InquireTextExtent ('Initiator', Width, Height, Descent);
    NDC_TextCoord (Width/2.0, 1.0 - Height/2.0, 'Initiator');
    Get_Locator_Vertex_List (N_Initiator, Initiator);
    NDC_ClearDisplay;
    N_Initiator := N_Initiator + 1;
    Initiator[N_Initiator] := Initiator[1];
End; {Get_Initiator}

(*-------------------------------------------------------------------------*)

Procedure Get_Generator (Var N_Generator : Integer;
			 Var Generator : VertexList);

(*
 * Initializes the vertex list for the generator.
 *)

Var
    Width	: Coordinate;
    Height	: Coordinate;
    Descent	: Coordinate;

Begin
    NDC_ClearDisplay;
    NDC_SetColor (LIGHT_RED);
    NDC_InquireTextExtent ('Generator', Width, Height, Descent);
    NDC_TextCoord (Width/2.0, 1.0 - Height/2.0, 'Generator');
    Get_Locator_Vertex_List (N_Generator, Generator);
    NDC_ClearDisplay;
    (*
     * Have vertex for generator.  Now scale, rotate and translate it
     * so that the first vertex is at (0,0) and the last vertex is
     * at (1,1).
     *)
    Scale_Generator (N_Generator, Generator);
End; {Get_Generator}

(*-------------------------------------------------------------------------*)

Procedure Koch (P1, P2 : Point; Depth : Integer);

(*
 * Recursive procedure to replace sides of the initiator with instances
 * of the generator.  Each replacement consists of a scaling, a rotation
 * and a translation of the generator so that the endpoints will correspond
 * to the endpoints of the segment to be replaced.  The recursion continues
 * until Depth is zero in which case a line is drawn.
 *)

Var
    New_Gen	: VertexList;
    M		: Matrix;
    Dx, Dy	: Real;
    D, A	: Real;
    I		: Integer;

Begin
    If Depth = 0 then
	NDC_Line (P1, P2)
    Else Begin
	Dx := P2.X - P1.X;
	Dy := P2.Y - P1.Y;
	D := Sqrt(Sqr(Dx) + Sqr(Dy));
	If Dx = 0.0 then
	    A := Abs(Dy)*Pi/(2*Dy)
	Else
	    A := ArcTan(Dy / Dx);
	If Dx < 0.0 then
	    A := Pi + A;
	Create_Transformation_Matrix (0.0, 0.0, D, D, 0.0, 0.0, A,
				P1.X, P1.Y, M);
	For I := 1 to N_Generator do
	    Do_Transformation (New_Gen[I], Generator[I], M);
	For I := 1 to N_Generator - 1 do
	    Koch (New_Gen[I], New_Gen[I+1], Depth - 1);
    End; {Else}
End; {Koch}

(*-------------------------------------------------------------------------*)
(*-------------------------------------------------------------------------*)
(*-------------------------------------------------------------------------*)

Begin
    (*
     * Turn on NDC graphics and initialize devices.
     *)
    NDC_Begin (480, 480);
    NDC_SetInputMode (KEYBOARD, EVENT);
    NDC_SetKeyboardProcessingMode (RAW);
    NDC_SetFont (0);

    (*
     * Basic Koch Snowflake initiator.
     *)
    N_Initiator := 4;
    NDC_DefPoint (0.5 - SIDE/2, 0.5 - SIDE/(2 * Sqrt(3.0)), Initiator[1]);
    NDC_DefPoint (0.5, 0.5 + SIDE/Sqrt(3.0), Initiator[2]);
    NDC_DefPoint (0.5 + SIDE/2, 0.5 - SIDE/(2 * Sqrt(3.0)), Initiator[3]);
    NDC_DefPoint (0.5 - SIDE/2, 0.5 - SIDE/(2 * Sqrt(3.0)), Initiator[4]);

    (*
     * Basic Koch Snowflake generator.
     *)
    N_Generator := 5;
    NDC_DefPoint (0.0, 0.0, Generator[1]);
    NDC_DefPoint (1.0/3.0, 0.0, Generator[2]);
    NDC_DefPoint (0.5, 1.0/(2*Sqrt(3.0)), Generator[3]);
    NDC_DefPoint (2.0/3.0, 0.0, Generator[4]);
    NDC_DefPoint (1.0, 0.0, Generator[5]);

    (*
     * Main Loop - use key presses to determine what to do.
     *)
    Done := False;
    Repeat
	(*
	 * Wait for KEYBOARD event - ignore LOCATOR events
	 *)
	NDC_SetColor (YELLOW);
	NDC_InquireTextExtent (MENU, Width, Height, Descent);
	NDC_TextCoord (Width/2, 1-Height/2, MENU);
	Repeat
	    NDC_WaitEvent (INDEFINITE, Device);
	    If Device = LOCATOR then
		NDC_GetLocator (LocMeasure);
	Until Device = KEYBOARD;

	(*
	 * Get Key that was pressed and process it.
	 *)
	NDC_GetKeyboard (KeyMeasure);
	Case KeyMeasure[1] of
	    'f','F':	Get_Data_From_File (N_Initiator, Initiator,
						N_Generator, Generator);
	    'g','G':	Get_Generator (N_Generator, Generator);
	    'i','I':	Get_Initiator (N_Initiator, Initiator);
	    'q','Q':	Done := True;
	    '0'..'9':
		Begin
		    If (N_Initiator > 0) and (N_Generator > 0) then Begin
			Depth := Ord(KeyMeasure[1]) - Ord('0');
			NDC_ClearDisplay;
			NDC_SetColor (WHITE);
			For I := 1 to N_Initiator - 1 do
			    Koch (Initiator[I], Initiator[I+1], Depth);
		    End; {If}
		End; {'0'..'6'}
	End; {Case}
    Until Done;

    (*
     * Turn off graphics and exit.
     *)
    NDC_End;
End.