maxc1087@ucselx.sdsu.edu (James Hensley) (09/22/89)
here are a couple of pascal fractal progs. one implements
the random iteration algorithm and is quite fast, the
other a slow escape time julia set generator. (run it
overnight) - I converted some IBM turbo basic code I found.
(see comments.) runs on my 128k enhanced //e, but I think
any ][ that can run apple pascal 1.2.
----------------- * cut here * ------------------
program RandomItFrac(input, output, VarFile);
{ Author : James Hensley }
{ Program : RandomItFrac }
{ Purpose : create fractals, using IFS }
{ algorithm from Barnsley, }
{ Fractals EveryWhere, Academic }
{ Press, 1988, Program 9.8.1 }
{ allow reading of variables }
{ from a file, keyboard, or }
{ default to a fractal tree. }
{ Machine : Apple //e, 128k }
{ Language: UCSD Pascal }
{ OpSys : Apple Pascal 1.2 }
{ Comments: this was converted from a BASIC }
{ program (ick!) }
uses TurtleGraphics,
AppleStuff;
const
MaxBounds = 4;
MaxX = 279;
MaxY = 191;
var
Debug : boolean;
Ch : char;
A, D, B, C,
F : array[1..MaxBounds] of real;
E, P : array [1..MaxBounds] of integer;
X, Y, NewX, NewY : real;
Loop, NumIts,
N, K, R, W,
XScale, YScale,
XAdd, YAdd : integer;
Err : boolean;
CommentLine,
FileName : string;
VarFile : text;
procedure Plot(X, Y: real);
var Xt, Yt : integer;
Dot : boolean;
begin
Xt := XAdd + trunc(XScale * X);
Yt := YAdd + trunc(XScale * Y);
if Debug then
begin
writeln('Plot, x=', X, ' y=', Y);
writeln('Plot, xt=', Xt, ' yt=', Yt);
end; { if Debug }
if (Xt <= MaxX) and (Yt <= MaxY) then
DrawBlock(Dot, 1, 0, 0, 1, 1, Xt, Yt, 15)
else
begin
chartype(6);
pencolor(black);
moveto(50, 50);
pencolor(blue);
wstring('Point out of bounds');
end;
end; { Plot }
function Rand(Low, High:integer; var Error:boolean):integer;
var Mx, C, D : integer;
begin
Rand := 0;
Error := true;
if Low > High then
exit(Rand); { error in params }
if Low <= 0 then
if High > MaxInt + Low then
exit(Rand);
Error := false;
if Low = High then
Rand := Low
else
begin
C := High - Low + 1;
Mx := (MaxInt - High + Low) div C;
Mx := Mx * (High - Low) + (Mx - 1);
repeat
D := random
until D <= Mx;
Rand := Low + D mod C;
end; { else }
end; { rand }
procedure InitArrays;
begin
A[1] := 0;
A[2] := 0.42;
A[3] := 0.42;
A[4] := 0.1;
B[1] := 0;
B[2] := -0.42;
B[3] := 0.42;
B[4] := 0;
C[1] := 0;
C[2] := 0.42;
C[3] := -0.42;
C[4] := 0;
D[1] := 0.5;
D[2] := 0.42;
D[3] := 0.42;
D[4] := 0.1;
E[1] := 0;
E[2] := 0;
E[3] := 0;
E[4] := 0;
F[1] := 0;
F[2] := 0.2;
F[3] := 0.2;
F[4] := 0.2;
P[1] := 5;
P[2] := 40;
P[3] := 40;
P[4] := 15;
NumIts := 1000;
XScale := 200;
YScale := 100;
XAdd := 100;
Yadd := 75;
end; { InitArrays }
procedure GetChoices;
procedure DoFile;
begin
write('FileName>');
readln(FileName);
reset(VarFile, FileName);
readln(VarFile, CommentLine);
while (CommentLine[1] = '!') do
begin
readln(VarFile, CommentLine);
writeln(CommentLine);
end;
readln(VarFile, W);
writeln('W=', W);
readln(VarFile, NumIts, XScale, YScale, XAdd, YAdd);
writeln(NumIts, XScale, YScale, XAdd, YAdd);
for Loop := 1 to W do
begin
readln(VarFile, A[Loop], B[Loop], C[Loop],
D[Loop], E[Loop], F[Loop], P[Loop]);
writeln(A[Loop], B[Loop], C[Loop],
D[Loop], E[Loop], F[Loop], P[Loop]);
end;
end; { DoFile }
procedure DoKb;
begin
write('Number of iterations');
readln(NumIts);
write('X scale');
readln(XScale);
write('Y scale');
readln(YScale);
write('X adder');
readln(XAdd);
write('Y adder');
readln(YAdd);
repeat
write('W=');
read(W);
if (W > MaxBounds) or (trunc(W) <> W) then
write('Maximum=', MaxBounds:2);
until W <= MaxBounds;
writeln;
for Loop := 1 to W do
begin
write('A[', W:2, ']>');
readln(A[W]);
write('B[', W:2, ']>');
readln(B[W]);
write('C[', W:2, ']>');
readln(C[W]);
write('D[', W:2, ']>');
readln(D[W]);
write('E[', W:2, ']>');
readln(E[W]);
write('F[', W:2, ']>');
readln(F[W]);
write('P[', W:2, ']>');
readln(P[W]);
end; { for Loop }
end; { DoKb }
begin { GetChoices }
InitArrays; { default to tree. }
write('Read vars from File or Keyboard (F/K)>');
read(Ch);
writeln;
if Ch in ['f', 'F'] then
DoFile;
if Ch in ['k', 'K'] then
DoKb;
end; { GetChoices }
begin { main }
GetChoices;
randomize;
initTurtle;
pencolor(White);
page(output);
Debug := false; { may be set at any time during execution. }
X := 0;
Y := 0;
for N := 1 to NumIts do
begin
R := rand(0, 100, Err);
K := 1; { check probability }
if R > P[1] then K := 2;
if R > P[1] + P[2] then K := 3;
if R > P[1] + P[2] + P[3] then K := 4;
NewX := A[K]*X + B[K]*Y + E[K];
NewY := C[K]*X + D[K]*Y + F[K];
X := NewX;
Y := NewY;
if N > 10 then
Plot(X,Y);
if keypress then
begin
read(Ch);
if Ch in ['d', 'D'] then
begin
Debug := not(Debug);
pencolor(black);
moveto(0,0);
pencolor(blue);
wstring('debug ');
if Debug
then wstring('on ')
else
wstring('off');
pencolor(white);
end; { if ch in [d,D] }
if Ch in [Chr(27), 'q', 'Q'] then
exit(RandomItFrac)
else if not (Ch in ['d', 'D']) then
begin
textmode;
repeat
page(output);
write('"q" to quit, "c" to continue>');
read(Ch);
writeln;
if Ch in ['q', 'Q'] then
begin
page(output);
writeln('leaving RandomIteration.');
writeln('have a fractal day');
exit(RandomItFrac); { later..... }
end;
until (Ch in ['c', 'C']);
grafmode;
end; { else begin }
end; { if keypress }
end; { for N }
textmode;
page(output);
writeln('hit a key to exit, "v" to view picture.');
read(Ch);
if Ch in ['v', 'V'] then
begin
grafmode;
read(keyboard, ch);
textmode;
end; { if }
page(output);
end.
{ -- these files are used by the Random Iteration program. -- }
{ -- save them under the filename specified and enter at prompt. }
{ -- leave the blank line after the comments. }
{ ------- snip here ------- }
! File:Fern.Text. - data for a fern picture.
! Date:4-Sep-89
! Format: W = number of rows in array
! NumIts, XScale, YScale, XAdd, YAdd
! A[W],B[W],C[W],D[W],E[W],F[W],P[W]
! for W rows.
! A B C D E F P
4
2000 14 7 100 50
0 0 0 0.16 0 0 1
0.85 0.04 -0.04 0.85 0 1.6 85
0.2 -0.26 0.23 0.22 0 1.6 7
-0.15 0.28 0.26 0.24 0 0.44 7
{ ------- snip here ------ }
! File:Tree.Text - data for a tree picture.
! Date:4-Sep-89
! Format: W = number of rows in array
! NumIts, XScale, YScale, XAdd, YAdd
! A[W],B[W],C[W],D[W],E[W],F[W],P[W]
! for W rows.
! A B C D E F P
4
2000 250 124 150 50
0 0 0 0.5 0 0 5
0.42 -0.42 0.42 0.42 0 0.2 40
0.42 0.42 -0.42 0.42 0 0.2 40
-0.1 0 0 0 0 0.2 15
{ ------ snip here ------- }
! File: Tri.Text. - data for a triangle picture.
! Date:4-Sep-89
! Format: W = number of rows in array
! NumIts, XScale, YScale, XAdd, YAdd
! A[W],B[W],C[W],D[W],E[W],F[W],P[W]
! for W rows.
! A B C D E F P
3
4000 1 1 100 50
0.5 0 0 0.5 1 1 33
0.5 0 0 0.5 1 50 33
0.5 0 0 0.5 50 50 34
{ ----- snip here ------ }
! File:Square.Text - data for a square picture
! Date:4-Sep-89
! Format: W = number of rows in array
! NumIts, XScale, YScale, XAdd, YAdd
! A[W],B[W],C[W],D[W],E[W],F[W],P[W]
! for W rows.
! A B C D E F P
4
2000 1 1 10 5
0.5 0 0 0.5 1 1 25
0.5 0 0 0.5 50 1 25
0.5 0 0 0.5 1 50 25
0.5 0 0 0.5 50 50 25
{-------------------- *snip here* --------------------}
program EscapeTime(input, output, VarFile);
{ Author : James Hensley }
{ Language: UCSD Pascal }
{ Machine : Apple //e, 128k }
{ OpSys : Apple Pascal 1.2 }
{ Purpose : implement julia set Escape time algorithm }
{ as found as in Barnsley: Fractals Everywhere, }
{ Academic press, 1989, program 7.1.1 }
{ Use colors White, Orange, Violet, Blue, Green. }
{ Was converted from a nasty BASIC pgm (IBM, yet!) }
(*$R-*) { disable compiler range checking }
uses TurtleGraphics,
AppleStuff;
const
MaxX = 279; { screen dimensions }
MaxY = 191;
var
Ch : char;
A, {= -2;}
B, {= -2;}
C, {= 2;}
D, {= 2;}
R, {= 16;} { 200 }
NumIts : integer; {= 20;}
P, Q : 1..512;
Color : integer;
K, L, X, NewX,
Y, NewY : real;
PenArray : array[1..5] of ScreenColor;
VarFile : text;
procedure Plot(X, Y: integer; Color:integer);
var Dot:boolean;
begin
if X <= MaxX then { bounds check }
if Y <= MaxY then
begin
PenColor(None);
MoveTo(X,Y);
PenColor(PenArray[Color]);
MoveTo(X,Y);
{ DrawBlock(Dot, 1, 0, 0, 1, 1, X, Y, 3); }
end; { if vars in bounds }
end; { Plot }
begin
writeln('Read vars from file or Keyboard? (F/K)');
readln(Ch);
if Ch in ['f', 'F'] then
begin
reset(VarFile, 'EscDat.Text');
readln(VarFile, A, B, C, D, R, NumIts);
writeln('A=', A);
writeln('B=', B);
writeln('C=', C);
writeln('D=', D);
writeln('R=', R);
close(VarFile);
end
else if Ch in ['K', 'k'] then
begin { get vars from user }
write('NumIts>');
readln(NumIts);
write('A>');
readln(A);
write('B>');
readln(C);
write('D>');
readln(D);
write('R>');
readln(R);
end { else read from keyboard }
else
begin { use internal var values. }
NumIts := 20;
A := -2;
B := -2;
C := 2;
D := 2;
R := 16;
end; { if }
PenArray[1] := White;
PenArray[2] := Green;
PenArray[3] := Violet;
PenArray[4] := Orange;
PenArray[5] := Blue;
InitTurtle;
for P := 1 to MaxX do
for Q := 1 to MaxY do
begin
X := A + (C-A) * P/MaxX;
Y := B + (D-B) * Q/MaxY;
for Color := 1 to NumIts do
begin
if Y > 0.5 then
begin
X := 2 * X;
Y := 2 * Y - 1;
end
else
if X > 0.5 then
begin
X := 2 * X - 1;
Y := 2 * Y;
end
else
begin
X := 2 * X;
Y := 2 * Y;
end;
if X*X + Y*Y > R then
begin
Plot(P, Q, Color mod 4 + 1);
Color := NumIts;
end; { if X*X+Y*Y }
if keypress then
begin
read(keyboard, Ch);
if (Ch = 'Q') or (Ch = 'q') or (Ch = chr(27)) then
begin
writeln('Escape Time Escaped.');
exit(EscapeTime);
end; { if }
end; { if keypress }
end; { for Color }
end; { for Q }
read(Ch);
end.