From: eldorado@en.ecn.purdue.edu (David D Jansen)
Newsgroups: comp.binaries.apple2
Subject: Fractal 2.1
Message-ID: <1991Jan21.201831.4315@en.ecn.purdue.edu>
Date: 21 Jan 91 20:18:31 GMT


A new version already.  It fixes a bug which prints the picture upside-down.
And in case you where wondering where the fractal mountains were, Now
they are an option.  My copy of system utilities always garbles data when
copying from pascal to prodos.  Sorry.  Following this posting is a BASIC
program that will convert a saved fractal (once transfered to prodos) to
the Professional File format system used by Dazzle Draw.  In other words,
you can now view, edit, print your fractals from Dazzle Draw.  Enjoy!

Dave

cut here 8<---------------------------------------------


{  authors :  David Jansen   eldorado@en.ecn.purdue.edu  }
{             Wayne Scott    wscott@en.ecn.purdue.edu    }
{             Miki Rifani    miki@en.ecn.purdue.edu      }

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.
-- 

Just Institutionalized!
_______________________________________________________________________________
Dave Jansen             |  INTERNET:  eldorado@en.ecn.purdue.edu