Program  Fractal;

(*$IA:HRG/TOOL.800*)

Const  xmax   = 319;
       ymax   = 199;
       border =   0;

       color  : Array (.0..15.) of Byte = ( 0,  1,  2,  3,  8,  9,  4,  5,
                                           10, 11,  6,  7, 12, 13, 14, 15);

Type   strng = String(.21.);

Var    ti, m, n, k, name : Integer;
       x1, x2, y1, y2    : Real;
       c, d              : Char;
       p0, p1, p2, p3    : Byte;


  Procedure  FractalPlotter (x1, y1, x2, y2 : Real);
  Const  g = 100;
  Var    dx, dy, xc, yc, xx, yy, xz, yz : Real;
         x, y                           : Integer;
  Begin
    dx := (x2 - x1) / 320;
    dy := (y2 - y1) / 200;
    y  := 199;
    yc := y1;
    Repeat x  := 0;
           xc := x1;
           Repeat k  := 0;
                  xz := 0;
                  yz := 0;
                  Repeat k  := Succ(k);
                         xx := Sqr(xz);
                         yy := Sqr(yz);
                         yz := 2 * xz * yz - yc;
                         xz := xx - yy - xc
                  Until (k = ti + 1) or (xx + yy >= g);
                  If k <> ti + 1
                   then Begin SetPkt(     x shl 1 , y, k mod 4);
                              SetPkt(Succ(x shl 1), y, k mod 4)
                        End;
                  x  := Succ(x);
                  xc := xc + dx
           Until x > xmax;
           y  := Pred(y);
           yc := yc + dy
    Until y < 0
  End;

  Procedure  ReadReal (Var r : Real; x, y : Integer; text : strng);
  Const  leerstring = '                                             ';
  Var    Eingabe : strng;
         Code    : Integer;
  Begin
    Repeat GotoXY(x, y);
           Write(leerstring);
           GotoXY(x, y);
           Write(text);
           Readln(Eingabe);
           Val(Eingabe, r, Code)
    Until (Code = 0) and (Length(Eingabe) > 0);
    GotoXY(x+40, y);
    Write('Eingabe : ', r:12:8)
  End;

  Procedure  ReadInteger (Var i : Integer; x, y : Integer; text : strng);
  Const  leerstring = '                                             ';
  Var    Eingabe : strng;
         Code : Integer;
  Begin
    Repeat GotoXY(x, y);
           Write(leerstring);
           GotoXY(x, y);
           Write(text);
           Readln(Eingabe);
           Val(Eingabe, i, Code)
    Until (Code = 0) and (Length(Eingabe) > 0);
    GotoXY(x+40, y);
    Write('Eingabe : ', i)
  End;

  Procedure  Ausdruck;
  Var  x, y, i, k : Integer;
       c          : Array (.1..3.) of Byte;
  Begin
    Box(0, 0, 639, 199, 3);
    Box(1, 0, 638, 199, 3);
    Box(1, 1, 637, 198, 0);
    Box(2, 1, 636, 198, 0);
    Write(Lst, #27'@', #27'A'#8);
    For y := 0 to ymax div 4 do
     Begin Write(Lst, #27'L'#192#3);
           For x := 0 to xmax do
            Begin c(.1.) := 0;
                  c(.2.) := 0;
                  c(.3.) := 0;
                  For i := 0 to 3 do
                   Begin k := $C0 shr (2*i);
                         Case Point(2*x, y*4+i) of
                           1 : Case ((y*4+i) mod 4) of
                                 0    : c(.1.) := c(.1.) or k;
                                 2    : c(.3.) := c(.3.) or k
                                 else   c(.2.) := c(.2.) or k
                                End;
                           2 : Case ((y*4+i) mod 8) of
                                 0, 2 : Begin  c(.1.) := c(.1.) or k;
                                               c(.2.) := c(.2.) or k
                                        End;
                                 4, 6 : Begin  c(.2.) := c(.2.) or k;
                                               c(.3.) := c(.3.) or k
                                        End
                                 else   Begin  c(.1.) := c(.1.) or k;
                                               c(.3.) := c(.3.) or k
                                        End
                                End;
                           3 : Begin c(.1.) := c(.1.) or k;
                                     c(.2.) := c(.2.) or k;
                                     c(.3.) := c(.3.) or k
                               End
                          End (* Case Point... *)
                   End;
                  Write(Lst, Chr(c(.1.)), Chr(c(.2.)), Chr(c(.3.)))
            End
     End;
    Write(Lst, #13#10#12#27'@')
  End;

  Procedure  Animation;
  Var  n, m : Integer;
       c    : Char;
  Begin
    m := 0;
    p0 := color(.m.);
    Delay(500); Pal(0, 0); Pal(1, 0); Pal(2, 0); Pal(3, 0);
    m := Succ(m) mod 16; p1 := p0; p0 := color(.m.);
    Delay(500); Pal(0, p0);
    m := Succ(m) mod 16; p2 := p1; p1 := p0; p0 := color(.m.);
    Delay(500); Pal(0, Color(.2.)); Pal(1, Color(.1.));
    m := Succ(m) mod 16; p3 := p2; p2 := p1; p1 := p0; p0 := color(.m.);
    Delay(500); Pal(0, Color(.3.)); Pal(1, Color(.2.)); Pal(2, Color(.1.));
    Repeat  m := Succ(m) mod 16;
            p3 := p2;
            p2 := p1;
            p1 := p0;
            p0 := color(.m.);
            Delay(500);
            Pal(0, p0);
            Pal(1, p1);
            Pal(2, p2);
            Pal(3, p3)
    Until KeyPressed;
    Read(Kbd, c);
    Pal(0, 0); Pal(1, 4); Pal(2, 8); Pal(3, 12)
  End;


Begin
  HRG_Tool_Init;
  Repeat GrfIni;
         p0 :=  0;
         p1 :=  4;
         p2 :=  8;
         p3 := 12;
         Repeat GotoXY(1, 1);
                Write('Neue Berechnung         ? (j/n) : ');
                Repeat Until KeyPressed;
                Read(kbd, c);
                c := UpCase(c)
         Until c in (.'J', 'N'.);
         If c = 'J'
          then Write('ja')
          else Write('nein');
         Repeat GotoXY(1, 3);
                Write('Mit Ausdruck            ? (j/n) : ');
                Repeat Until KeyPressed;
                Read(kbd, d);
                d := UpCase(d)
         Until d in (.'J', 'N'.);
         If d = 'J'
          then Write('ja')
          else Write('nein');
         If c = 'J'
          then Begin Repeat ReadInteger(ti, 1, 7, 'Berechnungstiefe : ');
                            ReadReal(x1, 1, 10, 'minimaler Realteil : ');
                            ReadReal(x2, 1, 11, 'maximaler Realteil : ');
                            ReadReal(y1, 1, 13, 'min. Immagin{rteil : ');
                            ReadReal(y2, 1, 14, 'max. Immagin{rteil : ')
                     Until (x1 < x2) and (y1 < y2);
                     Repeat GotoXY(1, 17);
                            Write('Datei-Nr. : ');
                            Readln(name)
                     Until name < 256;
                     ClrScr;
                     Pal(0, p0);
                     Pal(1, p1);
                     Pal(2, p2);
                     Pal(3, p3);
                     Pal(4, border);
                     FractalPlotter(x1, y1, x2, y2);
                     SaveHRG(0, name)
               End
          else Begin Repeat GotoXY(1, 9);
                            Writeln('Bild-Nr. (0..255) : ');
                            Writeln;
                            Writeln(' 1 .. Urbild (a)');
                            Writeln(' 2 .. Urbild (b)');
                            GotoXY(21, 9);
                            Readln(name)
                     Until name < 256;
                     Pal(0, p0);
                     Pal(1, p1);
                     Pal(2, p2);
                     Pal(3, p3);
                     Pal(4, border);
                     LoadHRG(0, name)
               End;
         If d = 'J' then Ausdruck;
         Repeat Until KeyPressed;
         Read(Kbd, c);
         Animation;
         Repeat GotoXY(1, 1);
                Write('Neue Grafik ? ');
                Repeat Until KeyPressed;
                Read(kbd, c);
                c := UpCase(c)
        Until c in (.'J', 'N'.)
  Until c = 'N';
  ClrScr;
  GotoXY(1, 1);
  GrfIni
End.
