{ VIEWGEM.PAS 1.01 (12 September 1994) (Borland Pascal 7.0, real) }
program ViewGEM;
{==============================================================================
   ViewGEM allows you to try a GEM font to see what text drawn in it looks
like.  Any number of fonts can be tried in a single session.  The program
requires a VGA card.
   ViewGEM may be invoked without arguments, in which case it will prompt you
for the name of a file containing a GEM font.
   Alternatively you may specify a file name as an argument when you invoke
ViewGEM.
-------------------------------------------------------------------------------
 3/20/93 - 1.00.  Initial compilation.
 9/14/93 - 1.01.  Corrected the handling of errors in LoadFont (after detecting
           an error, LoadFont incorrectly went on to test for other
           conditions).
==============================================================================}
uses DOS, CRT, Graph, BgiDriv;

type

  TWordArray = array[0..0] of word;
  PWordArray = ^TWordArray;

  TByteArray = array[0..0] of byte;
  PByteArray = ^TByteArray;

  TGEMFontHeader = record
    FontID: word;
    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;
  PGEMFontHeader = ^TGEMFontHeader;

var

  Argument: string;

  OriginalTextAttr: byte;

  FontFileName: PathStr;

  FontPtr: PByteArray;
  FontFileSize: word;
  FontStorageAllocated: boolean;
  FontHeaderPtr: PGEMFontHeader;
  HOTPtr, CharacterOffsetTablePtr: PWordArray;
  FontDataPtr: PByteArray;
  Ch: char;
  GraphDriver, GraphMode: integer;
  MaxX, MaxY: integer;
  CellHeight, Leading, MinCode, MaxCode, Code: word;
  CharacterNumber: word;
  CharacterX: array[1..500] of word;
  PatternOffset, PatternWidth: word;
  X, Y, PreviousX, NextX: integer;
  ByteIndex: word;
  Mask: byte;
  Col, RowIndex, Row: word;
  RowByte: byte;
  ErrorCode: word;
{*****************************************************************************}
procedure IdentifyProgram;
begin { IdentifyProgram }
  Writeln('IMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM;');
  Writeln(':                              VIEWGEM 1.01                                   :');
  Writeln(':          Copyright 1993 by Rufus S. Hendon.  All rights reserved.           :');
  Writeln('HMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM<');
end; { IdentifyProgram }
{*****************************************************************************}
procedure Explain;
begin { Explain }
  IdentifyProgram;
  Writeln('   ViewGEM allows you to try a GEM font to see what text drawn in it looks');
  Writeln('like.  Any number of fonts can be tried in a single session.  The program');
  Writeln('requires a VGA card and a color monitor.');
  Writeln('   ViewGEM may be invoked without arguments, in which case it will prompt you');
  Writeln('for the name of a file containing a GEM font.');
  Writeln('   Alternatively you may specify a file name as an argument when you invoke');
  Writeln('ViewGEM.');
  Halt(1)
end; { Explain }
{*****************************************************************************}
function ColorMonitor: boolean;
{    The function returns True if the monitor attached to the system is a
  color monitor, False if it is a monochrome monitor.  (The information is
  taken from the System Equipment Data Area.) }
var
  Flags: byte;
begin { ColorMonitor }
  asm
    int $11
    mov Flags,ah
  end;
  ColorMonitor := (Flags and $30) <> $30
end; { ColorMonitor }
{*****************************************************************************}
function FileExists(FileName: string): boolean;
{ The function returns True if the file designated by FileName exists, False
  if it doesn't. }
var
  ASCIIZName: string;
  P: pointer;
begin { FileExists }
  ASCIIZName := FileName+#0;
  P := @ASCIIZName;
  asm
    push ds              { Save DS                                      }
    mov ax,$4300         { Attempt to ascertain the attributes of       }
    mov dx,word ptr P    {   the file named FileName                    }
    inc dx
    mov cx,word ptr P+2
    mov ds,cx
    int $21
    jc @1                { If the attempt failed (carry flag set)       }
    and cx,$0018         {   or if the attempt succeeded but FileName   }
    jnz @1               {   is actually a volume label or a directory, }
    mov al,1             {   set the return value to False.  Otherwise  }
    jmp @2               {   set it to True                             }
    @1: xor al,al
    @2: mov @Result,al
    pop ds               { Restore DS                                   }
  end
end; { FileExists }
{*****************************************************************************}
procedure Warble;
{ A warbling sound is produced. }
var
  I: word;
begin { Warble }
  for I := 1 to 2 do begin
    Sound(740);
    Delay(65);
    NoSound;
    Sound(600);
    Delay(50);
    NoSound
  end;
  Sound(740);
  Delay(65);
  NoSound
end; { Warble }
{*****************************************************************************}
function GetFontFileName: boolean;
begin { GetFontFileName }
  while True do begin
    Writeln(
        'If you want to view another GEM font, enter the name of the file.');
    Writeln('But if you want to quit, just press Enter.');
    Write('>');
    Readln(FontFileName);
    if Length(FontFileName) = 0
      then Break
      else if FileExists(FontFileName)
        then Break
        else Writeln('Can''t find the file!')
  end;
  GetFontFileName := Length(FontFileName) > 0
end; { GetFontFileName }
{*****************************************************************************}
function LoadFont(var ErrorCode: word): boolean;
var
  FontFile: file;
  LongFileSize: longint;
  IsGEMFont: boolean;
begin { LoadFont }
  if FontStorageAllocated then begin
    FreeMem(FontPtr,FontFileSize);
    FontStorageAllocated := False
  end;

  Assign(FontFile,FontFileName);
  Reset(FontFile,1);

  LongFileSize := FileSize(FontFile);
  if LongFileSize > 65528
    then begin
      ErrorCode := 1;
      LoadFont := False;
      Exit
    end
  else FontFileSize := LongFileSize;

  if FontFileSize > MaxAvail
    then begin
      ErrorCode := 2;
      LoadFont := False;
      Exit
    end
    else begin
      GetMem(FontPtr,FontFileSize);
      FontStorageAllocated := True
    end;

  BlockRead(FontFile,FontPtr^,FontFileSize);
  Close(FontFile);

  FontHeaderPtr := PGEMFontHeader(FontPtr);
  IsGEMFont := True;
  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 < SizeOf(TGEMFontHeader)-4) or
              (HorizontalOffsetTableOffset > FontFileSize))
            then IsGEMFont := False
            else if (CharacterOffsetTableOffset < SizeOf(TGEMFontHeader)-4) or
              (CharacterOffsetTableOffset > FontFileSize)
            then IsGEMFont := False
            else if (FontDataOffset < CharacterOffsetTableOffset) or
                (FontDataOffset > FontFileSize)
              then IsGEMFont := False
  end; { with ... }
  if IsGEMFont
    then ErrorCode := 0
    else ErrorCode := 3;
  LoadFont := IsGEMFont
end; { LoadFont }
{*****************************************************************************}
procedure ClearGraphicsScreen;
begin { ClearGraphicsScreen }
{ Fill the screen with light gray: }
  SetFillStyle(SolidFill,LightGray);
  Bar(0,0,MaxX,MaxY)
end; { ClearGraphicsScreen }
{*****************************************************************************}
procedure StartNewLine(var X, Y: integer);
begin { StartNewLine }
  Inc(Y,Leading);
  if (Y+Pred(Leading)) > MaxY then begin
    ClearGraphicsScreen;
    Y := 0
  end;
  X := 0
end; { StartNewLine }
{*****************************************************************************}
begin { ViewGEM }
  if ParamCount > 0 then begin
    Argument := ParamStr(1);
    if (Argument = '/?') or (Argument = '?') then Explain
  end;

  OriginalTextAttr := TextAttr;
  if ColorMonitor
    then TextAttr := $17   { light gray on blue }
    else TextAttr := $70;  { black on low-intensity white }

  ClrScr;
  IdentifyProgram;

  {DetectGraph(GraphDriver,GraphMode);
  if (GraphDriver = grNotDetected) or (GraphDriver <> VGA)
    then begin
      TextAttr := OriginalTextAttr;
      Writeln('This program requires a VGA.');
      Halt(1)
    end
    else begin
      GraphMode := VGAHi;
      if RegisterBGIDriver(@EGAVGADriverProc) < 0 then begin
        TextAttr := OriginalTextAttr;
        Writeln('EGA/VGA: ',GraphErrorMsg(GraphResult));
        Halt(1)
      end
    end;}

  FontStorageAllocated := False;
  FileMode := 0;  { allow read-only files to be processed }

  while GetFontFileName do begin
    ClrScr;

    if LoadFont(ErrorCode)

      then begin  { font loaded }
        with FontHeaderPtr^ do begin
          HOTPtr := @FontPtr^[HorizontalOffsetTableOffset];
          CharacterOffsetTablePtr := @FontPtr^[CharacterOffsetTableOffset];
          FontDataPtr := @FontPtr^[FontDataOffset];
          Writeln('File name: ',FontFileName);
          Writeln('Font name: ',FontName,' (height: ',PointSize,' pixels)');
          Writeln('Character code range: ',LowASCII,'-',HighASCII)
        end; { with ... }
        Writeln;
        Writeln('ZDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD?');
        Writeln('3                                Instructions                                3');
        Writeln('3                                                                            3');
        Writeln('3 After the switch to graphics mode, type text.  The text will be displayed  3');
        Writeln('3 on the screen in the GEM font.  You may use backspace to erase characters. 3');
        Writeln('3 Press Enter to begin a new line.  When the screen is full, it will be      3');
        Writeln('3 cleared automatically.  When you want to quit, press any function key.     3');
        Writeln('@DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDY');
        Writeln;
        Writeln('                           [Press any key to begin!]');
        Ch := ReadKey;

        {InitGraph(GraphDriver,GraphMode,'');
        if GraphResult <> grOK then begin
          TextAttr := OriginalTextAttr;
          Writeln('Error attempting to switch to graphics mode.');
          Halt(1)
        end;}
        InitBGI256;

        MaxX := GetMaxX;
        MaxY := GetMaxY;

        with FontHeaderPtr^ do begin
          CellHeight := Height;
          MinCode := LowASCII;
          MaxCode := HighASCII;
          Leading := Height
        end;

        ClearGraphicsScreen;

        X := 0;
        Y := 0;
        CharacterNumber := 0;
        Ch := ReadKey;
        while Ch <> #0 do begin
          Code := Ord(Ch);

          if Code = 13  { Enter }

            then begin
              StartNewLine(X,Y);
              CharacterNumber := 0
            end

            else if Code = 8  { Backspace }

              then begin
                if CharacterNumber = 0
                  then { don't do anything }
                  else begin
                  { Fill the area occupied by the pattern with light gray: }
                    SetFillStyle(SolidFill,LightGray);
                    PreviousX := CharacterX[CharacterNumber];
                    Bar(PreviousX,Y,Pred(X),Y+Pred(Leading));
                    X := PreviousX;
                    Dec(CharacterNumber)
                  end
              end

              else if (Code < MinCode) or (Code > MaxCode)

                then  { don't do anything }

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

                  if PatternWidth = 0

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

                    else begin  { defined character }
                      NextX := X+Pred(PatternWidth);
                      if NextX > MaxX then begin
                        Inc(Y,Leading);
                        if (Y+Pred(Leading)) > MaxY then begin
                          SetFillStyle(SolidFill,LightGray);
                          Bar(0,0,MaxX,MaxY);
                          Y := 0
                        end;
                        X := 0;
                        CharacterNumber := 0
                      end;
                      ByteIndex := PatternOffset div 8;
                      Mask := $80 shr (PatternOffset mod 8);
                      for Col := 0 to Pred(PatternWidth) do begin
                        RowIndex := ByteIndex;
                        for Row := 0 to Pred(CellHeight) do begin
                          RowByte := FontDataPtr^[RowIndex];
                          if (RowByte and Mask) = Mask
                            then PutPixel(X+Col,Y+Row,Black);
                          RowIndex := RowIndex+FontHeaderPtr^.SpanWidth
                        end; { for Row ... }
                        Mask := Mask shr 1;
                        if Mask = $00 then begin
                          Inc(ByteIndex);
                          Mask := $80
                        end
                      end; { for Col ... }
                      Inc(CharacterNumber);
                      CharacterX[CharacterNumber] := X;
                      Inc(X,PatternWidth)
                    end  { defined character }

                end;  { valid character code }

          Ch := ReadKey
        end; { while Ch <> #0 ... }

        Ch := ReadKey;  { read the pending extended code }
        CloseGraph;
        ClrScr
      end  { font loaded }
      else begin  { font not loaded }
        ClrScr;
        case ErrorCode of
          1: Writeln('This file is too large to contain a GEM font.');
          2: Writeln('There isn''t enough memory to load this file.');
          3: Writeln('This file doesn''t appear to contain a GEM Font.')
        end; { case ... }
        Writeln('                         [Press any key to continue.]');
        Ch := ReadKey;
        if Ch = #0 then Ch := ReadKey
      end  { font not loaded }

  end; { while GetFontFileName ... }

  TextAttr := OriginalTextAttr;
  ClrScr
end. { ViewGEM }
