From NISC.SRI.COM!unix!Teknowledge.COM!uw-beaver!rice!cs.utexas.edu!tut.cis.ohio-state.edu!ucbvax!EN.ECN.PURDUE.EDU!wscott Thu Apr 19 18:55:34 PDT 1990
Article 778 of comp.binaries.apple2:
Path: NISC.SRI.COM!unix!Teknowledge.COM!uw-beaver!rice!cs.utexas.edu!tut.cis.ohio-state.edu!ucbvax!EN.ECN.PURDUE.EDU!wscott
>From: wscott@EN.ECN.PURDUE.EDU (Wayne H Scott)
Newsgroups: comp.binaries.apple2
Subject: [eldorado: DHR fractal generator]
Message-ID: <9004180122.AA01114@en.ecn.purdue.edu>
Date: 18 Apr 90 01:22:26 GMT
Sender: daemon@ucbvax.BERKELEY.EDU
Lines: 773

Date: Tue, 17 Apr 90 19:30:09 -0500
>From: eldorado (David D Jansen)
To: wscott

Posted:	Sat Apr 14 00:17:00 EST 1990
Newsgroups: comp.binaries.apple2
Subject: DHR fractal generator
Keywords: fractals

This is a program that I have worked on off and on.  It is a UCSD Pascal
program that generates Mandelbrot, Julia and Cantor sets.  Some aspects of
this program are not fully supported but I better get this off now before
summer.  About the only thing that does not work correctly is the option
to change the current region by selecting a point on the graphics screen,
but the region can be changed by entering two points.  There are two graphics
file types implemented.  One is a file of booleans and the other is a text file.
The text file is about 4k and the boolean file is about 16k.  Use which ever
you wish.  The reason for two types is I have a copy that I run on unix
which I then download and plot to the screen.  I do have to say that this
program is extremely slow unless you have an accelerator.  Enjoy it.  If you
have any bug reports or make any great modifications send me mail.
Also a sample data file is included (the first line should begin with 0F).


Just a student trying to slip through the cracks of Our Great Education System.
_______________________________________________________________________________
Dave Jansen             |  INTERNET:  eldorado@en.ecn.purdue.edu
Electrical Engineering  |  BITNET:    eldorado%ea.ecn.purdue.edu@purccvm
Purdue University       |  UUCP:     {purdue, pur-ee}!en.ecn.purdue.edu!eldorado

cut here------------------------------------------------------------------------

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

uses transcend,turtlegraphics;

const
base = 8192;
maximumint = 32767;
squaredradius = 4;
maxiter = 100; {the maximum number of iteritions}
hor = 560; {the number of points on the screen horizontally}
ver = 192; {the number of points vertically}
mina = -2.25;
maxa = 0.75;
minb = -1.5;
maxb = 1.5;

type 
imaginary = record {an imaginary number  i.e. a + bi}
              a : real;
              b : real;
            end;
region = record case integer of {a rectangle on the imaginary plane}
           0: (min : imaginary;
               max : imaginary);
           1: (lownum : imaginary;
               highnum : imaginary);
	 end;
screen = record {the data that describes a screen}
           where : region;
           bitmap : packed array [1..hor,1..ver] of boolean;
         end;
store = record
          where : region;
          line : packed array [1..hor] of boolean;
        end;
bitarray = array [0..5] of boolean;
byte = 0..255;
memloc = packed array [0..1] of byte;
access = record
           case boolean of
             true: (address:integer);
             false: (pointer: ^memloc);
           end;

var
prntr:text;
remotefile:text;
screenfile:file of store;
graphed:boolean;
fraccalc:boolean;
userdone:boolean;
name:string;
pages:screen;
choice:char;
con:imaginary;
memory:access;

function peek (addrs:integer):byte;
begin
  memory.address:=addrs;
  peek:=memory.pointer^[0];
end;

procedure poke (addrs:integer;val:byte);
begin
  memory.address:=addrs;
  memory.pointer^[0]:=val;
end;

procedure dhrenable;
begin
  poke (-16302,0); {full screen}
  poke (-16300,0); {page 2 off}
  poke (-16297,0); {hires on}
  poke (-16371,0); {80 col on}
  poke (-16258,0); {IOUdis on}
  poke (-16290,0); {DHR on}
  poke (-16304,0); {graphics on}
  poke (-16383,0); {80 store on}
end;

procedure dhrclear;
begin
  initturtle;
  poke (-16383,0); {80 store on}
  poke (-16299,0); {page 2 on}
  initturtle;
  poke (-16300,0); {page 2 off}
end;

procedure dhrscreen (var pages:screen;var graphed:boolean);
var
a,b,c,d,e,i,j,k,p,s,t:integer;
x,y,scalex,scaley:real;
begin
  dhrenable;
  scalex:=hor / 560;
  scaley:=ver / 192;
  y:=0;
  for j:=1 to 192 do
  begin
    c:=trunc (y / 64);
    e:=trunc (y - (c * 64));
    b:=trunc (e / 8);
    a:=e - (b * 8);
    d:=(1024 * a) + (128 * b) + (40 * c) + base;
    x:=0;
    for i:=1 to 80 do
    begin
      if (i mod 2)=0 then
        poke (-16300,0)
      else
        poke (-16299,0);
      t:=0;
      for k:=6 downto 0 do
      begin
        if pages.bitmap[trunc (7*x+k+1),trunc (y+1)] then
          p:=1
        else
          p:=0;
        s:=p * trunc (exp (0.6931471806 * k));
        t:=t + s;
      end;
      poke (((i-1) div 2) + d,t);
      x:=x+scalex;
    end;
    y:=y+scaley;
  end;
  graphed:=true;
end;

procedure dhrprinter (var pages:screen;name:string);
var
i,j,v,w,x,y:integer;
pixel1:integer;
pixel2:integer;
pixel3:integer;
bit:bitarray;
begin
  dhrenable;
  rewrite (prntr,'PRINTER:');
  writeln (prntr);
  writeln (prntr,'Fractal: ',name);
  writeln (prntr);
  for w:=0 to ((ver div 6) - 1) do
  begin
    write (prntr,chr(27),'j');
    write (prntr,chr(27),'C1120');
    j:=6 * w;
    for v:=1 to (hor div 7) do
    begin
      i:=7 * v;
      for x:=i downto i-6 do
      begin
        for y:=j to j+5 do
          bit[y-j]:=pages.bitmap[x,y+1];
        pixel1:=0;
        pixel2:=0;
        pixel3:=0;
        if bit[0] then
          pixel1:=15;
        if bit[1] then
          pixel1:=240+pixel1;
        if bit[2] then
          pixel2:=15;
        if bit[3] then
          pixel2:=240+pixel2;
        if bit[4] then
          pixel3:=15;
        if bit[5] then
          pixel3:=240+pixel3;
        for y:=1 to (1120 div hor) do
          write (prntr,chr(pixel1),chr(pixel2),chr(pixel3));
      end;
    end;
    writeln (prntr);
  end;
  writeln (prntr);
  writeln (prntr,'Fractal coordinates are: ');
  with pages.where do
  begin
    write (prntr,max.a:12:5,' + ',max.b:12:5,'i   to   ',min.a:12:5,' + ');
    writeln (prntr,min.b:12:5,'i');
  end;
  close (prntr);
end;

procedure setting (var pages:screen;var con:imaginary;var fraccalc:boolean);
var
userdone:boolean;
choice:char;
begin
  pages.where.max.a:=maxa;
  pages.where.min.a:=mina;
  pages.where.max.b:=maxb;
  pages.where.min.b:=minb;
  repeat
    page (output);
    writeln;
    write ('Real c:  ');
    readln (con.a);
    write ('Imaginary c:  ');
    readln (con.b);
    writeln;
    write ('Is this correct? (Y)es or (N)o ');
    read (choice);
    case choice of
      'Y','y': userdone:=true;
      'N','n': userdone:=false;
    end;
  until userdone;
  fraccalc:=false;
end;

procedure julia (var pages:screen;con:imaginary;var fraccalc:boolean);
var
dval,z:imaginary;
h,v,n:integer;
temp:real;
begin
  dval.a:=(pages.where.max.a - pages.where.min.a)/(hor - 1); 
  dval.b:=(pages.where.max.b - pages.where.min.b)/(ver - 1); 
  for v:=1 to ver do
  begin
    for h:=1 to hor do
    begin
      z.a:=pages.where.min.a + (h - 1) * dval.a; {val is the value of the}
      z.b:=pages.where.min.b + (v - 1) * dval.b; {current point on the screen}
      n:=0;
      while ((z.a*z.a) + (z.b*z.b) <= squaredradius) and (n < maxiter) do
      begin
        temp:=z.a;
        z.a:=(z.a * z.a) - (z.b * z.b) + con.a;
        z.b:=2 * temp * z.b + con.b;
        n:=n + 1;
      end;
      if (((z.a * z.a) + (z.b * z.b)) <= squaredradius) then
        pages.bitmap[h,v]:=true
    end;
    writeln (v/ver*100:5:2,'% done');
  end;
  gotoxy (40,24);
  fraccalc:=true;
end;

procedure mandelbrot (var pages:screen;var fraccalc:boolean);
var
dval,z,val:imaginary;
h,v,n:integer;
temp:real;
begin
  dval.a:=(pages.where.max.a - pages.where.min.a)/(hor - 1); 
  dval.b:=(pages.where.max.b - pages.where.min.b)/(ver - 1); 
  for v:=1 to ver do
  begin
    for h:=1 to hor do
    begin
      val.a:=pages.where.min.a + (h - 1) * dval.a; {val is the value of the}
      val.b:=pages.where.min.b + (v - 1) * dval.b;{current point on the screen}
      n:=0;
      z.a:=0;
      z.b:=0;
      while ((z.a*z.a) + (z.b*z.b) <= squaredradius) and (n < maxiter) do
      begin
        temp:=z.a;
        z.a:=(z.a * z.a) - (z.b * z.b) + val.a;
        z.b:=2 * temp * z.b + val.b;
        n:=n + 1;
      end;
      if (((z.a * z.a) + (z.b * z.b)) <= squaredradius) then
        pages.bitmap[h,v]:=true
    end;
    writeln (v/ver*100:5:2,'% done');
  end;
  gotoxy (40,24);
  fraccalc:=true;
end;

procedure textprinter (var pages:screen);
var
i,j,x,y:integer;
begin
  i:=hor div 80;
  j:=ver div 24;
  for y:=1 to 24 do
  begin
    for x:=1 to 80 do
      if (pages.bitmap[i*x,j*y]) then
	write ('*')
      else
	write (' ');
  end;
end;

procedure loadfrac (var pages:screen;var fraccalc:boolean;var name:string);
var
i,j:integer;
begin
  page (output);
  writeln;
  writeln;
  write ('What is the name of the file to load? ');
  readln (name);
  reset (screenfile,name);
  for j:=1 to ver do
  begin
    pages.where:=screenfile^.where;
    for i:=1 to hor do
      pages.bitmap[i,j]:=screenfile^.line[i];
    get (screenfile);
  end;
  close (screenfile);
  fraccalc:=true;
  write (chr (7));
end;

procedure savefrac (var pages:screen;var name:string);
var
i,j:integer;
begin
  page (output);
  writeln;
  writeln;
  write ('What do you want to name this file? ');
  readln (name);
  rewrite (screenfile,name);
  for j:=1 to ver do
  begin
    screenfile^.where:=pages.where;
    for i:=1 to hor do
      screenfile^.line[i]:=pages.bitmap[i,j];
    put (screenfile);
  end;
  close (screenfile);
  write (chr (7));
end;

procedure loadfile (var pages:screen;var fraccalc:boolean;var name:string);
var
temp,last,x,y:integer;
temp2:char;
bit:boolean;
begin
page (output);
  writeln;
  writeln;
  write ('What is the name of the file to load? ');
  readln (name);
  reset (remotefile,name);
  y:=1;
  x:=1;
  last:=0;
  readln (remotefile,temp,temp2);
  while not (eof (remotefile)) do
  begin
    if (temp2='T') then
      bit:=true
    else
      bit:=false;
    while (x<=temp) do
    begin
      if ((x+last)>hor) then
      begin
        temp:=temp-x+1;
        y:=y+1;
        x:=1;
        last:=0;
      end;
      pages.bitmap[last+x,y]:=bit;
      x:=x+1;
    end;
    if (x+last=hor+1) then
      y:=y+1;
    last:=((last+temp) mod hor);
    x:=1;
    readln (remotefile,temp,temp2);
  end;
  if (temp2='T') then
    bit:=true
  else 
    bit:=false;
  while (x<=temp) do
  begin
    if ((x+last)>hor) then
    begin
      temp:=temp-x+1;
      y:=y+1;
			x:=1;
      last:=0;
    end;
    pages.bitmap[last+x,y]:=bit;
    x:=x+1;
  end;
  close (remotefile);
  fraccalc:=true;
end;

procedure savefile (var pages:screen;var name:string);
var
i,j,x:integer;
prev,cur:char;
begin
  page (output);
  writeln;
  writeln;
  write ('What do you want to name this file? ');
  readln (name);
  rewrite (remotefile,name);
  x:=0;
  prev:='F';
  for j:=1 to ver do
  begin
    for i:=1 to 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
        writeln (remotefile,x:1,prev);
        x:=1;
        prev:=cur;
      end;
    end;
  end;
  writeln (remotefile,x:1,prev);
  close (remotefile);
end;

procedure findpoint (var pages:screen;var h,v:integer);
var
dir:char;
point:boolean;
x,y,z:integer;
begin
  point:=false;
  h:=hor div 2;
  z:=ver div 2;
  pencolor (none);
  v:=ver-v+1;
  moveto (h,v);
  if (pages.bitmap[h,v]) then
    pencolor (black)
  else
    pencolor (white);
  moveto (h+1,v);
  pencolor (none);
  moveto (h,v);
  repeat
    read (dir);
    if (dir=chr (11)) then
      y:=-5
    else
    if (dir=chr (8)) then
      x:=-5
    else
    if (dir=chr (21)) then
      x:=5
    else
    if (dir=chr (10)) then
      y:=5
    else
    if (dir='P') or (dir='p') then
      point:=true;
    if (pages.bitmap[h,v]) then
      pencolor (white)
    else
      pencolor (black);
    moveto (h+1,v);
    h:=h+x;
    v:=v+y;
    x:=0;
    y:=0;
    pencolor (none);
    moveto (h,v);
    if (pages.bitmap[h,v]) then
      pencolor (black)
    else
      pencolor (white);
    moveto (h+1,v);
    pencolor (none);
    moveto (h,v);
  until point;
end;

procedure selectregion (var pages:screen);
var
h,v,x,y:integer;
tempregion:region;
begin
  dhrenable;
  findpoint (pages,h,v);
	findpoint (pages,x,y);
	pencolor (white);
	moveto (x,ver-v+1);
	moveto (x,ver-y+1);
	moveto (h+1,ver-v+1);
	moveto (h+1,ver-y+1);
	pencolor (none);
	with pages.where do
	begin
		tempregion.highnum.a:=min.a + (h-1)*(max.a-min.a)/(hor-1);
		tempregion.highnum.b:=min.b + (v-1)*(max.b-min.b)/(ver-1);
		tempregion.lownum.a:=min.a + (x-1)*(max.a-min.a)/(hor-1);
    tempregion.lownum.b:=min.b + (y-1)*(max.b-min.b)/(ver-1);
  end;
  pages.where:=tempregion;
end;
 
procedure changeregion (var pages:screen;var fraccalc,graphed:boolean);
var
temp:char;
begin
  page (output);
  writeln;
  writeln ('Current region set at:');
  with pages.where do
  begin
    write (max.a:12:5,' + ',max.b:12:5,'i   to   ',min.a:12:5,' + ');
    writeln (min.b:12:5,'i');
  end;
  writeln;
  writeln;
  repeat
    writeln;
    writeln ('Do you want to (e)nter the values for the region or (s)elect');
    writeln ('the region on screen?');
    read (temp);
  until (temp='E') or (temp='e') or (temp='S') or (temp='s');
  writeln;
  writeln;
  case temp of
    'E', 'e' : begin
                 writeln ('Type the maximum imaginary');
                 writeln ('number in the region. ie.  4.5 -3.4i');
                 with pages.where do
                 begin
                   readln (max.a,max.b,temp);
                   writeln;
                   writeln ('Now type the minimum imaginary in the region.');
                   readln (min.a,min.b,temp);
                 end;
               end;
    'S', 's' : if fraccalc and graphed then
               begin
                 writeln ('Use arrow keys to move cursor and push (P)');
                 writeln (' to select both points');
                 selectregion (pages);
                 poke (-16303,0);
               end
               else
               begin 
                 page (output);
                 writeln;
                 writeln;
                 write ('You must calculate and graph the fractal before ');
	         writeln ('you can display it');
	         writeln;
                 write ('Press <return> to continue ');
                 readln;
               end;
  end;
  graphed:=false;
  fraccalc:=false;
  writeln ('Please wait, initializing variables');
end;

procedure deletebitmap (var pages:screen);  {clear bitmap of current screen}
var
h,v:integer;
begin
  for h:=1 to hor do
    for v:=1 to ver do
      pages.bitmap[h,v]:=false;
end;

procedure mainscreen (var pages:screen;var fraccalc:boolean);
begin
  page (output);
  writeln;
  writeln ('                           Fractal Generation Program');
  writeln ('                                       by');
  writeln ('                         Michael Rifani and Wayne Scott');
  writeln ('                    Modified for the Apple II by David Jansen');
  writeln;
  writeln ('Current region set at:');
  with pages.where do
  begin
    write (max.a:12:5,' + ',max.b:12:5,'i   to   ',min.a:12:5,' + ');
    writeln (min.b:12:5,'i');
  end;
  writeln;
  write ('This region has ');
  if not(fraccalc) then
    write ('not yet ');
  writeln ('been calculated.');
  writeln;
  writeln ('    (M) calculate mandelbrot fractal for current region');
  writeln ('    (J) calculate julia fractal for current region');
  writeln ('    (C)hange current region of fractal');
  writeln ('    (D)isplay fractal in a text screen');
  writeln ('    (L)oad fractal');
  writeln ('    (S)ave fractal');
  writeln ('    (P)rint hardcopy');
  writeln ('    (T)ext screen graph');
  writeln ('    (R)ead text data file');
  writeln ('    (W)rite text data file');
  writeln ('    (Q)uit');
  writeln;
  write ('      Enter your choice:  ');
end;

begin {main}
  dhrclear;
  poke (-16303,0);
  deletebitmap (pages);
  with pages.where do
  begin
    min.a:=mina;
    max.a:=maxa;     {set inital region}
    min.b:=minb;
    max.b:=maxb;
  end;
  fraccalc:=false;
  userdone:=false;
  graphed:=false;
  page (output);
  write (chr (7));
  repeat
    repeat
      mainscreen (pages,fraccalc);
      read (choice);
    until choice in ['C','c','M','m','J','j','D','d','L','l','S','s',
                     'T','t','P','p','W','w','R','r','Q','q'];
    case choice of
      'C','c': begin
                 changeregion (pages,fraccalc,graphed);
                 deletebitmap (pages);
                 dhrclear;
                 write (chr (7));
               end;
      'M','m': begin
                 mandelbrot (pages,fraccalc);
                 write (chr (7));
               end;
      'J','j': begin
                 setting (pages,con,fraccalc);
                 julia (pages,con,fraccalc);
                 write (chr(7));
               end;
      'D','d': if graphed then
               begin
                 dhrenable;
                 readln;
                 poke (-16303,0);
               end
               else
               if fraccalc then
               begin
                 dhrenable;
                 dhrscreen (pages,graphed);
                 write (chr (7));
                 readln;
                 poke (-16303,0);
               end
	       else
	       begin
	         page (output);
                 writeln;
                 writeln;
                 write ('You must calculate the fractal before you can ');
	         writeln ('display it');
	         writeln;
                 write ('Press <return> to continue ');
                 readln;
               end;
      'L','l': loadfrac (pages,fraccalc,name);
      'S','s': if fraccalc then
                 savefrac (pages,name)
               else
               begin
                 page (output);
                 writeln;
                 writeln;
                 write ('You can''t save a fractal that has not been ');
                 writeln ('calculated');
                 writeln;
                 write ('Press <return> to continue ');
                 readln;
               end;
      'P','p': if fraccalc then
                 dhrprinter (pages,name)
               else
               begin
                 page (output);
                 writeln;
                 writeln;
                 write ('You can''t print a fractal that has not been ');
                 writeln ('calculated');
                 writeln;
                 write ('Press <return> to continue ');
                 readln;
               end;
      'T','t': if fraccalc then
               begin
                 page (output);
                 textprinter (pages);
                 readln;
               end
               else
               begin
                 page (output);
                 writeln;
                 writeln;
                 write ('You can''t print a fractal that has not been ');
                 writeln ('calculated');
                 writeln;
                 write ('Press <return> to continue ');
                 readln;
               end;
      'W','w': if fraccalc then
                 savefile (pages,name)
               else
               begin
                 page (output);
                 writeln;
                 writeln;
                 write ('You can''t save a fractal that has not been ');
                 writeln ('calculated');
                 writeln;
                 write ('Press <return> to continue ');
                 readln;
               end;
      'R','r': loadfile (pages,fraccalc,name);
      'Q','q': userdone := true;
    end;
  until userdone;
end.