Newsgroups: comp.binaries.apple2
From: eldorado@en.ecn.purdue.edu (David D Jansen)
Subject: mandelbrots julia mountain fractals
Message-ID: <1990Dec9.194946.19133@en.ecn.purdue.edu>
Date: Sun, 9 Dec 90 19:49:46 GMT

This program will create fractals in Double Hi Resolution so it only works on
a 128K apple.  It creates Mandelbrots, Julia and mountain terrain fractals
for basically any resolution fractal.  Just change the horizontal and
vertical constants.  Why?  Well a printer can usually handle more pixels
than the Apple II screen so why not create fractals for that resolution?
It prints out fractals and automatically compresses and saves them.  Try
it and send me any opinions.

Dave

-------------------------------------------------------------------------
program fractal (input,output,remotefile,prntr);

uses applestuff, turtlegraphics, transcend;

const
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}

maximumint    = 32767;
squaredradius = 4;
maxiter       = 100;     {maximum number of iteritions}
horizontal    = 560;     {number of points on the screen horizontally}
vertical      = 192;     {number of points vertically}
mina          = -2.25;   {default minimum real value of the region}
maxa          = 0.75;    {default maximum real value of the region}
minb          = -1.5;    {dh	efault minimum imaginary value of the region}
maxb          = 1.5;     {default maximum imaginary value of the region}

pi            = 3.14159;
xs            = 0.04;
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;
coor = packed array [1..horizontal,1..vertical] of boolean;
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 screen}
           where : region;
           con : imaginary;
           name : string;
           bitmap : coor;
         end;
byte = 0..255;
memloc = packed array [0..1] of byte;
access = record
           case boolean of
             true: (address:integer);
             false: (pointer: ^memloc);
           end;

var
graphed:boolean;
fraccalc:boolean;
choice:char;
pages:screen;

levels:integer;
xlast,ylast:integer;
y3:real;

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;
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;
begin
  dhrenable;
  initturtle;
  poke (-16299,0);  {page 2 on}
  initturtle;
  poke (-16300,0);  {page 2 off}
end;

procedure txtmode;
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-*)
(*$R-*)

procedure line (x,y:integer);
var
ang:real;
i,j,k,p,q,clr:integer;
begin
  clr:=peek (color);  {get current color}
  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
  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 line other than a vertical 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
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}
      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}
    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
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
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;
    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+*)

procedure dhrprinter (var pages:screen);
var
i,j,v,w,x,y:integer;
pixel1,pixel2,pixel3:integer;
bit:array [0..5] of boolean;
prntr:text;
begin
  dhrenable;
  rewrite (prntr,'PRINTER:');
    x:=i;
      while (x >= i-6) do
      begin
        y:=j;
        while (y <= j+5) do
        begin
          bit[y-j]:=pages.bitmap[x,y+1];
          y:=y+1;
        end;
        if bit[0] then
          pixel1:=15
        else
          pixel1:=0;
        if bit[1] then
          pixel1:=240+pixel1;
        if bit[2] then
          pixel2:=15
        else
          pixel2:=0;
        if bit[3] then
          pixel2:=240+pixel2;
        if bit[4] then
          pixel3:=15
        else
          pixel3:=0;
        if bit[5] then
          pixel3:=240+pixel3;
        y:=1;
        while (y <= 1120 div pages.where.hor) do
        begin
          write (prntr,chr(pixel1),chr(pixel2),chr(pixel3));
          y:=y+1;
        end;
        x:=x-1;
      end;
      v:=v+1;
    end;
    writeln (prntr);
    w:=w+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);
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,v]:=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,v]:=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;
  writeln ('Name of current fractal: ',pages.name);
  writeln;
  writeln ('Current region set at:');
  with pages do
  begin
    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)/(pages.where.hor-1);
    tempregion.max.b:=min.b + (v-1)*(max.b-min.b)/(pages.where.ver-1);
    tempregion.min.a:=min.a + (x-1)*(max.a-min.a)/(pages.where.hor-1);
    tempregion.min.b:=min.b + (y-1)*(max.b-min.b)/(pages.where.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 ((pages.where.hor-1)*(con.a-where.min.a)/(where.max.a-where.min.a)+1);
v:=round ((pages.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)/(pages.where.hor-1);
    con.b:=where.min.b+(v-1)*(where.max.b-where.min.b)/(pages.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 correcrocedure 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.0');
    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');
    writeln ('    (F)ractal mountains');
    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.
-- 

I am not really here.
_______________________________________________________________________________
Dave Jansen             |  INTERNET:  eldorado@en.ecn.purdue.edu