Liren Large Software Subsidy 9/09.iso/l/l048/1.ddi/KERNEL.SYS

Text File | 1986-05-06 | 30.4 KB | 1,256 lines

(***********************************************************)
(*                                                         *)
(*                TURBO GRAPHIX version 1.06A              *)
(*                                                         *)
(*                  Graphics system kernel                 *)
(*                   Module version 1.06A                  *)
(*                                                         *)
(*                  Copyright (C) 1985 by                  *)
(*                  BORLAND International                  *)
(*                                                         *)
(***********************************************************)

procedure GotoXYTurbo(X, Y : integer);
begin
  GotoXY(X, Y);  { This will call Turbo's GotoXY }
end; { GotoXYTurbo }

procedure GotoXY(X, Y : integer);
{ Further calls to GotoXY will call this procedure }
begin
  if not GrafModeGlb then
    GotoXYTurbo(X, Y);
  XTextGlb := X;
  YTextGlb := Y;
end; { GotoXY }

procedure ClrEOLTurbo;
begin
  ClrEOL;  { This will call Turbo's ClrEOL }
end; { ClrEOLTurbo }

procedure ClrEOL;
{ Further calls to ClrEOL will call this procedure }
var
  Temp : integer;
begin
  if not GrafModeGlb then
    ClrEOLTurbo
  else
    begin
      Temp := XTextGlb;
      for XTextGlb := Temp to 80 do
        DC(32);
      XTextGlb := Temp;
    end;
end; { ClrEOL }

procedure Error { declared in GRAPHIX.SYS: (ErrProc, ErrCode : integer) };
type
  String2 = string[2];
var
  NLevels, PCValue, XLoc, YLoc : integer;
  Ch : char;

function HexString(Byt : byte) : string2;
const
  Hex : array[0..15] of char = '0123456789ABCDEF';
begin
  HexString := Hex[Byt shr 4] + Hex[Byt and 15];
end; { HexString }

begin { Error }
  if not (ErrProc in [0..MaxProcsGlb]) then
  begin
    LeaveGraphic;
    WriteLn('FATAL Error 1: illegal procedure number ', ErrProc);
    Halt;
  end;
  if not (ErrCode in [0..MaxErrsGlb]) then
  begin
    LeaveGraphic;
    WriteLn('FATAL Error 2: illegal Error code ', ErrCode);
    Halt;
  end;
  ErrCodeGlb := ErrCode;
  if BrkGlb then
    LeaveGraphic;
  if MessageGlb or BrkGlb then
  begin
    XLoc := XTextGlb;
    YLoc := YTextGlb;
    GotoXY(1, 24);
    ClrEOL;
    WriteLn('Turbo Graphix Error #', ErrCode, ' in procedure #', ErrProc);
    if MessageGlb then
    begin
      ClrEOL;
      Write('(', ErrorCode[ErrCode]^, ' in ', ErrorProc[ErrProc]^, ')');
    end;
  end;
  if MessageGlb and BrkGlb then
    begin
      WriteLn;
      WriteLn('Traceback:');
      NLevels := 0;
      repeat
        inline($89/$EB/$8B/$8E/ NLevels /$09/$C9/$74/$05/$8B/$6E/
               $00/$E2/$FB/$8B/$46/$02/$89/$DD/$89/$86/ PCValue );
        if PCValue <> 0 then
          WriteLn(PcGlb, ' : ', HexString(Hi(PCValue - 1)),
                  HexString(Lo(PCValue - 1)));
        NLevels := NLevels + 1;
      until (NLevels > 20) or (PCValue = 0); { Trace back no more than 20 levels }
      Halt;
    end
  else if BrkGlb { and not MessageGlb } then
    Halt
  else if MessageGlb then
    begin
      Write('.  Hit enter: ');
      repeat
        Read(KBD, Ch);
      until (Ch = ^M) or (Ch = ^C);
      if Ch = ^C then
      begin
        LeaveGraphic;
        Halt;
      end;
      GotoXY(XLoc, YLoc);
    end;
end; { Error }

procedure SetBreakOff;
begin
  BrkGlb := false;
end; { SetBreakOff }

procedure SetBreakOn;
begin
  BrkGlb := true;
end; { SetBreakOn }

function GetErrorCode : byte;
begin
  GetErrorCode := ErrCodeGlb;
  ErrCodeGlb := 0;
end; { GetErrorCode }

procedure SetWindowModeOff;
begin
  DirectModeGlb := true;
end; { SetWindowModeOff }

procedure SetWindowModeOn;
begin
  DirectModeGlb := false;
end; { SetWindowModeOn }

procedure SetClippingOn;
begin
  ClippingGlb := true;
end; { SetClippingOn }

procedure SetClippingOff;
begin
  ClippingGlb := false;
end; { SetClippingOff }

procedure SetMessageOn;
begin
  MessageGlb := true;
end; { SetMessageOn }

procedure SetMessageOff;
begin
  MessageGlb := false;
end; { SetMessageOff }

procedure SetHeaderOn;
begin
  HeaderGlb := true;
end; { SetHeaderOn }

procedure SetHeaderOff;
begin
  HeaderGlb := false;
end; { SetHeaderOff }

procedure SetHeaderToTop;
begin
  TopGlb := true;
end; { SetHeaderToTop }

procedure SetHeaderToBottom;
begin
  TopGlb := false;
end; { SetHeaderToBottom }

procedure RemoveHeader(I : integer);
begin
  if I in [1..MaxWindowsGlb] then
    with Window[I] do
    begin
      Drawn := false;
      Top := true;
      Header := '';
    end
  else
    Error(22, 2);
end; { RemoveHeader }

procedure SetColorWhite;
begin
  ColorGlb := 255;
end; { SetColorWhite }

procedure SetColorBlack;
begin
  ColorGlb := 0;
end; { SetColorBlack }

function GetWindow : integer;
begin
  GetWindow := WindowNdxGlb;
end; { GetWindow }

function GetColor : integer;
begin
  GetColor := ColorGlb;
end; { GetColor }

function Clipping : boolean;
begin
    Clipping := ClippingGlb;
end; { Clipping }

function WindowMode : boolean;
begin
  WindowMode := not DirectModeGlb;
end; { WindowMode }

procedure SetScreenAspect(Aspect : real);
begin
  if Aspect <> 0.0 then
    AspectGlb := abs(Aspect);
end; { SetScreenAspect }

function GetScreenAspect : real;
begin
  GetScreenAspect := AspectGlb;
end; { GetScreenAspect }

procedure SetAspect(Aspect : real);
begin
  if Aspect <> 0.0 then
    AspectGlb := abs(Aspect) * AspectFactor;
end; { SetAspect }

function GetAspect : real;
begin
  GetAspect := AspectGlb / AspectFactor;
end; { GetAspect }

procedure SetLinestyle(Ls : integer);
var
  I : integer;
const
  Lsa : array[0..4] of byte = ($FF,$88,$F8,$E4,$EE);

begin
  if not (Ls in [0..4]) then
    Ls := Ls and $FF + $100;
  LineStyleGlb := Ls;
  if Ls < 5 then
    Ls := Lsa[Ls];
  for I := 0 to 7 do
    LineStyleArrayGlb[7 - I] := ((Ls shr I) and 1) <> 0;
  CntGlb := 7;
end; { SetLinestyle }

function GetLinestyle : integer;
begin
  GetLinestyle := LinestyleGlb;
end; { GetLinestyle }

procedure SetVStep(Vs : integer);
begin
  if Vs > 0 then
    VStepGlb := Vs;
end; { SetVStep }

function GetVStep : integer;
begin
  GetVStep := VStepGlb;
end; { GetVStep }

procedure DefineHeader(I : integer; Hdr : WrkString);
begin
  if (I in [1..MaxWindowsGlb]) then
    Window[I].Header := Hdr
  else
    Error(3, 2);
end; { DefineHeader }

procedure SelectScreen(I : integer);
begin
  if RamScreenGlb and (I = 2) then
    GrafBase := Seg(ScreenGlb^)
  else
    GrafBase := HardwareGrafBase;
end; { SelectScreen }

function GetScreen : byte;
begin
  if GrafBase = HardwareGrafBase then
    GetScreen := 1
  else
    GetScreen := 2;
end; { GetScreen }

procedure DefineWorld(I : integer; X_1, Y_1, X_2, Y_2 : real);
begin
  if ((X_1 <> X_2) and (Y_1 <> Y_2)) and (I in [1..MaxWorldsGlb]) then
    with World[I] do
    begin
      X1 := X_1; Y1 := Y_1; X2 := X_2; Y2 := Y_2;
      if I > MaxWorldGlb then
        MaxWorldGlb := I;
    end
  else if I in [1..MaxWorldsGlb] then
    Error(1, 3)
  else
    Error(1, 2);
end; { DefineWorld }

procedure SelectWorld(I : integer);
begin
  if (I in [1..MaxWorldGlb]) then
    with World[I] do
    begin
      WorldNdxGlb := I;
      X1WldGlb := X1;
      Y1WldGlb := Y1;
      X2WldGlb := X2;
      Y2WldGlb := Y2;
    end
  else
    Error(2, 2);
end; { SelectWorld }

procedure ReDefineWindow(I, X_1, Y_1, X_2, Y_2 : integer);
begin
  if (I in [1..MaxWindowsGlb]) and (X_1 <= X_2) and (Y_1 <= Y_2) and (X_1 >= 0)
     and (X_2 <= XScreenMaxGlb) and (Y_1 >= 0) and (Y_2 <= YMaxGlb) then
    with Window[I] do
    begin
      X1 := X_1;
      Y1 := Y_1;
      X2 := X_2;
      Y2 := Y_2;
      if I > MaxWindowGlb then
        MaxWindowGlb := I;
    end
  else if I in [1..MaxWindowsGlb] then
    Error(3, 3)
  else
    Error(3, 2);
end; { ReDefineWindow }

procedure DefineWindow(I, X_1, Y_1, X_2, Y_2 : integer);
begin
  ReDefineWindow(I, X_1, Y_1, X_2, Y_2);
  with Window[I] do
  begin
    Header := '';
    Top := true;
    Drawn := false;
  end;
end; { DefineWindow }

function TextLeft(TX, Boundary : integer) : integer;
var
  TL : integer;
begin
  TL := ((TX - 1) * ((XScreenMaxGlb + 1) div 80) - Boundary) div 8;
  if TL < 0 then
    TL := 0
  else if TL > XMaxGlb then
    TL := XMaxGlb;
  TextLeft := TL;
end; { TextLeft }

function TextRight(TX, Boundary : integer) : integer;
var
  TR : integer;
begin
  TR := (XScreenMaxGlb + 1) div 80;
  TR := (TX * TR + Boundary - 1) div 8;
  if TR < 0 then
    TR := 0
  else if TR > XMaxGlb then
    TR := XMaxGlb;
  TextRight := TR;
end; { TextRight }

function TextUp(TY, Boundary : integer) : integer;
var
  TU : integer;
begin
  TU := (TY - 1) * ((YMaxGlb + 1) div 25) - Boundary;
  if TU < 0 then
    TU := 0
  else if TU > YMaxGlb then
    TU := YMaxGlb;
  TextUp := TU;
end; { TextUp }

function TextDown(TY, Boundary : integer) : integer;
var
  TD : integer;
begin
  TD := TY * ((YMaxGlb + 1) div 25) + Boundary - 1;
  if TD < 0 then
    TD := 0
  else if TD > YMaxGlb then
    TD := YMaxGlb;
  TextDown := TD;
end; { TextDown }

procedure DefineTextWindow(I, X1, Y1, X2, Y2, B : integer);
begin
  DefineWindow(I, TextLeft(X1, B), TextUp(Y1, B),
               TextRight(X2, B), TextDown(Y2, B));
end; { DefineTextWindow }

procedure SelectWindow(I : integer);
begin
  if (I in [1..MaxWindowGlb]) then
    with Window[I] do
    begin
      WindowNdxGlb := I;
      X1RefGlb := X1;
      Y1RefGlb := Y1;
      X2RefGlb := X2;
      Y2RefGlb := Y2;
      BxGlb := ((X2 - X1) shl 3 + 7) / (X2WldGlb - X1WldGlb);
      ByGlb := (Y2 - Y1) / (Y2WldGlb - Y1WldGlb);
      AxGlb := (X1 shl 3) - X1WldGlb * BxGlb;
      AyGlb := Y1 - Y1WldGlb * ByGlb;
      if AxisGlb then
      begin
        AxisGlb := false;
        X1Glb := 0;
        Y1Glb := 0;
        X2Glb := 0;
        Y2Glb := 0;
      end;
    end
  else
    Error(4, 2);
end; { SelectWindow }

function WindowX(X : real) : integer;
var
  Temp : real;
begin
  Temp := AxGlb + BxGlb * X;
  if Temp > MaxInt then
    WindowX := MaxInt
  else if Temp < -32767 then
    WindowX := -32767
  else
    WindowX := trunc(Temp);
end; { WindowX }

function WindowY(Y : real) : integer;
var
  Temp : real;
begin
  Temp := AyGlb + ByGlb * Y;
  if Temp > MaxInt then
    WindowY := MaxInt
  else if Temp < -32767 then
    WindowY := -32767
  else
    WindowY := trunc(Temp);
end; { WindowY }

procedure InitGraphic;
var
  Fil : file of CharArray;
  Tfile : text;
  Test : ^integer;
  Temp : WrkString;
  I : integer;
begin
  GotoXY(1, 1);
  if not HardwarePresent then
  begin
    ClrScr;
    GotoXY(1, 2);
    WriteLn('Fatal Error: graphics hardware not found or not properly activated');
    Halt;
  end;
  MessageGlb := true;
  BrkGlb := false;
  GrafModeGlb := false;
  GetMem(ErrorProc[0], 16);
  GetMem(ErrorCode[0], 24);
  ErrorProc[0]^ := 'InitGraphic';
  ErrorCode[0]^ := 'Error.MSG missing';
  Assign(Tfile, 'Error.msg');
  {$I-} Reset(Tfile); {$I+}
  if IOresult = 0 then
    begin
      for I := 0 to MaxProcsGlb do
      begin
        ReadLn(Tfile, Temp);
        if I <> 0 then
          GetMem(ErrorProc[I], Length(Temp) + 1);
        ErrorProc[I]^ := Temp;
      end;
      for I := 0 to MaxErrsGlb do
      begin
        ReadLn(Tfile, Temp);
        if I <> 0 then
          GetMem(ErrorCode[I], Length(Temp) + 1);
        ErrorCode[I]^ := Temp;
      end;
      ReadLn(Tfile, PcGlb);
      Close(Tfile);
    end
  else
    begin
      GetMem(ErrorProc[1], 14);
      ErrorProc[1]^ := '** UNKNOWN **';
      for I := 2 to MaxProcsGlb do
        ErrorProc[I] := ErrorProc[1];
      for I := 1 to MaxErrsGlb do
        ErrorCode[I] := ErrorProc[1];
      Error(0, 0);
    end;
  for I := 1 to MaxWorldsGlb do
    DefineWorld(I, 0, 0, XScreenMaxGlb, YMaxGlb);
  MaxWorldGlb := 1;
  for I := 1 to MaxWindowsGlb do
  begin
    DefineWindow(I, 0, 0, XMaxGlb, YMaxGlb);
    with Stack[I] do
    begin
      W.Size := 0;
      Contents := nil;
    end;
    RemoveHeader(I);
  end;
  MaxWindowGlb := 1;
  if CharFile <> '' then
  begin
    Assign(Fil, CharFile);
    {$I-} Reset(Fil); {$I+}
    if IOresult = 0 then
      Read(Fil, CharSet)
    else
      Error(0, 1);
    Close(Fil);
  end;
  BrkGlb := true;
  if RamScreenGlb then
  begin
    AllocateRAMScreen;
    SelectScreen(2);
    ClearScreen;
  end;
  SelectScreen(1);
  WindowNdxGlb := 1;
  SelectWorld(1);
  SelectWindow(1);
  SetColorWhite;
  SetClippingOn;
  SetAspect(AspectFactor);
  DirectModeGlb := false;
  PieGlb := false;
  SetMessageOn;
  SetHeaderOff;
  SetHeaderToTop;
  ErrCodeGlb := 0;
  SetLineStyle(0);
  VStepGlb := IVStepGlb;
  EnterGraphic;
  X1Glb := 0;
  X2Glb := 0;
  Y1Glb := 0;
  Y2Glb := 0;
  AxisGlb := false;
  HatchGlb := false;
end; { InitGraphic }

procedure ResetWindows;
var
  I : integer;
begin
  for I := 1 to MaxWindowsGlb do
  begin
    DefineWindow(I, 0, 0, XMaxGlb, YMaxGlb);
    RemoveHeader(I);
  end;
  SelectWindow(1);
end; { ResetWindows }

procedure ResetWorlds;
var
  I : integer;
begin
  for I := 1 to MaxWorldsGlb do
    DefineWorld(I, 0, 0, XScreenMaxGlb, YMaxGlb);
  SelectWorld(1);
  SelectWindow(WindowNdxGlb);
end; { ResetWorlds }

function Clip(var X1, Y1, X2, Y2 : integer) : boolean;
var
  Ix1, Iy1, Ix2, Iy2, Dummy, X1Loc, X2Loc : integer;
  ClipLoc : boolean;
  Temp : real;

function Inside(X, Xx1, Xx2 : integer) : integer;
begin
  Inside := 0;
  if X < Xx1 then
    Inside := -1
  else if X > Xx2 then
    Inside := 1;
end; { Inside }

begin  { Clip }
  Clip := true;
  ClipLoc := true;
  if ClippingGlb then
    begin
      if HatchGlb then
        begin
          X1Loc := X1RefGlb;
          X2Loc := X2RefGlb;
        end
      else
        begin
          X1Loc := X1RefGlb shl 3;
          X2Loc := X2RefGlb shl 3 + 7;
        end;
      Ix1 := Inside(X1, X1Loc, X2Loc);
      Iy1 := Inside(Y1, Y1RefGlb, Y2RefGlb);
      Ix2 := Inside(X2, X1Loc, X2Loc);
      Iy2 := Inside(Y2, Y1RefGlb, Y2RefGlb);
      if (Ix1 or Ix2 or Iy1 or Iy2) <> 0 then
      begin
        if X1 <> X2 then
        begin
          if Ix1 <>0 then
          begin
            if Ix1 < 0 then
              Dummy := X1Loc
            else
              Dummy := X2Loc;
            if Y2 <> Y1 then
            begin
              Temp := (Y2 - Y1) / (X2 - X1) * (Dummy - X1);
              if Temp > MaxInt then
                Temp := MaxInt
              else if Temp < -32767 then
                Temp := -32767;
              Y1 := Y1 + trunc(Temp);
            end;
            X1 := Dummy;
          end;
          if (Ix2 <> 0) and (X1 <> X2) then
          begin
            if Ix2 < 0 then
              Dummy := X1Loc
            else
              Dummy := X2Loc;
            if Y2 <> Y1 then
            begin
              Temp := (Y2 - Y1) / (X2 - X1) * (Dummy - X1);
              if Temp > MaxInt then
                Temp := MaxInt
              else if Temp < -32767 then
                Temp := -32767;
              Y2 := Y1 + trunc(Temp);
            end;
            X2 := Dummy;
          end;
          Iy1 := Inside(Y1, Y1RefGlb, Y2RefGlb);
          Iy2 := Inside(Y2, Y1RefGlb, Y2RefGlb);
        end;
        if Y1 <> Y2 then
        begin
          if Iy1 <> 0 then
          begin
            if Iy1 < 0 then
              Dummy := Y1RefGlb
            else
              Dummy := Y2RefGlb;
            if X1 <> X2 then
            begin
              Temp := (X2 - X1) / (Y2 - Y1) * (Dummy - Y1);
              if Temp > MaxInt then
                Temp := MaxInt
              else if Temp < -32767 then
                Temp := -32767;
              X1 := X1 + trunc(Temp);
            end;
            Y1 := Dummy;
          end;
          if Iy2 <> 0 then
          begin
            if Iy2 < 0 then
              Dummy := Y1RefGlb
            else
              Dummy := Y2RefGlb;
            if X1 <> X2 then
            begin
              Temp := (X2 - X1) / (Y2 - Y1) * (Dummy - Y1);
              if Temp > MaxInt then
                Temp := MaxInt
              else if Temp < -32767 then
                Temp := -32767;
              X2 := X1 + trunc(Temp);
            end;
            Y2 := Dummy;
          end;
        end;
        Iy1 := Inside(Y1, Y1RefGlb, Y2RefGlb);
        Iy2 := Inside(Y2, Y1RefGlb, Y2RefGlb);
        if (Iy1 <> 0) or (Iy2 <> 0) then
          ClipLoc := false;
        if ClipLoc then
        begin
          Ix1 := Inside(X1, X1Loc, X2Loc);
          Ix2 := Inside(X2, X1Loc, X2Loc);
          if (Ix2 <> 0) or (Ix1 <> 0) then
            ClipLoc := false;
        end;
        Clip := ClipLoc;
      end;
    end;
end; { Clip }

procedure DrawPoint(Xr, Yr : real);
var
  X, Y : integer;
begin
  if DirectModeGlb then
    DP(trunc(Xr), trunc(Yr))
  else
    begin
      X := WindowX(Xr);
      Y := WindowY(Yr);
      if ClippingGlb then
        begin
          if (X >= X1RefGlb shl 3) and (X < X2RefGlb shl 3 + 7) then
            if (Y >= Y1RefGlb) and (Y <= Y2RefGlb) then
              DP(X, Y);
        end
      else
        DP(X, Y);
    end;
end; { DrawPoint }

function PointDrawn(Xr, Yr : real) : boolean;
begin
  if DirectModeGlb then
    PointDrawn := PD(trunc(Xr), trunc(Yr))
  else
    PointDrawn := PD(WindowX(Xr), WindowY(Yr));
end; { PointDrawn }

procedure DrawLine(X1, Y1, X2, Y2 : real);
var
  X1Loc, Y1Loc, X2Loc, Y2Loc : integer;

procedure DrawLineDirect(X1, Y1, X2, Y2 : integer);
var
  X, Y, DeltaX, DeltaY, XStep, YStep, Direction : integer;
begin
  X := X1;
  Y := Y1;
  XStep := 1;
  YStep := 1;
  if X1 > X2 then
    XStep := -1;
  if Y1 > Y2 then
    YStep := -1;
  DeltaX := abs(X2 - X1);
  DeltaY := abs(Y2 - Y1);
  if DeltaX = 0 then
    Direction := -1
  else
    Direction := 0;
  while not ((X = X2) and (Y = Y2)) do
  begin
    if LinestyleGlb = 0 then
      DP(X, Y)
    else
      begin
        CntGlb := (CntGlb + 1) and 7;
        if LineStyleArrayGlb[CntGlb] then
          DP(X, Y);
      end;
    if Direction < 0 then
      begin
        Y := Y + YStep;
        Direction := Direction + DeltaX;
      end
    else
      begin
        X := X + XStep;
        Direction := Direction - DeltaY;
      end;
  end;
end; { DrawLineDirect }

begin { DrawLine }
  if DirectModeGlb then
    DrawLineDirect(trunc(X1), trunc(Y1), trunc(X2), trunc(Y2))
  else
    begin
      X1Loc := WindowX(X1);
      Y1Loc := WindowY(Y1);
      X2Loc := WindowX(X2);
      Y2Loc := WindowY(Y2);
      if Clip(X1Loc, Y1Loc, X2Loc, Y2Loc) then
        DrawLineDirect(X1Loc, Y1Loc, X2Loc, Y2Loc);
    end;
end; { DrawLine }

procedure DrawLineClipped(X1, Y1, X2, Y2 : integer);
begin
  if Clip(X1, Y1, X2, Y2) then
    DrawLine(X1, Y1, X2, Y2);
end; { DrawLineClipped }

procedure DrawCrossDiag(X, Y, Scale : integer);
begin
  DrawLineClipped(X - Scale, Y + Scale, X + Scale + 1, Y - Scale - 1);
  DrawLineClipped(X - Scale, Y - Scale, X + Scale + 1, Y + Scale + 1);
end; { DrawCrossDiag }

procedure DrawWye(X, Y, Scale : integer);
begin
  DrawLineClipped(X - Scale, Y - Scale, X, Y);
  DrawLineClipped(X + Scale, Y - Scale, X, Y);
  DrawLineClipped(X, Y, X, Y + Scale);
end; { DrawWye }

procedure DrawDiamond(X, Y, Scale : integer);
begin
  DrawLineClipped(X - Scale, Y, X, Y - Scale - 1);
  DrawLineClipped(X, Y - Scale + 1, X + Scale, Y + 1);
  DrawLineClipped(X + Scale, Y + 1, X, Y + Scale);
  DrawLineClipped(X, Y + Scale, X - Scale, Y);
end; { DrawDiamond }

procedure DrawCircleDirect(Xr, Yr, R : integer; DirectModeLoc : boolean);
const
  N = 14;
type
  Circ = array[1..N] of integer;
const
  X : Circ = (0,121,239,355,465,568,663,749,823,885,935,971,993,1000);
var
  Xk1, Xk2, Yk1, Yk2, Xp1, Yp1, Xp2, Yp2 : integer;
  Xfact, Yfact : real;
  I : integer;

procedure DrawLinW(X1, Y1, X2, Y2 : integer);
var
  DrawIt : boolean;
begin
  DrawIt := DirectModeLoc;
  if not DrawIt then
    DrawIt := Clip(X1, Y1, X2, Y2);
  if DrawIt then
    DrawLine(X1, Y1, X2, Y2);
end; { DrawLinW }

begin { DrawCircleDirect }
  Xfact := abs(R * 0.001);
  Yfact := Xfact * AspectGlb;
  if Xfact > 0.0 then
    begin
      Xk1 := trunc(X[1] * Xfact + 0.5);
      Yk1 := trunc(X[N] * Yfact + 0.5);
      for I := 2 to N do
      begin
        Xk2 := trunc(X[I] * Xfact + 0.5);
        Yk2 := trunc(X[N - I + 1] * Yfact + 0.5);
        Xp1 := Xr - Xk1;
        Yp1 := Yr + Yk1;
        Xp2 := Xr - Xk2;
        Yp2 := Yr + Yk2;
        DrawLinW(Xp1, Yp1, Xp2, Yp2);
        Xp1 := Xr + Xk1;
        Xp2 := Xr + Xk2;
        DrawLinW(Xp1, Yp1, Xp2, Yp2);
        Yp1 := Yr - Yk1;
        Yp2 := Yr - Yk2;
        DrawLinW(Xp1, Yp1 + 1, Xp2, Yp2 + 1);
        Xp1 := Xr - Xk1;
        Xp2 := Xr - Xk2;
        DrawLinW(Xp1, Yp1 + 1, Xp2, Yp2 + 1);
        Xk1 := Xk2;
        Yk1 := Yk2;
      end;
    end
  else
    DP(Xr, Yr);
end; { DrawCircleDirect }

procedure DrawCircle(X_R, Y_R, Xradius : real);
var
  DirectModeLoc : boolean;
begin
  DirectModeLoc := DirectModeGlb;
  DirectModeGlb := true;
  if DirectModeLoc then
    DrawCircleDirect(trunc(X_R), trunc(Y_R), trunc(Xradius), true)
  else
    DrawCircleDirect(WindowX(X_R), WindowY(Y_R), trunc(Xradius * 100.0), false);
  DirectModeGlb := DirectModeLoc;
end; { DrawCircle }

procedure DrawCross(X1, Y1, Scale : integer);
begin
  DrawLineClipped(X1 - Scale, Y1, X1 + Scale + 2, Y1);
  DrawLineClipped(X1, Y1 - Scale, X1, Y1 + Scale + 1);
end; { DrawCross }

procedure DrawStar(X, Y, Scale : integer);
begin
  DrawLineClipped(X - Scale, Y + Scale, X + Scale + 1, Y - Scale - 1);
  DrawLineClipped(X - Scale, Y - Scale, X + Scale + 1, Y + Scale + 1);
  DrawLineClipped(X - Scale - 2, Y, X + Scale + 4, Y);
end; { DrawStar }

procedure DrawSquareC(X1, Y1, X2, Y2 : integer; Fill : boolean);
var
  I : integer;

procedure DSC(X1, X2, Y : integer);
begin
  if Clip(X1, Y, X2, Y) then
    if LineStyleGlb = 0 then
      DrawStraight(X1, X2, Y)
    else
      DrawLine(X1, Y, X2, Y);
end; { DSC }

begin { DrawSquareC }
  if not Fill then
    begin
      DSC(X1, X2, Y1);
      DrawLineClipped(X2, Y1, X2, Y2);
      DSC(X1, X2, Y2);
      DrawLineClipped(X1, Y2, X1, Y1);
    end
  else
    for I := Y2 to Y1 do
      DSC(X1, X2, I);
end; { DrawSquareC }

procedure DrawSquare(X1, Y1, X2, Y2 : real; Fill : boolean);
var
  I, X1Loc, Y1Loc, X2Loc, Y2Loc : integer;
  DirectModeLoc : boolean;

procedure DS(X1, X2, Y : integer);
begin
  if LineStyleGlb = 0 then
    DrawStraight(X1, X2, Y)
  else
    DrawLine(X1, Y, X2, Y);
end; { DS }

procedure DSC(X1, X2, Y : integer);
begin
  if Clip(X1, Y, X2, Y) then
    DS(X1, X2, Y);
end; { DSC }

procedure DrawSqr(X1, Y1, X2, Y2 : integer; Fill : boolean);
var
  I : integer;
begin
  if not Fill then
    begin
      DS(X1, X2, Y1);
      DrawLine(X2, Y1, X2, Y2);
      DS(X1, X2, Y2);
      DrawLine(X1, Y2, X1, Y1);
    end
  else
    for I := Y1 to Y2 do
      DS(X1, X2, I);
end; { DrawSqr }

begin { DrawSquare }
  if DirectModeGlb then
    DrawSqr(trunc(X1), trunc(Y1), trunc(X2), trunc(Y2), Fill)
  else
    begin
      DirectModeLoc := DirectModeGlb;
      DirectModeGlb := true;
      X1Loc := WindowX(X1);
      Y1Loc := WindowY(Y1);
      X2Loc := WindowX(X2);
      Y2Loc := WindowY(Y2);
      if not Fill then
        begin
          DSC(X1Loc, X2Loc, Y1Loc);
          DrawLineClipped(X2Loc, Y1Loc, X2Loc, Y2Loc);
          DSC(X1Loc, X2Loc, Y2Loc);
          DrawLineClipped(X1Loc, Y2Loc, X1Loc, Y1Loc);
        end
      else
        for I := Y1Loc to Y2Loc do
          DSC(X1Loc, X2Loc, I);
      DirectModeGlb := DirectModeLoc;
    end;
end; { DrawSquare }

procedure DrawAscii(var X, Y : integer; Size, Ch : byte);
var
  X1Ref, X2Ref, Xpos, Ypos, Xstart, Ystart, Xend, Yend, Xx, Yy : integer;
  CharByte : byte;
begin
  X1Ref := X1RefGlb shl 3;
  X2Ref := X2RefGlb shl 3 + 7;
  for Ypos := 0 to 5 do
  begin
    CharByte := (CharSet[Ch, (7 - Ypos) shr 1] shr ((Ypos and 1) shl 2)) and $0F;
    for Xpos := 0 to 3 do
      if (CharByte shr (3 - Xpos)) and 1 <> 0 then
      begin
        Xstart := X + Xpos * Size;
        Xend := Xstart + Size - 1;
        Ystart := Y + 1 + (Ypos - 2) * Size;
        Yend := Ystart + Size - 1;
        if ClippingGlb then
        begin
          if Xstart < X1Ref then
            Xstart := X1Ref;
          if Xend > X2Ref then
            Xend := X2Ref;
          if Ystart < Y1RefGlb then
            Ystart := Y1RefGlb;
          if Yend > Y2RefGlb then
            Yend := Y2RefGlb;
        end;
        for Yy := Ystart to Yend do
          for Xx := Xstart to Xend do
            DP(Xx, Yy);
      end;
  end;
  X := X + Size * 6;
end; { DrawAscii }

procedure DrawText(X, Y, Scale : integer; Txt : WrkString);
var
  LineStyleLoc, Code, AsciiValue, StringLen,
  I, SymbolScale, SymbolCode : integer;
  DirectModeLoc : boolean;
begin
  DirectModeLoc := DirectModeGlb;
  DirectModeGlb := true;
  LineStyleLoc := LinestyleGlb;
  SetLineStyle(0);
  StringLen := Length(Txt);
  I := 1;
  while I <= StringLen do
  begin
    AsciiValue := Ord(Txt[I]);
    if AsciiValue = 27 then
      begin
        SymbolScale := Scale;
        I := I + 1;
        if I <= StringLen then
        begin
          Val(Txt[I], SymbolCode, Code);
          if (I + 2 <= StringLen) and (Ord(Txt[I + 1]) = 64) then
          begin
            Val(Txt[I + 2], SymbolScale, Code);
            I := I + 2;
          end;
          case SymbolCode of
            1   : DrawCross(X + SymbolScale, Y + Scale, SymbolScale);
            2   : DrawCrossDiag(X + SymbolScale, Y + Scale, SymbolScale);
            3,4 : DrawSquareC(X, Y + (SymbolScale shl 1) - 1,
                              X + (SymbolScale shl 1), Y - 1, (SymbolCode = 4));
            5   : begin
                    DrawDiamond(X + trunc(1.5 * SymbolScale),
                                Y + SymbolScale - 1, SymbolScale + 1);
                    X := X + SymbolScale;
                  end;
            6   : DrawWye(X + SymbolScale, Y + SymbolScale - 1, SymbolScale);
            7   : begin
                    DrawStar(X + SymbolScale shl 1, Y + SymbolScale - 1, SymbolScale);
                    X := X + SymbolScale shl 1;
                  end;
            8   : DrawCircleDirect(X + SymbolScale, Y + (SymbolScale shr 1),
                                   SymbolScale + 1, false);
          end;
          X := X + 3 * SymbolScale;
          SymbolScale := Scale;
        end;
      end
    else
      DrawAscii(X, Y, Scale, AsciiValue);
    I := I + 1;
  end;
  DirectModeGlb := DirectModeLoc;
  SetLineStyle(LineStyleLoc);
end; { DrawText }

procedure DrawTextW(X, Y : real; Scale : integer; Txt : WrkString);
begin
  if DirectModeGlb then
    DrawText(trunc(X), trunc(Y), Scale, Txt)
  else
    DrawText(WindowX(X), WindowY(Y), Scale, Txt);
end; { DrawTextW }

procedure DrawBorder;
var
  ClipLoc, DirectModeLoc : boolean;
  Xl1, Xl2 : integer;

procedure DrawHeaderBackground(Y1, Y2 : integer);
var
  I : integer;
begin
  for I := Y1 to Y2 do
    DrawStraight(Xl1, Xl2, I);
end; { DrawHeaderBackground }

procedure DrawHeader;
var
  Y1Hdr, Y2Hdr, Yl1, Yl2 : integer;
begin
  with Window[WindowNdxGlb] do
  begin
    if Drawn then
      if Top then
        begin
          ReDefineWindow(WindowNdxGlb, X1RefGlb, Y1RefGlb - HeaderSizeGlb,
                         X2RefGlb, Y2RefGlb);
          SelectWindow(WindowNdxGlb);
        end
      else
        begin
          ReDefineWindow(WindowNdxGlb, X1RefGlb, Y1RefGlb, X2RefGlb,
                         Y2RefGlb + HeaderSizeGlb);
          SelectWindow(WindowNdxGlb);
        end;
    if TopGlb then
      begin
        Yl1 := Y1RefGlb + HeaderSizeGlb;
        Yl2 := Y2RefGlb;
        Y1Hdr := Y1RefGlb;
        Y2Hdr := Y1RefGlb + HeaderSizeGlb - 1;
      end
    else
      begin
        Yl1 := Y1RefGlb;
        Yl2 := Y2RefGlb - HeaderSizeGlb;
        Y1Hdr := Y2RefGlb - HeaderSizeGlb + 1;
        Y2Hdr := Y2RefGlb;
      end;
    Top := TopGlb;
    ReDefineWindow(WindowNdxGlb, X1RefGlb, Yl1, X2RefGlb, Yl2);
    SelectWindow(WindowNdxGlb);
    DrawHeaderBackground(Y1Hdr, Y2Hdr);
    ColorGlb := 255 - ColorGlb;
    DrawText(Xl1 + 2 + (Xl2 - Xl1 - Length(Header) * 6) shr 1,
             Y1Hdr + 3, 1, Header);
    DrawSquare(Xl1, Y1Hdr, Xl2, Y2Hdr, false);
    ColorGlb := 255 - ColorGlb;
    DrawSquare(Xl1, Y1RefGlb, Xl2, Y2RefGlb, false);
    Drawn := true;
  end;
end; { DrawHeader }

begin { DrawBorder }
  DirectModeLoc := DirectModeGlb;
  DirectModeGlb := true;
  ClipLoc := ClippingGlb;
  ClippingGlb := false;
  Xl1 := X1RefGlb shl 3;
  Xl2 := X2RefGlb shl 3 + 7;
  with Window[WindowNdxGlb] do
    if ((HeaderGlb) and (Length(Header) > 0)) and (Y2 - Y1 > HeaderSizeGlb) and
       ((Length(Header) * 6) < abs(Xl2 - Xl1) - 4) then
      DrawHeader
    else
      begin
        Drawn := false;
        DrawSquare(Xl1, Y1RefGlb, Xl2, Y2RefGlb, false);
      end;
    DirectModeGlb := DirectModeLoc;
    ClippingGlb := ClipLoc;
end; { DrawBorder }

procedure HardCopy(Inverse : boolean; Mode : byte); { EPSON }
var
  I, J, Top : integer;
  ColorLoc, PrintByte : byte;

procedure DoLine(Top:integer);

function ConstructByte(J, I : integer) : byte;
const
  Bits : array[0..7] of byte = (128,64,32,16,8,4,2,1);
var
  CByte, K : byte;
begin
  I := I shl 3;
  CByte := 0;
  for K := 0 to Top do
    if PD(J, I + K) then
      CByte := CByte or Bits[K];
  ConstructByte := CByte;
end; { ConstructByte }

begin { DoLine }
  if Mode = 1 then
    Write(Lst, ^['L')
  else
    Write(Lst, ^['*', Chr(Mode));
  Write(Lst, Chr(Lo(XScreenMaxGlb + 1)), Chr(Hi(XScreenMaxGlb + 1)));
  for J := 0 to XScreenMaxGlb do
  begin
    PrintByte := ConstructByte(J, I);
    if Inverse then
      PrintByte := not PrintByte;
    Write(Lst, Chr(PrintByte));
  end;
  if Mode <> 4 then
    WriteLn(Lst);
end; { DoLine }

begin { HardCopy }
  Top := 7;
  ColorLoc := ColorGlb;
  ColorGlb := 255;
  Mode := Mode and 7;
  if (Mode = 5) or (Mode = 0) then
    Mode := 4;
  Write(Lst, ^['3'#24);
  for I := 0 to ((YMaxGlb + 1) shr 3) - 1 do
    DoLine(7);
  I := ((YMaxGlb + 1) shr 3);
  if (YMaxGlb + 1) and 7 <> 0 then
    DoLine((YMaxGlb + 1) and 7);
  WriteLn(Lst, ^['2');
  ColorGlb := ColorLoc;
end; { HardCopy }