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

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

(********************************************************************)
(*                         GRAPHIX TOOLBOX 4.0                      *)
(*       Copyright (c) 1985, 87 by  Borland International, Inc.     *)
(*                                                                  *)
(*           Graphics module for IBM Color/Graphics Adapter         *)
(********************************************************************)

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.44;           { Aspect ratio for a true circle }
  ScreenSizeGlb  = 8191;           { Total size -1 of the screen in words }
  HardwareGrafBase : word = $B800; { Location of the hardware screen }
  XMaxGlb        = 79;             { Number of bytes -1 in one screen line }
  XScreenMaxGlb  = 639;            { Number of pixels -1 in one screen line }
  YMaxGlb        = 199;            { Number of lines -1 on the screen }
  IVStepGlb      = 2;              { Initial value of VStepGlb }
  MinForeground : word = 0;        { Lowest allowable foreground color }
  MaxForeground : word = 15;       { Highest allowable foreground color }
  MinBackground : word = 0;        { Lowest allowable background color }
  MaxBackground : word = 0;        { Highest allowable background color }
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 address of scanline Y }

procedure Error(ErrProc, ErrCode : integer);

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

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 character C at the position XTextGlb, YTextGlb }

procedure SetIBMPalette(PaletteNumber, Color : word);
{ Set up the palette registers on the IBM CGA }

procedure SetForegroundColor(Color : word);
{ Set the foreground color }

procedure SetBackgroundColor(Color : word);
{ Set the background color }

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
  GrafMode = $0006;   { BIOS Interrupt 10 AX register }

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

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

var
  Font          : GrfFont;
  DisplayType   : (IBMPCjr, IBMCGA, IBMEGA, NoDisplay);
  SaveStateGlb  : word;

function BaseAddress{(Y : word) : word};
{ Calculate address of scanline Y }
begin
  BaseAddress:=(Y and 1) shl 13 + (Y and -2) shl 5 + (Y and -2) shl 3;
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
  EquipFlag       : word;
  Info, EGASwitch : byte;
  HP              : boolean;
  Regs            : Registers;

begin
  HP := false;
  DisplayType := NoDisplay;
  with Regs do
  begin
    Intr($11, Regs);
    EquipFlag := AX;
    AH := $12;
    BL := $10;
    Intr($10, Regs);
    EGASwitch := CL;
    Info := BH;
  end;

  if Mem[$F000:$FFFE] = $FD then                             { PCjr }
    begin
      MinForeground := 0;        { Actually only 0 and 15 are valid }
      MaxForeground := 15;
      MinBackground := 0;
      MaxBackground := 15;
      DisplayType := IBMPCjr;
      HP := true;
    end
  else if ((EquipFlag and 52) in [0,16,32]) and (Info = 0) then
    begin                       { EGA present, active, and in color }
      MinForeground := 0;
      MaxForeground := 15;
      MinBackground := 0;
      MaxBackground := 15;
      DisplayType := IBMEGA;
      HP := true;
    end;
  if not HP then
    if ((EquipFlag and 48) in [16,32]) or                     { CGA }
       (((EquipFlag and 52) = 4) and           { EGA but not active }
       (EGASwitch in [4,5,10,11])) then               { EGA is mono }
      begin
        MinForeground := 0;
        MaxForeground := 15;
        MinBackground := 0;
        MaxBackground := 0;
        DisplayType := IBMCGA;
        HP := true;
      end;
    HardwarePresent := HP;
end; { HardwarePresent }

procedure AllocateRAMScreen;
{ Allocates the RAM screen and makes sure that
  ScreenGlb is on a segment (16 byte) boundary }
var
  BytePtr : ^byte;
begin
  New(ScreenGlb);
  while Ofs(ScreenGlb^) <> 0 do   { Make absolutely certain that ScreenGlb }
  begin                           { is on a segment (16 byte) boundary!    }
    Dispose(ScreenGlb);
    New(BytePtr);
    New(ScreenGlb);
  end;
end; { AllocateRAMScreen }

{$L GrafCGA.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
  Regs.AX := SaveStateGlb;
  Intr($10, Regs);
  GrafCharsOFF;
  GrafModeGlb := false;
end; { LeaveGraphic }

procedure SetIBMPalette{(PaletteNumber, Color : word)};
{ Set up the palette registers on the IBM CGA }
var
  Regs : Registers;
begin
  with Regs do
  begin
    if PaletteNumber <> 2 then
      begin
        AH := $0B;
        BL := Color;
        BH := PaletteNumber;
      end
    else
      begin
        AX := $1000;
        BL := 1;
        BH := Color;
      end;
    Intr($10, Regs);
  end;
end; { SetIBMPalette }

procedure SetForegroundColor{(Color : word)};
{ Set the foreground color }
begin
  case DisplayType of
    IBMPCjr : SetIBMPalette(1, 1 - (Color and 1));
    IBMCGA  : SetIBMPalette(0, Color);
    IBMEGA  : SetIBMPalette(2, Color);
  end;
  ForegroundColorGlb := Color;
end; { SetForegroundColor }

procedure SetBackgroundColor{(Color : word)};
{ Set the background color }
begin
  case DisplayType of
    IBMPCjr,
    IBMEGA  : SetIBMPalette(0, Color);
  end;
  if DisplayType = IBMEGA then
    SetIBMPalette(2, ForegroundColorGlb);
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
  Regs     : Registers;
  FontFile : file of GrfFont;
begin
  if not FontLoaded then
  begin
    Assign(FontFile, '8x8.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;
  SaveStateGlb := 10;
  Regs.AX := $0F00;
  Intr($10, Regs);
  if (Regs.AL < 4) or (SaveStateGlb = 10) then
    SaveStateGlb := Regs.AL;
  Regs.AX := GrafMode;
  Intr($10, Regs);
  SetForegroundColor(MaxForeground);
  if not GrafModeGlb then
    GrafCharsON;
  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 : integer)};
{ 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
  PicFile = file of ScreenType;
var
  Picture     : ScreenPointer;
  PictureFile : PicFile;
  IOErr       : boolean;

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

begin
  if FileName <> '' then
    begin
      IOErr := false;
      Picture := Ptr(GrafBase, 0);
      Assign(PictureFile, FileName);
      {$I-} Rewrite(PictureFile); {$I+}
      IOCheck;
      if not IOErr then
      begin
        {$I-} Write(PictureFile, Picture^); {$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
  PicFile = file of ScreenType;
var
  Picture     : ScreenPointer;
  PictureFile : PicFile;
begin
  if FileName <> '' then
    begin
      Picture := Ptr(GrafBase, 0);
      Assign(PictureFile, FileName);
      {$I-} Reset(PictureFile); {$I+}
      if IOresult <> 0 then
        Error(11, 5)
      else
        begin
          Read(PictureFile, Picture^);
          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 }