eldorado@en.ecn.purdue.edu (David D Jansen) (12/10/90)
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.eduunknown@ucscb.UCSC.EDU (The Unknown User) (12/15/90)
I tried posting to comp.sys.apple2 about this and nobody answered..
So now I'm doing what pisses everyone else (including me) off, posting
on a binaries group.
WHAT can this be compiled and run under?!?! Just UCSD Pascal?!
WHAT?!?!?!?
And WHY was it posted here instead of comp.sources.apple2? (Don't
whine at me for posting on a binaries group, as I tried to do the right thing
and got NO RESPONSE after many days)
--
/Apple II(GS) Forever! unknown@ucscb.ucsc.edu MAIL ME FOR INFO ABOUT CHEAP CDs\
|WRITE TO ORIGIN ABOUT ULTIMA VI //e and IIGS! Mail me for addresses, & info. |
\ "Dammit Bev, is it you inside or is it the clown?" -IT by Stephen King /