← Back to branch summary

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

« back to all changes in this revision

Viewing changes to fpcsrc/packages/amunits/examples/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/amunits/examples/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.