Power-Programmierung/CD1.mdf/pascal/library/dos/sampler/02/mandel/mandel4.pas

Pascal/Delphi Source File | 1988-03-14 | 16.5 KB | 615 lines

PROGRAM Mandel4;

{This program generates a section of the Mandelbrot Set, can save it
on disk, and use existing Mandelbrot pictures to zoom further into
the Set.}

USES
   Crt, Graph, Cmplx; { CMPLX.TPU is created from CMPLX.PAS }

CONST
   Scan_Width = 359; { 719 (max Hercules) DIV 2 }
   Max_Scan_Lines = 349; { PC3270 maximum }
   Aspect = 0.75; { Typical screen aspect ratio }
   Real_Length = 30;
   Yes_N_No:  SET OF char = ['Y', 'N', 'y', 'n'];
   Yes:  SET OF char = ['Y', 'y'];
   No:  SET OF char = ['N', 'n'];
   TP_Path = 'T:';

TYPE
   Scan_Line = ARRAY [0..Scan_Width] OF byte;
   Scan_Line_Ptr = ^Scan_Line;
   Real_String = STRING[Real_Length];
   Color_Array = ARRAY [0..55] OF integer;

CONST
   Colors_2:  Color_Array = (0, 0, 0, 0, 1, 1, 1, 1,
                             0, 0, 0, 0, 1, 1, 1, 1,
   { Color arrangement for } 0, 0, 0, 0, 1, 1, 1, 1,
   { 2-color screens       } 0, 0, 0, 0, 1, 1, 1, 1,
                             0, 0, 0, 0, 1, 1, 1, 1,
                             0, 0, 0, 0, 1, 1, 1, 1,
                             0, 0, 0, 0, 1, 1, 1, 1);

   Colors_4:  Color_Array = (1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2,
                             3, 3, 3, 3, 3, 3, 1, 1, 1, 1, 1, 1,
   { Color arrangement for } 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3,
   { 4-color screens       } 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2,
                             3, 3, 3, 3, 3, 3, 0, 0);

   Colors_16:  Color_Array = (1,  9, 1,  9, 1,  9, 1,  9,
                              2, 10, 2, 10, 2, 10, 2, 10,
   { Color arrangement for }  3, 11, 3, 11, 3, 11, 3, 11,
   { 16-color screens      }  4, 12, 4, 12, 4, 12, 4, 12,
                              5, 13, 5, 13, 5, 13, 5, 13,
                              6, 14, 6, 14, 6, 14, 6, 14,
                              7, 15, 7, 15, 7, 15, 7, 15);

VAR
   Ch:  Char;
   Low, High, Delta:  Complex;
   Dots_Horizontal, Dots_Vertical, Start_Y, Max_Count, Color_Count,
      Device, Graph_Mode, Max_Colors, Max_X:  integer;
   Use_Color:  Color_Array;
   Picture_Loaded:  boolean;
   File_Name:  STRING[80];

   Data_Line:  Scan_Line;
   Screen_File:  FILE OF Scan_Line;
   Screen:  ARRAY [0..Max_Scan_Lines] OF Scan_Line_Ptr;
   Screen_Data:  RECORD
                    Dots_H, Dots_V, Count, Start:  integer;
                    Low_Real, Low_Imag,
                    High_Real, High_Imag:  Real_String;
                    Note:  String[200]
                 END ABSOLUTE Data_Line;

{*******************************************************************}

PROCEDURE Initialize;

{  This procedure checks for the graphics screen and selects a mode
based on a compromise between resolution and the number of colors.  }

VAR
   X:  integer;

BEGIN
TextMode (LastMode);
TextColor (LightBlue);
TextBackground (Black);
DirectVideo := False;
File_Name := '';
Picture_Loaded := False;
DetectGraph (Device, Graph_Mode);
X := GraphResult;

IF X<>grOk THEN
   BEGIN
   Writeln ('Sorry, I can''t cope with this:  ', GraphErrorMsg (X));
   Halt
   END {* THEN *};

CASE Device OF
   EGA:  Graph_Mode := EGAHi;
   VGA:  Graph_Mode := VGAMed;
   MCGA:  Graph_Mode := MCGAC0;
   EGA64:  Graph_Mode := EGA64Lo;
   ATT400:  Graph_Mode := ATT400C0;
   PC3270:  Graph_Mode := PC3270Hi;
   HercMono:  Graph_Mode := HercMonoHi;
   CGA, RESERVED:  Graph_Mode := CGAC0
END {* CASE *};

InitGraph (Device, Graph_Mode, TP_Path);

CASE Device OF
   CGA, MCGA, RESERVED,
   ATT400:  BEGIN
            Color_Count := 54;
            Use_Color := Colors_4;
            Max_Colors := 3;
            Max_X := GetMaxX
            END {* CASE CGAC0, MCGAC0, ATT400C0 *};

   EGA, VGA,
   EGA64:  BEGIN
           Color_Count := 56;
           Use_Color := Colors_16;
           Max_Colors := 15;
           Max_X := GetMaxX DIV 2
           END {* CASE EGAHi, VGAHi, EGA64Lo *};

   ELSE BEGIN
        Color_Count := 56;
        Use_Color := Colors_2;
        Max_Colors := 1;
        Max_X := GetMaxX DIV 2
        END {* CASE ELSE *}
END {* CASE *};

FOR X := 0 TO Max_Scan_Lines DO
   New (Screen[X]);

RestoreCrtMode
END {* Initialize *};

{*******************************************************************}

PROCEDURE Plot (X, Y:  integer;
                Color:  word);

{  This procedure plots points on the screen.  For high-resolution-
width screens, two adjacent pixels are set.  }

BEGIN
CASE Device OF
   CGA, MCGA, RESERVED,
   ATT400:  PutPixel (X, Y, Color);

   ELSE BEGIN
        PutPixel (X*2, Y, Color);
        PutPixel (X*2+1, Y, Color)
        END {* CASE ELSE *}
END {* CASE *}
END {* Plot *};

{*******************************************************************}

PROCEDURE Define_Screen;

{This procedure defines the area of the Mandelbrot Set to be viewed.
It can either be typed in at the keyboard, loaded as a partially
completed screen, or as a smaller sector of a completed picture.  }

VAR
   X, Y:  integer;
   Temp, Ratio:  double;

   {****************************************************************}

   PROCEDURE No_Blank (VAR RS:  Real_String);

   {  This procedure removes leading blanks from the string RS.  }

   BEGIN
   WHILE RS[1]=' ' DO
      RS := Copy (RS, 2, Length (RS)-1)
   END {* No_Blank *};

   {****************************************************************}

   PROCEDURE Sub_Picture;

   {  This procedure allows the user to select a sub-section of a
   completed screen to be blown up, effectively zooming in on a
   smaller area.

      Pressing keys 2 thru 5 changes the grid on the screen.  A sub-
   section may be chosen by pressing a letter, starting with A in the
   upper left corner and moving across:
                                            ┌─────┬─────┬─────┐
             ┌─────┬─────┐                  │  A  │  B  │  C  │
             │  A  │  B  │                  ├─────┼─────┼─────┤
         2:  ├─────┼─────┤              3:  │  D  │  E  │  F  │
             │  C  │  D  │                  ├─────┼─────┼─────┤
             └─────┴─────┘                  │  G  │  H  │  I  │
                                            └─────┴─────┴─────┘
                                      ┌─────┬─────┬─────┬─────┬─────┐
       ┌─────┬─────┬─────┬─────┐      │  A  │  B  │  C  │  D  │  E  │
       │  A  │  B  │  C  │  D  │      ├─────┼─────┼─────┼─────┼─────┤
       ├─────┼─────┼─────┼─────┤      │  F  │  G  │  H  │  I  │  J  │
       │  E  │  F  │  G  │  H  │      ├─────┼─────┼─────┼─────┼─────┤
   4:  ├─────┼─────┼─────┼─────┤  5:  │  K  │  L  │  M  │  N  │  O  │
       │  I  │  J  │  K  │  L  │      ├─────┼─────┼─────┼─────┼─────┤
       ├─────┼─────┼─────┼─────┤      │  P  │  Q  │  R  │  S  │  T  │
       │  M  │  N  │  O  │  P  │      ├─────┼─────┼─────┼─────┼─────┤
       └─────┴─────┴─────┴─────┘      │  U  │  V  │  W  │  X  │  Y  │
                                      └─────┴─────┴─────┴─────┴─────┘

   Once a section has been chosen, the program proceeds to calculate
   and display the smaller section, as large as the screen may allow.}

   CONST
      Max_Letter:  ARRAY [2..5] OF char = ('D', 'I', 'P', 'Y');

   VAR
      Ch:  char;
      New_Size, Size, X, Y, Z, Sector, Sector_X, Sector_Y:  integer;

   BEGIN
   Size := 1;
   File_Name := '';
   Ch := '2';

   REPEAT
      IF Ch IN ['2'..'5'] THEN
         BEGIN {* Change grid *}
         New_Size := Ord (Ch) - Ord ('0');

         IF Size<>New_Size THEN
            BEGIN
            { Undo existing grid }
            FOR X := 0 TO Dots_Horizontal DO
               FOR Z := 1 TO Size-1 DO
                  BEGIN
                  Y := Z * Dots_Vertical DIV Size;
                  Plot (X, Y, Screen[Y]^[X])
                  END {* FOR, FOR *};

            FOR Y := 0 TO Dots_Vertical DO
               FOR Z := 1 TO Size-1 DO
                  BEGIN
                  X := Z * Dots_Horizontal DIV Size;
                  Plot (X, Y, Screen[Y]^[X])
                  END {* FOR, FOR *};

            Size := New_Size;

            { Make new grid }
            FOR X := 0 TO Dots_Horizontal DO
               FOR Z := 1 TO Size-1 DO
                  BEGIN
                  Y := Z * Dots_Vertical DIV Size;
                  Plot (X, Y, Max_Colors-Screen[Y]^[X])
                  END {* FOR, FOR *};

            FOR Y := 0 TO Dots_Vertical DO
               FOR Z := 1 TO Size-1 DO
                  BEGIN
                  X := Z * Dots_Horizontal DIV Size;
                  Plot (X, Y, Max_Colors-Screen[Y]^[X])
                  END {* FOR, FOR *}
            END {* THEN *}
         END {* THEN *};

      Ch := UpCase (ReadKey)
   UNTIL (Size IN [2..5]) AND (Ch IN ['A'..Max_Letter[Size]]);

   { Calculate new limits }
   Sector := Ord (Ch) - Ord ('A');
   Sector_X := Sector MOD Size;
   Sector_Y := Size - 1 - Sector DIV Size;
   Sub_Comp (High, Low, Delta);
   Div_C_By_R (Delta, Size, Delta);
   Low.R := Low.R + Delta.R * Sector_X;
   High.R := Low.R + Delta.R;
   Low.I := Low.I + Delta.I * Sector_Y;
   High.I := Low.I + Delta.I;

   WITH Screen_Data DO
      BEGIN
      Start_Y := 0;
      Dots_H := Dots_Horizontal;
      Dots_V := Dots_Vertical;
      Count := Max_Count;
      Str (Low.R, Low_Real);
      Str (Low.I, Low_Imag);
      Str (High.R, High_Real);
      Str (High.I, High_Imag);
      No_Blank (Low_Imag);
      No_Blank (Low_Real);
      No_Blank (High_Imag);
      No_Blank (High_Real)
      END {* WITH *};

   RestoreCrtMode;
   Write
   ('Maximum iteration count = ', Max_Count, '.  Change it? (Y/N) ');

   REPEAT
      Ch := ReadKey
   UNTIL Ch IN Yes_N_No;

   Writeln (Ch);

   IF Ch IN Yes THEN
      BEGIN
      REPEAT
         Write ('Enter maximum iteration count:  ');
         {$I-} Readln (Max_Count) {$I+}
      UNTIL IOResult=0;

      IF Max_Count<10 THEN
         Max_Count := 10;

      Screen_Data.Count := Max_Count
      END {* THEN *};

   Write ('Enter note:  ');
   Readln (Screen_Data.Note);
   SetGraphMode (Graph_Mode)
   END {* Sub_Picture *};

   {****************************************************************}

BEGIN {* Define_Screen *}
Ch := 'N';

IF Picture_Loaded THEN
   BEGIN
   Write ('Use picture in memory? (Y/N) ');

   REPEAT
      Ch := ReadKey
   UNTIL Ch IN Yes_N_No;

   Writeln (Ch)
   END {* THEN *};

IF Ch IN No THEN
   BEGIN
   Write ('Load a picture file? (Y/N) ');

   REPEAT
      Ch := ReadKey
   UNTIL Ch IN Yes_N_No;

   Writeln (Ch);

   IF Ch IN Yes THEN
      BEGIN { Load picture file }
      REPEAT
         Write ('Enter name of file:  ');
         Readln (File_Name);
         Assign (Screen_File, File_Name);
         {$I-} Reset (Screen_File) {$I+};
      UNTIL IOResult=0;

      Read (Screen_File, Data_Line);

      FOR X := 0 TO Screen_Data.Start-1 DO
         Read (Screen_File, Screen[X]^);

      Close (Screen_File);
      Picture_Loaded := True
      END {* THEN *}

   ELSE
      BEGIN { Get info from keyboard }
      REPEAT
         Write ('Enter range for the real (horiz.) axis:  ');
         {$I-} Readln (Low.R, High.R) {$I+}
      UNTIL (IOResult=0) AND (Low.R<>High.R);

      IF Low.R>High.R THEN
         BEGIN
         Temp := Low.R;
         Low.R := High.R;
         High.R := Temp
         END {* THEN *};

      REPEAT
         Write ('Enter range for the imaginary (vert.) axis:  ');
         {$I-} Readln (Low.I, High.I) {$I+}
      UNTIL (IOResult=0) AND (Low.I<>High.I);

      IF Low.I>High.I THEN
         BEGIN
         Temp := Low.I;
         Low.I := High.I;
         High.I := Temp
         END {* THEN *};

      REPEAT
         Write ('Enter maximum iteration count:  ');
         {$I-} Readln (Max_Count) {$I+}
      UNTIL IOResult=0;

      IF Max_Count<10 THEN
         Max_Count := 10;

      Write ('Enter note:  ');
      Readln (Screen_Data.Note);
      Start_Y := 0;
      Sub_Comp (High, Low, Delta);
      Ratio := Delta.I / Delta.R;
      SetGraphMode (Graph_Mode);

      IF Ratio>=Aspect THEN
         BEGIN
         Dots_Horizontal := Round ((Max_X + 1) * Aspect / Ratio) - 1;
         Dots_Vertical := GetMaxY
         END (* THEN *)

      ELSE
         BEGIN
         Dots_Vertical := Round ((GetMaxY + 1) * Ratio / Aspect) - 1;
         Dots_Horizontal := Max_X
         END (* ELSE *);

      WITH Screen_Data DO
         BEGIN
         Dots_H := Dots_Horizontal;
         Dots_V := Dots_Vertical;
         Count := Max_Count;
         Str (Low.I, Low_Imag);
         Str (Low.R, Low_Real);
         Str (High.I, High_Imag);
         Str (High.R, High_Real);
         No_Blank (Low_Imag);
         No_Blank (Low_Real);
         No_Blank (High_Imag);
         No_Blank (High_Real)
         END {* WITH *};

      Picture_Loaded := False;
      File_Name := ''
      END {* ELSE *}
   END {* THEN *};

IF Picture_Loaded THEN
   BEGIN { Dump picture onto the screen }
   SetGraphMode (Graph_Mode);

   WITH Screen_Data DO
      BEGIN
      Start_Y := Start;
      Max_Count := Count;
      Dots_Horizontal := Dots_H;
      Dots_Vertical := Dots_V;
      Val (Low_Real, Low.R, X);
      Val (Low_Imag, Low.I, X);
      Val (High_Real, High.R, X);
      Val (High_Imag, High.I, X)
      END {* WITH *};

   FOR Y := 0 TO Start_Y-1 DO
      FOR X := 0 TO Dots_Horizontal DO
         Plot (X, Y, Screen[Y]^[X]);

   IF Start_Y>GetMaxY THEN
      Sub_Picture { Get a subregion of the completed picture }
   ELSE
      Sub_Comp (High, Low, Delta) { Continue drawing the picture }
   END {* THEN *};

Delta.R := Delta.R / (Dots_Horizontal + 1);
Delta.I := Delta.I / (Dots_Vertical + 1)
END {* Define_Screen *};

{*******************************************************************}

PROCEDURE Generate;

{  This is where most of the program's time is spent, generating the
screen.  The section marked 1* is where code has been optimized by
putting the complex-number math instructions in this procedure rather
than calling the actual procedures.  }

VAR
   X, Y, Count:  integer;
   Z_Point, C_Point:  Complex;
   Temp:  double;

BEGIN {* Generate *}
Plot (Dots_Horizontal, Dots_Vertical, Max_Colors);
C_Point.I := High.I - Start_Y * Delta.I;
Y := Start_Y;

WHILE (Y<=Dots_Vertical) AND NOT KeyPressed DO
   BEGIN
   FillChar (Screen[Y]^, Scan_Width+1, 0);
   C_Point.R := Low.R - Delta.R;

   FOR X := 0 TO Dots_Horizontal DO
      BEGIN
      Plot (X, Y, Max_Colors);
      C_Point.R := C_Point.R + Delta.R;
      Z_Point := C_Point;
      Count := 0;

      WHILE (Count<=Max_Count) AND (Square_Size_Of_C (Z_Point)<4.0) DO
         BEGIN
{ 1*     Mult_Comp (Z_Point, Z_Point, Z_Point);  }
{ 2*     Add_Comp (Z_Point, C_Point, Z_Point);  }

         Temp := Sqr (Z_Point.R) - Sqr (Z_Point.I) + C_Point.R;
         Z_Point.I := 2.0 * Z_Point.I * Z_Point.R + C_Point.I;
         Z_Point.R := Temp;
         Count := Succ (Count)
         END {* WHILE *};

      IF Count<Max_Count THEN
         Screen[Y]^[X] := Use_Color[Count MOD Color_Count];

      Plot (X, Y, Screen[Y]^[X])
      END {* FOR *};

   C_Point.I := C_Point.I - Delta.I;
   Y := Y + 1
   END {* WHILE *};

Screen_Data.Start := Y
END {* Generate *};

{*******************************************************************}

PROCEDURE Wrap_Up;

{  This procedure deals with the shutting down of a picture.  }

VAR
   X:  integer;

BEGIN
Picture_Loaded := True;

IF KeyPressed THEN
   Sound (440)

ELSE
   BEGIN
   Sound (660);
   Delay (20);
   Sound (1000)
   END {* ELSE *};

Delay (50);
NoSound;

Ch := ReadKey;

RestoreCrtMode;
Write ('Save picture? (Y/N) ');

REPEAT
   Ch := ReadKey
UNTIL Ch IN Yes_N_No;

Writeln (Ch);

IF Ch IN Yes THEN
   BEGIN
   IF File_Name<>'' THEN
      BEGIN
      Write ('Save as ', File_Name, '? (Y/N) ');

      REPEAT
         Ch := ReadKey
      UNTIL Ch IN Yes_N_No;

      Writeln (Ch)
      END {* THEN *}

   ELSE
      Ch := 'N';

   IF Ch IN No THEN
      BEGIN
      Write ('Enter filename to save it in:  ');
      Readln (File_Name)
      END {* THEN *};

   Assign (Screen_File, File_Name);
   Rewrite (Screen_File);
   Write (Screen_File, Data_Line);

   FOR X := 0 TO Screen_Data.Start-1 DO
      Write (Screen_File, Screen[X]^);

   Close (Screen_File)
   END {* THEN *};

Write ('Do another? (Y/N) ');

REPEAT
   Ch := ReadKey
UNTIL Ch IN Yes_N_No;

Writeln (Ch)
END {* Wrap_Up *};

{*******************************************************************}

BEGIN {* main *}
Initialize;

REPEAT
   Define_Screen;
   Generate;
   Wrap_Up
UNTIL Ch IN No
END.