1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
Program Snowflake;
{ This program draws a fractal snowflake pattern. I think I got it out
of some magazine years ago. It was written, as I remember it, for the
PC in BASIC, which I converted to AmigaBASIC. I have long since
forgotten the details of how it worked, so I could not give the
variables meaningful names. To the original author, by the way, goes
the credit for those names. Invoke the program with the line "Snow
<level>", where <level> is a digit between 1 and 6. In order to get a
feel for what's going on, try running the levels in order. Level 6
takes a long time, and frankly doesn't look as good as level 5. }
{
Translated to fpc pascal from pcq pascal.
Updated the source to the new style. Will
now also open a screen.
04 Apr 2001.
Reworked to use systemvartags.
28 Nov 2002.
nils.sjoholm@mailbox.swipnet.se
}
uses exec,intuition,graphics,utility,systemvartags;
var
dx : array [0..11] of real;
dy : array [0..11] of real;
sd : array [0..6] of Longint;
rd : array [0..6] of Longint;
sn : array [0..6] of Longint;
ln : array [0..6] of real;
a : real;
nc : Longint;
x, y, t : real;
w : pWindow;
s : pScreen;
rp : pRastPort;
n : Longint;
d, ns, i, j : Longint;
l : real;
m : pMessage;
const
pens : array [0..0] of integer = (not 0);
Procedure usage;
begin
writeln('Usage: Snow <level>');
writeln(' where <level> is between 1 and 6');
halt(20);
end;
procedure CleanUp(why : string; err : longint);
begin
if assigned(w) then CloseWindow(w);
if assigned(s) then CloseScreen(s);
if why <> '' then writeln(why);
halt(err);
end;
Function readcycles: Longint;
var
cycles : Longint;
begin
if paramcount <> 1 then usage;
cycles := ord(paramstr(1)[1]) - ord('0');
if (cycles > 6) or (cycles < 1) then
usage;
readcycles := cycles;
end;
procedure initarrays;
begin
sd[0] := 0;
rd[0] := 0;
sd[1] := 1;
rd[1] := 0;
sd[2] := 1;
rd[2] := 7;
sd[3] := 0;
rd[3] := 10;
sd[4] := 0;
rd[4] := 0;
sd[5] := 0;
rd[5] := 2;
sd[6] := 1;
rd[6] := 2;
for n := 0 to 6 do
ln[n] := 1.0 / 3.0;
ln[2] := sqrt(ln[1]);
a := 0.0;
for n := 6 to 11 do begin
dy[n] := sin(a);
dx[n] := cos(a);
a := a + 0.52359;
end;
for n := 0 to 5 do begin
dx[n] := -(dx[n + 6]);
dy[n] := -(dy[n + 6]);
end;
x := 534.0;
y := 151.0;
t := 324.0;
end;
begin
nc := readcycles();
initarrays;
s := OpenScreenTags(nil, [SA_Pens, @pens,
SA_Depth, 2,
SA_DisplayID, HIRES_KEY,
SA_Title, 'Simple Fractal SnowFlakes',
TAG_END]);
if s = NIL then CleanUp('No screen',20);
w := OpenWindowTags(nil, [
WA_IDCMP, IDCMP_CLOSEWINDOW,
WA_Left, 0,
WA_Top, s^.BarHeight +1,
WA_Width, s^.Width,
WA_Height, s^.Height - (s^.BarHeight + 1),
WA_DepthGadget, ltrue,
WA_DragBar, ltrue,
WA_CloseGadget, ltrue,
WA_ReportMouse, ltrue,
WA_SmartRefresh, ltrue,
WA_Activate, ltrue,
WA_Title, 'Close the Window to Quit',
WA_CustomScreen, s,
TAG_END]);
if w = nil then CleanUp('No window',20);
rp := w^.RPort;
SetAPen(rp,2);
for n := 0 to nc do
sn[n] := 0;
Move(rp, trunc(x), trunc(y));
repeat
d := 0;
l := t;
ns := 0;
for n := 1 to nc do begin
i := sn[n];
l := l * ln[i];
j := sn[n - 1];
ns := ns + sd[j];
if odd(ns) then
d := (d + 12 - rd[i]) mod 12
else
d := (d + rd[i]) mod 12;
end;
x := x + 1.33 * l * dx[d];
y := y - 0.5 * l * dy[d];
Draw(rp, trunc(x), trunc(y));
sn[nc] := sn[nc] + 1;
n := nc;
while (n >= 1) and (sn[n] = 7) do begin
sn[n] := 0;
sn[n - 1] := sn[n - 1] + 1;
n := n - 1;
end;
until sn[0] <> 0;
m := WaitPort(w^.UserPort);
forbid;
repeat
m := GetMsg(w^.UserPort);
until m = nil;
permit;
CleanUp('',0);
end.
|
