{ GEMFONTU.PAS 1.00 (22 March 1993) (Borland Pascal 7.0, real) }
{ Copyright 1993 by Rufus S. Hendon.  All rights reserved. }
unit GEMFontU;
{==============================================================================
   This unit provides facilities for using GEM-format bitmap fonts in programs
that use BGI graphics.
   GEM fonts may be loaded from files during program execution or they may be
linked into the .EXE file.  (This requires converting the font to an .OBJ file
using BINOBJ and then creating a .TPU file following the same procedures as for
BGI drivers and fonts.)  GEM fonts are manipulated by identifiers, which have
the form of pointers.
   The same color setting and text settings that control the use of BGI fonts
also control the use of GEM fonts, with these differences:
   (1) The text settings for font and size are ignored.  GEM files are always
drawn at their native size.
   (2) Several directions in addition to the two available for BGI fonts can be
specified in a call to SetTextSettings.  These are:
       2 - Vertical, from top to bottom, rotated 90 degrees clockwise.  For
this direction, left justification means that the top (beginning) of the text
is at the current position, center justification means that half the text is
above the current position and half below, and right justification means that
the bottom (end) of the text is at the current position.
       3 - Horizontal, from right to left.  Right justification means that the
right end (beginning) of the text is at the current position, center justifica-
tion means that the text is centered at the current position, and left justifi-
cation means that the left end (end) of the text is at the current position.
       4 - Vertical, from top to bottom, without rotation.  The meaning of
justification is the same as for 2.  The "Vert" setting is interpreted as
applying to the horizontal positioning of the characters relative to the X
coordinate of the current position.  TopText causes the left edges of the
characters to be aligned at X.  CenterText causes the characters to be centered
at X.  BottomText causes the right edges of the characters to be aligned at X.
-------------------------------------------------------------------------------
 3/20/93 - 1.00.  Initial compilation.
==============================================================================}
interface
uses DOS;

type

  TWordArray0 = array[0..32766] of word;
  PWordArray0 = ^TWordArray0;

  TByteArray0 = array[0..65534] of byte;
  PByteArray0 = ^TByteArray0;

  TExtendedGEMFontHeader = record
    CharacterOffsetTablePtr: PWordArray0;  { Extended portion begins here }
    FontDataPtr: PByteArray0;
    AllocatedBytes: word;
    FontID: word;                          { True font header begins here }
    PointSize: word;
    FontName: array[0..31] of char;
    LowASCII: word;
    HighASCII: word;
    Top, Ascent, Half, Descent, Bottom: integer;
    WidestCharacterWidth: word;
    WidestCellWidth: word;
    LeftOffset: integer;
    RightOffset: integer;
    Thickness: word;
    UnderscoreThickness: word;
    LightTextMask: word;
    ItalicTextMask: word;
    Flags: word;
    HorizontalOffsetTableOffset: longint;
    CharacterOffsetTableOffset: longint;
    FontDataOffset: longint;
    SpanWidth: word;
    Height: word;
    NextFontOffset: longint
  end;
  PExtendedGEMFontHeader = ^TExtendedGEMFontHeader;

function GEMTextHeight(GEMFontID: pointer; TextString: string): word;
{ If GEMFontID is a valid identifier of a GEM font, this function returns the
  character height of TextString in pixels when drawn in font GEMFontID.  (The
  character height is identical with the cell height of the font.)  Otherwise
  the function returns 0.  (The function makes no use of TextString, since the
  cell height is an attribute of the font. TextString is included for symmetry
  with the TextHeight function.) }

function GEMTextWidth(GEMFontID: pointer; TextString: string): word;
{ If GEMFontID is a valid identifier of a GEM font, this function returns the
  width of TextString in pixels when drawn in font GEMFontID.  Otherwise it
  returns 0. }

function LoadGEMFont(FontFileName: PathStr; var Leading, ErrorCode: word):
  pointer;
{ This function loads a GEM font from file FontFileName, sets Leading to the
  cell height of the font and ErrorCode to 0, and returns an identifier for
  the font.  If, however, an error occurs during the attempt to load the font,
  the function returns nil with ErrorCode set to one of these codes:
     1 - The file is too large for LoadGEMFont to process.
     2 - There isn't enough heap memory to store the font.
     3 - The file doesn't contain a GEM font.                                 }

procedure OutGEMText(GEMFontID: pointer; TextString: string);
{ If GEMFontID is a valid identifier of a GEM font, TextString is drawn at the
  current position in that font.  The text is clipped at the boundaries of the
  screen.  The current position is updated only if the direction is horizontal
  and justification is left (if the direction is left to right) or right (if
  the direction is right to left).  However, if GEMFontID isn't a valid
  identifier, no action is taken. }

procedure OutGEMTextXY(GEMFontID: pointer; X, Y: integer; TextString: string);
{ Like OutGEMText,except that the text is drawn at position (X,Y) rather than
  the current position.  Also, the current position isn't updated under any
  circumstances. }

function RegisterGEMFont(LinkedGEMFontPtr: pointer; var Leading, ErrorCode:word): pointer;
{ LinkedGEMFontPtr is the address of the external name of a GEM font that was
  linked into the .EXE file from a unit.  The function returns an identifier
  for the font, sets Leading to the cell height of the font, and sets ErrorCode
  to 0.  However, if an error is detected, the function returns nil with
  Leading set to 0 and ErrorCode set to one of these codes:
     1 - LinkedGEMFontPtr is nil.
     2 - There isn't enough heap memory for the control information created by
         the function.
     3 - LinkedGEMFontPtr doesn't point to a GEM font.                        }

procedure UnloadGEMFont(var GEMFontID: pointer);
{ The GEM font identified by GEMFontID is removed from memory and GEMFontID is
  set to nil. }
{=============================================================================}
implementation
uses Graph;

const
  ExtensionBytes = 10;  { extra bytes needed for the font header extension }

{*****************************************************************************}
function GEMTextHeight(GEMFontID: pointer; TextString: string): word;
var
  FontHeaderPtr: PExtendedGEMFontHeader absolute GEMFontID;
begin { GEMTextHeight }
  if GEMFontID <> nil
    then GEMTextHeight := FontHeaderPtr^.Height
    else GEMTextHeight := 0
end; { GEMTextHeight }
{*****************************************************************************}
function GEMTextWidth(GEMFontID: pointer; TextString: string): word;
var
  FontHeaderPtr: PExtendedGEMFontHeader absolute GEMFontID;

  MinCode, MaxCode, Width: word;
  COTPtr: PWordArray0;
  StringPtr: pointer;
  SaveDS: word;
begin { GEMTextWidth }
  Width := 0;

  if GEMFontID <> nil then begin
    with FontHeaderPtr^ do begin
      MinCode := LowASCII;
      MaxCode := HighASCII;
      COTPtr := CharacterOffsetTablePtr
    end;
    StringPtr := @TextString;
    asm
      mov SaveDS,ds            { Save DS in SaveDS                            }
      lds si,StringPtr         { Set DS:SI to @TextString[0]                  }
      mov cl,[si]              { Set CX to Length(TextString)                 }
      xor ch,ch                {                                              }
      jcxz @3                  { If CX = 0, skip to @3                        }
      mov ah,byte ptr MaxCode  { Otherwise set AH to MaxCode, AL to MinCode   }
      mov al,byte ptr MinCode  {                                              }
      les di,COTPtr            { Set ES:DI to point to the Character Offset   }
                               {   Table                                      }
      @1: inc si               { For each character of TextString:            }
      mov bl,[si]              {   Set BL to the character                    }
      cmp bl,al                {   If BL < Mincode or > MaxCode, do nothing   }
      jb @2                    {                                              }
      cmp bl,ah                {                                              }
      ja @2                    {                                              }
      sub bl,al                {   Otherwise reset BX to (BL-MinCode)*2 to    }
      xor bh,bh                {     index the Character Offset Table entry   }
      shl bx,1                 {     for the character                        }
      mov dx,es:[di+bx+2]      {   Set DX to the entry for the next higher    }
      sub dx,es:[di+bx]        {     character - the entry for this character }
                               {     = the width of this character            }
      add Width,dx             {   Add DX to Width                            }
      @2: loop @1              {                                              }
      @3: mov ds,SaveDS        { Restore DS from SaveDS                       }
    end
  end;

  GEMTextWidth := Width
end; { GEMTextWidth }
{****************************************************************************}
function LoadGEMFont(FontFileName: PathStr; var Leading, ErrorCode: word):
  pointer;
var
  FontFile: file;
  LongFileSize: longint;
  FontFileSize, AllocationSize: word;
  FontPtr: PByteArray0;
  FontHeaderPtr: PExtendedGEMFontHeader absolute FontPtr;
  IsGEMFont: boolean;
  TrueFontHeaderSize: word;
begin { LoadGEMFont }
  Assign(FontFile,FontFileName);
  Reset(FontFile,1);

  LongFileSize := FileSize(FontFile);
  if LongFileSize > 65518  { 65528-ExtensionBytes }
    then begin
      ErrorCode := 1;
      LoadGEMFont := nil
    end
  else begin
    FontFileSize := LongFileSize;
    AllocationSize := ExtensionBytes+FontFileSize
  end;

  if AllocationSize > MaxAvail
    then begin
      ErrorCode := 2;
      LoadGEMFont := nil
    end
    else GetMem(FontPtr,AllocationSize);

  BlockRead(FontFile,FontPtr^[ExtensionBytes],FontFileSize);
  Close(FontFile);

  IsGEMFont := True;
  TrueFontHeaderSize := SizeOf(TExtendedGEMFontHeader)-ExtensionBytes;
  with FontHeaderPtr^ do begin
    if (LowASCII > 255) or (HighASCII > 255) or (LowASCII > HighASCII)
      then IsGEMFont := False
      else if WidestCharacterWidth > WidestCellWidth
        then IsGEMFont := False
          else if (HorizontalOffsetTableOffset <> 0) and
              ((HorizontalOffsetTableOffset < (TrueFontHeaderSize-4))
              or (HorizontalOffsetTableOffset > FontFileSize))
            then IsGEMFont := False
            else if (CharacterOffsetTableOffset < (TrueFontHeaderSize-4)) or
              (CharacterOffsetTableOffset > FontFileSize)
            then IsGEMFont := False
            else if (FontDataOffset < CharacterOffsetTableOffset) or
                (FontDataOffset > FontFileSize)
              then IsGEMFont := False
  end; { with ... }
  if not IsGEMFont
    then begin
      FreeMem(FontPtr,AllocationSize);
      ErrorCode := 3;
      Leading := 0;
      LoadGEMFont := nil
    end
    else with FontHeaderPtr^ do begin
      AllocatedBytes := AllocationSize;
      CharacterOffsetTablePtr := @FontPtr^[CharacterOffsetTableOffset+
          ExtensionBytes];
      FontDataPtr := @FontPtr^[FontDataOffset+ExtensionBytes];
      Leading := Height;
      ErrorCode := 0;
      LoadGEMFont := FontPtr
    end
end; { LoadGEMFont }
{*****************************************************************************}
(*
procedure DrawGEMText(GEMFontID: pointer; X, Y: integer; var TextString:
  string; UpdateCP: boolean);
var
  FontPtr: PByteArray0 absolute GEMFontID;
  FontHeaderPtr: PExtendedGEMFontHeader absolute GEMFontID;

  CellHeight, CellHeightLess1, MinCode, MaxCode: word;
  COTPtr: PWordArray0;
  StrikePtr: PByteArray0;
  RowInterval: word;
  TextSettings: TextSettingsType;
  Width: word;
  OriginalY, MaxX, MaxY: integer;
  Color, I: word;
  Ch: char;
  Code, PatternOffset, PatternWidth, PatternWidthLess1, ByteIndex: word;
  Mask: byte;
  Col, RowIndex, Row: integer;
  RowByte: byte;
begin { DrawGEMText }
  if GEMFontID = nil then Exit;

  with FontHeaderPtr^ do begin
    CellHeight := Height;
    MinCode := LowASCII;
    MaxCode := HighASCII;
    COTPtr := CharacterOffsetTablePtr;
    StrikePtr := FontDataPtr;
    RowInterval := SpanWidth
  end; { with FontHeaderPtr^ ... }

  GetTextSettings(TextSettings);
  with TextSettings do begin
    if (Direction <> HorizDir) or (Horiz <> LeftText)
      then UpdateCP := False;
    if Horiz <> LeftText then begin
      Width := GEMTextWidth(GEMFontID,TextString);
      if Horiz = CenterText
        then X := X-Width div 2
        else if Horiz = RightText
          then X := Succ(X-Width)
    end;
    OriginalY := Y;
    case Vert of
      BottomText:  Y := Succ(Y-CellHeight);
      CenterText:  Y := Y-CellHeight div 2;
      TopText: { leave Y as is };
    end
  end; { with TextSettings ... }

  MaxX := GetMaxX;
  MaxY := GetMaxY;
  Color := GetColor;

  if Y+Pred(CellHeight) > MaxY        { to clip at the bottom of the screen }
    then CellHeight := Succ(MaxY-Y);  { if necessary                        }

  CellHeightLess1 := Pred(CellHeight);

  for I := 1 to Length(TextString) do begin
    Ch := TextString[I];
    Code := Ord(Ch);
    if (Code < MinCode) or (Code > MaxCode)

      then  { don't do anything }

      else begin  { valid character code }
        Code := Code-MinCode;
        PatternOffset := COTPtr^[Code];
        PatternWidth := COTPtr^[Succ(Code)]-PatternOffset;

        if PatternWidth = 0

          then  { undefined character -- don't do anything }

          else begin  { defined character }
            PatternWidthLess1 := Pred(PatternWidth);
            if X+PatternWidthLess1 > MaxX then begin  { clip at the right  }
              PatternWidth := Succ(MaxX-X);           { edge of the screen }
              PatternWidthLess1 := Pred(PatternWidth) { if necessary       }
            end;
            ByteIndex := PatternOffset div 8;
            Mask := $80 shr (PatternOffset mod 8);
            for Col := X to X+PatternWidthLess1 do begin
              if Col >= 0 then begin  { clip at the left edge of the screen }
                RowIndex := ByteIndex;
                for Row := Y to Y+CellHeightLess1 do begin
                  RowByte := StrikePtr^[RowIndex];
                  if (RowByte and Mask) = Mask
                    then PutPixel(Col,Row,Color);
                  Inc(RowIndex,RowInterval)
                end { for Row ... }
              end;
              if Mask = $01
                then begin
                  Inc(ByteIndex);
                  Mask := $80
                end
                else Mask := Mask shr 1
            end; { for Col ... }
            Inc(X,PatternWidth);
            if X > MaxX then Break
          end  { defined character }

      end  { valid character code }

  end; { for I ... }

  if UpdateCP then begin
    if X <= MaxX
      then MoveTo(X,OriginalY)
      else MoveTo(MaxX,OriginalY) { Programmer's Reference doesn't specify   }
                                  { what OutText does in this case, so this  }
                                  { is arbitrary!                            }
  end
end; { DrawGEMText }
*)
{*****************************************************************************}
procedure DrawGEMText0(GEMFontID: pointer; X, Y: integer; var TextString:
  string; var TextSettings: TextSettingsType; UpdateCP: boolean);
var
  FontPtr: PByteArray0 absolute GEMFontID;
  FontHeaderPtr: PExtendedGEMFontHeader absolute GEMFontID;

  CellHeight, MinCode, MaxCode: word;
  COTPtr: PWordArray0;
  StrikePtr: PByteArray0;
  RowInterval: word;
  Width: word;
  OriginalY, MaxX, MaxY: integer;
  Color: word;
  PatternOffset, PatternWidth, ByteIndex: word;
  Mask: byte;
  Col, RowIndex, Row: integer;

  TextStringPtr: pointer;
  SaveDS, TextStringCX, ColCX, RowCX: word;
  MinMax: word;
begin { DrawGEMText0 }
  with FontHeaderPtr^ do begin
    CellHeight := Height;
    MinCode := LowASCII;
    MaxCode := HighASCII;
    COTPtr := CharacterOffsetTablePtr;
    StrikePtr := FontDataPtr;
    RowInterval := SpanWidth
  end; { with FontHeaderPtr^ ... }

  with TextSettings do begin
    if (Direction <> HorizDir) or (Horiz <> LeftText)
      then UpdateCP := False;
    if Horiz <> LeftText then begin
      Width := GEMTextWidth(GEMFontID,TextString);
      if Horiz = CenterText
        then X := X-Width div 2
        else if Horiz = RightText
          then X := Succ(X-Width)
    end;
    OriginalY := Y;
    case Vert of
      BottomText: Y := Succ(Y-CellHeight);
      CenterText: Y := Y-CellHeight div 2;
      TopText: { leave Y as is };
    end
  end; { with TextSettings ... }

  MaxX := GetMaxX;
  MaxY := GetMaxY;
  Color := GetColor;

  if Y+Pred(CellHeight) > MaxY        { to clip at the bottom of the screen }
    then CellHeight := Succ(MaxY-Y);  { if necessary                        }

  TextStringPtr := @TextString;

  asm
    mov SaveDS,ds
    mov al,byte ptr MinCode
    mov ah,byte ptr MaxCode
    mov MinMax,ax
    lds si,TextStringPtr
    mov cl,[si]
    xor ch,ch
    test cx,cx
    jnz @NextCh
    jmp @ResetDS

    @NextCh: mov TextStringCX,cx
    lds si,TextStringPtr
    inc si
    mov word ptr TextStringPtr,si
    mov bl,[si]
    mov ax,MinMax
    cmp bl,al
    jb @StepCh
    cmp bl,ah
    ja @StepCh
    xor bh,bh
    sub bl,al
    shl bx,1
    lds si,COTPtr
    mov ax,[si+bx]
    mov PatternOffset,ax
    mov bx,[si+bx+2]
    sub bx,ax
    mov PatternWidth,bx
    mov cx,ax
    shr ax,1
    shr ax,1
    shr ax,1
    mov ByteIndex,ax  { PatternOffset div 8 }
    mov al,$80
    and cx,$07
    shr al,cl
    mov Mask,al  { $80 shr (PatternOffset mod 8) }
    mov ax,X
    add ax,bx
    dec ax  { X+PatternWidth-1 }
    cmp ax,MaxX
    jle @XOK

    mov ax,MaxX
    sub ax,X
    inc ax
    mov PatternWidth,ax  { MaxX-X+1 }

    @XOK: mov si,X  { Col }
    mov ah,Mask
    mov cx,PatternWidth
    mov ds,SaveDS  { for PutPixel }

    @ColLoop: mov ColCX,cx
    test si,si
    jl @ShiftMask
    mov bx,ByteIndex
    mov dx,Y  { Row }
    les di,StrikePtr
    mov cx,CellHeight

    @RowLoop: mov al,es:[di+bx]
    and al,ah
    jz @StepRow

    mov Mask,ah  { save AH, BX, CX, DX, SI }
    mov RowIndex,bx
    mov RowCX,cx
    mov Row,dx
    mov Col,si
    push si  { PutPixel(Col,Row,Color); }
    push dx
    mov ax,Color
    push ax
    call PutPixel
    mov ah,Mask  { restore AH, BX, CX, DX, SI }
    mov bx,RowIndex
    mov cx,RowCX
    mov dx,Row
    mov si,Col
    les di,StrikePtr  { reset ES:DI }

    @StepRow: add bx,RowInterval
    inc dx
    loop @RowLoop

    @ShiftMask: shr ah,1
    jnz @StepCol
    inc ByteIndex
    mov ah,$80
    @StepCol: inc si
    mov cx,ColCX
    loop @ColLoop

    mov ax,X
    add ax,PatternWidth
    cmp ax,MaxX
    jg @ResetDS
    mov X,ax
    @StepCh: mov cx,TextStringCX
    loop @StepCh1
    jmp @ResetDS
    @StepCh1: jmp @NextCh

    @ResetDS: mov ds,SaveDS
  end;

  if UpdateCP then begin
    if X < 0
      then X := 0
      else if X > MaxX
        then X := MaxX;
    MoveTo(X,OriginalY)
  end
end; { DrawGEMText0 }
{*****************************************************************************}
procedure DrawGEMText1(GEMFontID: pointer; X, Y: integer; var TextString:
  string; var TextSettings: TextSettingsType);
{ For Direction = VertDir (vertical, bottom up, rotated 90 degrees counter-
  clockwise). }
var
  FontPtr: PByteArray0 absolute GEMFontID;
  FontHeaderPtr: PExtendedGEMFontHeader absolute GEMFontID;

  CellHeight, CellHeightLess1, MinCode, MaxCode: word;
  COTPtr: PWordArray0;
  StrikePtr: PByteArray0;
  RowInterval: word;
  Width: word;
  MaxX, MaxY: integer;
  Color, I: word;
  Ch: char;
  Code, PatternOffset, PatternWidth, PatternWidthLess1, ByteIndex: word;
  Mask: byte;
  Col, RowIndex, Row: integer;
  RowByte: byte;
begin { DrawGEMText1 }
  with FontHeaderPtr^ do begin
    CellHeight := Height;
    MinCode := LowASCII;
    MaxCode := HighASCII;
    COTPtr := CharacterOffsetTablePtr;
    StrikePtr := FontDataPtr;
    RowInterval := SpanWidth
  end; { with FontHeaderPtr^ ... }

  with TextSettings do begin
    if Horiz <> LeftText then begin
      Width := GEMTextWidth(GEMFontID,TextString);
      if Horiz = CenterText
        then Y := Y+Width div 2
        else if Horiz = RightText
          then Y := Pred(Y+Width)
    end;
    case Vert of
      BottomText: X := Succ(X-CellHeight);
      CenterText: X := X-CellHeight div 2;
      TopText: { leave X as is };
    end
  end; { with TextSettings ... }

  MaxX := GetMaxX;
  MaxY := GetMaxY;
  Color := GetColor;

  if X+Pred(CellHeight) > MaxX        { to clip at the right edge of the }
    then CellHeight := Succ(MaxX-X);  { screen                           }

  CellHeightLess1 := Pred(CellHeight);

  for I := 1 to Length(TextString) do begin
    Ch := TextString[I];
    Code := Ord(Ch);
    if (Code < MinCode) or (Code > MaxCode)

      then  { don't do anything }

      else begin  { valid character code }
        Code := Code-MinCode;
        PatternOffset := COTPtr^[Code];
        PatternWidth := COTPtr^[Succ(Code)]-PatternOffset;

        if PatternWidth = 0

          then  { undefined character -- don't do anything }

          else begin  { defined character }
            PatternWidthLess1 := Pred(PatternWidth);
            if Y-PatternWidthLess1 < 0 then begin     { clip at the top of }
              PatternWidth := Succ(Y);                { the screen         }
              PatternWidthLess1 := Pred(PatternWidth)
            end;
            ByteIndex := PatternOffset div 8;
            Mask := $80 shr (PatternOffset mod 8);
            for Col := Y downto Y-PatternWidthLess1 do begin
              if Col <= MaxY then begin  { clip at the bottom of the screen }
                RowIndex := ByteIndex;
                for Row := X to X+CellHeightLess1 do begin
                  RowByte := StrikePtr^[RowIndex];
                  if (RowByte and Mask) = Mask
                    then if Row >= 0                { clip at the left edge }
                      then PutPixel(Row,Col,Color); { of the screen         }
                  Inc(RowIndex,RowInterval)
                end { for Row ... }
              end;
              if Mask = $01
                then begin
                  Inc(ByteIndex);
                  Mask := $80
                end
                else Mask := Mask shr 1
            end; { for Col ... }
            Dec(Y,PatternWidth);
            if Y < 0 then Break
          end  { defined character }

      end  { valid character code }

  end { for I ... }
end; { DrawGEMText1 }
{*****************************************************************************}
procedure DrawGEMText2(GEMFontID: pointer; X, Y: integer; var TextString:
  string; var TextSettings: TextSettingsType);
{ For Direction = 2 (vertical, top down, rotated 90 degrees clockwise. }
var
  FontPtr: PByteArray0 absolute GEMFontID;
  FontHeaderPtr: PExtendedGEMFontHeader absolute GEMFontID;

  CellHeight, CellHeightLess1, MinCode, MaxCode: word;
  COTPtr: PWordArray0;
  StrikePtr: PByteArray0;
  RowInterval: word;
  Width: word;
  MaxX, MaxY: integer;
  Color, I: word;
  Ch: char;
  Code, PatternOffset, PatternWidth, PatternWidthLess1, ByteIndex: word;
  Mask: byte;
  Col, RowIndex, Row: integer;
  RowByte: byte;
begin { DrawGEMText1 }
  with FontHeaderPtr^ do begin
    CellHeight := Height;
    MinCode := LowASCII;
    MaxCode := HighASCII;
    COTPtr := CharacterOffsetTablePtr;
    StrikePtr := FontDataPtr;
    RowInterval := SpanWidth
  end; { with FontHeaderPtr^ ... }

  with TextSettings do begin
    if Horiz <> LeftText then begin
      Width := GEMTextWidth(GEMFontID,TextString);
      if Horiz = CenterText
        then Y := Y-Width div 2
        else if Horiz = RightText
          then Y := Succ(Y-Width)
    end;
    case Vert of
      BottomText: X := Pred(X+CellHeight);
      CenterText: X := X+CellHeight div 2;
      TopText: { leave X as is };
    end
  end; { with TextSettings ... }

  MaxX := GetMaxX;
  MaxY := GetMaxY;
  Color := GetColor;

  if Succ(X) < CellHeight        { to clip at the left edge of the }
    then CellHeight := Succ(X);  { screen                          }

  CellHeightLess1 := Pred(CellHeight);

  for I := 1 to Length(TextString) do begin
    Ch := TextString[I];
    Code := Ord(Ch);
    if (Code < MinCode) or (Code > MaxCode)

      then  { don't do anything }

      else begin  { valid character code }
        Code := Code-MinCode;
        PatternOffset := COTPtr^[Code];
        PatternWidth := COTPtr^[Succ(Code)]-PatternOffset;

        if PatternWidth = 0

          then  { undefined character -- don't do anything }

          else begin  { defined character }
            PatternWidthLess1 := Pred(PatternWidth);
            if Y+PatternWidthLess1 > MaxY then begin  { clip at the bottom }
              PatternWidth := Succ(MaxY-Y);           { of the screen      }
              PatternWidthLess1 := Pred(PatternWidth)
            end;
            ByteIndex := PatternOffset div 8;
            Mask := $80 shr (PatternOffset mod 8);
            for Col := Y to Y+PatternWidthLess1 do begin
              if Col >= 0 then begin  { clip at the top of the screen }
                RowIndex := ByteIndex;
                for Row := X downto X-CellHeightLess1 do begin
                  RowByte := StrikePtr^[RowIndex];
                  if (RowByte and Mask) = Mask
                    then if Row <= MaxX             { clip at the right  }
                      then PutPixel(Row,Col,Color); { edge of the screen }
                  Inc(RowIndex,RowInterval)
                end { for Row ... }
              end;
              if Mask = $01
                then begin
                  Inc(ByteIndex);
                  Mask := $80
                end
                else Mask := Mask shr 1
            end; { for Col ... }
            Inc(Y,PatternWidth);
            if Y > MaxY then Break
          end  { defined character }

      end  { valid character code }

  end { for I ... }
end; { DrawGEMText2 }
{*****************************************************************************}
procedure DrawGEMText3(GEMFontID: pointer; X, Y: integer; var TextString:
  string; var TextSettings: TextSettingsType; UpdateCP: boolean);
{ For Direction = 3 (horizontal, right to left). }
var
  FontPtr: PByteArray0 absolute GEMFontID;
  FontHeaderPtr: PExtendedGEMFontHeader absolute GEMFontID;

  CellHeight, MinCode, MaxCode: word;
  COTPtr: PWordArray0;
  StrikePtr: PByteArray0;
  RowInterval: word;
  Width: word;
  OriginalY, MaxX, MaxY: integer;
  Color: word;
  PatternOffset, PatternWidth, ByteIndex: word;
  Mask: byte;
  Col, RowIndex, Row: integer;

  TextStringPtr: pointer;
  SaveDS, TextStringCX, ColCX, RowCX: word;
  MinMax: word;
begin { DrawGEMText3 }
  with FontHeaderPtr^ do begin
    CellHeight := Height;
    MinCode := LowASCII;
    MaxCode := HighASCII;
    COTPtr := CharacterOffsetTablePtr;
    StrikePtr := FontDataPtr;
    RowInterval := SpanWidth
  end; { with FontHeaderPtr^ ... }

  with TextSettings do begin
    if (Direction <> HorizDir) or (Horiz <> RightText)
      then UpdateCP := False;
    if Horiz <> RightText then begin
      Width := GEMTextWidth(GEMFontID,TextString);
      if Horiz = CenterText
        then X := X+Width div 2
        else if Horiz = LeftText
          then X := Pred(X+Width)
    end;
    OriginalY := Y;
    case Vert of
      BottomText: Y := Succ(Y-CellHeight);
      CenterText: Y := Y-CellHeight div 2;
      TopText: { leave Y as is };
    end
  end; { with TextSettings ... }

  MaxX := GetMaxX;
  MaxY := GetMaxY;
  Color := GetColor;

  if Y+Pred(CellHeight) > MaxY        { to clip at the bottom of the screen }
    then CellHeight := Succ(MaxY-Y);  { if necessary                        }

  TextStringPtr := @TextString;

  asm
    mov SaveDS,ds
    mov al,byte ptr MinCode
    mov ah,byte ptr MaxCode
    mov MinMax,ax
    lds si,TextStringPtr
    mov cl,[si]
    xor ch,ch
    test cx,cx
    jnz @NextCh
    jmp @ResetDS

    @NextCh: mov TextStringCX,cx
    lds si,TextStringPtr
    inc si
    mov word ptr TextStringPtr,si
    mov bl,[si]
    mov ax,MinMax
    cmp bl,al
    jb @StepCh
    cmp bl,ah
    ja @StepCh
    xor bh,bh
    sub bl,al
    shl bx,1
    lds si,COTPtr
    mov ax,[si+bx]
    mov PatternOffset,ax
    mov bx,[si+bx+2]
    sub bx,ax
    mov PatternWidth,bx
    mov cx,ax
    shr ax,1
    shr ax,1
    shr ax,1
    mov ByteIndex,ax  { PatternOffset div 8 }
    mov al,$80
    and cx,$07
    shr al,cl
    mov Mask,al  { $80 shr (PatternOffset mod 8) }
    mov ax,X
    sub ax,bx
    inc ax  { X-PatternWidth+1 }
    jge @XOK

    mov ax,X
    inc ax
    mov PatternWidth,ax  { X+1 }

    @XOK: mov si,X  { Col = X-PatternWidth+1 }
    mov cx,PatternWidth
    sub si,cx
    inc si
    mov ah,Mask
    mov ds,SaveDS  { for PutPixel }

    @ColLoop: mov ColCX,cx
    cmp si,MaxX
    jg @ShiftMask
    test si,si
    jl @ShiftMask
    mov bx,ByteIndex
    mov dx,Y  { Row }
    les di,StrikePtr
    mov cx,CellHeight

    @RowLoop: mov al,es:[di+bx]
    and al,ah
    jz @StepRow

    mov Mask,ah  { save AH, BX, CX, DX, SI }
    mov RowIndex,bx
    mov RowCX,cx
    mov Row,dx
    mov Col,si
    push si  { PutPixel(Col,Row,Color); }
    push dx
    mov ax,Color
    push ax
    call PutPixel
    mov ah,Mask  { restore AH, BX, CX, DX, SI }
    mov bx,RowIndex
    mov cx,RowCX
    mov dx,Row
    mov si,Col
    les di,StrikePtr  { reset ES:DI }

    @StepRow: add bx,RowInterval
    inc dx
    loop @RowLoop

    @ShiftMask: shr ah,1
    jnz @StepCol
    inc ByteIndex
    mov ah,$80
    @StepCol: inc si
    mov cx,ColCX
    loop @ColLoop

    mov ax,X
    sub ax,PatternWidth
    jl @ResetDS
    mov X,ax
    @StepCh: mov cx,TextStringCX
    loop @StepCh1
    jmp @ResetDS
    @StepCh1: jmp @NextCh

    @ResetDS: mov ds,SaveDS
  end;

  if UpdateCP then begin
    if X < 0
      then X := 0
      else if X > MaxX
        then X := MaxX;
    MoveTo(X,OriginalY)
  end
end; { DrawGEMText3 }
{*****************************************************************************}
procedure DrawGEMText4(GEMFontID: pointer; X, Y: integer; var TextString:
  string; var TextSettings: TextSettingsType);
{ For Direction = 4 (vertical, top down, no rotation. }
var
  FontPtr: PByteArray0 absolute GEMFontID;
  FontHeaderPtr: PExtendedGEMFontHeader absolute GEMFontID;

  CellHeight, CellHeightLess1, MinCode, MaxCode: word;
  COTPtr: PWordArray0;
  StrikePtr: PByteArray0;
  RowInterval: word;
  LeftAlign, CenterAlign, RightAlign: boolean;
  Width: word;
  MaxX, MaxY: integer;
  Color, I: word;
  Ch: char;
  Code, PatternOffset, PatternWidth, PatternWidthLess1, ByteIndex: word;
  Mask: byte;
  Col, RowIndex, Row, CharX: integer;
  RowByte: byte;
begin { DrawGEMText4 }
  with FontHeaderPtr^ do begin
    CellHeight := Height;
    MinCode := LowASCII;
    MaxCode := HighASCII;
    COTPtr := CharacterOffsetTablePtr;
    StrikePtr := FontDataPtr;
    RowInterval := SpanWidth
  end; { with FontHeaderPtr^ ... }

  with TextSettings do begin
    if Horiz <> LeftText then begin
      Width := GEMTextWidth(GEMFontID,TextString);
      if Horiz = CenterText
        then Y := Y-Width div 2
        else if Horiz = RightText
          then Y := Succ(Y-Width)
    end;
    LeftAlign := False;
    CenterAlign := False;
    RightAlign := False;
    case Vert of
      TopText:    LeftAlign := True;    { X to left of character }
      CenterText: CenterAlign := True;  { X in center of character }
      BottomText: RightAlign := True;   { X to right of character }
    end
  end; { with TextSettings ... }

  MaxX := GetMaxX;
  MaxY := GetMaxY;
  Color := GetColor;

  CellHeightLess1 := Pred(CellHeight);

  for I := 1 to Length(TextString) do begin
    Ch := TextString[I];
    Code := Ord(Ch);
    if (Code < MinCode) or (Code > MaxCode)

      then  { don't do anything }

      else begin  { valid character code }
        Code := Code-MinCode;
        PatternOffset := COTPtr^[Code];
        PatternWidth := COTPtr^[Succ(Code)]-PatternOffset;

        if PatternWidth = 0

          then  { undefined character -- don't do anything }

          else begin  { defined character }
            PatternWidthLess1 := Pred(PatternWidth);
            if LeftAlign
              then CharX := X
              else if CenterAlign
                then CharX := X-PatternWidth div 2
                else CharX := X-PatternWidthLess1;
            if X+PatternWidthLess1 > MaxX then begin   { clip at the right  }
              PatternWidth := Succ(MaxX-CharX);        { edge of the screen }
              PatternWidthLess1 := Pred(PatternWidth)
            end;
            ByteIndex := PatternOffset div 8;
            Mask := $80 shr (PatternOffset mod 8);
            for Col := CharX to CharX+PatternWidthLess1 do begin
              if Col >= 0 then begin  { clip at the left edge of the screen }
                RowIndex := ByteIndex;
                for Row := Y to Y+CellHeightLess1 do begin
                  RowByte := StrikePtr^[RowIndex];
                  if (RowByte and Mask) = Mask
                    then if (Row >= 0) and (Row <= MaxY)  { clip at the top   }
                      then PutPixel(Col,Row,Color);       { and the bottom of }
                  Inc(RowIndex,RowInterval)               { screen            }
                end { for Row ... }
              end;
              if Mask = $01
                then begin
                  Inc(ByteIndex);
                  Mask := $80
                end
                else Mask := Mask shr 1
            end; { for Col ... }
            Inc(Y,CellHeight);
            if Y > MaxY then Break
          end  { defined character }

      end  { valid character code }

  end { for I ... }
end; { DrawGEMText4 }
{*****************************************************************************}
procedure OutGEMText(GEMFontID: pointer; TextString: string);
var
  X, Y: integer;
  TextSettings: TextSettingsType;
begin { OutGEMText }
  if GEMFontID <> nil then begin
    X := GetX;
    Y := GetY;
    GetTextSettings(TextSettings);
    case TextSettings.Direction of
      HorizDir: DrawGEMText0(GEMFontID,X,Y,TextString,TextSettings,True);
      VertDir:  DrawGEMText1(GEMFontID,X,Y,TextString,TextSettings);
      2:        DrawGEMText2(GEMFontID,X,Y,TextString,TextSettings);
      3:        DrawGEMText3(GEMFontID,X,Y,TextString,TextSettings,True);
      4:        DrawGEMText4(GEMFontID,X,Y,TextString,TextSettings);
    end
  end
end; { OutGEMText }
{*****************************************************************************}
procedure OutGEMTextXY(GEMFontID: pointer; X, Y: integer; TextString: string);
var
  TextSettings: TextSettingsType;
begin { OutGEMTextXY }
  if GEMFontID <> nil then begin
    GetTextSettings(TextSettings);
    case TextSettings.Direction of
      HorizDir: DrawGEMText0(GEMFontID,X,Y,TextString,TextSettings,True);
      VertDir:  DrawGEMText1(GEMFontID,X,Y,TextString,TextSettings);
      2:        DrawGEMText2(GEMFontID,X,Y,TextString,TextSettings);
      3:        DrawGEMText3(GEMFontID,X,Y,TextString,TextSettings,True);
      4:        DrawGEMText4(GEMFontID,X,Y,TextString,TextSettings);
    end
  end
end; { OutGEMTextXY }
{*****************************************************************************}
function IncPtr(P: pointer; Inc: longint): pointer;
{ Increments P by Inc and returns the result in normalized form.  Inc may be
  negative. }
type
  TPtrRec = record  { structure of a pointer }
    Offset, Segment: Word
  end;
var
  L: longint;
begin
  with TPtrRec(P) do
    L := ((longint(Segment) shl 4) + longint(Offset))+Inc;
  IncPtr := Ptr(word(L shr 4),word(L and $0000000F))
end;
{*****************************************************************************}
function RegisterGEMFont(LinkedGEMFontPtr: pointer; var Leading, ErrorCode: word): pointer;
var
  ObjFontPtr: PByteArray0 absolute LinkedGEMFontPtr;
  ObjFontHeaderPtr, NewFontHeaderPtr: PExtendedGEMFontHeader;
  IsGEMFont: boolean;
  TrueFontHeaderSize: word;
begin { RegisterGEMFont }
  Leading := 0;
  RegisterGEMFont := nil;

  if LinkedGEMFontPtr = nil then begin
    ErrorCode := 1;
    Exit
  end;

  ObjFontHeaderPtr := IncPtr(LinkedGEMFontPtr,-ExtensionBytes);

  IsGEMFont := True;
  TrueFontHeaderSize := SizeOf(TExtendedGEMFontHeader)-ExtensionBytes;
  with ObjFontHeaderPtr^ do begin
    if (LowASCII > 255) or (HighASCII > 255) or (LowASCII > HighASCII)
      then IsGEMFont := False
      else if WidestCharacterWidth > WidestCellWidth
        then IsGEMFont := False
          else if (HorizontalOffsetTableOffset <> 0) and
              (HorizontalOffsetTableOffset < (TrueFontHeaderSize-4))
            then IsGEMFont := False
            else if (CharacterOffsetTableOffset < (TrueFontHeaderSize-4))
              then IsGEMFont := False
              else if FontDataOffset < CharacterOffsetTableOffset
                then IsGEMFont := False
  end; { with ... }

  if not IsGEMFont then begin
    ErrorCode := 3;
    Exit
  end;

  if SizeOf(TExtendedGEMFontHeader) > MaxAvail then begin
    ErrorCode := 2;
    Exit
  end;

  GetMem(NewFontHeaderPtr,SizeOf(TExtendedGEMFontHeader));
  Move(LinkedGEMFontPtr^,NewFontHeaderPtr^.FontID,TrueFontHeaderSize);
  with NewFontHeaderPtr^ do begin
    CharacterOffsetTablePtr := @ObjFontPtr^[CharacterOffsetTableOffset];
    FontDataPtr := @ObjFontPtr^[FontDataOffset];
    AllocatedBytes := SizeOf(TExtendedGEMFontHeader);
    Leading := Height
  end;
  ErrorCode := 0;
  RegisterGEMFont := pointer(NewFontHeaderPtr)
end; { RegisterGEMFont }
{*****************************************************************************}
procedure UnloadGEMFont(var GEMFontID: pointer);
var
  FontHeaderPtr: PExtendedGEMFontHeader absolute GEMFontID;
begin { UnloadGEMFont }
  if GEMFontID <> nil then begin
    FreeMem(GEMFontID,FontHeaderPtr^.AllocatedBytes);
    GEMFontID := nil
  end
end; { UnloadGEMFont }
{*****************************************************************************}
end.
