← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/amunits/demos/snow.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

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