← Back to branch summary

~ubuntu-branches/ubuntu/lucid/fpc/lucid-proposed

« back to all changes in this revision

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

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-10-09 23:29:00 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20081009232900-553f61m37jkp6upv
Tags: 2.2.2-4
http://bugs.debian.org/498882
[ Torsten Werner ]
* Update ABI version in fpc-depends automatically.
* Remove empty directories from binary package fpc-source.

[ Mazen Neifer ]
* Removed leading path when calling update-alternatives to remove a Linitian
  error.
* Fixed clean target.
* Improved description of packages. (Closes: #498882)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/amunits/demos/bezier.pas
1
 
Program Bezier;
2
 
 
3
 
 
4
 
{
5
 
   This program draws Bezier curves using the degree elevation
6
 
   method.  For large numbers of points (more than 10, for
7
 
   example) this is faster than the recursive way.
8
 
}
9
 
 
10
 
{
11
 
   History:
12
 
   Changed the source to use 2.0+.
13
 
   Looks a lot better.
14
 
   Added CloseWindowSafely.
15
 
   Made the window dynamic, it will
16
 
   adjust the size after the screen size.
17
 
   9 May 1998.
18
 
 
19
 
   Translated the source to fpc.
20
 
   20 Aug 1998.
21
 
 
22
 
   Changed to use TAGS and pas2c.
23
 
   31 Oct 1998.
24
 
 
25
 
   Removed Opening of graphics.library,
26
 
   handled by graphics.pas.
27
 
   21 Mar 2001.
28
 
 
29
 
   Uses systemvartags and
30
 
   OpenScreenTags
31
 
   OpenWindowTags
32
 
   Text to GText.
33
 
   09 Nov 2002.
34
 
 
35
 
   nils.sjoholm@mailbox.swipnet.se
36
 
}
37
 
 
38
 
uses exec, intuition, graphics, utility,pastoc, systemvartags;
39
 
 
40
 
type
41
 
    PointRec = packed Record
42
 
        X, Y : Real;
43
 
    end;
44
 
 
45
 
Const
46
 
    w  : pWindow  = Nil;
47
 
    s  : pScreen   = Nil;
48
 
 
49
 
{
50
 
    This will make the new look for screen.
51
 
    SA_Pens, Integer(pens)
52
 
}
53
 
    pens : array [0..0] of integer = (not 0);
54
 
 
55
 
Var
56
 
    rp : pRastPort;
57
 
 
58
 
    PointCount : Word;
59
 
    Points : Array [1..200] of PointRec;
60
 
 
61
 
    LastX, LastY : Word;
62
 
 
63
 
Procedure CleanUpAndDie;
64
 
begin
65
 
    if assigned(w) then CloseWindow(w);
66
 
    if assigned(s) then CloseScreen(s);
67
 
    Halt(0);
68
 
end;
69
 
 
70
 
Procedure DrawLine;
71
 
begin
72
 
    Move(rp, Trunc(Points[PointCount].X), Trunc(Points[PointCount].Y));
73
 
    Draw(rp, LastX, LastY);
74
 
end;
75
 
 
76
 
Procedure GetPoints;
77
 
var
78
 
    LastSeconds,
79
 
    LastMicros  : Longint;
80
 
    IM : pIntuiMessage;
81
 
    StoreMsg : tIntuiMessage;
82
 
    Leave : Boolean;
83
 
    OutOfBounds : Boolean;
84
 
    BorderLeft, BorderRight,
85
 
    BorderTop, BorderBottom : Word;
86
 
    dummy : Boolean;
87
 
 
88
 
    Procedure AddPoint;
89
 
    begin
90
 
    Inc(PointCount);
91
 
    with Points[PointCount] do begin
92
 
        X := Real(StoreMsg.MouseX);
93
 
        Y := Real(StoreMsg.MouseY);
94
 
    end;
95
 
    with StoreMsg do begin
96
 
        LastX := MouseX;
97
 
        LastY := MouseY;
98
 
        LastSeconds := Seconds;
99
 
        LastMicros := Micros;
100
 
    end;
101
 
    SetAPen(rp, 2);
102
 
    SetDrMd(rp, JAM1);
103
 
    DrawEllipse(rp, LastX, LastY, 5, 3);
104
 
    SetAPen(rp, 3);
105
 
    SetDrMd(rp, COMPLEMENT);
106
 
    DrawLine;
107
 
    end;
108
 
 
109
 
    Function CheckForExit : Boolean;
110
 
    {   This function determines whether the user wanted to stop
111
 
    entering points.  I added the position tests because my
112
 
    doubleclick time is too long, and I was too lazy to dig
113
 
    out Preferences to change it. }
114
 
    begin
115
 
    with StoreMsg do
116
 
        CheckForExit := DoubleClick(LastSeconds, LastMicros,
117
 
                    Seconds, Micros) and
118
 
                (Abs(MouseX - Trunc(Points[PointCount].X)) < 5) and
119
 
                (Abs(MouseY - TRunc(Points[PointCount].Y)) < 3);
120
 
    end;
121
 
 
122
 
    Procedure ClearIt;
123
 
    {  This just clears the screen when you enter your first point }
124
 
    begin
125
 
    SetDrMd(rp, JAM1);
126
 
    SetAPen(rp, 0);
127
 
    RectFill(rp, BorderLeft, BorderTop,
128
 
             BorderRight, BorderBottom);
129
 
    SetDrMd(rp, COMPLEMENT);
130
 
    SetAPen(rp, 3);
131
 
    end;
132
 
 
133
 
begin
134
 
    dummy := ModifyIDCMP(w, IDCMP_CLOSEWINDOW or IDCMP_MOUSEBUTTONS or
135
 
IDCMP_MOUSEMOVE);
136
 
    SetDrMd(rp, COMPLEMENT);
137
 
    PointCount := 0;
138
 
    Leave := False;
139
 
    OutOfBounds := False;
140
 
    BorderLeft := w^.BorderLeft;
141
 
    BorderRight := (w^.Width - w^.BorderRight) -1;
142
 
    BorderTop := w^.BorderTop;
143
 
    BorderBottom := (w^.Height - w^.BorderBottom) -1;
144
 
    repeat
145
 
        IM := pIntuiMessage(WaitPort(w^.UserPort));
146
 
        IM := pIntuiMessage(GetMsg(w^.UserPort));
147
 
        StoreMsg := IM^;
148
 
        ReplyMsg(pMessage(IM));
149
 
        case StoreMsg.IClass of
150
 
           IDCMP_MOUSEMOVE : if PointCount > 0 then begin
151
 
                 if not OutOfBounds then
152
 
                 DrawLine;
153
 
                     LastX := StoreMsg.MouseX;
154
 
                     LastY := StoreMsg.MouseY;
155
 
                 if (LastX > BorderLeft) and
156
 
                (LastX < BorderRight) and
157
 
                (LastY > BorderTop) and
158
 
                (LastY < BorderBottom) then begin
159
 
                 DrawLine;
160
 
                 OutOfBounds := False;
161
 
                 end else
162
 
                 OutOfBounds := True;
163
 
                 end;
164
 
           IDCMP_MOUSEBUTTONS : if StoreMsg.Code = SELECTUP then begin
165
 
                    if PointCount > 0 then
166
 
                    Leave := CheckForExit
167
 
                else
168
 
                    ClearIt;
169
 
                    if (not Leave) and (not OutOfBounds) then
170
 
                    AddPoint;
171
 
                    end;
172
 
           IDCMP_CLOSEWINDOW : CleanUpAndDie;
173
 
        end;
174
 
    until Leave or (PointCount > 50);
175
 
    if not Leave then
176
 
        DrawLine;
177
 
    dummy := ModifyIDCMP(w, IDCMP_CLOSEWINDOW);
178
 
    SetDrMd(rp, JAM1);
179
 
    SetAPen(rp, 1);
180
 
end;
181
 
 
182
 
Procedure Elevate;
183
 
var
184
 
    t, tprime,
185
 
    RealPoints : Real;
186
 
    i : Integer;
187
 
begin
188
 
    Inc(PointCount);
189
 
    RealPoints := Real(PointCount);
190
 
    Points[PointCount] := Points[Pred(PointCount)];
191
 
    for i := Pred(PointCount) downto 2 do
192
 
    with Points[i] do begin
193
 
        t := Real(i) / RealPoints;
194
 
        tprime := 1.0 - t;
195
 
        X := t * Points[Pred(i)].X + tprime * X;
196
 
        Y := t * Points[Pred(i)].Y + tprime * Y;
197
 
    end;
198
 
end;
199
 
 
200
 
Procedure DrawCurve;
201
 
var
202
 
    i : Integer;
203
 
begin
204
 
    Move(rp, Trunc(Points[1].X), Trunc(Points[1].Y));
205
 
    for i := 2 to PointCount do
206
 
    Draw(rp, Round(Points[i].X), Round(Points[i].Y));
207
 
end;
208
 
 
209
 
Procedure DrawBezier;
210
 
begin
211
 
    SetAPen(rp, 2);
212
 
    while PointCount < 100 do begin
213
 
    Elevate;
214
 
    DrawCurve;
215
 
    if GetMsg(w^.UserPort) <> Nil then
216
 
        CleanUpAndDie;
217
 
    end;
218
 
    SetAPen(rp, 1);
219
 
    DrawCurve;
220
 
end;
221
 
 
222
 
begin
223
 
 
224
 
   s := OpenScreenTags(nil,[SA_Pens,@pens,
225
 
      SA_Depth,     2,
226
 
      SA_DisplayID, HIRES_KEY,
227
 
      SA_Title,     'Simple Bezier Curves',
228
 
      TAG_END]);
229
 
 
230
 
    if s = NIL then CleanUpAndDie;
231
 
 
232
 
      w := OpenWindowTags(nil,[
233
 
      WA_IDCMP,        IDCMP_CLOSEWINDOW,
234
 
      WA_Left,         0,
235
 
      WA_Top,          s^.BarHeight +1,
236
 
      WA_Width,        s^.Width,
237
 
      WA_Height,       s^.Height - (s^.BarHeight + 1),
238
 
      WA_DepthGadget,  ltrue,
239
 
      WA_DragBar,      ltrue,
240
 
      WA_CloseGadget,  ltrue,
241
 
      WA_ReportMouse,  ltrue,
242
 
      WA_SmartRefresh, ltrue,
243
 
      WA_Activate,     ltrue,
244
 
      WA_Title,        'Close the Window to Quit',
245
 
      WA_CustomScreen, s,
246
 
      TAG_END]);
247
 
 
248
 
    IF w=NIL THEN CleanUpAndDie;
249
 
 
250
 
    rp := w^.RPort;
251
 
    Move(rp, 252, 30);
252
 
    GText(rp, pas2c('Enter points by pressing the left mouse button'), 46);
253
 
    Move(rp, 252, 40);
254
 
    GText(rp, pas2c('Double click on the last point to begin drawing'), 47);
255
 
    repeat
256
 
        GetPoints;  { Both these routines will quit if }
257
 
        DrawBezier; { the window is closed. }
258
 
    until False;
259
 
    CleanUpAndDie;
260
 
end.