program fractal (input,output,remotefile,prntr);
 
 uses applestuff, turtlegraphics, transcend;
 
 const
   {memory locations for low level turtlegraphic routines}
 xhi           = 3449;    {the most significant byte in the x coordinate}
 xlo           = 3450;    {the least significant byte in the y coordinate}
 ylo           = 3452;    {the turtlegraphics y coordinate}
 color         = 3453;    {the color which is currently being plotted}
 base          = 8192;    {the base of the page 1 hires screen}
 
   {basic constants}
 maximumint    = 32767;   {maxint for 16 bit integers}
 squaredradius = 4;       {faster than testing for sqr(2)}
 maxiter       = 100;     {maximum number of iteritions}
 pi            = 3.14159; {everyone's favorite number}
 
   {initial parameters}
 horizontal    = 560;     {number of horizontal screen points}
 vertical      = 192;     {number of vertical screen points}
 mina          = -2.25;   {default minimum real value of the region}
 maxa          = 0.75;    {default maximum real value of the region}
 minb          = -1.5;    {default minimum imaginary value of the region}
 maxb          = 1.5;     {default maximum imaginary value of the region}
 
   {constants for fractal mountain routines}
 xs            = 0.04;    {scaling constants}
 ys            = 0.04;
 zs            = 0.04;
 hr            = 0.52359; {pi / 6}
 vt            = 0.62831; {pi / 5}
 
 type
 map = array [0..64,0..32] of integer;  {matrix of topograph data}
 coor = packed array [1..horizontal,1..vertical] of boolean;  {DHR graphics
  screen}
 imaginary = record       {an imaginary number  i.e. a + bi}
               a : real;
               b : real;
             end;
 region = record          {a rectangle on the imaginary plane}
            max : imaginary;
            min : imaginary;
            hor : integer;
            ver : integer;
   end;
 screen = record          {the data that describes a file}
            where : region;
            con : imaginary;
            name : string;
            bitmap : coor;
          end;
 byte = 0..255;               {tricks for low level peeks and pokes}
 memloc = packed array [0..1] of byte;
 access = record case boolean of
            true: (address:integer);
            false: (pointer: ^memloc);
          end;
 
 var
 graphed:boolean;       {is the fractal graphed}
 fraccalc:boolean;      {is there a valid fractal in memory}
 choice:char;           {generic var}
 pages:screen;          {the current fractal}
 
   {mountain fractal vars}
 levels:integer;        {the resolution of the mountain fractals}
 xlast,ylast:integer;   {the previous point graphed to the screen}
 y3:real;               {just had to be global}
 
 function peek (addrs:integer):byte;
 var
 memory:access;
 begin
   memory.address:=addrs;
   peek:=memory.pointer^[0];
 end;
 
 procedure poke (addrs:integer;val:byte);
 var
 memory:access;
 begin
   memory.address:=addrs;
   memory.pointer^[0]:=val;
 end;
 
 procedure dhrenable;  {turns on double hires graphics - grafmode}
 begin
   poke (-16302,0);  {full screen}
   poke (-16297,0);  {hires on}
   poke (-16371,0);  {80 col on}
   poke (-16304,0);  {graphics on}
   poke (-16258,0);  {IOUdis on}
   poke (-16290,0);  {DHR on}
   poke (-16383,0);  {80 store on}
   poke (-16300,0);  {page 2 off}
 end;
 
 procedure dhrclear;  {clears both hires screens - initturtle}
 begin
   dhrenable;
   initturtle;
   poke (-16299,0);  {access aux mem}
   initturtle;
   poke (-16300,0);  {return to main mem}
 end;
 
 procedure txtmode;  {sets text screen use - textmode}
 begin
   poke (-16384,0);  {turn off 80 store softswitch}
   poke (-16289,0);  {turn off the double hi resolution softswitch}
   poke (-16300,0);  {turn on text page 1}
   poke (-16303,0);  {turn on the text screen}
 end;
 
 (*$I-*)  {turn off input/output status checking - for speed}
 (*$R-*)  {turn off range checking - for speed}
 
 procedure line (x,y:integer);  {draws a line from current point to point (x,y)}
 var                            {in the array but not on the screen - similar}
 ang:real;                      {to moveto (x,y)}
 i,j,k,p,q,clr:integer;
 begin
   clr:=peek (color);  {get current parameters}
   i:=256 * peek (xhi) + peek (xlo);
   j:=peek (ylo);
   if (x > i) or ((x = i) and (y > j)) then  {set increment}
     k:=1
   else
     k:=-1;
   if (i = x) then  {determine if vertical or sloped line}
   begin
     j:=j + k;  {vertical line}
     while (j <> (y+k)) do
     begin
       if (clr = 15) then
         pages.bitmap[i+1,j+1]:=true
       else
         if (clr = 0) then
           pages.bitmap[i+1,j+1]:=false;
       j:=j + k;
     end;
     j:=j - k;
   end
   else
   begin
     p:=i;  {draw a sloped line}
     q:=j;
     ang:=(y - j) / (x - i);
     i:=i + k;
     while (i <> (x+k)) do
     begin
       j:=round (ang * (i-p) + q);
       if (clr = 15) then
         pages.bitmap[i+1,j+1]:=true
       else
         if (clr = 0) then
           pages.bitmap[i+1,j+1]:=false;
       i:=i + k;
     end;
     i:=i - k;
   end;
   poke (xlo,i mod 256);  {store new coordinates}
   poke (xhi,i div 256);
   poke (ylo,j);
 end;
 
 procedure test (ax,ay,mx,my:integer;var bx,by:integer);
 begin
   if (ay > my) then
   begin
     by:=mx + 1 - ay;
     bx:=mx - ax;
   end
   else
   begin
     by:=ay;
     bx:=ax;
   end;
 end;
 
 procedure landscape (mx,my,sk,ib:integer;l:real;var darray:map);
 var                     {creates random topograph}
 xe,ye:integer;
 d1,d2:integer;
 bx,by:integer;
 begin
   ye:=0;
   while (ye <= mx-1) do
   begin
     xe:=ib + ye;
     while (xe <= mx) do
     begin
       test (xe-ib,ye,mx,my,bx,by);
       d1:=darray[bx,by];
       test (xe+ib,ye,mx,my,bx,by);
       d2:=darray[bx,by];
       test (xe,ye,mx,my,bx,by);
  darray[bx,by]:=round ((d1 + d2) / 2.0 + random / 32767.0 * l / 2.0 - l / 4.0);
       xe:=xe + sk
     end;
     ye:=ye + sk;
   end;
   xe:=mx;
   while (xe >= 1) do
   begin
     ye:=ib;
     while (ye <= xe) do
     begin
       test (xe,ye+ib,mx,my,bx,by);
       d1:=darray[bx,by];
       test (xe,ye-ib,mx,my,bx,by);
       d2:=darray[bx,by];
       test (xe,ye,mx,my,bx,by);
  darray[bx,by]:=round ((d1 + d2) / 2.0 + random / 32767.0 * l / 2.0 - l / 4.0);
       ye:=ye + sk
     end;
     xe:=xe - sk;
   end;
   xe:=0;
   while (xe <= mx-1) do
   begin
     ye:=ib;
     while (ye <= mx - xe) do
     begin
       test (xe+ye-ib,ye-ib,mx,my,bx,by);
       d1:=darray[bx,by];
       test (xe+ye+ib,ye+ib,mx,my,bx,by);
       d2:=darray[bx,by];
       test (xe+ye,ye,mx,my,bx,by);
  darray[bx,by]:=round ((d1 + d2) / 2.0 + random / 32767.0 * l / 2.0 - l / 4.0);
       ye:=ye + sk
     end;
     xe:=xe + sk;
   end;
 end;
 
 procedure adjust (var x0:integer;var xx,yy,zz:real);
 var
 clr:integer;
 xp,yp:integer;
 temp:real;
 ra,r1,rd:real;
 begin
   xx:=xx * xs;
   yy:=yy * ys;
   zz:=zz * zs;
   if (xx <> 0.0) then
   begin
     ra:=atan (yy / xx);
     if (xx < 0.0) then
       ra:=ra + pi;
     if (yy > 10000.0) then
       yy:=10000.0;
     if (yy < -10000.0) then
       yy:=-10000.0;
   end
   else
   begin
     if (yy <= 0.0) then
       ra:=-pi / 2.0
     else
       ra:=pi / 2.0;
   end;
   rd:=sqrt (xx * xx + yy * yy);
   r1:=ra + hr;
   xx:=rd * cos (r1);
   yy:=rd * sin (r1);
   if (xx = 0.0) then
     ra:=pi / 2.0
   else
   begin
     ra:=atan (zz / xx);
     if (xx < 0.0) then
       ra:=ra + pi;
   end;
   rd:=sqrt (zz * zz + xx * xx);
   r1:=ra - vt;
   xx:=rd * cos (r1) + xx;
   zz:=rd * sin (r1);
   temp:=yy * 0.625 * 2;
   if (temp >= -32768.0) and (temp <= 32767.0) then
     xp:=round (temp)
   else
     if (temp > 32767.0) then
       xp:=maxint
     else
       xp:=-maxint;
   temp:=33.14 - 0.663 * zz;
   if (temp >= -32768.0) and (temp <= 32767.0) then
     yp:=round (temp)
   else
     if (temp > 32767.0) then
       yp:=maxint
     else
       yp:=-maxint;
   if (x0 = -999) then
   begin
     xlast:=xp;
     ylast:=yp;
     x0:=0;
   end;
   if (ylast <= 191) and (ylast >= 0) and (yp <= 191) and (yp >= 0) then
   begin
     clr:=peek (color);  {get current color}
     poke (color,16);  {set color none}
     line (xlast,ylast);
     poke (color,clr);  {set color to previous color}
     line (xp,yp);
     xlast:=xp;
     ylast:=yp;
   end;
 end;
 
 procedure calc (x0:integer;var xx,yy,zz,x,y,z:real);
 var
 temp:boolean;
 xt,yt,zt:real;
 w3,x3,z3:real;
 begin
   if (x0 <> -999) then
   begin
     temp:=(z < 0.0) and (zz < 0.0);
     if (z > 0.0) and (zz > 0.0) or temp then
     begin
       x:=xx;
       y:=yy;
       z:=zz;
       if temp then
         zz:=0.0;
       exit (calc);
     end;
   end
   else
   begin
     x:=xx;
     y:=yy;
     z:=zz;
     if (zz < 0.0) then
     begin
       poke (color,15);  {darkblue - actually white because this is B&W}
       zz:=0.0;
     end
     else
       poke (color,15);  {white}
     exit (calc);
   end;
   if (y3 > 10000.0) then
     y3:=10000.0;
   if (y3 < -10000.0) then
     y3:=-10000.0;
   if (zz <> z) then
     w3:=zz / (zz - z);
   x3:=(x - xx) * w3 + xx;
   y3:=(y - yy) * y3 + yy;
   z3:=0.0;
   xt:=xx;
   yt:=yy;
   zt:=zz;
   xx:=x3;
   yy:=y3;
   zz:=z3;
   adjust (x0,xx,yy,zz);
   if (zt <= 0.0) then
   begin
     poke (color,15);  {darkblue - actually while since this is only B&W}
     xx:=xt;
     yy:=yt;
     zz:=0.0;
     z:=zt;
   end
   else
   begin
     poke (color,15);  {white}
     xx:=xt;
     yy:=yt;
     zz:=zt;
     z:=zz;
   end;
   x:=xx;
   y:=yy;
 end;
 
 procedure graph3d (var mx,my:integer;var darray:map);
 var
 x0:integer;
 ax,ay:integer;
 bx,by:integer;
 ex,ey:integer;
 xx,yy,zz:real;
 x,y,z:real;
 begin
   for ax:=0 to mx do
   begin
     x0:=-999;
     for ay:=0 to ax do
     begin
       test (ax,ay,mx,my,bx,by);
       zz:=darray[bx,by];
       yy:=ay / mx * 10000.0;
       xx:=ax / mx * 10000.0 - yy / 2.0;
       calc (x0,xx,yy,zz,x,y,z);
       adjust (x0,xx,yy,zz);
     end;
   end;
   for ay:=0 to mx do
   begin
     x0:=-999;
     for ax:=ay to mx do
     begin
       test (ax,ay,mx,my,bx,by);
       zz:=darray[bx,by];
       yy:=ay / mx * 10000.0;
       xx:=ax / mx * 10000.0 - yy / 2.0;
       calc (x0,xx,yy,zz,x,y,z);
       adjust (x0,xx,yy,zz);
     end;
   end;
   for ex:=0 to mx do
   begin
     x0:=-999;
     for ey:=0 to mx-ex do
     begin
       ax:=ex + ey;
       ay:=ey;
       test (ax,ay,mx,my,bx,by);
       zz:=darray[bx,by];
       yy:=ay / mx * 10000.0;
       xx:=ax / mx * 10000.0 - yy / 2.0;
       calc (x0,xx,yy,zz,x,y,z);
       adjust (x0,xx,yy,zz);
     end;
   end;
 end;
 
 procedure mountfrac (var levels:integer;var fraccalc:boolean);
 var                 {driver for fractal mountains}
 mx,my:integer;
 i,j:integer;
 sk:integer;
 ib:integer;
 l:real;
 darray:map;
 begin
   for j:=0 to 32 do
     for i:=0 to 64 do
       darray[i,j]:=0;
   l:=2.0;
   for i:=1 to levels do
     l:=l + exp ((i - 1) * 0.693147);
   mx:=round (l - 1);
   my:=mx div 2;
   randomize;
   for i:=1 to levels do
   begin
     l:=10000 / exp (i * ln (1.8));
     ib:=round (mx / exp (i * 0.693147));
     sk:=ib * 2;
     landscape (mx,my,sk,ib,l,darray);
   end;
   graph3d (mx,my,darray);
   fraccalc:=true;
   write (chr (7));
 end;
 
 procedure display (var bitmap:coor;var graphed:boolean);
 var               {copies the boolean matrix to the DHR graphics screen}
 a,b,c,d,e,i,j,k,s,t:integer;
 begin
   dhrenable;
   j:=1;
   while (j <= pages.where.ver) and (j <= 192) do
   begin
     c:=j div 64;
     e:=j mod 64;
     b:=e div 8;
     a:=e mod 8;
     d:=(1024 * a) + (128 * b) + (40 * c) + base;
     i:=0;  {convert 7 booleans to a char to poke in video RAM}
     while (i < (pages.where.hor div 7)) and (i < 80) do
     begin
       t:=0;
       s:=64;
       k:=7;
       while (k > 0) do
       begin
         if bitmap[(7*i)+k,j] then
           t:=t + s;
         s:=s div 2;
         k:=k-1;
       end;
       poke (-16299 - i mod 2,0);  {select correct screen}
       poke ((i div 2) + d,t);  {store bit pattern}
       i:=i+1;
     end;
     j:=j+1;
   end;
   graphed:=true;
   write (chr (7));
 end;
 
 (*$I+*)  {turn on input/output status checking}
 
 procedure dhrprinter (var pages:screen);
 const                {copies boolean matrix to printer for hardcopy}
 numlines = 32;
 type
 printhead = record case boolean of
               true : (bool:packed array [1..24] of boolean);
               false : (c:packed array [1..3] of char);
             end;
 var
 x,y,nl,i,row,rep,col:integer;
 val:array [1..4] of char;
 pixel:printhead;
 prntr:text;
 begin
   rewrite (prntr,'PRINTER:');
   writeln (prntr);
   writeln (prntr,'Fractal: ',pages.name);
   writeln (prntr);
   row:=(24 * numlines) div vertical;
   rep:=1280 div pages.where.hor;
   col:=pages.where.hor * (1280 div pages.where.hor);
   for i:=4 downto 1 do
   begin
     val[i]:=chr (col mod 10 + 48);
     col:=col div 10;
   end;
   nl:=1;
   while (nl <= numlines) do
   begin
     write (prntr,chr(27),'j');
     write (prntr,chr(27),'C',val[1],val[2],val[3],val[4]);
     y:=(24 div row) * (nl - 1);
     x:=1;
     while (x <= pages.where.hor) do
     begin
       for i:=1 to 24 do
         pixel.bool[i]:=pages.bitmap[x,y + (i div row)];
       for i:=1 to rep do
         write (prntr,pixel.c[1],pixel.c[2],pixel.c[3]);
       x:=x+1;
     end;
     writeln (prntr);
     nl:=nl+1;
   end;
   with pages do
   begin
     writeln (prntr);
     writeln (prntr,'Fractal coordinates are: ');
     write (prntr,where.max.a:12:5,' + ',where.max.b:12:5,'i   to   ');
     writeln (prntr,where.min.a:12:5,' + ',where.min.b:12:5,'i');
     writeln (prntr,'Julia Constant is: ');
     writeln (prntr,con.a:12:5,' + ',con.b:12:5,'i');
   end;
   close (prntr);
   write (chr(7));
 end;
 
 procedure julia (var pages:screen;var fraccalc,graphed:boolean);
 var
 h,v,n:integer;
 a,b,temp:real;
 dval,z:imaginary;
 begin
   dval.a:=(pages.where.max.a - pages.where.min.a)/(pages.where.hor - 1);
   dval.b:=(pages.where.max.b - pages.where.min.b)/(pages.where.ver - 1);
   v:=1;
   while (v <= pages.where.ver) do
   begin
     h:=1;
     while (h <= pages.where.hor) do
     begin
       z.a:=pages.where.min.a + (h - 1) * dval.a;
       z.b:=pages.where.min.b + (v - 1) * dval.b;
       n:=0;
       a:=z.a*z.a;
       b:=z.b*z.b;
       while (a + b <= squaredradius) and (n < maxiter) do
       begin
         temp:=z.a;
         z.a:=a - b + pages.con.a;
         z.b:=2 * temp * z.b + pages.con.b;
         n:=n + 1;
         a:=z.a*z.a;
         b:=z.b*z.b;
       end;
       if (a + b <= squaredradius) then
         pages.bitmap[h,pages.where.ver - v + 1]:=true;
       h:=h+1;
     end;
     gotoxy (40,23);
     write (v/pages.where.ver*100:5:2,'% done');
     v:=v+1;
   end;
   fraccalc:=true;
   graphed:=false;
   pages.name:='None';
 end;
 
 procedure mandelbrot (var pages:screen;var fraccalc,graphed:boolean);
 var
 h,v,n:integer;
 a,b,temp:real;
 dval,z,val:imaginary;
 begin
   dval.a:=(pages.where.max.a - pages.where.min.a)/(pages.where.hor - 1);
   dval.b:=(pages.where.max.b - pages.where.min.b)/(pages.where.ver - 1);
   v:=1;
   while (v <= pages.where.ver) do
   begin
     val.b:=pages.where.min.b + (v - 1) * dval.b;
     h:=1;
     while (h <= pages.where.hor) do
     begin
       val.a:=pages.where.min.a + (h - 1) * dval.a;
       n:=0;
       z.a:=0;
       z.b:=0;
       a:=0;
       b:=0;
       while (a + b <= squaredradius) and (n < maxiter) do
       begin
         temp:=z.a;
         z.a:=a - b + val.a;
         z.b:=2 * temp * z.b + val.b;
         a:=z.a*z.a;
         b:=z.b*z.b;
         n:=n + 1;
       end;
       if (a + b <= squaredradius) then
         pages.bitmap[h,pages.where.ver - v + 1]:=true;
       h:=h+1;
     end;
     gotoxy (40,23);
     write (v/pages.where.ver*100:5:2,'% done');
     v:=v+1;
   end;
   fraccalc:=true;
   graphed:=false;
   pages.name:='None';
 end;
 procedure loadfrac (var pages:screen;var fraccalc,graphed:boolean);
 var
 temp,last,x,y:integer;
 temp2:char;
 remotefile:text;
 begin
 page (output);
   writeln;
   writeln;
   write ('What is the name of the file to load? ');
   readln (pages.name);
   reset (remotefile,pages.name);
   with pages do
   begin
     readln (remotefile,name);
     readln (remotefile,where.hor);
     readln (remotefile,where.ver);
     readln (remotefile,where.max.a);
     readln (remotefile,where.min.a);
     readln (remotefile,where.max.b);
     readln (remotefile,where.min.b);
     readln (remotefile,con.a);
     readln (remotefile,con.b);
   end;
   if (pages.where.hor > horizontal) or (pages.where.ver > vertical) then
   begin
     writeln ('Error: graph too large for current screen size');
     writeln ('Please change horizontal and/or vertical constants to');
     writeln (pages.where.hor,' * ',pages.where.ver);
     writeln ('Please press <return>');
     pages.where.hor:=horizontal;
     pages.where.ver:=vertical;
     readln;
   end
   else
   begin
     last:=0;
     y:=1;
     x:=1;
     repeat
       readln (remotefile,temp);
       if (temp < 0) then
       begin
         temp2:='F';
         temp:=-temp;
       end
       else
         temp2:='T';
       while (x - last <= temp) do
       begin
         pages.bitmap[x,y]:=(temp2='T');
         x:=x+1;
         if (x > pages.where.hor) then
         begin
           temp:=temp - (x-last-1);
           last:=0;
           x:=1;
           y:=y+1;
         end;
       end;
       last:=x-1;
     until eof (remotefile);
     close (remotefile);
     fraccalc:=true;
     graphed:=false;
     write (chr (7));
   end;
 end;
 
 procedure savefrac (var pages:screen);
 var
 i,j,x:integer;
 prev,cur:char;
 remotefile:text;
 begin
   page (output);
   writeln;
   writeln;
   write ('What do you want to name this file? ');
   readln (pages.name);
   rewrite (remotefile,pages.name);
   with pages do
   begin
     writeln (remotefile,name);
     writeln (remotefile,where.hor);
     writeln (remotefile,where.ver);
     writeln (remotefile,where.max.a:12:5);
     writeln (remotefile,where.min.a:12:5);
     writeln (remotefile,where.max.b:12:5);
     writeln (remotefile,where.min.b:12:5);
     writeln (remotefile,con.a:12:5);
     writeln (remotefile,con.b:12:5);
   end;
   x:=0;
   prev:='F';
   j:=1;
   while (j <= pages.where.ver) do
   begin
     i:=1;
     while (i <= pages.where.hor) do
     begin
       if pages.bitmap[i,j] then
         cur:='T'
       else
         cur:='F';
       if (cur = prev) and (x < maximumint) then
         x:=x+1
       else
       begin
         if (prev = 'T') then
           writeln (remotefile,x:1)
         else
           writeln (remotefile,-x:1);
         x:=1;
         prev:=cur;
       end;
       i:=i+1;
     end;
     j:=j+1;
   end;
   if (prev = 'T') then
     writeln (remotefile,x:1)
   else
     writeln (remotefile,-x:1);
   close (remotefile,lock);
   write (chr (7));
 end;
 
 procedure invert (x,y:integer;var bitmap:coor);
 var
 bit,clr,a,b,c,d,i,j,k,l:integer;
 begin
   y:=192 - y;
   c:=y div 64;  {calculate byte of point (x,y)}
   d:=y mod 64;
   b:=d div 8;
   a:=d mod 8;
   i:=x div 7;
   j:=(1024 * a) + (128 * b) + (40 * c) + base + (i div 2);
   l:=1;  {mask to set correct bit}
   for k:=1 to (x mod 7) do
     l:=l*2;
   poke (-16383,0);  {set 80 store}
   poke (-16299 - i mod 2,0);  {sets the correct screen}
   bit:=peek (j);
   if (ord (odd (bit) and odd (l)) = l) then
     poke (j,ord (odd (bit) and not (odd (l))))  {plot black point}
   else
     poke (j,ord (odd (bit) or odd (l)));  {plot white point}
 end;
 
 (*$R+*)
 
 procedure findpoint (var h,v:integer;var bitmap:coor);
 var
 dir:char;
 page,point:boolean;
 x,y:integer;
 begin
   point:=false;
   while not point do
   begin
     invert (h,v,bitmap);
     page:=peek (-16356) > 127;  {determine which screen is displayed}
     poke (-16300,0);  {turn on main screen}
     read (dir);
     dhrenable;
     if page then
       poke (-16299,0);
     if (dir='P') or (dir='p') then
       point:=true
     else
     begin
       x:=0;
       y:=0;
       if (dir=chr (11)) then
         y:=1
       else
       if (dir=chr (8)) then
         x:=-1
       else
       if (dir=chr (21)) then
         x:=1
       else
       if (dir=chr (10)) then
         y:=-1;
       invert (h,v,bitmap);
       if (h+x >= 0) and (h+x <= 559) then
         h:=h+x;
       if (v+y >= 1) and (v+y <= 192) then
         v:=v+y;
     end;
   end;
   invert (h,v,bitmap);
   write (chr (7));
 end;
 
 procedure status (fraccalc:boolean;var pages:screen);
 begin
   writeln;
   with pages do
   begin
     writeln ('Name of current fractal: ',name);
     writeln;
     writeln ('Current region set at:');
     write (where.max.a:12:5,' + ',where.max.b:12:5,'i   to   ');
     writeln (where.min.a:12:5,' + ',where.min.b:12:5,'i');
     writeln ('Current Julia Constant: ',con.a:12:5,' + ',con.b:12:5,'i');
   end;
   writeln;
   write ('This region has ');
   if not fraccalc then
     write ('not yet ');
   writeln ('been calculated.');
   writeln;
 end;
 
 procedure changescreen (var choice:char;fraccalc:boolean;var pages:screen);
 begin
   page (output);
   status (fraccalc,pages);
   repeat
     writeln;
     writeln;
     writeln ('  (E)nter new values for the region');
     writeln ('  (S)elect the new region from the graph');
     writeln ('  (T)ype in a new Julia Constant');
     writeln ('  (C)hoose a new Julia Constant from the graph');
     writeln ('  (D)o not change region or constant');
     writeln;
     write ('  Enter your choice:  ');
     read (choice);
     writeln;
   until choice in ['c','C','d','D','e','E','s','S','t','T'];
 end;
 
 procedure selectregion (var pages:screen);
 var
 temp,i,h,v,x,y:integer;
 tempregion:region;
 begin
   writeln;
   writeln ('Use arrow keys to move cursor and push (P)');
   write ('to select both points.  Press <return>.');
   readln;
   dhrenable;
   h:=pages.where.hor div 2;
   v:=pages.where.ver div 2;
   findpoint (h,v,pages.bitmap);
   x:=h;
   y:=v;
   findpoint (x,y,pages.bitmap);
   if (h < x) then
   begin
     temp:=x;
     x:=h;
     h:=temp;
   end;
   if (v < y) then
   begin
     temp:=y;
     y:=v;
     v:=temp;
   end;
   for i:=y to v do
     invert (h,i,pages.bitmap);
   for i:=h downto x do
     invert (i,v,pages.bitmap);
   for i:=v downto y do
     invert (x,i,pages.bitmap);
   for i:=x to h do
     invert (i,y,pages.bitmap);
   with pages.where do
   begin
     tempregion.max.a:=min.a + (h-1)*(max.a-min.a)/(hor-1);
     tempregion.max.b:=min.b + (v-1)*(max.b-min.b)/(ver-1);
     tempregion.min.a:=min.a + (x-1)*(max.a-min.a)/(hor-1);
     tempregion.min.b:=min.b + (y-1)*(max.b-min.b)/(ver-1);
   end;
   pages.where:=tempregion;
   poke (-16300,0);  {turn on page 1}
   readln;
   poke (-16303,0);  {turn on text screen}
 end;
 
 procedure selectconst (var pages:screen);
 var
 h,v:integer;
 begin
   writeln;
   writeln ('Use arrow keys to move cursor and push (P)');
   write ('to select the point.  Press <return>.');
   readln;
   dhrenable;
   with pages do
   begin
     h:=round ((where.hor-1)*(con.a-where.min.a)/(where.max.a-where.min.a)+1);
     v:=round ((where.ver-1)*(con.b-where.min.b)/(where.max.b-where.min.b)+1);
     findpoint (h,v,bitmap);
     con.a:=where.min.a+(h-1)*(where.max.a-where.min.a)/(where.hor-1);
     con.b:=where.min.b+(v-1)*(where.max.b-where.min.b)/(where.ver-1);
   end;
   poke (-16300,0);  {turn on page 1}
   poke (-16303,0);  {turn on text screen}
 end;
 
 procedure enterregion (var pages:screen);
 var
 userdone:boolean;
 choice:char;
 temp:real;
 begin
   repeat
     writeln;
     write ('Type the maximum imaginary ');
     writeln ('number in the region. ie.  4.5 -3.4i');
     with pages.where do
     begin
       readln (max.a,max.b,choice);
       writeln;
       writeln ('Now type the minimum imaginary in the region.');
       readln (min.a,min.b,choice);
       if (max.a < min.a) then
       begin
         temp:=max.a;
         max.a:=min.a;
         min.a:=temp;
       end;
       if (max.b < min.b) then
       begin
         temp:=max.b;
         max.b:=min.b;
         min.b:=temp;
       end;
     end;
     with pages do
     begin
       if (con.a < where.min.a) or (con.a > where.max.a) or
          (con.b < where.min.b) or (con.b > where.max.b) then
          begin
            writeln;
            write ('Invalid coordinates.  Press <return>.');
            readln;
            userdone:=false;
            page (output);
          end
       else
       begin
         write ('Is this correct? (Y)es or (N)o ');
         read (choice);
         case choice of
           'N','n': userdone:=false;
           'Y','y': userdone:=true;
         end;
       end;
     end;
   until userdone;
 end;
 
 procedure enterconst (var pages:screen);
 var
 userdone:boolean;
 choice:char;
 begin
   repeat
     writeln;
     write ('Type the new Julia Constant ');
     writeln ('for the region. ie.  4.5 -3.4i');
     with pages do
     begin
       readln (con.a,con.b,choice);
       writeln;
       if (con.a < where.min.a) or (con.a > where.max.a) or
          (con.b < where.min.b) or (con.b > where.max.b) then
          begin
            writeln;
            write ('Invalid coordinates.  Press <return>.');
            readln;
            userdone:=false;
            page (output);
          end
       else
       begin
         write ('Is this correct? (Y)es or (N)o ');
         read (choice);
         case choice of
           'N','n': userdone:=false;
           'Y','y': userdone:=true;
         end;
       end;
     end;
   until userdone;
 end;
 
 procedure error (num:integer);
 begin
   page (output);
   writeln;
   writeln;
   write ('Please calculate the fractal before ');
   case num of
     1: writeln ('displaying it.');
     2: writeln ('saving it.');
     3: writeln ('printing it.');
   end;
   writeln;
   write ('Press <return> to continue ');
   readln;
 end;
 
 procedure change (graphed,fraccalc:boolean;var pages:screen);
 var
 choice:char;
 begin
   changescreen (choice,fraccalc,pages);
   case choice of
     'C', 'c' : if graphed then
                  selectconst (pages)
                else
                  error (1);
     'D', 'd' : ;
     'E', 'e' : enterregion (pages);
     'S', 's' : if graphed then
                  selectregion (pages)
                else
                  error (1);
     'T', 't' : enterconst (pages);
   end;
 end;
 
 procedure init (var pages:screen;var fraccalc,graphed:boolean);
 begin
   with pages do  {set inital region}
   begin
     where.min.a:=mina;
     where.max.a:=maxa;
     where.min.b:=minb;
     where.max.b:=maxb;
     where.hor:=horizontal;
     where.ver:=vertical;
     con.a:=(where.max.a + where.min.a) / 2;
     con.b:=(where.max.b + where.min.b) / 2;
     name:='None';
   end;
   fraccalc:=false;
   graphed:=false;
   fillchar (pages.bitmap,round ((horizontal / 8.0) * vertical),chr(0));
   page (output);
   dhrclear;
   poke (-16303,0);  {turn on text screen}
 end;
 
 procedure mainscreen (var choice:char;var pages:screen;
                       var fraccalc,graphed:boolean);
 begin
   repeat
     page (output);
     writeln ('                         Fractal Generation Program v2.1');
     writeln ('                        by Michael Rifani and Wayne Scott');
     writeln ('                    Modified for the Apple II by David Jansen');
     status (fraccalc,pages);
     writeln ('    (M)andelbrot fractal calculation for current region');
     writeln ('    (J)ulia fractal calculation for current region and point');
                 writeln ('    (F)ractal mountain landscape');
     writeln ('    (C)hange current region or Julia Constant of fractal');
     writeln ('    (D)isplay fractal on a graphics screen');
     writeln ('    (P)rint hardcopy');
     writeln ('    (L)oad fractal');
     writeln ('    (S)ave fractal');
     writeln ('    (Q)uit');
     writeln;
     writeln;
     write ('    Enter your choice:  ');
     read (choice);
   until choice in ['C','c','D','d','F','f','J','j','L','l','M','m',
                    'P','p','Q','q','S','s'];
 end;
 
 begin  {main}
   init (pages,fraccalc,graphed);
   repeat
     mainscreen (choice,pages,fraccalc,graphed);
     case choice of
       'C','c': change (graphed,fraccalc,pages);
       'D','d': if fraccalc then
                begin
                  dhrenable;
                  if not graphed then
                  begin
                    dhrclear;
                    display (pages.bitmap,graphed);
                  end;
                  readln;
                  poke (-16303,0);  {turn on text screen}
                end
         else
                  error (1);
       'F','f': begin
                  repeat
                    page (output);
                    writeln;
                    write ('Enter number of levels (1 - 6) : ');
                    readln (levels);
                  until (levels > 0) and (levels < 7);
                  mountfrac (levels,fraccalc);
                end;
       'J','j': begin
                  dhrclear;
           fillchar (pages.bitmap,round ((horizontal / 8.0) * vertical),chr(0));
                  poke (-16303,0);  {turn on text screen}
                  julia (pages,fraccalc,graphed);
                  write (chr(7));
                end;
       'L','l': loadfrac (pages,fraccalc,graphed);
       'M','m': begin
                  dhrclear;
           fillchar (pages.bitmap,round ((horizontal / 8.0) * vertical),chr(0));
                  poke (-16303,0);  {turn on text screen}
                  mandelbrot (pages,fraccalc,graphed);
                  write (chr (7));
                end;
       'P','p': if fraccalc then
                  dhrprinter (pages)
                else
                  error (3);
       'S','s': if fraccalc then
                  savefrac (pages)
                else
                  error (2);
     end;
   until (choice='Q') or (choice='q');
   txtmode;
 end.