AMIGA PD 1/AMIGA-PD-1.iso/Programme_zum_Heft/Programmieren/Kurztests/PascalPCQ/Examples/Bezier2.p

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.