{************************************************}
{                                                }
{        Zbigniew Szkaradnik 26-May-88           }
{        GRAF.PAS                                }
{        Turbo Pascal Compiler Vers. 3.0         }
{                                                }
{************************************************}


Program GraphicPackage;

Type
  Pointer = ^Byte;
  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;

(*$I MONITOR.INC*)
(*$I PRINTER.INC*)
(*$I PLOTTER.INC*)

Procedure CallDevice (Dev :Devices);
Begin
  Case Dev Of
    Monitor :MonitorDriver (Parameter);
    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.INC*)

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 := StackPtr;
  PushStack (Y); PushStack (X);
  While StackPtr <> 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 StackPtr <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 (StackPtr <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 := StackPtr;
        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.INC*)

Begin
  If OpenDevice (Monitor) Then
    Begin
      Tool := Pen;
      ErrorMode := ClipMode;
      Clear;
      FnGraph(-3.0,3.0,-2.0,2.0,0.0,1.0
              ,Addr(Zfun));
      ReadLn;
      CloseDevice (Monitor);
    End;
End.