Power-Programmierung/CD1.mdf/pascal/library/dos/mouse/oomouse/bezier.pas

Pascal/Delphi Source File | 1989-11-26 | 12.0 KB | 336 lines

program BezierCurves;
{ program that demonstrates use of the mouse object and Bezier spline curves }
{ Mods: }
{ 11-25-89 MAW - Add code to set mouse limits as found by GetMaxX and GetMaxY }
{ 11-26-89 MAW - Generalize Bezier Curve for more control points,
                 as determined by max_points. You can make a pretzel
                 10 points, try it!                                    }
uses
  Crt,
  Graph,
  MouseUnit;

const
  max_points = 4;            { How many points to handle                }
  radius = 5;                                 { radius of pickup circle }
  resolution = 0.025;        { resolution of Bezier curve approximation }

type
  coordinate = record
        row     : integer;
        column  : integer;
  end;

var
  OldExitProc   : Pointer;               { Saves exit procedure address }
  last_Bezier_curve : array[1..42] of coordinate; { array size = 1 / resolution + 2 }
  Bezier_fill_pointer : integer;
  mouse         : mouse_object;                          { mouse object }
  MaxX, MaxY    : word;          { The maximum resolution of the screen }
  point         : array[1..Max_Points] of coordinate;
                                 { end and control points       }

{-----------------------------------------------------------------------}

{$F+} procedure MyExitProc; {$F-}
begin
        ExitProc := OldExitProc;       { Restore exit procedure address }
        CloseGraph;                     { Shut down the graphics system }
end; { MyExitProc }

{-----------------------------------------------------------------------}

procedure Initialize;
{ Initialize graphics and report any errors that may occur }
var
  GraphDriver   : integer;                 { The Graphics device driver }
  GraphMode     : integer;                    { The Graphics mode value }
  ErrorCode     : integer;                { Reports any graphics errors }
  InGraphicsMode : boolean; { Flags initialization of graphics mode }
  PathToDriver   : string;  { Stores the DOS path to *.BGI & *.CHR }
  xasp, yasp : word;
begin
  { when using Crt and graphics, turn off Crt's memory-mapped writes }
  DirectVideo := False;
  OldExitProc := ExitProc;                { save previous exit proc }
  ExitProc := @MyExitProc;                { insert our exit proc in chain }
  PathToDriver := 'c:\lang\bgi';
  repeat

{$IFDEF Use8514}                          { check for Use8514 $DEFINE }
    GraphDriver := IBM8514;
    GraphMode := IBM8514Hi;
{$ELSE}
    GraphDriver := Detect;                { use autodetection }
{$ENDIF}

    InitGraph(GraphDriver, GraphMode, PathToDriver);
    ErrorCode := GraphResult;             { preserve error return }
    if ErrorCode <> grOK then             { error? }
    begin
      Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
      if ErrorCode = grFileNotFound then  { Can't find driver file }
      begin
        Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
        Readln(PathToDriver);
        Writeln;
      end
      else
        Halt(1);                          { Some other error: terminate }
    end;
  until ErrorCode = grOK;

  MaxX := GetMaxX;                        { Get screen resolution values }
  MaxY := GetMaxY;

  Mouse.ColRange(0,MaxX);                 { Set mouse screen size! }
  Mouse.RowRange(0,MaxY);                 { M. Warot - 11-25-89    }

  SetLineStyle ( SolidLn, SolidFill, NormWidth );
end; { Initialize }

{-----------------------------------------------------------------------}

function adjasp(y : integer) : integer;
begin
        adjasp := (MaxY - y);
end;

{-----------------------------------------------------------------------}

function pow(x : real; y : word) : real;
{ compute x to the y                                                    }
var
  count : word;
  result : real;
begin
        result := 1;
        for count := 1 to y do
                result := result * x;
        pow := result;
end;

{-----------------------------------------------------------------------}

function within(x1, y1, x2, y2, radius : integer) : boolean;
{ check to see if point is within control point circle                  }
begin
        if (sqrt(abs(sqr(x2 - x1) + sqr(y2 - y1))) <= radius) then
                within := true
        else
                within := false;
end;

{-----------------------------------------------------------------------}

procedure Old_Bezier(t : real; var x, y : integer);
{ compute actual Bezier coordinates for 0 <= t <= 1 and current control }
{ points.  The Bezier spline curve function is:                         }
{                                                                       }
{                     3              2       2             3            }
{       x(t) = (1 - t) X  + 3t(1 - t) X  + 3t (1 - t)X  + t X           }
{                       0              1              2      3          }
{                                                                       }
{                     3              2       2             3            }
{       y(t) = (1 - t) Y  + 3t(1 - t) Y  + 3t (1 - t)Y  + t Y           }
{                       0              1              2      3          }
{                                                                       }
begin
        x := round(pow(1 - t, 3) * point[1].column +
                3 * t * pow(1 - t, 2) * point[2].column +
                3 * t * t * (1 - t) * point[3].column +
                pow(t, 3) * point[4].column);
        y := round(pow(1 - t, 3) * point[1].row +
                3 * t * pow(1 - t, 2) * point[2].row +
                3 * t * t * (1 - t) * point[3].row +
                pow(t, 3) * point[4].row);
end;

{-----------------------------------------------------------------------}
{ Newer, more generalize Bezier curve, for any number of control points,
  by M. Warot 11-26-1989                                                }

Var
  Binomial : array[1..max_points] of real;
procedure Binomial_Init;
var
  i,j : word;
begin
  for i := 1 to max_points do
    Binomial[i] := 0;
  Binomial[1] := 1.0;

  for j := 2 to max_points do
    for i := j downto 2 do
      binomial[i] := binomial[i] + binomial[i-1];
end;

procedure Bezier(t : real; var x, y : integer);
var
  a    : word;
  s    : real;
  zz   : real;
begin
  s := 1.0-t;
  zz:= 0;
  for a := 1 to max_points do
    zz := zz + (binomial[a] *
                pow(t,a-1) *
                pow(s,max_points-a) *
                point[a].column);
  x := round(zz);

  zz := 0;
  for a := 1 to max_points do
    zz := zz + (binomial[a] *
                pow(t,a-1) *
                pow(s,max_points-a) *
                point[a].row);
  y := round(zz);
end;

{-----------------------------------------------------------------------}

procedure EraseBezierCurve;
{ erase old Bezier curve stored in last_Bezier_curve array              }
var x : integer;
begin
        moveto(last_Bezier_curve[1].column, last_Bezier_curve[1].row);
        for x := 2 to Bezier_fill_pointer do
                lineto(last_Bezier_curve[x].column, last_Bezier_curve[x].row);
end;

{-----------------------------------------------------------------------}

procedure DrawBezierCurve;
{ calculate, draw and save new Bezier curve                             }
var
        t : real;
        x, y : integer;
begin
        Bezier_fill_pointer := 1;
        moveto(point[1].column, adjasp(point[1].row));
        t := 0;
        while t < 1 do begin
                { calculate new Bezier coordinates                      }
                Bezier(t, x, y);

                { draw new Bezier curve                                 }
                lineto(x, adjasp(y));
                t := t + resolution;

                { save new coordinate for erase function                }
                last_Bezier_curve[Bezier_fill_pointer].column := x;
                last_Bezier_curve[Bezier_fill_pointer].row := adjasp(y);
                inc(Bezier_fill_pointer);
        end;
end;

{-----------------------------------------------------------------------}

procedure move_point(point_index : integer);
{ redraw Bezier curve as a control point is moved                       }
var
  x             : integer;
  status        : integer;
  mouse_row, mouse_column : integer;
  old_mouse_row, old_mouse_column : integer;
begin
        { initialize "old" mouse positions                              }
        mouse.GetStatus(status, old_mouse_row, old_mouse_column);
        repeat
          { get mouse position                                          }
          mouse.GetStatus(status, mouse_row, mouse_column);

          { redraw new Bezier curve only if mouse has been moved        }
          if (mouse_row <> old_mouse_row) or (mouse_column <> old_mouse_column) then begin
            old_mouse_row := mouse_row;
            old_mouse_column := mouse_column;

            { hide mouse while updating screen                          }
            mouse.Hide;

            { erase old control point and Bezier curve                  }
            setcolor(0);
            circle(point[point_index].column, adjasp(point[point_index].row), radius);
            EraseBezierCurve;                   { erase old curve       }

            { set new control point coordinates                         }
            point[point_index].row := adjasp(mouse_row);
            point[point_index].column := mouse_column;

            { draw all control points and new curve                     }
            setcolor(GetMaxColor);
            for x := 1 to Max_Points do
                    circle(point[x].column, adjasp(point[x].row), radius);
            DrawBezierCurve;

            { show mouse now that updates have been written to screen   }
            mouse.Show;
          end;

          { this just prevents mouse run-on when button has been released}
          mouse.GetStatus(status, mouse_row, mouse_column);
        until status and $01 = 0;
end;

{-----------------------------------------------------------------------}

var
  ch : char;
  done          : boolean;
  status        : integer;
  button_row    : integer;
  button_column : integer;
  i,j           : word;

begin
  Binomial_Init;
        { check for mouse driver                                        }
        if not mouse.Exists then begin
                writeln('Error:  this program requires the use of a mouse');
                halt(1);
        end;

        { initialize graphics system                                    }
        Initialize;

        { setup origional Bezier curve control points                   }
        for i := 1 to max_points do
        begin
          Point[i].column := (i * maxX) div (max_points+1);
          Point[i].row    := maxY div 4;
        end;

        Point[1].row          := MaxY div 2;
        Point[max_points].row := MaxY div 2;

        { draw origional Bezier curve control points                    }
        for i := 1 to max_points do
          circle(point[i].column, adjasp(point[i].row), radius);

        { draw origional Bezier curve                                   }
        DrawBezierCurve;

        { show mouse pointer                                            }
        if mouse.Exists then mouse.show;

        done := false;
        repeat
                mouse.GetStatus(status, button_row, button_column);
                { if button one pushed then check if in control point   }
                if status and $01 <> 0 then
                begin
                  for i := 1 to max_points do
                    if within(point[i].column, adjasp(point[i].row), button_column, button_row, radius)
                        then move_point(i);
                end;

                { repeat until ESC pressed                              }
                if keypressed then begin
                  ch := readkey;
                  if ch = #27 then done := true;
                end;
        until done;
end.