POINT Software Programming/PPROG1.ISO/pascal/visionix/vfontu.pas

Pascal/Delphi Source File | 1993-12-28 | 37.8 KB | 1,953 lines

{
 ════════════════════════════════════════════════════════════════════════════

 Visionix EGA/VGA Font Manipulation Unit (VFONT)
   Version 0.8
 Copyright 1991,92,93 Visionix
 ALL RIGHTS RESERVED

 ────────────────────────────────────────────────────────────────────────────

 Revision history in reverse chronological order:

 Initials  Date      Comment
 ────────  ────────  ────────────────────────────────────────────────────────

 jrt       11/02/93  Brought CGAPixelMap stuff from VBIOS,
                     made use VStringu.

 jrt       05/23/93  Maded VFontPut work in DPMI protected mode.

 mep       05/20/93  Added many new functions, such as font sets, textfile
                     font load/save, image file load/save, resolution scaling,
                     and alternate font sets.

 lpg       03/15/93  Added Source Documentation

 mep       02/11/93  Cleaned up code for beta release

 jrt       02/08/93  Sync with beta 0.12 release

 jrt       12/15/92  Updated to work in protected mode for BP 7.0

 jrt       12/07/92  Sync with beta 0.11 release

 jrt       11/25/92  Moved VFontVGAWidthSet to here from VCRT.
                     Wrote template for VFontDefaultLoad.
                     Rename VPutFont/VGetFont to VFontPut/VFontGet.

 jrt       11/21/92  Sync with beta 0.08

 jrt       09/01/92  First logged revision.

 ════════════════════════════════════════════════════════════════════════════
}

(*-

[TEXT]

<Overview>

The VFONTu unit implements functions to create and manage new text-mode
character sets.

The documentation for this unit will be enhanced in the next release.

<Interface>

-*)



Unit VFontu;

Interface

Uses

  DOS,
  VDOSHu,
{$IFNDEF OS2}
  VDPMIu,
  VEQUIPu,
{$ELSE}
  VVIOi,
{$ENDIF}
{$IFDEF DEBUG}
  VDebugu,
{$ENDIF}
  VTYPESu,
  VStringu,
  VGENu;

{────────────────────────────────────────────────────────────────────────────}

Const

  {------------}
  { Font Types }
  {------------}

  Font_Int1F    = 0; { INT $1F font }
  Font_Int43F   = 1; { INT $43 font }
  Font_EGA_8x14 = 2; { ROM 8x14 character font }
  Font_VGA_8x8  = 3; { ROM 8x8 double dot font }
  Font_DDH_8x8  = 4; { ROM 8x8 double dot high font }
  Font_AA_9x14  = 5; { ROM 9x14 alpha alternate font }
  Font_VGA_8x16 = 6; { ROM 8x16 font }
  Font_A_9x16   = 7; { ROM 9x16 alternate font }

Type

  TFontSet = RECORD

    ScanLines : BYTE;        { Number of elements per font }
    Width     : BYTE;        { Number of bits per element }
    FontPtr   : POINTER;     { Location of font table on vidcard }

    Table     : POINTER;     { Internal user font table }

  END;

  PFontSet = ^TFontSet;


  TCharPixelMap = Array[0..7] of BYTE;
  PCharPixelMap = ^TCharPixelMap;

  {----}


{────────────────────────────────────────────────────────────────────────────}

{--------------------------------}
{ Basic table to/from video card }
{--------------------------------}

Procedure VFontGet(               FontType       : BYTE;
                              Var ScanLines      : BYTE;
                              Var Table          : POINTER      );

Procedure VFontPut(               Index          : WORD;
                                  Count          : WORD;
                                  ScanLines      : BYTE;
                                  Table          : POINTER      );

{-----------}
{ Font Sets }
{-----------}

Procedure VFontSetNew(        Var FontSet        : TFontSet;
                                  Width          : BYTE;
                                  ScanLines      : BYTE         );

Procedure VFontSetGet(            FontType       : BYTE;
                              Var FontSet        : TFontSet     );

Procedure VFontSetPut(            FontSet        : TFontSet     );

Procedure VFontSetDispose(        FontSet        : TFontSet     );

Function  VFontSetIndex(          FontSet        : TFontSet;
                                  ASCII          : BYTE         ) : LONGINT;

Function  VFontSetIndexPtr(       FontSet        : TFontSet;
                                  ASCII          : BYTE         ) : POINTER;

{------}
{ File }
{------}

Procedure VFontGetImage(          Filename       : PathStr;
                              Var FontSet        : TFontSet     );

Procedure VFontGetNewImage(       Filename       : PathStr;
                              Var FontSet        : TFontSet     );

Procedure VFontPutImage(          Filename       : PathStr;
                                  FontSet        : TFontSet     );

Procedure VFontGetText(           Filename       : PathStr;
                                  StartChar      : BYTE;
                                  EndChar        : BYTE;
                                  OnBitChar      : CHAR;
                                  OffBitChar     : CHAR;
                              Var FontSet        : TFontSet     );

Procedure VFontPutText(           Filename       : PathStr;
                                  StartChar      : BYTE;
                                  EndChar        : BYTE;
                                  OnBitChar      : CHAR;
                                  OffBitChar     : CHAR;
                                  FontSet        : TFontSet     );

Procedure VFontMakePascal(        Filename       : PathStr;
                                  FontSet        : TFontSet;
                                  StartChar      : BYTE;
                                  EndChar        : WORD         );

{-----------}
{ ROM Fonts }
{-----------}

Procedure VFontROM8x16Load;

Procedure VFontROM8x14Load;

Procedure VFontROM8x8Load;

Procedure VFontDefaultLoad;

Procedure VFontVGAWidthSet(       CharWidth      : BYTE         );

{--------------}
{ Miscellanous }
{--------------}

Procedure VFontSetScale(          Source         : TFontSet;
                                  StartChar      : BYTE;
                                  EndChar        : WORD;
                              Var Target         : TFontSet     );

Procedure VFontAltPut(            Index          : BYTE;
                                  Count          : WORD;
                                  ScanLines      : BYTE;
                                  Table          : POINTER      );

Procedure VFontAltSetPut(         FontSet        : TFontSet     );



Function  GetCGAPixelMap( Ch : CHAR ) : PCharPixelMap;

{────────────────────────────────────────────────────────────────────────────}

Implementation

Const

  BPCParam : STRING[18] = 'SCANLINES';

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontGet(               FontType       : BYTE;
                              Var ScanLines      : BYTE;
                              Var Table          : POINTER      );

[PARAMETERS]

FontType    Requested font information for various modes (see interface).

              Font_Int1F    = 0; { INT $1F font }
              Font_Int43F   = 1; { INT $43 font }
              Font_EGA_8x14 = 2; { ROM 8x14 character font }
              Font_VGA_8x8  = 3; { ROM 8x8 double dot font }
              Font_DDH_8x8  = 4; { ROM 8x8 double dot high font }
              Font_AA_9x14  = 5; { ROM 9x14 alpha alternate font }
              Font_VGA_8x16 = 6; { ROM 8x16 font }
              Font_A_9x16   = 7; { ROM 9x16 alternate font }


[RETURNS]

ScanLines   Lines of on-screen font (not the requested font!).
Table       Location of requested font table.

[DESCRIPTION]

Requests font information for specified font modes.

[SEE-ALSO]

VFontPut

[EXAMPLE]

Uses CRT;
Var
  ScanLines : BYTE;
  Table     : POINTER;

BEGIN
  TextMode(co80); { make sure in 80x25 mode }
  VFontGet(Font_VGA_8x16, Scanlines, Table);

  { Scanlines = 16 and Table points to ROM 8x16 fonts }
END;

-*)

Procedure VFontGet(               FontType       : BYTE;
                              Var ScanLines      : BYTE;
                              Var Table          : POINTER      );

{$IFNDEF OS2}

Var

  P   : POINTER;
  BPC : BYTE;

BEGIN

  ASM

    MOV AH, 11h
    MOV AL, 30h
    MOV BH, FontType
    PUSH BP

    INT 10h
    MOV DX, BP
    POP BP

    MOV Byte( BPC ), CL
    MOV Word( P   ), DX
    MOV Word( P+2 ), ES

  END;

  Table := P;
  ScanLines:=BPC;

END;

{$ELSE}

BEGIN



  {!^!}

END;

{$ENDIF}


{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontPut(               Index          : WORD;
                                  Count          : WORD;
                                  ScanLines      : BYTE;
                                  Table          : POINTER      );

[PARAMETERS]

Index       ASCII character to start font update at
Count       number of characters to update
ScanLines   Scanlines in new font table.
Table       Pointer to new font table.

[RETURNS]

<none>

[DESCRIPTION]

Redefines the EGA/VGA font bitmap, starting at character "index" and
going for "count" characters.  "ScanLines" should the number of bytes
per character in the new font table (since each character is always
8-bits or pixels wide), and "table" should be a pointer to the
new font table information.

[SEE-ALSO]

VFontGet

[EXAMPLE]

Const

  Arrow : Array[0..15] of BYTE =
    ( $00, $00, $FC, $1C, $3C, $74, $E4, $E4,
      $74, $3C, $1C, $FC, $00, $00, $00, $00      );

BEGIN

  VFontPut( 181, 1, 16, @Arrow );

  { Makes ASCII #181 an arrow }

END;

-*)

(*
procedure showfont( fb : Pbytearray0; count : word );

var

  z,col,row : integer;
  S         : STRING;

begin

  for z:=1 to count do
  begin

    Debugwriteln('');
    debugwriteln('Character '+IntToStr(Z-1) );
    debugwriteln('');

    for row := 1 to 16 do
    begin

      S:='';

      for col := 7 downto 0 do
      begin

       if FB^[ (Pred(z)*16) + (Pred(row)) ] and (1 SHL COL) > 0 Then
         S := S + '#'
       Else
         S := S + '.';

      end;

      DebugWriteLn( S );
      WriteLn( S );

    end;

  end;

end;
*)

Procedure VFontPut(               Index          : WORD;
                                  Count          : WORD;
                                  ScanLines      : BYTE;
                                  Table          : POINTER      );


{$IFNDEF OS2}

Var

  P : POINTER;

  R : REGISTERS;

BEGIN

  P := Table;

  R.AH := $11;
  R.AL := $0;
  R.BH := ScanLines;
  R.BL := 0;
  R.CX := Count;
  R.DX := Index;
  R.ES := Seg( Table^ );
  R.BP := Ofs( Table^ );

  RefBuffIntr( rb_ESBP+rb_Down,
                $10,
                R,
                Table,
                ScanLines*Count );


END;

{$ELSE}

Var

  VFI      : TVioFontInfo;
  FB       : PByteArray0;
  Err      : WORD;
  CharSize : WORD;
  FontOfs  : WORD;


BEGIN

  {$IFDEF DEBUG}
    DebugWriteLn('    In VFontPut');
    DebugWriteLn('    Allocating a font buffer');
  {$ENDIF}

  { allocate a font buffer }

  New( FB );

  {$IFDEF DEBUG}
    DebugWriteLn('    Settings up the font into struct');
  {$ENDIF}

  { setup the Font info struct }

  VFI.CB       := 14;
  VFI.TheType  := VGFI_GETCURFONT;
  VFI.CellRows := 0;
  VFI.CellCols := 0;
  VFI.FontData := FB;
  VFI.CBData   := SizeOf( FB^ );

  { get the full font }

  {$IFDEF DEBUG}
    DebugWriteLn('    Cbdata = '+IntTostr(Vfi.cbdata) );
    DebugWriteLn('    Get the full font (VioGetFont)');
  {$ENDIF}

  Err := VioGetFont( @VFI, 0 );

  {$IFDEF DEBUG}
    DebugWriteLn('      (VioGetFont returned '+IntToStr(err)+')' );
  {$ENDIF}


  IF Err=0 Then
  BEGIN


    {$IFDEF DEBUG}
      DebugWriteLn('      VFI.CellRows = '+IntToStr(VFI.CellRows) );
      DebugWriteLn('      VFI.CellCols = '+IntToStr(VFI.CellCols) );
      DebugWriteLn('      VFI.CBData   = '+IntToStr(VFI.CBData  ) );
    {$ENDIF}


    { Validate that the incoming char size and }
    { the actual font size match.              }

    If (VFI.CellRows=ScanLines) Then
    BEGIN

      CharSize  := VFI.CellRows;

      FontOfs  := Index * CharSize;

      {$IFDEF DEBUG}
        DebugWriteLn('      Charsize = '+IntToStr(charsize) );
        DebugWriteLn('      fontofs  = '+IntToStr(fontofs)  );
      {$ENDIF}


      { copy our changes over }

      Move( Table^, FB^[FontOfs], Count * CharSize );

      { set the full font }

      VFI.TheType := 0;

      {$IFDEF DEBUG}
        DebugWriteLn('      Calling VioSetFont' );
      {$ENDIF}

      Err := VioSetFont( @VFI, 0 );

      {$IFDEF DEBUG}
        DebugWriteLn('      (VioSetFont returned '+IntToStr(err)+')' );
      {$ENDIF}

      { showfont( fb, 256  ); }

    END; { if font sizes match }

  END; { if err=0 }

END;

{$ENDIF}

{────────────────────────────────────────────────────────────────────────────}


Function  VFontNewTable(          ScanLines      : BYTE         ) : POINTER;

Var

  P : POINTER;

BEGIN

  If MaxAvail < (ScanLines * 256) Then
    P := NIL
  Else
  BEGIN

    GetMem(P, ScanLines * 256);
    FillChar(P^, ScanLines * 256, 0);

  END;

  VFontNewTable := P;

END;

{────────────────────────────────────────────────────────────────────────────}

Procedure VFontDisposeTable(  Var Table          : POINTER;
                                  ScanLines      : BYTE           );

BEGIN

  If Table = NIL Then
    Exit;

  FreeMem( Table, ScanLines * 256 );
  Table := NIL;

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontSetNew(        Var FontSet        : TFontSet;
                                  Width          : BYTE;
                                  ScanLines      : BYTE         );

[PARAMETERS]

FontSet     Fontlist information record.
Width       Width of each font (8 bits normally).
ScanLines   Number of lines (rows) per font (1..16).

[RETURNS]

<None>

[DESCRIPTION]

Creates a new font set (table).  This must be called before any calls to
the FontSet procedures.

Note that you do not need to call this if you are using VFontSetGet, because
that procedure calls this automatically.

Also remember to always VFontSetDispose your FontSet after this procedure
has been used.

[SEE-ALSO]

VFontSetDispose
VFontSetGet

[EXAMPLE]

Var fs : TFontSet;

BEGIN
  VFontSetNew( fs, 8, 16 );

  { table created for 8x16 fonts.. now, do your routines.. }

  VFontSetDispose( fs );
END;

-*)

Procedure VFontSetNew(        Var FontSet        : TFontSet;
                                  Width          : BYTE;
                                  ScanLines      : BYTE         );

BEGIN

  FontSet.Width     := Width;
  FontSet.ScanLines := Scanlines;
  FontSet.Table     := VFontNewTable( ScanLines );

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontSetGet(            FontType       : BYTE;
                              Var FontSet        : TFontSet     );

[PARAMETERS]

FontType    Requested font information for various modes (see interface).

[RETURNS]

FontSet     Fontlist information record.

[DESCRIPTION]

Initializes a FontSet with a ROM Font set.  This creates an internal
table with the fontlist.  Do not call VFontSetNew if this is being used.

Also, remember to use VFontSetDispose whenever this procedure is used.

[SEE-ALSO]

VFontSetNew
VFontSetPut

[EXAMPLE]

Var fs8 : TFontSet;

BEGIN
  TextMode(co80+font8x8);
  VFontROM8x8Load;
  VFontSetGet( fs8, Font_VGA_8x8 );

  { Your fontset now has the ROM 8x8 set loaded.. }

  VFontSetDispose( fs8 );
END;

-*)

Procedure VFontSetGet(            FontType       : BYTE;
                              Var FontSet        : TFontSet     );

BEGIN

  FillChar( FontSet, SizeOf(TFontSet), 0 );

  With FontSet Do
  BEGIN

    Width := 8;
    VFontGet( FontType, ScanLines, FontPtr );
    Table := VFontNewTable( ScanLines );
    Move( FontPtr^, Table^, ScanLines * 256 );

  END;

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontSetPut(            FontSet        : TFontSet     );

[PARAMETERS]

FontSet     Fontlist information record.

[RETURNS]

<none>

[DESCRIPTION]

Sends the whole set within FontSet to the video card font generator.
Typesetting is automatically allowed for whole set.

[SEE-ALSO]

VFontSetGet

[EXAMPLE]

Var fs16 : TFontSet;

BEGIN
  TextMode(co80);
  VFontROM8x16Load;
  VFontSetGet(Font_VGA_8x16, fs16);

  { ..here you can do whatever (ie. modifing the loaded table).. }

  VFontSetPut(fs16);
END;

-*)

Procedure VFontSetPut(            FontSet        : TFontSet     );

BEGIN

  VFontPut( 0, 256, FontSet.ScanLines, Addr(FontSet.Table^) );

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontSetDispose(        FontSet        : TFontSet     );

[PARAMETERS]

FontSet     Fontlist information record.

[RETURNS]

<none>

[DESCRIPTION]

Disposes a font set (table).  This must be called once you are done with
your FontSet calls to reclaim allocated memory.

Also remember to always VFontSetNew your FontSet before this procedure is
used!

[SEE-ALSO]

VFontSetNew

[EXAMPLE]

Var fs : TFontSet;

BEGIN
  TextMode(co80);
  VFontROM8x16Load;
  VFontSetGet( fs, Font_VGA_8x16 );

  { Your fontset now has the ROM 8x16 set loaded.. }

  VFontSetDispose( fs );
END;

-*)

Procedure VFontSetDispose(        FontSet        : TFontSet     );

BEGIN

  VFontDisposeTable( FontSet.Table, FontSet.ScanLines );

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Function  VFontSetIndex(          FontSet        : TFontSet;
                                  ASCII          : BYTE         ) : LONGINT;

[PARAMETERS]

FontSet     Fontlist information record.
ASCII       ASCII character number in table (0..255).

[RETURNS]

Index into table.

[DESCRIPTION]

Number of bytes indexed into fontset where the bitmap is located.

[SEE-ALSO]

VFontSetIndexPtr

[EXAMPLE]

-*)

Function  VFontSetIndex(          FontSet        : TFontSet;
                                  ASCII          : BYTE         ) : LONGINT;

BEGIN

  VFontSetIndex := FontSet.ScanLines * ASCII;  { !^! Width not used. }

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Function  VFontSetIndexPtr(       FontSet        : TFontSet;
                                  ASCII          : BYTE         ) : POINTER;

[PARAMETERS]

FontSet     Fontlist information record.
ASCII       ASCII character number in table (0..255).

[RETURNS]

Pointer index into table.

[DESCRIPTION]

Pointer to the index into fontset where the bitmap is located.

[SEE-ALSO]

VFontSetIndex

[EXAMPLE]

-*)

Function  VFontSetIndexPtr(       FontSet        : TFontSet;
                                  ASCII          : BYTE         ) : POINTER;

BEGIN

  VFontSetIndexPtr := PtrAdd( FontSet.Table, VFontSetIndex(FontSet, ASCII) );

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontGetImage(          Filename       : PathStr;
                              Var FontSet        : TFontSet     );

[PARAMETERS]

Filename    A valid filename to a font file.

[RETURNS]

FontSet     Fontlist information record.

[DESCRIPTION]

Loads an image file from disk into a fontset.  You must have allocated a new
FontSet BEFORE this procedure is called.  This procedure is good for
reloading already allocated FontSets.  If you want to allocate a new FontSet
from an image file, use VFontGetNewImage.

[SEE-ALSO]

VFontGetNewImage

[EXAMPLE]

-*)

Procedure VFontGetImage(          Filename       : PathStr;
                              Var FontSet        : TFontSet     );

Var

  FontF : FILE;

BEGIN

  If NOT FileExist(Filename) Then
    Exit;

  Assign(FontF, Filename);
  Reset(FontF, 1);
  BlockRead(FontF, FontSet.Table^, FontSet.ScanLines * 256);
  Close(FontF);

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontGetNewImage(       Filename       : PathStr;
                              Var FontSet        : TFontSet     );

[PARAMETERS]

Filename    A valid filename to a font file.

[RETURNS]

FontSet     Fontlist information record.

[DESCRIPTION]

Loads an image file from disk into a fontset.  This procedure allocates a
new table automatically - be careful not to allocate a fontset more than
once (ie. calling this procedure more than once per FontSet).

Remember, when using this procedure, to use VFontSetDispose.

[SEE-ALSO]

VFontGetImage
VFontSetDispose

[EXAMPLE]

-*)

Procedure VFontGetNewImage(       Filename       : PathStr;
                              Var FontSet        : TFontSet     );

Var

  FontF : FILE;

BEGIN

  If NOT FileExist(Filename) Then
    Exit;

  Assign(FontF, Filename);
  Reset(FontF, 1);

  FontSet.ScanLines := FileSize(FontF) DIV 256;

  VFontSetNew( FontSet, 8, FontSet.ScanLines );

  BlockRead(FontF, FontSet.Table^, FontSet.ScanLines * 256);
  Close(FontF);

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontPutImage(          Filename       : PathStr;
                                  FontSet        : TFontSet     );

[PARAMETERS]

Filename    A valid path and filename to create.
FontSet     Fontlist information record.

[RETURNS]

<none>

[DESCRIPTION]

Creates an image file using the specified FontSet.

[SEE-ALSO]

VFontGetImage
VFontGetNewImage

[EXAMPLE]

-*)

Procedure VFontPutImage(          Filename       : PathStr;
                                  FontSet        : TFontSet     );

Var

  FontF : FILE;

BEGIN

  If NOT FileExist(Filename) Then
    Exit;

  Assign(FontF, Filename);
  Rewrite(FontF, 1);
  BlockWrite(FontF, FontSet.Table^, FontSet.ScanLines * 256);
  Close(FontF);

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontGetText(           Filename       : PathStr;
                                  StartChar      : BYTE;
                                  EndChar        : BYTE;
                                  OnBitChar      : CHAR;
                                  OffBitChar     : CHAR;
                              Var FontSet        : TFontSet     );

[PARAMETERS]

Filename    A valid path and filename to create.
StartChar   Starting character to "overwrite" (0..255).
EndChar     Ending character to "overwrite" (0..255).
OnBitChar   Character in textfile to consider as an On-Bit in a font.
OffBitChar  Character in textfile to consider as an Off-Bit in a font.

[RETURNS]

FontSet     Fontlist information record.

[DESCRIPTION]

Loads a textfile into the specified range of the FontSet.  Loading will
overwrite any fonts within that region.

IMPORTANT: Even though the StartChar and EndChar might not include the whole
range of the FontSet, reading fonts will ALWAYS begin at the beginning of the
textfile - note that the first font in the text file might not be the
font you want as the "StartChar" in your FontSet.

[SEE-ALSO]

VFontPutText

[EXAMPLE]

-*)

Procedure VFontGetText(           Filename       : PathStr;
                                  StartChar      : BYTE;
                                  EndChar        : BYTE;
                                  OnBitChar      : CHAR;
                                  OffBitChar     : CHAR;
                              Var FontSet        : TFontSet     );

Var

  F       : FILE;
  Buf     : PCharDarray0;
  BufSize : LONGINT;
  BufPos  : LONGINT;

  BPCPos  : LONGINT;

  S       : STRING;
  P       : POINTER;
  Param   : STRING[2];

  OnFont  : WORD;
  OnLine  : BYTE;
  OnBit   : BYTE;

  {────────────────────────────────────────────────────────────────────────}

  Procedure IncFontPos;
  BEGIN
    If (OnBit > 0) Then
      Dec(OnBit)
    Else
    BEGIN
      OnBit := Pred(FontSet.Width);
      If (OnLine < FontSet.ScanLines) Then
        Inc(OnLine)
      Else
      BEGIN
        OnLine := 1;
        Inc(OnFont);
      END;
    END;
  END;

  {────────────────────────────────────────────────────────────────────────}

BEGIN

  {-----------------------------------}
  { Check for reserved bit characters }
  {-----------------------------------}

  If ( Pos(OnBitChar, BPCParam) <> 0 ) OR
     ( OnBitChar = '=' ) OR
     ( IsNum(OnBitChar) ) Then
    Exit;

  If ( Pos(OffBitChar, BPCParam) <> 0 ) OR
     ( OffBitChar = '=' ) OR
     ( IsNum(OffBitChar) ) Then
    Exit;

  {----------------}
  { Blockread file }
  {----------------}

  If NOT FileExist(Filename) Then
    Exit;

  Assign(F, Filename);
  Reset(F, 1);
  BufSize := FileSize(F);
  GetMem( Buf, BufSize );
  BlockRead( F, Buf^, BufSize );
  Close( F );

  {---------------}
  { Get ScanLines }
  {---------------}

  BPCPos := PosBufNoCase( BPCParam, Buf^, BufSize );
  If (BPCPos = -1) Then
    FontSet.ScanLines := 16
  Else
  BEGIN

    P := PtrAdd(Buf, BPCPos);
    S[0] := #0;
    S := ArrayToStr( P^, Byte(BPCParam[0])+3 );
    Param := GetParamData(S);
    If NOT IsNum(Param[2]) Then
      Param[0] := #1;
    FontSet.ScanLines := StrToInt(Param);

  END;

  {-----------------}
  { Create fontmaps }
  {-----------------}

  OnFont := StartChar;
  OnLine := 1;
  OnBit  := Pred(FontSet.Width);
  BufPos := 0;

  While ( BufPos <= BufSize ) AND
        ( (OnFont <= 255) OR
          (OnFont <= EndChar) ) Do
  BEGIN

    If (Buf^[BufPos] = OnBitChar) Then
    BEGIN

      TByteArray(FontSet.Table^)[(OnFont*FontSet.ScanLines)+OnLine] :=
        TByteArray(FontSet.Table^)[(OnFont*FontSet.ScanLines)+OnLine] OR CBitMapW[OnBit];
      IncFontPos;

    END
    Else
    If (Buf^[BufPos] = OffBitChar) Then
    BEGIN         { TByteArrayZ }

      TByteArray(FontSet.Table^)[(OnFont*FontSet.ScanLines)+OnLine] :=
        TByteArray(FontSet.Table^)[(OnFont*FontSet.ScanLines)+OnLine] AND NOT CBitMapW[OnBit];
      IncFontPos;

    END;

    Inc(BufPos);

  END;

  FreeMem( Buf, BufSize );

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontPutText(           Filename       : PathStr;
                                  StartChar      : BYTE;
                                  EndChar        : BYTE;
                                  OnBitChar      : CHAR;
                                  OffBitChar     : CHAR;
                                  FontSet        : TFontSet     );

[PARAMETERS]

Filename    A valid path and filename to create.
StartChar   Starting character to "overwrite" (0..255).
EndChar     Ending character to "overwrite" (0..255).
OnBitChar   Character in textfile to consider as an On-Bit in a font.
OffBitChar  Character in textfile to consider as an Off-Bit in a font.
FontSet     Fontlist information record.

[RETURNS]

<none>

[DESCRIPTION]

Creates a textfile with the specified range of the FontSet.  The layout
overwrite any fonts within that region.

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontPutText(           Filename       : PathStr;
                                  StartChar      : BYTE;
                                  EndChar        : BYTE;
                                  OnBitChar      : CHAR;
                                  OffBitChar     : CHAR;
                                  FontSet        : TFontSet     );

Var

  T       : TEXT;
  Z1,
  Z2,
  Z4      : INTEGER;
  S       : STRING;

BEGIN

  {-----------------------------------}
  { Check for reserved bit characters }
  {-----------------------------------}

  If ( Pos(OnBitChar, BPCParam) <> 0 ) OR
     ( OnBitChar = '=' ) OR
     ( IsNum(OnBitChar) ) Then
    Exit;

  If ( Pos(OffBitChar, BPCParam) <> 0 ) OR
     ( OffBitChar = '=' ) OR
     ( IsNum(OffBitChar) ) Then
    Exit;

  {------------}
  { Setup file }
  {------------}

  Assign(T, Filename);
  ReWrite(T);

  {----------------}
  { Write fontmaps }
  {----------------}

  WriteLn( T, BPCParam + '=' + IntToStr(FontSet.ScanLines) );

  For Z1 := StartChar to EndChar Do
  BEGIN

    WriteLn(T, '_', Pad('/'+IntToStr(Z1)+'\', 7, OnRight, '_') );

    For Z2 := 1 to FontSet.ScanLines Do
    BEGIN

      S[0] := #0;

      For Z4 := Pred(FontSet.Width) downto 0 Do
      BEGIN

        If (TByteArray(FontSet.Table^)[(Z1*FontSet.ScanLines)+Z2] AND CBitMapW[Z4]) <> 0 Then
          S := S + OnBitChar
        Else
          S := S + OffBitChar;

      END;

      Write(T, S);

      If (Z2 = 1) Then
        WriteLn(T, '\')
      Else
        WriteLn(T, '│');

    END;

  END;

  Flush(T);
  Close(T);

END;


{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontMakePascal(        Filename       : PathStr;
                                  FontSet        : TFontSet;
                                  StartChar      : BYTE;
                                  EndChar        : WORD         );

[PARAMETERS]

[RETURNS]

[DESCRIPTION]

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontMakePascal(        Filename       : PathStr;
                                  FontSet        : TFontSet;
                                  StartChar      : BYTE;
                                  EndChar        : WORD         );

Var

  T      : TEXT;
  OnFont : WORD;
  OnSL   : WORD;

BEGIN

  Assign ( T, MaskWildcards(Filename, '*.PAS') );
  Rewrite( T );

  WriteLn( T, 'Const' );
  WriteLn( T, '     Fonts : Array[0..',
           ( ( ( EndChar - StartChar ) + 1 ) * 16 ) - 1, '] of BYTE =' );

  Write  ( T, '               ( ' );

  For OnFont := StartChar to EndChar Do
  BEGIN

    For OnSL := 1 to FontSet.ScanLines Do
    BEGIN

      If OnSL = 9 Then
      BEGIN

        WriteLn( T );
        Write  ( T, '                 ' );

      END;

      Write(T, '$',
        ByteToHex(TByteArray(FontSet.Table^)[(OnFont*FontSet.ScanLines)+OnSL]) );

      If ( OnFont <> EndChar ) AND ( OnSL <> FontSet.ScanLines ) Then
        Write( T, ', ' );

    END;

    WriteLn( T );
    Write  ( T, '                 ' );

  END;

  WriteLn( T, ' );' );

  Close( T );

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontROM8x16Load;

[PARAMETERS]

[RETURNS]

[DESCRIPTION]

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontROM8x16Load;

{$IFNDEF OS2}

Assembler;
ASM

  MOV AH, $11
  MOV AL, $04
  MOV BL, 0

  INT $10

END;

{$ELSE}

BEGIN

  {!^!}

END;

{$ENDIF}


{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontROM8x14Load;

[PARAMETERS]

[RETURNS]

[DESCRIPTION]

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontROM8x14Load;

{$IFNDEF OS2}

Assembler;
ASM

  MOV  AH, $11
  MOV  AL, $01
  MOV  BL, 0

  INT  $10

END;

{$ELSE}

BEGIN

  {!^!}

END;

{$ENDIF}


{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontROM8x8Load;

[PARAMETERS]

[RETURNS]

[DESCRIPTION]

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontROM8x8Load;

{$IFNDEF OS2}

Assembler;
ASM

  MOV  AH, $11
  MOV  AL, $02
  MOV  BL, 0

  INT  $10

END;

{$ELSE}

BEGIN

  {!^!}

END;

{$ENDIF}


{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontDefaultLoad;

[PARAMETERS]

[RETURNS]

[DESCRIPTION]

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontDefaultLoad;

BEGIN

{

  If PrimaryConsoleIsVGA Then
  BEGIN

    If Rows50 Then
      VFontRom8x8Load
    Else
      VFontRom8x16Load;

  END
  ELSE
  If PrimaryConsoleisEGA Then
  BEGIN

    If Rows43 Then
      VFonrRom8x8Load
    Else
      VFontRom8x14Load;

  END;

}

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontVGAWidthSet(       CharWidth      : BYTE         );

[PARAMETERS]

[RETURNS]

[DESCRIPTION]

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontVGAWidthSet(       CharWidth      : BYTE     );

{$IFNDEF OS2}

Var

  R : REGISTERS;
  B : BYTE;

BEGIN

  If CharWidth in [8..9] Then
  BEGIN

    Case CharWidth Of

      8 :
      BEGIN

        B    := (Port[ $3CC ] and NOT(4+8));
        R.BX := $0001;

      END;

      9 :
      BEGIN

        B    := (Port[ $3CC ] and NOT(4+8)) or 4;
        R.BX := $0800;

      END;

    END;

    Port[ $3C2 ] := B;

    ASM CLI; END;

    PortW[ $3C4 ] := $0100;
    PortW[ $3C4 ] := $01 + R.BL SHL 8;
    PortW[ $3C4 ] := $0300;

    ASM STI; END;

    R.AX := $1000;
    R.BL := $13;
    R.ES := $0;
    R.DS := $0;

    Intr( $10, R );

  END;

END;

{$ELSE}

BEGIN

 {!^!}

END;

{$ENDIF}

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontSetScale(          Source         : TFontSet;
                                  StartChar      : BYTE;
                                  EndChar        : WORD;
                              Var Target         : TFontSet     );

[PARAMETERS]

[RETURNS]

[DESCRIPTION]

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontSetScale(          Source         : TFontSet;
                                  StartChar      : BYTE;
                                  EndChar        : WORD;
                              Var Target         : TFontSet     );

Var

  P1     : PByteArray; { Source table }
  P2     : PByteArray; { Target table }

  P1Loc  : WORD;       { Base location of source table }
  P2Loc  : WORD;       { Base location of target table }

  OnFont : BYTE;       { Current Font # (ASCII value) }
  OnSL   : BYTE;       { Current Scanline (element) }
  OnBit  : BYTE;       { Current Bit (in element) }

  SS     : BYTE;       { Source Scanlines }
  TS     : BYTE;       { Target Scanlines }
  SW     : BYTE;       { Source Width }
  TW     : BYTE;       { Target Width }

  L1     : BYTE;

  {────────────────────────────────────────────────────────────────────────}

  Function Scale( Var Pos, Max, NewMax : BYTE ) : BYTE;
  Var

    R : REAL;

  BEGIN

    R := (Pos * NewMax) / Max;

    Scale := Round( R );

  END;

  {────────────────────────────────────────────────────────────────────────}

BEGIN

  { Setup code macros }

  P1 := Source.Table;
  P2 := Target.Table;
  SS := Source.ScanLines;
  TS := Target.ScanLines;
  SW := Source.Width;
  TW := Target.Width;

  FillChar( P2^[StartChar * TS], (EndChar - StartChar) * TS, 0 );

  For OnFont := StartChar to EndChar Do
  BEGIN

    { setup locators }

    P1Loc := (SS * OnFont);
    P2Loc := (TS * OnFont);

    { erase target font }

    { now check scanlines }

    For OnSL := 1 to SS Do
    BEGIN

      { check Width }

      For OnBit := 0 to Pred(SW) Do
      BEGIN

        If (P1^[P1Loc + OnSL] AND CBitMapW[OnBit] <> 0) Then
        BEGIN

          L1 := Scale(OnSL, SS, TS);

        { turn bit on }

          P2^[P2Loc + L1] := P2^[P2Loc + L1] OR
            CBitMapW[Scale(OnBit, SW, TW)];

        END;

      END;

    END;

  END;

END;

{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontAltPut(            Index          : BYTE;
                                  Count          : WORD;
                                  ScanLines      : BYTE;
                                  Table          : POINTER      );

[PARAMETERS]

[RETURNS]

[DESCRIPTION]

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontAltPut(            Index          : BYTE;
                                  Count          : WORD;
                                  ScanLines      : BYTE;
                                  Table          : POINTER      );
{$IFNDEF OS2}

BEGIN

  ASM

   { Set alternate font map block }

    MOV  AX, 1100h
    MOV  BH, ScanLines
    MOV  BL, 1
    MOV  CX, Word( Count )
    MOV  DX, Word( Index )
    MOV  ES, Word( Table + 2 )
    PUSH BP
    MOV  BP, Word( Table )
    INT  10h
    POP  BP

   { Set intensity bit and palette register }


    MOV  AX, 1103h
    MOV  BL, 00000100b
    INT  10h

    MOV  AX, 1000h
    MOV  BX, 0712h
    INT  10h

  END;

END;

{$ELSE}

BEGIN

  {!^!}

END;

{$ENDIF}


{────────────────────────────────────────────────────────────────────────────}

(*-

[FUNCTION]

Procedure VFontAltSetPut(         FontSet        : TFontSet     );

[PARAMETERS]

[RETURNS]

[DESCRIPTION]

[SEE-ALSO]

[EXAMPLE]

-*)

Procedure VFontAltSetPut(         FontSet        : TFontSet     );

BEGIN

  VFontAltPut( 0, 256, FontSet.ScanLines, FontSet.Table );

END;

{────────────────────────────────────────────────────────────────────────────}

Function  GetCGAPixelMap( Ch : CHAR ) : PCharPixelMap;
BEGIN

  If Ch > #127 Then
    GetCGAPixelMap := NIL
  Else
    GetCGAPixelMap := Ptr( $FFA6, $E + ( Byte(Ch) SHL 3 ) );

END;

{────────────────────────────────────────────────────────────────────────────}
{────────────────────────────────────────────────────────────────────────────}
{────────────────────────────────────────────────────────────────────────────}

BEGIN
END.