ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/MISC/BGIHERC.ZIP/HERCULES.PAS

Pascal/Delphi Source File | 1989-05-31 | 9.4 KB | 459 lines

UNIT HERCULES;
{  February 21, 1989  Turbo Pascal .TPU source                          }
{  A collection of subroutines to mani[ulate the unique aspects of the  }
{  Hercules family of video cards.  These are all character mode or     }
{  InColor Card palette manipulation routines.  All mode changes        }
{  assume a 9x14 character matrix.                                      }

INTERFACE

uses
    dos;

type
   ArrayOfPal  = array[0..15] of byte;
   ArrayOfHPal = array[0..17] of byte;
   Font        = array[0..4095] of byte;
   ScrRec      = record
                   CHR : char;
                   ATR : byte;
                 end;
   FontMem     = array[0..11] of Font;
   AdapterType = (None,MDA,Herc102,Herc112,Herc222,CGA,EGAMono,EGAColor,
                  VGAMono,VGAColor,MCGAMono,MCGAColor);

var
   AttBits    : byte;
   PalBits    : byte;
   CursorBits : byte;


Procedure Set48K;
Procedure Set4K;
Procedure SetROM;
Procedure Write48K(Text : string; AttValue, XPos, YPos : integer);
Procedure SetNormalAtt;
Procedure SetAlternateAtt;
Procedure LoadPal(PalArray : ArrayOfPal);
Procedure EnableIPal;
Procedure DisableIPal;
Procedure InitCursor(Start, Stop, Color : integer);
Procedure InitOverStrike(Position, Color : integer);
Procedure InitUnderScore(Position, Color : integer);
Procedure ClearFonts;
Procedure ResetVid;
Procedure LoadHPAL;
Procedure LoadHFNT;
Function CheckVid : AdapterType;
Function LoadFontFile(FileName : string; StartType, Planes : integer) : integer;


IMPLEMENTATION


Procedure Set48K;

 begin
  port[$03B4] := $14;
  port[$03B5] := $5;
 end;


Procedure Set4K;

 begin
  port[$03B4] := $14;
  port[$03B5] := $1;
 end;


Procedure SetROM;

 begin
  port[$03B4] := $14;
  port[$03B5] := $0;
 end;


Procedure Write48K(Text : string; AttValue, XPos, YPos : integer);

 var
    i         : integer;
    ScrPtr    : integer;
    ScrollPtr : integer;
    Screen    : array[0..1999] of ScrRec absolute $B000:0;

 begin
  ScrPtr := ((XPos * 80) + YPos);
  For i := 1 to Length(Text) do
   begin
    if ScrPtr = 2000
     then
      begin
       For ScrollPtr := 0 to 1919 do
         Screen[ScrollPtr] := Screen[ScrollPtr + 80];
       ScrPtr := 1920;
       For ScrollPtr := 1920 to 1999 do
        begin
         Screen[ScrollPtr].CHR := ' ';
         Screen[ScrollPtr].ATR := Lo(AttValue);
        end;
      end;
    Screen[ScrPtr].CHR := Text[i];
    Screen[ScrPtr].ATR := Lo(AttValue);
    ScrPtr := ScrPtr + 1;
    port[$03B4] := $0E;
    port[$03B5] := Hi(ScrPtr);
    port[$03B4] := $0F;
    port[$03B5] := Lo(ScrPtr);
   end;
 end;


Procedure SetNormalAtt;

 begin
  AttBits := $20;
  port[$03B4] := $17;
  port[$03B5] := AttBits OR PalBits OR CursorBits;
 end;


Procedure SetAlternateAtt;

 begin
  AttBits := $00;
  port[$03B4] := $17;
  port[$03B5] := AttBits OR PalBits OR CursorBits;
 end;


Procedure LoadPal(PalArray : ArrayOfPal);

 var
    ResetByte : byte;
    i         : integer;

 begin
  port[$03B4] := $1C;
  ResetByte := port[$03B5];
  For i := 0 to 15 do
    port[$03B5] := PalArray[i];
 end;


Procedure EnableIPal;

 begin
  PalBits := $10;
  port[$03B4] := $17;
  port[$03B5] := AttBits OR PalBits OR CursorBits;
 end;


Procedure DisableIPal;

 begin
  PalBits := $00;
  port[$03B4] := $17;
  port[$03B5] := AttBits OR PalBits OR CursorBits;
 end;


Procedure InitCursor(Start, Stop, Color : integer);

 begin
  CursorBits := Lo(Color);
  port[$03B4] := $17;
  port[$03B5] := AttBits OR PalBits OR CursorBits;
  port[$03B4] := $0A;
  port[$03B5] := Lo(Start);
  port[$03B4] := $0B;
  port[$03B5] := Lo(Stop);
 end;


Procedure InitOverStrike(Position, Color : integer);

 begin
  port[$03B4] := $16;
  port[$03B5] := (Lo(Color) SHL 4) OR Position;
 end;


Procedure InitUnderScore(Position, Color : integer);

 begin
  port[$03B4] := $15;
  port[$03B5] := (Lo(Color) SHL 4) OR Position;
 end;


Procedure ClearFonts;

 var
    FontNo   : integer;
    ScanLine : integer;
    FontByte : FontMem absolute $B400:0;

 begin
  port[$03B4] := $18;
  port[$03B5] := $0F;
  For FontNo := 0 to 11 do
    For ScanLine := 0 to 4095 do
      FontByte[FontNo, ScanLine] := 0;
 end;


Procedure ResetVid;

 var
    i         : integer;
    BlankChar : ScrRec;
    Screen    : array[0..1999] of ScrRec;

 begin
  AttBits    := $20;
  PalBits    := $00;
  CursorBits := $07;
  SetROM;
  SetNormalAtt;
  DisableIPal;
  InitCursor(12, 13, 7);
  InitOverstrike(6, 7);
  InitUnderScore(13, 7);
  BlankChar.CHR := ' ';
  BlankChar.ATR := 0;
  For i := 0 to 1999 do
    Screen[i] := BlankChar;
 end;


function GetEnvironmentString(SearchString : string) : string;
    {-Return a string from the environment}
  type
    Env = array[0..32767] of Char;
  var
    EPtr : ^Env;
    EStr : string;
    EStrLen : Byte absolute EStr;
    Done : Boolean;
    SearchLen : Byte absolute SearchString;
    I : Word;
  begin
    GetEnvironmentString := '';
    if SearchString = '' then
      Exit;

    {force upper case}
    for I := 1 to SearchLen do
      SearchString[I] := Upcase(SearchString[I]);

    EPtr := Ptr(MemW[PrefixSeg:$2C], 0);
    I := 0;
    if SearchString[SearchLen] <> '=' then
      SearchString := SearchString+'=';
    Done := False;
    EStrLen := 0;
    repeat
      if EPtr^[I] = #0 then begin
        if EPtr^[Succ(I)] = #0 then begin
          Done := True;
          if SearchString = '==' then begin
            EStrLen := 0;
            Inc(I, 4);
            while EPtr^[I] <> #0 do begin
              Inc(EStrLen);
              EStr[EStrLen] := EPtr^[I];
              Inc(I);
            end;
            GetEnvironmentString := EStr;
          end;
        end;
        if Copy(EStr, 1, SearchLen) = SearchString then begin
          GetEnvironmentString := Copy(EStr, Succ(SearchLen), 255);
          Done := True;
        end;
        EStrLen := 0;
      end
      else begin
        Inc(EStrLen);
        EStr[EStrLen] := EPtr^[I];
      end;
      Inc(I);
    until Done;
  end;



Procedure LoadHPAL;

 var
    ResetByte : byte;
    i         : integer;
    HPAL      : string;
    ThePal    : ArrayOfHPal;
    PALFile   : file of ArrayOfHPal;

 begin
  HPAL := GetEnvironmentString('HPAL');
  If HPAL <> ''
   then
    begin
     assign(PALFile, HPAL);
     {$I-};
     reset(PALFile);
     {$I+};
     If IOResult = 0
      then
       begin
        read(PALFile, ThePal);
        port[$03B4] := $1C;
        ResetByte := port[$03B5];
        For i := 0 to 15 do
          port[$03B5] := ThePal[i];
        port[$03B4] := $17;
        port[$03B5] := ThePal[16];
        port[$03B4] := $15;
        port[$03B5] := ThePal[17];
       end;
    end;
 end;


Procedure LoadHFNT;

 var
    HFNT : string;
    dummy : integer;

 begin
  HFNT := GetEnvironmentString('HFNT');
  If HFNT <> ''
   then
    begin
     dummy := LoadFontFile(HFNT, 0, 0);
     Set4K;
    end;
 end;



Function WhichHerc : AdapterType;

var
   ReadPort      : byte;
   QueryLoop     : integer;
   RetraceToggle : integer;

begin
 RetraceToggle := 0;
 ReadPort := port[$03BA] AND $80;
 For QueryLoop := 1 to 10000 do
   If (port[$03BA] AND $80) <> ReadPort
    then
     begin
      ReadPort := port[$03BA] AND $80;
      RetraceToggle := RetraceToggle + 1;
     end;
 If RetraceToggle > 2
  then
   begin
    ReadPort := port[$03BA] AND $70;
    case ReadPort of
     $10 : WhichHerc := Herc112;
     $50 : WhichHerc := Herc222;
     else WhichHerc := Herc102;
    end
   end
  else WhichHerc := MDA;
end;


Function CheckVid : AdapterType;

var
   Code : Byte;
   Regs : Registers;

begin
 Regs.AH := $1A;
 Regs.AL := $00;
 Intr($10, Regs);
 If Regs.AL = $1A
  then
   begin
    case Regs.BL of
     $00 : CheckVid := None;
     $01 : If WhichHerc = MDA
            then CheckVid := MDA
            else CheckVid := WhichHerc;
     $02 : CheckVid := CGA;
     $04 : CheckVid := EGAColor;
     $05 : CheckVid := EGAMono;
     $07 : CheckVid := VGAMono;
     $08 : CheckVid := VGAColor;
     $0A,$0C : CheckVid := MCGAColor;
     $0B : CheckVid := MCGAMono;
     else CheckVid := CGA
    end
   end
  else
   begin
    Regs.AH := $12;
    Regs.BX := $10;
    Intr($10, Regs);
    If Regs.BX <> $10
     then
      begin
       Regs.AH := $12;
       Regs.BL := $10;
       Intr($10, Regs);
       If (Regs.BH = 0)
        then CheckVid := EGAColor
        else CheckVid := EGAMono;
       end
      else
       begin
        Intr($11, Regs);
        Code := (Regs.AL AND $30) SHR 4;
        case Code of
         1 : CheckVid := CGA;
         2 : CheckVid := CGA;
         3 : If WhichHerc = MDA
              then CheckVid := MDA
              else CheckVid := WhichHerc;
         else CheckVid := None;
        end
      end
    end;
end;


Function LoadFontFile(FileName : string; StartType, Planes : integer) : integer;

 var
    TheFile : File of Font;
    TheFont : FontMem absolute $B400:0;

 begin
  assign(TheFile, FileName);
  {$I-};
  reset(TheFile);
  {$I+};
  If IOResult = 0
   then
    begin
     port[$03BF] := 3;
     port[$03B4] := $18;
     port[$03B5] := (Lo(Planes) SHL 4) OR $F;
     Read(TheFile, TheFont[StartType]);
     close(TheFile);
     LoadFontFile := 0;
    end
   else
    LoadFontFile := IOResult;
 end;

END.