eldorado@en.ecn.purdue.edu (David D Jansen) (01/22/91)
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