Turbo Toolbox/Turbo_Toolbox.iso/1989/04/extra/graf.pas

Pascal/Delphi Source File | 1989-01-25 | 9.2 KB | 385 lines

{************************************************}
{*                   GRAF.PAS                   *}
{*         Grafiksystem mit Treibern für        *}
{*             verschiedene Geräte              *}
{*          (C) 1989 S.Szkaradnik & TOOLBOX     *}
{************************************************}
PROGRAM GraphicPackage ;
TYPE
  Pattern = ARRAY[0..7] OF BYTE;
  Tools   = ( None, Pen ) ;
  Devices = ( Monitor, Plotter, Printer ) ;
  Func    = ( OpenF, PointF, PlotF, DotF,
              ClearF, CloseF ) ;
  ErrMode = ( ClipMode, WrapMode, FenceMode ) ;
  Parameters = RECORD
                 Command : Func ;
                 X, Y : INTEGER ;
                 Result : BOOLEAN ;
               END ;
  PolyPoint = RECORD
                N : BYTE ;
                Co : ARRAY[BYTE] OF
                     RECORD
                       X, Y : INTEGER;
                     END ;
              END ;

CONST
  Pat : Pattern = ( 128,64,32,16,8,4,2,1 ) ;

VAR
  Tool : Tools ;
  Device : Devices ;
  Position : RECORD
               X, Y : INTEGER ;
             END ;
  Xmin, Xmax : INTEGER ;
  Ymin, Ymax : INTEGER ;
  Parameter : Parameters ;
  ErrorMode : ErrMode ;
  BitMap : FILE ;

FUNCTION Min ( A, B : INTEGER ) : INTEGER ;
BEGIN
  IF A < B THEN Min := A ELSE Min := B
END ;

FUNCTION Max ( A, B : INTEGER ) : INTEGER ;
BEGIN
  IF A > B THEN Max := A ELSE Max := B
END ;

PROCEDURE Clip ( VAR X, Y : INTEGER ) ;
BEGIN
  X := Max ( Min ( X, Xmax ), Xmin ) ;
  Y := Max ( Min ( Y, Ymax ), Ymin ) ;
END ;

PROCEDURE Fence ;
BEGIN
  WriteLn ( 'Error: Out of range' ) ; Halt
END ;

PROCEDURE Wrap ( VAR X, Y : INTEGER ) ;
BEGIN
  IF Y > Ymax THEN
    Y := ( Y - Ymin ) MOD ( Ymax - Ymin ) + Ymin
  ELSE IF Y < Ymin THEN
    Y := - (Ymin - Y) MOD (Ymax - Ymin) + Ymax;
  IF X > Xmax THEN
    X := (X - Xmin) MOD (Xmax - Xmin) + Xmin
  ELSE IF X < Xmin THEN
    X := - (Xmin - X) MOD (Xmax - Xmin) + Xmax;
END ;

PROCEDURE Control ( VAR X, Y : INTEGER ) ;
BEGIN
  IF ( X < Xmin ) OR ( X > Xmax )
     OR ( Y < Ymin ) OR ( Y > Ymax )
    THEN
      CASE ErrorMode OF
        ClipMode  : Clip( X, Y ) ;
        WrapMode  : Wrap( X, Y ) ;
        FenceMode : Fence ;
      END ;
END ;
(* GRAPH.P wird in der Turbo 3.0 Version auf *)
(* IBM-Kompatiblen benötigt, um Pixel zu     *)
(* testen. Also:                             *)
(* $I GRAPH.P *)
(*$I MONITOR.TP3 *)
(* Plotter und Printer kommen in Folge 2 *)
(* $I PRINTER.PAS*)
(* $I PLOTTER.PAS*)

PROCEDURE CallDevice ( Dev : Devices ) ;
BEGIN
  CASE Dev OF
    Monitor : MonitorDriver ( Parameter ) ;
    (* Plotter und Printer kommen in Folge 2 *)
    Plotter : (* PlotterDriver ( Parameter )*) ;
    Printer : (* PrinterDriver ( Parameter )*) ;
  END
END ;

FUNCTION OpenDevice (Output : Devices): BOOLEAN;
BEGIN
  Parameter.Command := OpenF ;
  CallDevice ( Output ) ;
  OpenDevice := Parameter.Result
END ;

FUNCTION Point ( X, Y : INTEGER ) : BOOLEAN ;
BEGIN
  Parameter.Command := PointF ;
  Parameter.X := X ; Parameter.Y := Y ;
  CallDevice ( Device ) ;
  Point := Parameter.Result
END ;

PROCEDURE Plot ( X, Y : INTEGER ) ;
BEGIN
  Parameter.Command := PlotF ;
  Parameter.X := X ; Parameter.Y := Y ;
  CallDevice ( Device ) ;
END ;

PROCEDURE Dot ( X, Y : INTEGER ) ;
BEGIN
  Parameter.Command := DotF ;
  Parameter.X := X ; Parameter.Y := Y ;
  CallDevice ( Device ) ;
END ;

PROCEDURE Clear ;
BEGIN
  Parameter.Command := ClearF ;
  CallDevice ( Device ) ;
END ;

PROCEDURE Draw ( X, Y : INTEGER ) ;
VAR
  Dx, Dy, Sx, Sy, Xtemp, Ytemp, I, Eps : INTEGER;
  Flag : BOOLEAN ;

FUNCTION Sgn ( Val : INTEGER ) : INTEGER ;
BEGIN
  IF Val > 0
    THEN Sgn := 1
    ELSE IF Val < 0
           THEN Sgn := -1
           ELSE Sgn := 0
END ;

PROCEDURE Swap ( VAR A, B : INTEGER ) ;
VAR Temp : INTEGER ;
BEGIN
  Temp := A ; A := B ; B := Temp
END ;

BEGIN
  Ytemp := Position.Y ; Xtemp := Position.X ;
  Dy := Abs ( Y - Ytemp ) ;
  Dx := Abs ( X - Xtemp ) ;
  Sy := Sgn ( Y - Ytemp ) ;
  Sx := Sgn ( X - Xtemp ) ;
  IF Dx + Dy = 0
    THEN Dot ( Xtemp, Ytemp )
    ELSE
      BEGIN
        Flag := Dy > Dx ;
        IF Flag
          THEN Swap ( Dx, Dy ) ;
        Eps := Dy SHL 1 - Dx ;
        FOR I := 1 TO Dx DO
          BEGIN
            Dot ( Xtemp, Ytemp ) ;
            WHILE Eps >= 0 DO
              BEGIN
                IF Flag
                  THEN Xtemp := Xtemp + Sx
                  ELSE Ytemp := Ytemp + Sy ;
                Eps := Eps - Dx SHL 1
              END ;
            IF Flag
              THEN Ytemp := Ytemp + Sy
              ELSE Xtemp := Xtemp + Sx ;
            Eps := Eps + Dy SHL 1
          END
      END ;
  Position.X := X ; Position.Y := Y ;
END ;

PROCEDURE Line ( VAR Points : PolyPoint ) ;
VAR
  I : BYTE ;
BEGIN
  WITH Points DO
    IF N > 0 THEN
      BEGIN
        Plot ( Co [0].X, Co [0].Y ) ;
        FOR I := 1 TO N DO
          Draw ( Co [I].X, Co [I].Y ) ;
      END ;
END ;

(*$I STACK.ALL*)

PROCEDURE Fill ( X, Y : INTEGER ) ;
VAR
  EndOfStack, Return, Xleft, Xright,
  SaveX, Xc, Yc                      : INTEGER ;
  Pflag : BYTE ;

PROCEDURE Scan ;
BEGIN
  Return := PopStack ;
  WHILE Xc <= Xright DO
    BEGIN
      Pflag := 0 ;
      WHILE NOT Point ( Xc, Yc )
            AND ( Xc <= Xright ) DO
        BEGIN Pflag := 1 ; Xc := Succ ( Xc ) END ;
      IF Pflag = 1 THEN
        BEGIN
          IF (Xc = Xright) AND NOT Point (Xc, Yc)
            THEN BEGIN
              PushStack ( Yc ) ;
              PushStack ( Xc )
            END
            ELSE BEGIN
               PushStack ( Yc ) ;
               PushStack ( Pred ( Xc ))
             END ;
        END ;
      Xc := Succ ( Xc ) ;
      WHILE Point ( Xc, Yc )
            AND ( Xc < Xright ) DO
              Xc := Succ ( Xc ) ;
    END ;
  PushStack ( Return )
END ;

BEGIN
  EndOfStack := GrafStackPtr ;
  PushStack ( Y ) ; PushStack ( X ) ;
  WHILE GrafStackPtr <> EndOfStack DO
    BEGIN
      Xc := PopStack ; Yc := PopStack ;
      Dot ( Xc, Yc ) ;
      SaveX := Xc ;
      Xc := Succ ( SaveX ) ;
      WHILE NOT Point ( Xc, Yc ) DO
        BEGIN
          Dot ( Xc, Yc ) ;
          Xc := Succ ( Xc )
        END ;
      Xright := Pred ( Xc ) ;
      Xc := Pred ( SaveX ) ;
      WHILE NOT Point ( Xc, Yc ) DO
        BEGIN
          Dot ( Xc, Yc ) ;
          Xc := Pred ( Xc )
        END ;
      Xleft := Succ ( Xc ) ;
      Xc := Xleft ; Yc := Yc - 1 ; Scan ;
      Xc := Xleft ; Yc := Yc + 2 ; Scan ;
    END ;
END ;

PROCEDURE Area ( VAR Points : PolyPoint ) ;
VAR
  EndOfStack, Return,
  Yscan, MinY, MaxY : INTEGER ;
  I : BYTE ;

PROCEDURE RangeY ( VAR MaxY, MinY : INTEGER ) ;
VAR
  I : BYTE ;
BEGIN
  MaxY := Ymin ; MinY := Ymax ;
  WITH Points DO
    FOR I := 0 TO N DO
      BEGIN
        MaxY := Max ( MaxY, Co [I].Y ) ;
        MinY := Min ( MinY, Co [I].Y ) ;
      END ;
  MaxY := Min ( MaxY, Ymax ) ;
  MinY := Max ( MinY, Ymin ) ;
END ;

PROCEDURE CloseContour  ;
BEGIN
  WITH Points DO
    IF ( Co [0].X <> Co [N].X )
        OR ( Co [0].Y <> Co [N].Y ) THEN
      BEGIN
        N := Succ ( N ) ;
        Co [N].X := Co [0].X ;
        Co [N].Y := Co [0].Y ;
      END ;
END ;

FUNCTION Xcross ( Xstart, Ystart,
                  Xend, Yend, Yscan : INTEGER )
                                        : INTEGER;
BEGIN
  Xcross := Round((Yscan - Ystart)/(Yend - Ystart)
            * ( Xend - Xstart ) + Xstart ) ;
END ;

PROCEDURE DrawScan ( Yscan : INTEGER ) ;
BEGIN
  Return := PopStack ;
  WHILE GrafStackPtr < EndOfStack  DO
    BEGIN
      Plot ( PopStack, Yscan ) ;
      Draw ( PopStack, Yscan ) ;
    END ;
  PushStack ( Return ) ;
END ;

PROCEDURE SortStack ( Xins : INTEGER ) ;
VAR
  Xtst, N, I : INTEGER ;
BEGIN
  Return := PopStack ;
  N := 0 ; Xtst := PickStack ;
  WHILE ( GrafStackPtr < EndOfStack )
        AND ( Xtst < Xins ) DO
    BEGIN
      PushHeap ( PopStack ) ;
      N := Succ ( N ) ;
      Xtst := PickStack ;
    END ;
  PushStack ( Xins ) ; I := 1 ;
  WHILE I <= N DO BEGIN
    PushStack ( PopHeap ) ;
    I := Succ ( I ) ;
  END ;
  PushStack ( Return ) ;
END ;

BEGIN
  CloseContour ; Line ( Points ) ;
  RangeY ( MaxY, MinY ) ;
  FOR Yscan := MinY TO MaxY DO
    WITH Points DO BEGIN
      I := 0 ; EndOfStack := GrafStackPtr ;
      WHILE I < N DO BEGIN
        IF ( Co [I].Y <> Co [I+1].Y )
           AND ( Yscan >= Min ( Co [I].Y,
                                Co [I+1].Y ))
           AND ( Yscan < Max ( Co [I].Y,
                 Co [I+1].Y )) THEN
             SortStack(Xcross(Co[I].X,Co[I].Y,
                              Co[I+1].X,
                       Co [I+1].Y, Yscan )) ;
            I := Succ ( I ) ;
          END ;
        DrawScan ( Yscan ) ;
      END ;
END ;

PROCEDURE CloseDevice ( Output : Devices ) ;
BEGIN
  Parameter.Command := CloseF ;
  CallDevice ( Output ) ;
END ;

(*$I FUNGR.PAS*)

BEGIN
  IF OpenDevice ( Monitor ) THEN
    BEGIN
      Tool := Pen ;
      ErrorMode := ClipMode ;
      Clear ;
      FnGraph ( -3.0, 3.0, -2.0, 2.0, 0.0, 1.0) ;
      ReadLn ;
      CloseDevice ( Monitor ) ;
    END ;
END.