home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
AMIGA PD 1
/
AMIGA-PD-1.iso
/
Programme_zum_Heft
/
Programmieren
/
Kurztests
/
PascalPCQ
/
Examples
/
Bezier2.p
< prev
next >
Wrap
Text File
|
1990-07-18
|
7KB
|
289 lines
Program Bezier;
{
This program draws Bezier curves using the degree elevation
method. For large numbers of points (more than 10, for
example) this is faster than the recursive way.
}
{$I "Include:Exec/Libraries.i" for Forbid, Permit and library things }
{$I "Include:Exec/Interrupts.i"}
{$I "Include:Exec/Ports.i" for the Message stuff }
{$I "Include:Intuition/Intuition.i" for window & screen structures and functions }
{$I "Include:Graphics/Pens.i" for drawing stuff }
{$I "Include:Graphics/Graphics.i"}
{$I "Include:Graphics/Text.i" just for GText}
type
PointRec = Record
X, Y : Real;
end;
Const
w : WindowPtr = Nil;
s : Address = Nil;
{ The following definitions mean that the start-up code will
not create an output window for this program if it is run
from the Workbench. Therefore this program should NOT use
ReadLn and WriteLn. }
StdInName : Address = Nil;
StdOutName: Address = Nil;
Var
m : MessagePtr;
rp : RastPortPtr;
PointCount : Short;
Points : Array [1..200] of PointRec;
t, tprime : Real;
LastX, LastY : Short;
Procedure CleanUpAndDie;
begin
if w <> Nil then begin
Forbid;
repeat until GetMsg(w^.UserPort) = Nil;
CloseWindow(w);
Permit;
end;
if s <> Nil then
CloseScreen(s);
CloseLibrary(GfxBase);
Exit(0);
end;
Function OpenTheScreen() : Boolean;
var
ns : NewScreenPtr;
begin
new(ns);
with ns^ do begin
LeftEdge := 0;
TopEdge := 0;
Width := 640;
Height := 200;
Depth := 2;
DetailPen := 3;
BlockPen := 2;
ViewModes := 32768;
SType := CUSTOMSCREEN_f;
Font := nil;
DefaultTitle := "Simple Bezier Curves";
Gadgets := nil;
CustomBitMap := nil;
end;
s := OpenScreen(ns);
dispose(ns);
OpenTheScreen := s <> nil;
end;
Function OpenTheWindow() : Boolean;
var
nw : NewWindowPtr;
begin
new(nw);
with nw^ do begin
LeftEdge := 0;
TopEdge := 11;
Width := 640;
Height := 189;
DetailPen := -1;
BlockPen := -1;
IDCMPFlags := CLOSEWINDOW_f;
Flags := WINDOWDRAG + WINDOWDEPTH + REPORTMOUSE_f +
WINDOWCLOSE + SMART_REFRESH + ACTIVATE;
FirstGadget := nil;
CheckMark := nil;
Title := "Close the Window to Quit";
Screen := s;
BitMap := nil;
MinWidth := 50;
MaxWidth := -1;
MinHeight := 20;
MaxHeight := -1;
WType := CUSTOMSCREEN_f;
end;
w := OpenWindow(nw);
dispose(nw);
OpenTheWindow := w <> nil;
end;
Procedure DrawLine;
begin
Move(rp, Trunc(Points[PointCount].X), Trunc(Points[PointCount].Y));
Draw(rp, LastX, LastY);
end;
Procedure GetPoints;
var
LastSeconds,
LastMicros : Integer;
IM : IntuiMessagePtr;
StoreMsg : IntuiMessage;
Leave : Boolean;
OutOfBounds : Boolean;
BorderLeft, BorderRight,
BorderTop, BorderBottom : Short;
Procedure AddPoint;
begin
Inc(PointCount);
with Points[PointCount] do begin
X := Float(StoreMsg.MouseX);
Y := Float(StoreMsg.MouseY);
end;
with StoreMsg do begin
LastX := MouseX;
LastY := MouseY;
LastSeconds := Seconds;
LastMicros := Micros;
end;
SetAPen(rp, 2);
SetDrMd(rp, JAM1);
DrawEllipse(rp, LastX, LastY, 5, 3);
SetAPen(rp, 3);
SetDrMd(rp, COMPLEMENT);
DrawLine;
end;
Function CheckForExit : Boolean;
{ This function determines whether the user wanted to stop
entering points. I added the position tests because my
doubleclick time is too long, and I was too lazy to dig
out Preferences to change it. }
begin
with StoreMsg do
CheckForExit := DoubleClick(LastSeconds, LastMicros,
Seconds, Micros) and
(Abs(MouseX - Trunc(Points[PointCount].X)) < 5) and
(Abs(MouseY - TRunc(Points[PointCount].Y)) < 3);
end;
Procedure ClearIt;
{ This just clears the screen when you enter your first point }
begin
SetDrMd(rp, JAM1);
SetAPen(rp, 0);
RectFill(rp, BorderLeft, BorderTop,
BorderRight, BorderBottom);
SetDrMd(rp, COMPLEMENT);
SetAPen(rp, 3);
end;
begin
ModifyIDCMP(w, CLOSEWINDOW_f + MOUSEBUTTONS_f + MOUSEMOVE_f);
SetDrMd(rp, COMPLEMENT);
PointCount := 0;
Leave := False;
OutOfBounds := False;
BorderLeft := w^.BorderLeft;
BorderRight := 639 - w^.BorderRight;
BorderTop := w^.BorderTop;
BorderBottom := 189 - w^.BorderBottom;
repeat
IM := IntuiMessagePtr(WaitPort(w^.UserPort));
IM := IntuiMessagePtr(GetMsg(w^.UserPort));
StoreMsg := IM^;
ReplyMsg(MessagePtr(IM));
case StoreMsg.Class of
MOUSEMOVE_f : if PointCount > 0 then begin
if not OutOfBounds then
DrawLine;
LastX := StoreMsg.MouseX;
LastY := StoreMsg.MouseY;
if (LastX > BorderLeft) and
(LastX < BorderRight) and
(LastY > BorderTop) and
(LastY < BorderBottom) then begin
DrawLine;
OutOfBounds := False;
end else
OutOfBounds := True;
end;
MOUSEBUTTONS_f : if StoreMsg.Code = SELECTUP then begin
if PointCount > 0 then
Leave := CheckForExit
else
ClearIt;
if (not Leave) and (not OutOfBounds) then
AddPoint;
end;
CLOSEWINDOW_f : CleanUpAndDie;
end;
until Leave or (PointCount > 50);
if not Leave then
DrawLine;
ModifyIDCMP(w, CLOSEWINDOW_f);
SetDrMd(rp, JAM1);
SetAPen(rp, 1);
end;
Procedure Elevate;
var
t, tprime,
RealPoints : Real;
i : Integer;
begin
Inc(PointCount);
RealPoints := Float(PointCount);
Points[PointCount] := Points[Pred(PointCount)];
for i := Pred(PointCount) downto 2 do
with Points[i] do begin
t := Float(i) / RealPoints;
tprime := 1.0 - t;
X := t * Points[Pred(i)].X + tprime * X;
Y := t * Points[Pred(i)].Y + tprime * Y;
end;
end;
Procedure DrawCurve;
var
i : Integer;
begin
Move(rp, Trunc(Points[1].X), Trunc(Points[1].Y));
for i := 2 to PointCount do
Draw(rp, Round(Points[i].X), Round(Points[i].Y));
end;
Procedure DrawBezier;
var
i : Short;
begin
SetAPen(rp, 2);
while PointCount < 100 do begin
Elevate;
DrawCurve;
if GetMsg(w^.UserPort) <> Nil then
CleanUpAndDie;
end;
SetAPen(rp, 1);
DrawCurve;
end;
begin
GfxBase := OpenLibrary("graphics.library", 0);
if GfxBase <> nil then begin
if OpenTheScreen() then begin
if OpenTheWindow() then begin
rp := w^.RPort;
Move(rp, 252, 20);
GText(rp, "Enter points by pressing the left mouse button", 46);
Move(rp, 252, 30);
GText(rp, "Double click on the last point to begin drawing", 47);
repeat
GetPoints; { Both these routines will quit if }
DrawBezier; { the window is closed. }
until False;
end;
CloseScreen(s);
end;
CloseLibrary(GfxBase);
end;
end.