(**********************************************************************

:Program.    Apfelmann.mod
:Contens.    Ein Modul zur Darstellung des Apfelmännchens von Mandelbrot.
:Contens.    Hauptmodul ist ApfelMenu.
:Author.     Bernd Braun
:Address.    Lippestr. 11, D-3300 Braunschweig
:Phone.      0531/845498
:Copyright.  Public Domain
:Language.   Oberon
:Translator. Amiga Oberon A+L V1.17.1
:Imports.    Sys
:Support.    B. Mandelbrot
:History.    V1.0 10.Jan.1989 StartVersion.
:History.    V1.1 13.Dez.1989 Benutzerführung verbessert.
:History.    V1.2 11.Feb.1990 Algorithmus verbessert.
:History.    V1.3 21.Feb.1990 Divide & Conquer eingeführt.
:History.                     Normierte Zahlen eingeführt.
:History.    V1.4  1.Mär.1990 Leichte Optimierungen.
:History.    V1.5 30.Mär.1990 Tabelle eingeführt.
:History.    V1.6 18.Apr.1990 Doppelschritte eingeführt.
:History.    V2.0 31.Mai.1990 Maus-Oberfläche und
:History.                     Dreifachschritte eingeführt.
:History.    V2.1 22.Jul.1990 Randberechnung umgeschrieben.
:History.    V2.2  4.Aug.1990 Genauigkeit verdoppelt.
:History.    V2.3 22.Sep.1990 Draw statt WritePixel benutzt.
:History.    V3.0  1.Dez.1990 Erste Oberon Version.
:History.    V3.1 18.Dez.1990 Alle Genauigkeiten implementiert.
:History.    V3.2 23.Dez.1990 Berechnungsunterbrechung implementiert.
:History.    V3.3 10.Jan.1991 Tabelle ist nun Zeiger für SmallData

***********************************************************************)

MODULE ApfelMann;

(* $OvflChk- $RangeChk- $StackChk- $NilChk- $ReturnChk- $CaseChk- *)

   IMPORT e   : Exec,
          i   : Intuition,
          is  : IntuiSupport,
          g   : Graphics,
          s   : SYSTEM,
          sys : Sys;

   CONST
      F16      = 8192;  (* Normalisierungsfaktor für INTEGER *)
      FLOG16   = 13;    (* log2 ( F16 ) *)
      F32      = 32768; (* Normalisierungsfaktor für LONGINT *)
      FLOG32   = 15;    (* log2 ( F32 ) *)
      BLACK    = 0;
      WHITE    = 1;
      MAXTAB   = 32768; (* Größe der Quadratzahlentabelle *)
      Word*    = 1;     (* Modus INTEGER *)
      Long*    = 2;     (* Modus LONGINT *)
      Real*    = 3;     (* Modus LONGREAL *)

   VAR
      xmax, ymax, farben      : INTEGER;
      rmin, rmax, imin, imax  : LONGREAL;
      Tabelle                 : POINTER TO ARRAY MAXTAB OF LONGINT;
      Modus                   : INTEGER;

   (* Berechnet für 16-Bit Zahlen die Quadratzahlen bis MAXTAB
      und legt sie in Tabelle ab. *)
   PROCEDURE Init;
      VAR
         quadr, lauf, offset : LONGINT;
   BEGIN
      Tabelle [ 0 ] := 0;
      offset := 1;
      quadr  := 1;
      lauf   := 1;
      LOOP
         Tabelle [ lauf ] := s.LSH ( quadr, -FLOG16 );
         INC ( lauf );
         IF lauf >= MAXTAB THEN EXIT END;
         INC ( offset, 2 );
         INC ( quadr, offset );
      END;
   END Init;

   (* Berechnet die Mandelbrotmenge im Bereich
      [ rmin, rmax ] * [ imin, imax ] mit der maximalen Iterationtiefe
      von maxiter. *)
   PROCEDURE BerechneBild* ( rp      : g.RastPortPtr;
                             maxiter : INTEGER;
                             window  : i.WindowPtr );
      VAR
         dxw, dyw, rminw, iminw : INTEGER;
         dxl, dyl, rminl, iminl : LONGINT;
         dx, dy                 : LONGREAL;
         userbreak              : BOOLEAN;
         class                  : LONGSET;
         code                   : INTEGER;
         adr                    : e.ADDRESS;
         IMes                   : POINTER TO i.IntuiMessage;

      (* Berechnet den Punkt ( x, y ) der Mandelbrotmenge. *)
      PROCEDURE iteration ( x, y : INTEGER ) : INTEGER;
         VAR
            iter : INTEGER;

         (* 16 Bit-Routine zur Berechnung eines Punktes. *)
         PROCEDURE iter16 () : INTEGER;
            VAR
               iter, i, r             : INTEGER;
               qr, qi, cr, ci, zr, zi : LONGINT;
         BEGIN
            cr   := rminw + x * dxw;  (* Realteil der Konstanten *)
            ci   := iminw + y * dyw;  (* Imaginärteil der Konstanten *)
            iter := maxiter;
            zr   := cr;
            zi   := ci;
            LOOP
               (* Abbruchkriterium vorwegnehmen. *)
               IF ( zr >= 2 * F16 ) OR ( zr <= -2 * F16 ) OR
                  ( zi >= 2 * F16 ) OR ( zi <= -2 * F16 ) THEN
                  EXIT;
               END;
               r  := SHORT ( zr );
               i  := SHORT ( zi );
               qr := Tabelle [ ABS ( r ) ];
               qi := Tabelle [ ABS ( i ) ];
               IF qr + qi >= 4 * F16 THEN EXIT END;
               zr := qr - qi - cr;
               zi := sys.RightShift ( sys.Mult ( i, r ), FLOG16 - 1 ) - ci;
               DEC ( iter );
               IF iter = 0 THEN EXIT END;  (* Iterationsgrenze erreicht *)
            END;
            RETURN iter;
         END iter16;

         (* 32 Bit-Routine zur Berechnung eines Punktes. *)
         PROCEDURE iter32 () : INTEGER;
            VAR
               iter                         : INTEGER;
               qr, qi, cr, ci, zr, zi, i, r : LONGINT;
         BEGIN
            cr   := rminl + x * dxl;  (* Realteil der Konstanten *)
            ci   := iminl + y * dyl;  (* Imaginärteil der Konstanten *)
            iter := maxiter;
            zr   := cr;
            zi   := ci;
            LOOP
               (* Abbruchkriterium vorwegnehmen. *)
               IF ( zr >= 2 * F32 ) OR ( zr <= -2 * F32 ) OR
                  ( zi >= 2 * F32 ) OR ( zi <= -2 * F32 ) THEN
                  EXIT;
               END;
               r  := zr;
               i  := zi;
               qr := s.LSH ( r * r, -FLOG32 );
               qi := s.LSH ( i * i, -FLOG32 );
               IF qr + qi >= 4 * F32 THEN EXIT END;
               zr := qr - qi - cr;
               zi := sys.RightShift ( i * r, FLOG32 - 1 ) - ci;
               DEC ( iter );
               IF iter = 0 THEN EXIT END;  (* Iterationsgrenze erreicht *)
            END;
            RETURN iter;
         END iter32;

         (* LONGREAL-Routine zur Berechnung eines Punktes. *)
         PROCEDURE iterreal () : INTEGER;
            VAR
               iter                         : INTEGER;
               zr, zi, qr, qi, i, r, cr, ci : LONGREAL;
         BEGIN
            cr   := rmin + x * dx;
            ci   := imin + y * dy;
            iter := maxiter;
            zr   := cr;
            zi   := ci;
            LOOP
               r  := zr;
               i  := zi;
               qr := r * r;
               qi := i * i;
               IF qr + qi >= 4.0 THEN EXIT END;
               zr := qr - qi - cr;
               zi := 2.0 * i * r - ci;
               DEC ( iter );
               IF iter = 0 THEN EXIT END;
            END;
            RETURN iter;
         END iterreal;

      BEGIN
         CASE Modus OF
            Word : iter := iter16 ();
         |  Long : iter := iter32 ();
         |  Real : iter := iterreal ();
         END;
         IF iter = 0 THEN
            RETURN BLACK;   (* Punkt gehört der Mandelbrotmenge an *)
         ELSE
            RETURN iter MOD farben;
         END;
      END iteration;

      (* Berechnet rekursiv den Auschnitt [ vonx, bisx ] x [ vony, bisy ]
         der Mandelbrotmenge. *)
      PROCEDURE DivandConc ( vonx, bisx, vony, bisy : INTEGER );
         VAR
            t, u, v, w, farbneu, farbalt,
            farbbox, halbx, halby         : INTEGER;
            box, dummy                    : BOOLEAN;
      BEGIN
         (* Testen ob Bildausschnitt schon zu klein. *)
         IF ( bisy < vony ) OR ( bisx < vonx ) THEN
            (* Rekursionsschluß *)
            RETURN;
         END;
         (* Benutzerunterbrechungen abfangen. *)
         IF userbreak THEN
            RETURN;
         ELSE
            is.GetIMes ( window, class, code, adr );
            IF ( i.menuPick IN class ) THEN
               userbreak := TRUE;
               RETURN;
            END;
         END;
         (* Oberen Rand malen. *)
         box := TRUE;
         farbbox := iteration ( vonx, vony );  (* Farbe des Randes *)
         farbalt := farbbox;
         w := vonx + 3;
         v := w - 1;
         u := w - 2;
         t := vonx;
         g.Move ( rp, vonx, vony );
         WHILE w <= bisx DO
            farbneu := iteration ( w, vony );
            IF farbneu # farbalt THEN
               box     := FALSE;
               g.SetAPen ( rp, farbalt );
               g.Draw    ( rp, t, vony );
               farbalt := farbneu;
               farbneu := iteration ( u, vony );
               IF farbneu # farbalt THEN
                  g.SetAPen ( rp, farbneu );
                  dummy := g.WritePixel ( rp, u, vony );
                  g.SetAPen ( rp, iteration ( v, vony ) );
                  dummy := g.WritePixel ( rp, v, vony );
                  g.Move ( rp, w, vony );
               ELSE
                  g.Move ( rp, u, vony );
               END;
            END;
            t := w;
            INC ( u, 3 );
            INC ( v, 3 );
            INC ( w, 3 );
         END;
         (* Prüfen, ob zu wenig berechnet wurde *)
         g.SetAPen ( rp, farbalt );
         IF v = bisx THEN
            farbneu := iteration ( bisx, vony );
            IF farbalt = farbneu THEN
               g.Draw ( rp, bisx, vony );
            ELSE
               box := FALSE;
               farbalt := farbneu;
               g.Draw ( rp, t, vony );
               g.SetAPen ( rp, farbneu );
               dummy := g.WritePixel ( rp, bisx, vony );
               g.SetAPen ( rp, iteration ( u, vony ) );
               dummy := g.WritePixel ( rp, u, vony );
            END;
         ELSIF u = bisx THEN
            farbneu := iteration ( bisx, vony );
            IF farbneu = farbalt THEN
               g.Draw ( rp, bisx, vony );
            ELSE
               box := FALSE;
               farbalt := farbneu;
               g.Draw ( rp, t , vony );
               g.SetAPen ( rp, farbneu );
               dummy := g.WritePixel ( rp, bisx, vony );
            END;
         ELSE
            g.Draw ( rp, bisx , vony );
         END;

         (* Rechten Rand malen. *)
         w := vony + 3;
         v := w - 1;
         u := w - 2;
         t := vony;
         g.Move ( rp, bisx, u );
         WHILE w <= bisy DO
            farbneu := iteration ( bisx, w );
            IF farbneu # farbalt THEN
               box     := FALSE;
               g.SetAPen ( rp, farbalt );
               g.Draw    ( rp, bisx, t );
               farbalt := farbneu;
               farbneu := iteration ( bisx, u );
               IF farbneu # farbalt THEN
                  g.SetAPen ( rp, farbneu );
                  dummy := g.WritePixel ( rp, bisx, u );
                  g.SetAPen ( rp, iteration ( bisx, v ) );
                  dummy := g.WritePixel ( rp, bisx, v );
                  g.Move ( rp, bisx, w );
               ELSE
                  g.Move ( rp, bisx, u );
               END;
            END;
            t := w;
            INC ( u, 3 );
            INC ( v, 3 );
            INC ( w, 3 );
         END;
         (* Prüfen, ob zu wenig berechnet wurde *)
         g.SetAPen ( rp, farbalt );
         IF v = bisy THEN
            farbneu := iteration ( bisx, bisy );
            IF farbalt = farbneu THEN
               g.Draw ( rp, bisx, bisy );
            ELSE
               box := FALSE;
               g.Draw ( rp, bisx, t );
               g.SetAPen ( rp, farbneu );
               dummy := g.WritePixel ( rp, bisx, bisy );
               farbalt := farbneu;
               g.SetAPen ( rp, iteration ( bisx, u ) );
               dummy := g.WritePixel ( rp, bisx, u );
            END;
         ELSIF u = bisy THEN
            farbneu := iteration ( bisx, bisy );
            IF farbneu = farbalt THEN
               g.Draw ( rp, bisx, bisy );
            ELSE
               box := FALSE;
               g.Draw ( rp, bisx, t );
               g.SetAPen ( rp, farbneu );
               dummy := g.WritePixel ( rp, bisx, bisy );
               farbalt := farbneu;
            END;
         ELSE
            g.Draw ( rp, bisx, bisy );
         END;

         IF vony < bisy THEN
            (* Unteren Rand malen. *)
            w := bisx - 3;
            v := w + 1;
            u := w + 2;
            t := bisx;
            g.Move ( rp, u, bisy );
            WHILE w >= vonx DO
               farbneu := iteration ( w, bisy );
               IF farbneu # farbalt THEN
                  box     := FALSE;
                  g.SetAPen ( rp, farbalt );
                  g.Draw    ( rp, t, bisy );
                  farbalt := farbneu;
                  farbneu := iteration ( u, bisy );
                  IF farbneu # farbalt THEN
                     g.SetAPen ( rp, farbneu );
                     dummy := g.WritePixel ( rp, u, bisy );
                     g.SetAPen ( rp, iteration ( v, bisy ) );
                     dummy := g.WritePixel ( rp, v, bisy );
                     g.Move ( rp, w, bisy );
                  ELSE
                     g.Move ( rp, u, bisy );
                  END;
               END;
               t := w;
               DEC ( u, 3 );
               DEC ( v, 3 );
               DEC ( w, 3 );
            END;
            (* Prüfen, ob zu wenig berechnet wurde *)
            g.SetAPen ( rp, farbalt );
            IF v = vonx THEN
               farbneu := iteration ( vonx, bisy );
               IF farbalt = farbneu THEN
                  g.Draw ( rp, vonx, bisy );
               ELSE
                  box := FALSE;
                  farbalt := farbneu;
                  g.Draw ( rp, t, bisy );
                  g.SetAPen ( rp, farbneu );
                  dummy := g.WritePixel ( rp, vonx, bisy );
                  g.SetAPen ( rp, iteration ( u, bisy ) );
                  dummy := g.WritePixel ( rp, u, bisy );
               END;
            ELSIF u = vonx THEN
               farbneu := iteration ( vonx, bisy );
               IF farbneu = farbalt THEN
                  g.Draw ( rp, vonx, bisy );
               ELSE
                  box := FALSE;
                  farbalt := farbneu;
                  g.Draw ( rp, t , bisy );
                  g.SetAPen ( rp, farbneu );
                  dummy := g.WritePixel ( rp, vonx, bisy );
               END;
            ELSE
               g.Draw ( rp, vonx , bisy );
            END;
         ELSE
            box := FALSE;
         END;

         IF vonx < bisx THEN
            (* Linken Rand malen. *)
            w := bisy - 3;
            v := w + 1;
            u := w + 2;
            t := bisy;
            g.Move ( rp, vonx, u );
            WHILE w >= vony DO
               farbneu := iteration ( vonx, w );
               IF farbneu # farbalt THEN
                  box     := FALSE;
                  g.SetAPen ( rp, farbalt );
                  g.Draw    ( rp, vonx, t );
                  farbalt := farbneu;
                  farbneu := iteration ( vonx, u );
                  IF farbneu # farbalt THEN
                     g.SetAPen ( rp, farbneu );
                     dummy := g.WritePixel ( rp, vonx, u );
                     g.SetAPen ( rp, iteration ( vonx, v ) );
                     dummy := g.WritePixel ( rp, vonx, v );
                     g.Move ( rp, vonx, w );
                  ELSE
                     g.Move ( rp, vonx, u );
                  END;
               END;
               t := w;
               DEC ( u, 3 );
               DEC ( v, 3 );
               DEC ( w, 3 );
            END;
            (* Prüfen, ob zu wenig berechnet wurde *)
            g.SetAPen ( rp, farbalt );
            IF v = vony THEN
               farbneu := iteration ( vonx, vony );
               IF farbalt = farbneu THEN
                  g.Draw ( rp, vonx, vony );
               ELSE
                  box := FALSE;
                  g.Draw ( rp, vonx, t );
                  g.SetAPen ( rp, farbneu );
                  dummy := g.WritePixel ( rp, vonx, vony );
                  farbalt := farbneu;
                  g.SetAPen ( rp, iteration ( vonx, u ) );
                  dummy := g.WritePixel ( rp, vonx, u );
               END;
            ELSIF u = vony THEN
               farbneu := iteration ( vonx, vony );
               IF farbneu = farbalt THEN
                  g.Draw ( rp, vonx, vony );
               ELSE
                  box := FALSE;
                  g.Draw ( rp, vonx, t );
                  g.SetAPen ( rp, farbneu );
                  dummy := g.WritePixel ( rp, vonx, vony );
                  farbalt := farbneu;
               END;
            ELSE
               g.Draw ( rp, vonx, vony );
            END;
         ELSE
            box := FALSE;
         END;

         (* Auschnitt hat nur eine Farbe? *)
         IF box THEN
            (* Mit dieser Farbe einfärben. *)
            g.RectFill ( rp, vonx, vony, bisx, bisy );
         ELSE
            (* Auschnitt in vier Teile teilen und diese berechnen. *)
            halbx  := s.LSH ( ( bisx + vonx ), -1 );
            halby  := s.LSH ( ( bisy + vony ), -1 );
            DivandConc ( vonx  + 1, halbx   , vony  + 1, halby     );
            DivandConc ( halbx + 1, bisx - 1, vony  + 1, halby     );
            DivandConc ( halbx + 1, bisx - 1, halby + 1, bisy  - 1 );
            DivandConc ( vonx  + 1, halbx   , halby + 1, bisy  - 1 );
         END;
      END DivandConc;

   BEGIN
      userbreak := FALSE;
      dx    := ( rmax - rmin ) / xmax;
      dy    := ( imax - imin ) / ymax;
      dxl   := ENTIER ( ( rmax - rmin ) * F32 / xmax );
      dyl   := ENTIER ( ( imax - imin ) * F32 / ymax );
      dxw   := SHORT ( ENTIER ( ( rmax - rmin ) * F16 / xmax ) );
      dyw   := SHORT ( ENTIER ( ( imax - imin ) * F16 / ymax ) );
      rminl := ENTIER ( rmin * F32 );
      iminl := ENTIER ( imin * F32 );
      rminw := SHORT ( ENTIER ( rmin * F16 ) );
      iminw := SHORT ( ENTIER ( imin * F16 ) );
      DivandConc ( 0, xmax - 1, 0, ymax - 1 );
   END BerechneBild;

   (* Testet die mögliche Genauigkeit der Zahlendarstellung. 
      Gibt FALSE zurück, wenn die Genauigkeit unterschritten wird. 
      Schaltet dann in eine höhere Genauigkeit. *)
   PROCEDURE TestModus* ( VAR mod : INTEGER ) : BOOLEAN;
   BEGIN
      IF mod = Word THEN
         IF ( ENTIER ( ( rmax - rmin ) * F16 ) DIV xmax = 0 ) OR
            ( ENTIER ( ( imax - imin ) * F16 ) DIV ymax = 0 ) THEN
            mod   := Long;
            Modus := Long;
            RETURN FALSE;
         END;
      END;
      IF mod = Long THEN
         IF ( ENTIER ( ( rmax - rmin ) * F32 ) DIV xmax = 0 ) OR
            ( ENTIER ( ( imax - imin ) * F32 ) DIV ymax = 0 ) THEN
            mod   := Real;
            Modus := Real;
            RETURN FALSE;
         END;
      END;
      Modus := mod;
      RETURN TRUE;
   END TestModus;   

   (* Berechnet die neuen Grenzen des Bildes. Schaltet in eine höhere
      Genauigkeit wenn Zahlendarstellung nicht mehr ausreicht. *)
   PROCEDURE BerechneWerte* (     x1, y1, x2, y2 : INTEGER;
                              VAR mod            : INTEGER );
      VAR
         dx, dy, r1, r2, i1, i2 : LONGREAL;
   BEGIN
      dx := ( rmax - rmin ) / xmax;
      dy := ( imax - imin ) / ymax;
      r1 := rmin + x1 * dx;
      r2 := rmin + x2 * dx;
      i1 := imin + y1 * dy;
      i2 := imin + y2 * dy;
      IF Modus = Word THEN
         IF ( ENTIER ( ( r2 - r1 ) * F16 ) DIV xmax = 0  ) OR
            ( ENTIER ( ( i2 - i1 ) * F16 ) DIV ymax = 0  ) THEN
            mod   := Long;
            Modus := Long;
         END;
      END;
      IF Modus = Long THEN
         IF ( ENTIER ( ( r2 - r1 ) * F32 ) DIV xmax = 0 ) OR
            ( ENTIER ( ( i2 - i1 ) * F32 ) DIV ymax = 0 ) THEN
            mod   := Real;
            Modus := Real;
         END;
      END;
      rmin := r1;
      rmax := r2;
      imin := i1;
      imax := i2;
   END BerechneWerte;

   (* Größe des Bildschirm und Farbenanzahl übergeben. *)
   PROCEDURE UebergebeWerte* (     x, y, f : INTEGER;
                               VAR m       : INTEGER ) : BOOLEAN;
   BEGIN
      xmax   := x;
      ymax   := y;
      farben := f;
      Modus  := m;
      RETURN TestModus ( m );
   END UebergebeWerte;

   (* Bildausschnitt um das Doppelte vergrößern. *)
   PROCEDURE ZoomOut*;
      VAR
         x : LONGREAL;
   BEGIN
      x    := ( rmax - rmin ) / 1.99;
      rmin := rmin - x;
      IF rmin < -1.99 THEN rmin := -1.99 END;
      rmax := rmax + x;
      IF rmax >  1.99 THEN rmax :=  1.99 END;
      x    := ( imax - imin ) / 1.99;
      imin := imin - x;
      IF imin < -1.99 THEN imin := -1.99 END;
      imax := imax + x;
      IF imax >  1.99 THEN imax :=  1.99 END;
   END ZoomOut;

   (* Bildauschnitt auf das Startbild setzen. *)
   PROCEDURE Reset*;
   BEGIN
      rmax   :=  1.99;
      rmin   := -1.99;
      imax   :=  1.99;
      imin   := -1.99;
      Modus  := Word;
   END Reset;

BEGIN
   NEW(Tabelle); IF Tabelle=NIL THEN HALT(20) END;
   Init;
   Reset;
END ApfelMann.