Liren Large Software Subsidy 9/09.iso/l/l045/2.ddi/GRAFHGC.DVR

Text File | 1987-12-23 | 17.7 KB | 622 lines

(********************************************************************)
(*                         GRAPHIX TOOLBOX 4.0                      *)
(*       Copyright (c) 1985, 87 by  Borland International, Inc.     *)
(*                                                                  *)
(*         Graphics module for the Hercules Monochrome card         *)
(********************************************************************)

unit GDriver;

interface

{$I Float.inc}  { Determines what type Float means. }

uses
  Dos, Crt;

{$IFOPT N+}
type
  Float = Double; { 8 byte real, requires 8087 math chip }

{$ELSE}
type
  Float = real;   { 6 byte real, no math chip required }

{$ENDIF}

const
  MaxWorldsGlb = 4;
  MaxWindowsGlb = 16;
  MaxPiesGlb = 10;
  MaxPlotGlb = 100;
  StringSizeGlb = 80;
  HeaderSizeGlb = 10;
  RamScreenGlb : boolean = true;
  CharFile : string[StringSizeGlb] = '4x6.fon';
  MaxProcsGlb = 27;
  MaxErrsGlb = 7;
  AspectFactor  = 0.6667;          { Aspect ratio for a true circle          }
  ScreenSizeGlb = 16383;           { Total size in integers of the screen    }
  HardwareGrafBase : word = $B000; { Location of the hardware screen }
  XMaxGlb       = 89;              { Number of bytes -1 in one screen line   }
  XScreenMaxGlb = 719;             { Number of pixels -1 in one screen line  }
  YMaxGlb       = 349;             { Number of lines -1 on the screen        }
  IVStepGlb     = 5;               { Initial value of VStepGlb }
  VRowsGlb      = $58;             { Change to $57 if monitor loses horizontal hold }
  MinForeground : word = 1;        { Lowest allowable foreground color }
  MaxForeground : word = 1;        { Highest allowable foreground color }
  MinBackground : word = 0;        { Lowest allowable background color }
  MaxBackground : word = 0;        { Highest allowable background color }
  RamScreenInCard  : boolean = false;
  { Hercules: store RAM screen in the HGC's alternate bank?  Will interfere
    with some color cards if present -- see Hercules manual (sets 'Full' mode) }


type
  WrkString = string[StringSizeGlb];
  WrkStringPtr = ^WrkString;
  WorldType = record
                X1, Y1, X2, Y2 : Float;
              end;
  WindowType = record
                 X1, Y1, X2, Y2 : integer;
                 Header : WrkString;
                 Drawn, Top : boolean;
                 Size : word;
               end;
  Worlds = array[1..MaxWorldsGlb] of WorldType;
  Windows = array[1..MaxWindowsGlb] of WindowType;
  PlotArray = array[1..MaxPlotGlb, 1..2] of Float;
  Character = array[1..3] of byte;
  CharArray = array[32..126] of character;
  PieType = record
              Area : Float;
              Text : WrkString;
            end;
  PieArray = array[1..MaxPiesGlb] of PieType;
  BackgroundArray = array[0..7] of byte;
  LineStyleArray = array[0..7] of boolean;
  ScreenType        = array[0..ScreenSizeGlb] of word;
  ScreenPointer     = ^ScreenType;
  WindowStackRecord = record
                        W : WindowType;
                        Contents : ScreenPointer;
                      end;
  Stacks            = array[1..MaxWindowsGlb] of WindowStackRecord;

var
  X1WldGlb, X2WldGlb, Y1WldGlb, Y2WldGlb, AxGlb, AyGlb, BxGlb, ByGlb : Float;
  X1RefGlb, X2RefGlb, Y1RefGlb, Y2RefGlb : integer;
  LinestyleGlb, MaxWorldGlb, MaxWindowGlb, WindowNdxGlb, WorldNdxGlb : integer;
  X1Glb, X2Glb, Y1Glb, Y2Glb : integer;
  XTextGlb, YTextGlb, VStepGlb : integer;
  PieGlb, DirectModeGlb, ClippingGlb, AxisGlb, HatchGlb : boolean;
  MessageGlb, BrkGlb, HeaderGlb, TopGlb, GrafModeGlb : boolean;
  CntGlb, ColorGlb : byte;
  ErrCodeGlb : integer;
  LineStyleArrayGlb : LineStyleArray;
  ErrorProc : array[0..MaxProcsGlb] of WrkStringPtr;
  ErrorCode : array[0..MaxErrsGlb] of WrkStringPtr;
  PcGlb : string[40];
  AspectGlb : Float;
  GrafBase : word;
  World : Worlds;
  GrafWindow : Windows;
  CharSet : CharArray;
  ScreenGlb : ScreenPointer;
  Stack : Stacks;

function BaseAddress(Y : word) : word;
{ Calculate the address of scanline Y }

procedure Error(ErrProc, ErrCode : integer);

function HardwarePresent : boolean;
{ Test for the presence of a graphics card }

procedure HerculesMode(Mode : word); { 0 = Text, 1 = Graphics }

procedure AllocateRAMScreen;
{ Allocates the RAM screen and makes sure that
  ScreenGlb is on a segment (16 byte) boundary }

procedure LeaveGraphic;
{ Exit from graphics mode and clear the screen }

procedure DC(C : byte);
{ Draw the the character with ASCII code C at position (XTextGlb, YTextGlb). }

procedure SetForegroundColor(Color : word);

procedure SetBackgroundColor(Color : word);

procedure ClearScreen;
{ Clear the displayed screen }

procedure EnterGraphic;
{ Enter graphics mode }

procedure DP(X, Y : word);
{ Plot a pixel at (X, Y). }

function PD(X, Y : word) : boolean;
{ Return true if the color of the pixel at (X, Y) matches ColorGlb }

procedure SetBackground8(Background : BackgroundArray);
{ Fills the active display with the specified bit pattern }

procedure SetBackground(Byt : byte);
{ Determines the background pattern of the active window }

procedure DrawStraight(X1, X2, Y : word);
{ Draw a horizontal line from X1,Y to X2,Y }

procedure SaveScreen(FileName : WrkString);
{ Save the current screen on disk using FileName. }

procedure LoadScreen(FileName : WrkString);
{ Load screen from file FileName. }

procedure SwapScreen;
{ Exchanges the contents of the displayed
  screen with the contents of the RAM screen }

procedure CopyScreen;
{ Copies the active screen onto the inactive screen }

procedure InvertScreen;
{ Inverts the image on the active screen }

implementation

const
  FontLoaded         : boolean = false; { Has the font been loaded yet? }
  ForegroundColorGlb : word = 1;

type
  FontChar = array[0..13] of byte;
  GrfFont  = array[0..255] of FontChar;

var
  Font : GrfFont;

function BaseAddress{(Y : word) : word};
{ Calculate the address of scanline Y }
begin
  BaseAddress := (Y and 3) shl 13 + 90 * (Y shr 2);
end; { BaseAddress }

procedure Error{(ErrProc, ErrCode : integer)};
var
  XLoc, YLoc : integer;
  Ch : char;

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 BrkGlb then
    Halt
  else if MessageGlb then
    begin
      Write('.  Hit enter: ');
      repeat
        Ch := ReadKey;
      until (Ch = ^M) or (Ch = ^C);
      if Ch = ^C then
      begin
        LeaveGraphic;
        Halt;
      end;
      GotoXY(XLoc, YLoc);
    end;
end; { Error }

function HardwarePresent{ : boolean};
{ Test for the presence of a graphics card }
var
  Regs : Registers;

function HercPresent : boolean;
begin
  inline($BB/$00/$01/          {      MOV    BX,0100H             }
         $BA/$BA/$03/          {      MOV    DX,03BAH             }
         $EC/                  {      IN     AL,DX                }
         $88/$C4/              {      MOV    AH,AL                }
         $80/$E4/$80/          {      AND    AH,80H               }
         $B9/$40/$00/          { L3:  MOV    CX,0040H             }
         $EC/                  { L1:  IN     AL,DX                }
         $24/$80/              {      AND    AL,80H               }
         $38/$E0/              {      CMP    AL,AH                }
         $E1/$F9/              {      LOOPZ  L1                   }
         $75/$05/              {      JNZ    L2                   }
         $4B/                  {      DEC    BX                   }
         $75/$F1/              {      JNZ    L3                   }
         $EB/$33/              {      JMP    L4                   }
         $B8/$00/$B0/          { L2:  MOV    AX,B000H             }
         $8E/$C0/              {      MOV    ES,AX                }
         $E8/$11/$00/          {      CALL   L5                   }
         $75/$0B/              {      JNZ    L6                   }
         $B0/$01/              {      MOV    AL,01                }
         $BA/$BF/$03/          {      MOV    DX,03BFH             }
         $EE/                  {      OUT    DX,AL                }
         $E8/$06/$00/          {      CALL   L5                   }
         $74/$1E/              {      JZ     L4                   }
         $B0/$01/              { L6:  MOV    AL,01                }
         $EB/$1C/              {      JMP    L7                   }
         $26/$8A/$1E/$FF/$7F/  { L5:  MOV    BL,ES:[7FFFH]        }
         $26/$8A/$0E/$FF/$3F/  {      MOV    CL,ES:[3FFFH]        }
         $26/$FE/$06/$FF/$3F/  {      INC    BYTE PTR ES:[3FFFH]  }
         $26/$3A/$1E/$FF/$3F/  {      CMP    BL,ES:[3FFFH]        }
         $26/$88/$0E/$FF/$3F/  {      MOV    ES:[3FFFH],CL        }
         $C3/                  {      RET                         }
         $30/$C0);             { L4:  XOR    AL,AL                }
                               { L7:                              }

end; { HercPresent }

begin
  Intr($11, Regs);
  HardwarePresent := HercPresent and ((Regs.AX and 48) = 48);
end; { HardwarePresent }

procedure HerculesMode{(Mode : word)}; { 0=text, 1=graphics }
type
  ModeDescriptor = record
                     CRTMode : byte;
                     R6845   : array[0..11] of byte;
                   end;
const
  HercModes : array[0..1] of ModeDescriptor =
  ((CRTMode : 32; R6845 : ($61,$50,$52,$0F,$19,$06,$19,$19,$02,$0D,$0B,$0C)),
   (CRTMode : 2;  R6845 : ($35,$2D,$2E,$07,$5B,$02,$58,$58,$02,$03,$00,$00)));
  ScreenOn          = 8;
  IndexPort         = $3B4;
  DataPort          = $3B5;
  ControlPort       = $3B8;
  ConfigurationPort = $3BF;

var
  I : word;

begin
  Port[ConfigurationPort] := 1;
  Port[ControlPort] := HercModes[Mode].CRTMode;
  for I := 0 to 11 do
  begin
    Port[IndexPort] := I;
    Port[DataPort] := HercModes[Mode].R6845[I];
  end;
  Port[ControlPort] := HercModes[Mode].CRTMode or ScreenOn;
  if RAMScreenInCard then
    Port[ConfigurationPort] := 3;
end; { HerculesMode }

procedure AllocateRAMScreen;
{ Allocates the RAM screen and makes sure that
  ScreenGlb is on a segment (16 byte) boundary }
var
  Test : ^byte;
begin
  if RamScreenInCard then
    ScreenGlb := Ptr($B800, $0000)
  else
    begin
      New(ScreenGlb);
      while Ofs(ScreenGlb^) <> 0 do
      begin
        Dispose(ScreenGlb);
        New(Test);
        New(ScreenGlb);
      end;
    end;
end; { AllocateRAMScreen }

{$L GrafHGC.OBJ}
procedure DC{(C : byte)}; external;

procedure DP{(X, Y : word)}; external;

procedure SwapScreen; external;

procedure InvertScreen; external;

{$F+}
function WriteGrafChars(var F : TextRec) : integer;
{ Used to output graphics characters through the standard output channel. }
const
  BackSpace = #8;
  LineFeed  = #10;
  Return    = #13;
var
  I : integer;
begin
  with F do
    if Mode = fmOutput then
    begin
      if BufPos > BufEnd then
      begin
        for I := BufEnd to Pred(BufPos) do  { Flush the output buffer }
        begin
          case BufPtr^[I] of
            BackSpace : if XTextGlb > 1 then
                          DEC(XTextGlb);

            LineFeed  : if YTextGlb < 25 then
                          INC(YTextGlb);

            Return    : XTextGlb := 1;
          else
            DC(ORD(BufPtr^[I]));
            if XTextGlb < 80 then
              INC(XTextGlb);
          end; { case }
        end; { for }
      end;
      BufPos := BufEnd;
    end; { if }
  WriteGrafChars := 0;
end; { WriteGrafChars }

function GrafCharZero(var F : TextRec) : integer;
{ Called when standard output is opened and closed }
begin
  GrafCharZero := 0;
end; { GrafCharZero }
{$F-}

var
  OldOutput : Text; { Stores output I/O channel }

procedure GrafCharsON;
{ Redirects standard output to the WriteGrafChars function. }
begin
  Move(Output, OldOutput, SizeOf(Output));  { Save old output channel }
  with TextRec(Output) do
  begin
    OpenFunc:=@GrafCharZero;       { no open necessary }
    InOutFunc:=@WriteGrafChars;    { WriteGrafChars gets called for I/O }
    FlushFunc:=@WriteGrafChars;    { WriteGrafChars flushes automatically }
    CloseFunc:=@GrafCharZero;      { no close necessary }
    Name[0]:=#0;
  end;
end; { GrafCharsON }

procedure GrafCharsOFF;
{ Restores original output I/O channel }
begin
  Move(OldOutput, Output, SizeOf(OldOutput));
end; { GrafCharsOFF }

procedure LeaveGraphic;
{ Exit from graphics mode and clear the screen }
var
  Regs : Registers;
begin
  HerculesMode(0);
  ClrScr;
  GrafCharsOFF;
  GrafModeGlb := false;
end; { LeaveGraphic }

procedure SetForegroundColor{(Color : word)};
begin
  { No colors to choose }
end; { SetForegroundColor }

procedure SetBackgroundColor{(Color : word)};
begin
  { No colors to choose }
end; { SetBackgroundColor }

procedure ClearScreen;
{ Clear the displayed screen }
begin
  FillChar(Mem[GrafBase:0000], ScreenSizeGlb shl 1, 0);
end; { ClearScreen }

procedure EnterGraphic;
{ Enter graphics mode }
var
  FontFile : file of GrfFont;
begin
  if not FontLoaded then
  begin
    Assign(FontFile, '14x9.FON');
    {$I-} Reset(FontFile); {$I+}
    if IOresult=0 then
      begin
        Read(FontFile, Font);
        Close(FontFile);
      end
    else
      FillChar(Font, SizeOf(Font), 0);
    FontLoaded := true;
  end;
  HerculesMode(1);
  SetForegroundColor(MaxForeground);
  if not GrafModeGlb then
   GrafCharsON;
  ClearScreen;
  GrafModeGlb := true;
end; { EnterGraphic }

function PD{(X, Y : word) : boolean};
{ Return true if the color of the pixel at (X, Y) matches ColorGlb }
begin
  PD := (ColorGlb = 0) xor (Mem[GrafBase:BaseAddress(Y) + X shr 3]
                       and (128 shr (X and 7)) <> 0);
end; { PD }

procedure SetBackground8{(Background : BackgroundArray)};
{ Fills the active display with the specified bit pattern }
var
  I : word;
begin
  for I := Y1RefGlb to Y2RefGlb do
    FillChar(Mem[GrafBase:BaseAddress(I) + X1RefGlb], X2RefGlb - X1RefGlb+1,
             Background[I and 7]);
end; { SetBackground8 }

procedure SetBackground{(Byt : byte)};
{ Determines the background pattern of the active window }
var
  Bk : BackgroundArray;
begin
  FillChar(Bk, 8, Byt);
  SetBackground8(Bk);
end; { SetBackground }

procedure DrawStraight{(X1, X2, Y : word)};
{ Draw a horizontal line from X1,Y to X2,Y }
var
  I, X : word;
  DirectModeLoc : boolean;
begin
  if (not ((X1 < 0) or (X1 > XMaxGlb shl 3+7)) and not ((X2 < 0) or
     (X2 > XMaxGlb shl 3+7)) and ((Y >= 0) and (Y <= YMaxGlb))) then
  begin
    DirectModeLoc := DirectModeGlb;
    DirectModeGlb := true;
    if X1 > X2 then
    begin
      X := X1;
      X1 := X2;
      X2 := X;
    end;
    if X2-X1 < 16 then
      for X := X1 to X2 do
        DP(X, Y)
    else
      begin
        X1 := X1 + 8;
        for I := (X1 - 8) to (X1 and -8) do
          DP(I, Y);
        for I := (X2 and -8) to X2 do
          DP(I, Y);
        FillChar(Mem[GrafBase:BaseAddress(Y) + (X1 shr 3)],
                (X2 shr 3) - (X1 shr 3), ColorGlb);
      end;
    DirectModeGlb := DirectModeLoc;
  end
end; { DrawStraight }

procedure SaveScreen{(FileName : WrkString)};
{ Save the current screen on disk using FileName. }
type
  Sector = array[0..127] of byte;
  SecScreen = array[0..255] of sector;
var
  PictureFile : file of Sector;
  Pic : ^SecScreen;
  I : word;
  IOErr : boolean;

procedure IOCheck;
begin
  IOErr := IOResult <> 0;
  if IOErr then
    Error(27, 5);
end; { IOCheck }

begin
  if FileName <> '' then
    begin
      IOErr := false;
      Pic := Ptr(GrafBase, 0);
      Assign(PictureFile, FileName);
      {$I-}
      Rewrite(PictureFile);
      {$I+}
      IOCheck;
      for I := 0 to 255 do
        if not IOErr then
        begin
          {$I-}
          Write(PictureFile, Pic^[I]);
          {$I+}
          IOCheck;
        end;
      if not IOErr then
      begin
        {$I-}
        Close(PictureFile);
        {$I+}
        IOCheck;
      end;
    end
  else
    Error(27, 5);
end; { SaveScreen }

procedure LoadScreen{(FileName : WrkString)};
{ Load screen from file FileName. }
type
  Sector = array[0..127] of byte;
  SecScreen = array[0..255] of Sector;
var
  PictureFile : file of Sector;
  Pic : ^SecScreen;
  I : word;
begin
  if FileName <> '' then
    begin
      Pic := Ptr(GrafBase, 0);
      Assign(PictureFile, FileName);
      {$I-}
      Reset(PictureFile);
      {$I+}
      if IOResult <> 0 then
        Error(11, 5)
      else
        begin
          for I := 0 to 255 do
            Read(PictureFile, Pic^[I]);
          Close(PictureFile);
        end;
    end
  else
    Error(11, 5);
end; { LoadScreen }

procedure CopyScreen;
{ Copies the active screen onto the inactive screen }
var
  ToBase : word;
begin
  if RamScreenGlb then
  begin
    if GrafBase = HardwareGrafBase then
      ToBase := Seg(ScreenGlb^)
    else
      ToBase := HardwareGrafBase;
    Move(Mem[GrafBase:0000], Mem[ToBase:0000], ScreenSizeGlb shl 1);
  end;
end; { CopyScreen }

end. { GDriver }