QBasic & Borland Pascal & C/Delphi5.iso/Pascal/Samples/VGAFONT.ARJ/FONTFIND.PAS

Pascal/Delphi Source File | 1993-02-11 | 7.0 KB | 351 lines

program fontfind;

  USES
   TpString,TpCRT;


  Type
   ByteAry = Array [0..65519] of byte;
   ByteAryPtr = ^ByteAry;
   BytePtr = ^Byte;

  VAR
   F8x8  : array [0..255,0..7 ] of byte;
   F8x14 : array [0..255,0..13] of byte;
   F8x16 : array [0..255,0..15] of byte;



  (************************************************************************)

  VAR
   B : Array [0..255,0..31] of Byte absolute $A000:$0000;

   VIDEOBIOS : Array [0..$7fff] of byte absolute $C000:0;

  { Enable loading Software font }

  procedure EnaLoadFont; assembler;
  asm
               jmp @@0

   @@SeqParms:
               DW 0402h           { CPU writes only to map 2    }
               DW 0704h           { sequential addressing       }

   @@GCParms:  DW 0204h           { select map 2 for CPU reads  }
               DW 0005h           { disable odd-even addressing }
               DW 0006h           { map starts at A000:0000     }

      @@0:

               push ds

               push cs
               pop  ds

               cli
               mov       dx,3C4h  { Sequencer port address }
               mov       si,offset @@SeqParms
               mov       cx,2

      @@L01:   lodsw

               out       dx,ax
               loop      @@L01
               sti



               mov       dl,0CEh { DX := 3CEH (Graphics Controller port }

               mov       si,offset @@GCParms
               mov       cx,3

      @@L02:   lodsw
               out       dx,ax
               loop      @@L02

               pop ds
  end;



  { Restore back video buffer adressing after font load }

  procedure RestoreBack; assembler ;
  asm
                jmp @@0

    @@SeqParms:
                DW      0302h            { CPU writes to maps 0 and 1 }
                DW      0304h            { odd-even addressing }

    @@GCParms:  DW      0004h
                DW      1005h
                DW      0E06h            { Maps at start B800:0000 }

    @@0:                                 { Program the Sequencer }
                push ds
                push cs
                pop ds

                cli
                mov     dx,3C4h
                mov     si,offset @@SeqParms
                mov     cx,2

    @@L01:      lodsw

                out     dx,ax
                loop    @@L01
                sti



                mov     dl,0CEh

                mov     si,offset @@GCParms
                mov     cx,3

    @@L02:      lodsw
                out     dx,ax
                loop    @@L02

                pop     ds

  end;

  (************************************************************************)



  PROCEDURE GetFontPtr(N:Byte;var FPtr:Pointer;var FontPoints:Word;var ScreenRows:Byte);assembler;
  var Fp : Pointer;
  asm
       cld
       push  es
       push  bp
       mov   ax,1130h
       mov   bh,N
       int   10h
       mov   ax,bp
       pop   bp
       mov   word ptr Fp,ax
       mov   word ptr Fp[2],es
       pop   es

       les   di,ScreenRows
       mov   al,dl
       stosb
       les   di,FontPoints
       mov   ax,cx
       stosw

       les   di,FPtr
       mov   ax,word ptr Fp
       stosw
       mov   ax,word ptr Fp[2]
       stosw
  end;


  var
   BReport8x14L : BytePtr;
   BReport8x8L  : BytePtr;
   BReport8x8H  : BytePtr;
   BReport9x14H : BytePtr;
   BReport8x16  : BytePtr;
   BReport9x16  : BytePtr;


  Function Match(Src,Dest:BytePtr;Size:Word):Boolean;
  begin
   Match := True;
   While Size <> 0 do
    begin
     if Src^<>Dest^ then
       begin
        Match := False; Exit;
       end;
     inc(Src);
     inc(Dest);
     Dec(Size)
    end;
  end;


  PROCEDURE GetByHardware;
  var c,i : Byte;
  begin

   Textmode(3);

   { Get Font 8x8 }


   asm
    mov   ax,1112h
    mov   bl,0
    int   10h
   end;

   enaloadfont;
    For c := 0 to 255 do
     for i := 0 to 7 do
      begin
       F8x8[c,i] := B[c,i];
      end;
   restoreback;

   { Get Font 8x14 }

   asm
    mov   ax,1111h
    mov   bl,0
    int   10h
   end;

   enaloadfont;
    For c := 0 to 255 do
     for i := 0 to 13 do
      begin
       F8x14[c,i] := B[c,i];
      end;
   restoreback;

   { Get Font 8x16 }

   asm
    mov   ax,1114h
    mov   bl,0
    int   10h
   end;

   enaloadfont;
    For c := 0 to 255 do
     for i := 0 to 15 do
      begin
       F8x16[c,i] := B[c,i];
      end;
   restoreback;

  end;


  FUNCTION WhatIs(Dest:BytePtr):String;
  var S : String ;
  begin
   S := '';
   if MAtch(@F8x8 [  0,0],Dest,256*8)  then S := S + ' F8x8All' else
    if MAtch(@F8x8 [  0,0],Dest,128*8)  then S := S + ' F8x8Low';
   if MAtch(@F8x8 [128,0],Dest,128*8)  then S := S + ' F8x8High';

   if MAtch(@F8x14[  0,0],Dest,256*14) then S := S + ' F8x14All' else
    if MAtch(@F8x14[  0,0],Dest,128*14) then S := S + ' F8x14Low';
   if MAtch(@F8x14[128,0],Dest,128*14) then S := S + ' F8x14High';

   if MAtch(@F8x16[  0,0],Dest,256*16) then S := S + ' F8x16All' else
    if MAtch(@F8x16[  0,0],Dest,128*16) then S := S + ' F8x16Low';
   if MAtch(@F8x16[128,0],Dest,128*16) then S := S + ' F8x16High';

   if S = '' then S := ' nothing';
   WhatIs := '  Really it is :'+S;
  end;


  PROCEDURE ScanLetters8x16;
  var Src,Dst : BytePtr;
      C : Word ;
      S : String ;
  begin
   for C := 1 to 254 do
    begin
     Src := @F8x16[C];
     Dst := @VIDEOBIOS;
     S := '';
     while Dst <> Ptr($C000,$7ff0) do
      begin
       if Match(Src,Dst,16) then S := S+' '+HexW(Ofs(Dst^));
       Inc(Dst);
      end;
     Writeln('Char('+Hexb(C)+') found at '+S);
    end;
  end;


  PROCEDURE CheckIt;
  var C : Word;
  begin
   Writeln('VGA reports that font locations are:');
   writeln(' 8X14L:  at '+HexPtr(Breport8x14L)+WhatIs(Breport8x14L));
   writeln(' 8X8L :  at '+HexPtr(BReport8x8L) +WhatIs(Breport8x8L));
   writeln(' 8X8H :  at '+HexPtr(BReport8x8H) +WhatIs(Breport8x8H));
   writeln(' 9X14H:  at '+HexPtr(BReport9x14H)+WhatIs(Breport9x14H));
   writeln(' 8X16 :  at '+HexPtr(BReport8x16) +WhatIs(Breport8x16));
   writeln(' 9X16 :  at '+HexPtr(BReport9x16) +WhatIs(Breport9x16));


   {ScanLetters8x16;}


  end;



  PROCEDURE GetFonts;
  VAR N:Byte;
   FPtr:Pointer;
   FontPoints:Word;
   ScreenRows:Byte;
  begin
   GetFontPtr(2,FPtr,FontPoints,ScreenRows);
   BReport8x14L := FPtr;

   GetFontPtr(3,FPtr,FontPoints,ScreenRows);
   BReport8x8L := FPtr;

   GetFontPtr(4,FPtr,FontPoints,ScreenRows);
   BReport8x8H := FPtr;

   GetFontPtr(5,FPtr,FontPoints,ScreenRows);
   BReport9x14H := FPtr;

   GetFontPtr(6,FPtr,FontPoints,ScreenRows);
   BReport8x16 := FPtr;

   GetFontPtr(7,FPtr,FontPoints,ScreenRows);
   BReport9x16 := FPtr;
  end;






begin

 Writeln('VGA Font Locator. (C) 1993 by KoroSoft Pte Ltd. All rights reserved.'#13#10);

 GetFonts;
 GetByHardware;
 CheckIt;

{ Find8x8;
}

end.