(***************************************************************************)
(*                                                                         *)
(*  MODULE: Fractals3D                          Karlsruhe, den 06.02.1989  *) 
(*                                                      von Olaf Pfeiffer  *)
(*-------------------------------------------------------------------------*)
(*                                                                         *)
(***************************************************************************)


MODULE Fractals3D;

(* $F-, $R-, $S-, $V-, $N- *)


FROM MathLib0     IMPORT exp, ln;

FROM RandomNumber IMPORT Random, PutSeed;

FROM Intuition    IMPORT WindowPtr, ScreenPtr;

(* Folgende Importe beziehen sich auf die Amiga-Treasures! *)

FROM WindowInOut        IMPORT WWriteString, WReadInt, WWriteLn, 
                               WReadLongInt, WWriteInt, WReadChar, WReadReal,
                               InitForIO, FinishIO;

FROM WinIOControl IMPORT WCursorInvisible, WGotoXY;

FROM WinGraphics  IMPORT Polygon;

FROM WindowLib    IMPORT ScrWin, CloseWin, GetWinScr, ClearWin;

FROM ScreenLib    IMPORT SetColReg;

FROM UtilityLib   IMPORT Coordinates;


TYPE FELD = ARRAY[0..64],[0..64] OF INTEGER;


CONST maxtiefe = 6;

            
VAR F,Dx,Dy,Hoehe,Stg                : FELD;
    Dim,tiefe,diff,maxh,D,d          : INTEGER;
    sigma,delta,Hoeva,Glaette,addrnd : REAL;
    seed                             : LONGINT;
    ch                               : CHAR;
    Zeige,Netz                       : BOOLEAN;
    ptrW                             : WindowPtr;
    ptrS                             : ScreenPtr;
    
    

PROCEDURE PowerInt (Basis, Exponent : INTEGER): INTEGER;
(* Basis hoch Exponent für INTEGER-Variablen. *)

VAR n,z : INTEGER;

BEGIN
  IF Exponent <= 0
    THEN Basis := 0;
    ELSE z := Basis;
     n := 1;
    WHILE n < Exponent DO
       Basis := Basis * z;
      INC(n);
    END;
  END;
  RETURN Basis;
END PowerInt;



PROCEDURE PowerReal (Basis, Exponent : REAL): REAL;
(* Basis hoch Exponent für REAL-Variablen. *)

BEGIN
  RETURN exp( Exponent * ln(Basis) );
END PowerReal;



PROCEDURE am3 (delta : REAL; a,b,c : INTEGER): INTEGER;  
(* Berechnet den Durchschnitt dreier Zahlen a,b,c und addiert  *)
(* einen Zufälligen Wert von -delta bis +delta.                *)

BEGIN
  RETURN TRUNC( FLOAT(a+b+c)/3.0 + delta * ((Random()*2.0-1.0)) );
END am3;



PROCEDURE am4 (delta : REAL; a,b,c,d : INTEGER): INTEGER;
(* Berechnet den Durchschnitt von vier Zahlen a,b,c,d und addiert  *)
(* einen Zufälligen Wert von -delta bis +delta.                    *)

BEGIN
  RETURN TRUNC( FLOAT(a+b+c+d)/4.0 + delta * ((Random()*2.0-1.0)) );
END am4;



PROCEDURE BerechneMittel (a,b : INTEGER);
(* Berechnet die Werte F[x,y] der nächsten Tiefe. *)

VAR x,y,hx,hy : INTEGER;
  
BEGIN
   x := a;
   hx := x+d;
  WHILE (x <= Dim-d) AND (hx <= Dim) DO
     y := b;
     hy := y+d;
    WHILE (y <= Dim-d) AND (hy <= Dim) DO
       F[x,y] := am4(delta,F[x,hy],F[x,y-d],F[hx,y],F[x-d,y]);
      INC(y,D);
       hy := y+d;
    END;
    INC(x,D);
     hx := x+d;
  END;
END BerechneMittel;



PROCEDURE AddRandom (a,b : INTEGER);
(* Addiert zu den neuen Werten F[x,y] eine Zahl von -delta bis +delta. *)

VAR x,y : INTEGER;

BEGIN
   x := a;
  REPEAT
     y := a;
    REPEAT
      F[x,y] := F[x,y] + TRUNC( delta * ((Random()*2.0-1.0)) );
      INC(y,D);
    UNTIL (y > b);
    INC(x,D);
  UNTIL (x > b);
END AddRandom;



PROCEDURE Initialisieren;            
(* Setzen einiger globaler Variablen. *)
 
BEGIN
   Dim := PowerInt(2,maxtiefe);
   delta := sigma;
   F[0,0] := TRUNC( delta * Random());
   F[0,Dim] := TRUNC( delta * (Random()*2.0-1.0) );
   F[Dim,0] := TRUNC( delta * Random() );
   F[Dim,Dim] := TRUNC( delta * ( 0.0-Random() ) );
   D := Dim DIV 2;
   F[D,D] := TRUNC( delta * (Random()*2.0-1.0) );
   d := D DIV 2;
END Initialisieren;


  
PROCEDURE FarbenSetzen;
(* Setzt die Farben für den neuen Screen. *)

VAR n : INTEGER;

BEGIN
  ptrS := GetWinScr(ptrW);
  SetColReg(ptrS,0 ,0 ,0 ,2);
  SetColReg(ptrS,1 ,2 ,4 ,10);
  SetColReg(ptrS,2 ,0 ,5 ,1);
  SetColReg(ptrS,3 ,0 ,6 ,1);
  SetColReg(ptrS,4 ,1 ,6 ,2);
  SetColReg(ptrS,5 ,1 ,7 ,2); 
  SetColReg(ptrS,6 ,1 ,8 ,2);
  SetColReg(ptrS,7 ,2 ,8 ,3);
  SetColReg(ptrS,8 ,2 ,9 ,3);
  SetColReg(ptrS,9 ,2 ,10,3);
  SetColReg(ptrS,10,2 ,11,3);
  SetColReg(ptrS,11,3 ,11,4);
  SetColReg(ptrS,12,4 ,11,4);
  SetColReg(ptrS,13,4 ,12,4);
  SetColReg(ptrS,14,5 ,9 ,3);
  SetColReg(ptrS,15,7 ,6 ,0);
  SetColReg(ptrS,16,6 ,6 ,1);
  SetColReg(ptrS,17,5 ,5 ,2);
  SetColReg(ptrS,18,5 ,4 ,3);
  SetColReg(ptrS,19,3 ,3 ,3);
  SetColReg(ptrS,20,4 ,4 ,4);
  SetColReg(ptrS,21,5 ,5 ,5);
  SetColReg(ptrS,22,6 ,6 ,6);
  SetColReg(ptrS,23,7 ,7 ,7);
  SetColReg(ptrS,24,8 ,8 ,8);
  SetColReg(ptrS,25,9 ,9 ,9);
  SetColReg(ptrS,26,10,10,10);
  SetColReg(ptrS,27,11,11,11);
  SetColReg(ptrS,28,12,12,12);
  SetColReg(ptrS,29,13,13,13);
  SetColReg(ptrS,30,14,14,14);
  SetColReg(ptrS,31,15,15,15);
END FarbenSetzen;       
  


PROCEDURE NaechsteTeilung;
(* Hauptroutine, wird für jede Tiefe erneut aufgerufen. *)
    
VAR x,y    : INTEGER;
    addrnd : REAL;
    
BEGIN  
   delta := delta * PowerReal (0.5 , 0.5 * Hoeva);
   x := d;
  REPEAT
     y := d;
    REPEAT
       F[x,y] := am4(delta,F[x+d,y+d],F[x+d,y-d],F[x-d,y+d],F[x-d,y-d]);
      INC(y,D);
    UNTIL (y > Dim-d);
    INC(x,D);
  UNTIL (x > Dim-d); 
   addrnd := Random(); 
  IF (addrnd > Glaette) THEN AddRandom(0,Dim);
  END;
   delta := delta * PowerReal(0.5, 0.5 * Hoeva);
   x := d;
  REPEAT
     F[x,0] := am3(delta,F[x+d,0],F[x-d,0],F[x,d]);
     F[x,Dim] := am3(delta,F[x+d,Dim],F[x-d,Dim],F[x,Dim-d]);
     F[0,x] := am3(delta,F[0,x+d],F[0,x-d],F[d,x]);
     F[Dim,x] := am3(delta,F[Dim,x+d],F[Dim,x-d],F[Dim-d,x]);
     INC(x,D);
  UNTIL (x > Dim-d);
   BerechneMittel(d,D);
   BerechneMittel(D,d);
   addrnd := Random();
  IF (addrnd > Glaette) THEN 
     AddRandom(0,Dim);
     AddRandom(d,Dim-d);                  
  END;
   D := D DIV 2;
   d := d DIV 2;
END NaechsteTeilung;    



PROCEDURE Ausgabeberechnung;
(* Berechnet zu den Werten F[x,y] die zugehörigen x- und y-Koordinaten  *)
(* sowie die Höhe und die Steigung der einzelnen Polygone.              *)
 
VAR x,y,yi  : INTEGER;
    yr      : REAL;
    
BEGIN

   y := 0;
  REPEAT
     x := 0;
    REPEAT
       Dx[x,y] := 256 - TRUNC(FLOAT(2*y+192)/64.0*FLOAT(x)) + y;
      IF F[x,y] <= 0 
        THEN Dy[x,y] := 111 + 2*y;
        ELSE Dy[x,y] := 111 + 2*y - F[x,y];
      END;
      INC(x,D);
    UNTIL x > Dim;
    INC(y,D);
  UNTIL y > Dim;
   maxh := 29;
   y := 0;
  REPEAT
     x := 0;
    REPEAT
       Hoehe[x,y] := TRUNC(    
       FLOAT( F[x,y]+F[x,y+D]+F[x+D,y+D]+F[x+D,y] )/4.0+0.5
       );  
      IF((F[x,y]>0)OR(F[x,y+D]>0)OR(F[x+D,y]>0)OR(F[x+D,y+D]>0))AND
        (Hoehe[x,y]<=0) THEN Hoehe[x,y] := 1;
      END;
       Stg[x,y] := ABS(ABS(F[x,y]) + ABS(F[x+D,y]) - 2*Hoehe[x,y]) DIV D;
      IF Stg[x,y] > 7 THEN Stg[x,y] := 7;
      END;
      IF maxh < Hoehe[x,y] THEN maxh := Hoehe[x,y];
      END;
      INC(x,D);
    UNTIL x > Dim-D;
    INC(y,D)
  UNTIL y > Dim-D;
  
END Ausgabeberechnung;


   
PROCEDURE ZeichneLand;
(* Grafische Ausgabe in das Fenster auf dem LoRes-Screen. *)

VAR x,y,c,s   : INTEGER;
    dh,ds,h   : REAL;
    P         : ARRAY[0..4] OF Coordinates;
    
BEGIN
   dh := FLOAT(maxh)/29.0;
   y := 0;
  REPEAT
     x := 0;
    REPEAT
       P[0].xK := Dx[x,y];
       P[0].yK := Dy[x,y];
       P[1].xK := Dx[x+D,y];
       P[1].yK := Dy[x+D,y];
       P[2].xK := Dx[x+D,y+D];
       P[2].yK := Dy[x+D,y+D];
       P[3].xK := Dx[x,y+D];
       P[3].yK := Dy[x,y+D];
       P[4].xK := P[0].xK;
       P[4].yK := P[0].yK;
       h := FLOAT(Hoehe[x,y])/dh;
       s := Stg[x,y];
      IF h <= 0.0 THEN c := 1;
        ELSIF h > 24.0 THEN c := TRUNC(2.5 + h);
        ELSIF s > 3 THEN c := 27 - s;
        ELSIF (s > 2) AND (h > 0.5) THEN c := TRUNC(1.5 + h);
        ELSE c := TRUNC(2.5 + h);
      END;
        IF Netz = TRUE
          THEN Polygon(ptrW,P,4,0,TRUE);
        END;
        Polygon(ptrW,P,4,c,NOT Netz);
      INC(x,D);
    UNTIL x > Dim-D;
    INC(y,D);
  UNTIL y > Dim-D;
END ZeichneLand;
        

                    
BEGIN
  ptrW := ScrWin("Fraktale Landschaft",0,10,320,240,1,5,7);
  InitForIO(ptrW);
  REPEAT
     WWriteLn;
     WWriteString(">> Erstellung fraktaler Landschaften <<");
     WWriteLn;
     WWriteString("=======================================");
     WWriteLn;
     WWriteString("von Olaf Pfeiffer             Juli 1989");
     WWriteLn;
    REPEAT  
       WWriteLn;
       WWriteString("Seed für Zufallsgenerator) : ");
       WReadLongInt(seed);
    UNTIL seed <> 0; 
     PutSeed(seed);
    REPEAT
       WWriteLn;
       WWriteString("Hoehe (10 bis 100) : ");
       WReadReal(sigma);
    UNTIL (sigma >= 10.0) AND (sigma <= 100.0);
    REPEAT
       WWriteLn;
       WWriteString("Hoehenvarianz (0.75 bis 2.25) : ");
       WReadReal(Hoeva);
    UNTIL (Hoeva >= 0.75) AND (Hoeva <= 2.25);
    REPEAT
       WWriteLn;
       WWriteString("Glaettungsfaktor (0.0 bis 1.0) : "); 
       WReadReal(Glaette);
    UNTIL (Glaette >= 0.0) AND (Glaette <= 1.0);
    REPEAT
       WWriteLn;
       WWriteString(">>N<< etz oder >>R<< eal ? ");
       WReadChar(ch);
    UNTIL (ch = "n") OR (ch = "r");
    IF ch = "n" 
      THEN Netz := TRUE;
      ELSE Netz := FALSE;
    END;
     REPEAT
       WWriteLn; WWriteLn;
       WWriteString("Alle Tiefen ausgeben ? ");
       WReadChar(ch);
    UNTIL (ch = "j") OR (ch = "n");
    IF ch = "j" 
      THEN Zeige := TRUE;
      ELSE Zeige := FALSE;
    END;
     WCursorInvisible();
     Initialisieren;
     FarbenSetzen;
     tiefe := 2;
    REPEAT
      ClearWin(ptrW);
      WGotoXY(1,1);
      WWriteString("      Moment, ich rechne !   ");
      NaechsteTeilung;
      IF (tiefe = maxtiefe) OR ( (tiefe > 1) AND (Zeige = TRUE) ) 
        THEN 
         Ausgabeberechnung;
         ClearWin(ptrW);
         ZeichneLand;
        IF tiefe <> maxtiefe
          THEN
           WGotoXY(2,1);
           WWriteString(">>W<< eiterrechnen >>A<< ufhören ?");
          REPEAT
             WReadChar(ch);
          UNTIL (ch = "w") OR (ch = "a");
        END;
      END;
      INC(tiefe);
    UNTIL (tiefe > 6) OR (ch = "a");
     WGotoXY(8,2);
     WWriteString(" e - ende , n - nochmal!");
    REPEAT
       WReadChar(ch);
    UNTIL (ch = "e") OR (ch = "n");
    ClearWin(ptrW);
   UNTIL (ch = "e");
   FinishIO(ptrW);
   CloseWin(ptrW);

END Fractals3D.