Uses cfg;

Const 
  HeaderOffset = 233;

Type 
  TTDFont = Record
    A         : char;
    typo      : Array[1..18] Of char;
    B         : char;
    fs        : Array[1..4] Of Byte;
    NameLen   : Byte;
    FontName  : Array[1..12] Of char;
    nouse     : Array[1..4] Of Byte;
    FontType  : Byte;
    Spacing   : Byte;
    BlockSize : word;
    CharAddr  : Array[1..94] Of word;
  End;

Type 
  TFontChar = Record
    width  : Byte;
    height : Byte;
  End;

Var 
  font     : TTDFont;
  Datapath : String;
  FontFile : String;

Procedure GetTDFHeader(f:String);
Var 
  fptr : file;
  i : Integer;
Begin
  If Not fileexist(f) Then
    Begin
      Writeln('Font file [ '+f+' ]does not exist');
      Pause;
      Halt;
    End;
  fontfile := f;
  fAssign(fptr,f,66);
  fReset(fptr);
  fRead(fptr,font,sizeof(font));
  fClose(fptr);
End;

Procedure TDFWriteCharBL(x,y:Byte;c:char): Byte;
Var 
  fptr  : file;
  i     : Integer;
  FChar : TFontChar;
  tbyte : Array[1..2] Of Byte;
  sx,sy : Byte;
  asc   : Byte;
Begin
  If c=' ' Then
    Begin
      TDFWritecharBL := 1;
      Exit;
    End;
  asc := ord(c)-32;
  fAssign(fptr,fontfile,66);
  fReset(fptr);
  fSeek(fptr,headeroffset+font.charaddr[asc]);
  fRead(fptr,FChar,sizeof(Fchar));
  tbyte[1] := 32;
  tbyte[2] := 32;
  GotoXY(x,y);
  While tbyte[1]<>0 And Not feof(fptr) Do
    Begin
      fRead(fptr,tbyte[1],1);
      If tbyte[1]=13 Then
        Begin
          GotoXY(x,wherey+1);
          If wherey>25 Then Break;
        End;
      Else
        Begin
          fRead(fptr,tbyte[2],1);
          TextColor(tbyte[2] % 16 + tbyte[2] - (tbyte[2] % 16));
          Write(chr(tbyte[1]));
          If wherex>79 Then Break;
        End;
    End;
  fClose(fptr);
  TDFWritecharbl := fchar.width;
End;

Procedure TDFWriteCharCL(x,y:Byte;c:char): Byte;
Var 
  fptr  : file;
  i     : Integer;
  FChar : TFontChar;
  tbyte : Array[1..2] Of Byte;
  sx,sy : Byte;
  asc   : Byte;
Begin
  If c=' ' Then
    Begin
      TDFWritecharcl := 1;
      Exit;
    End;
  asc := ord(c)-32;
  fAssign(fptr,fontfile,66);
  fReset(fptr);
  fSeek(fptr,headeroffset+font.charaddr[asc]);
  fRead(fptr,FChar,sizeof(Fchar));
  tbyte[1] := 32;
  GotoXY(x,y);
  While tbyte[1]<>0 And Not feof(fptr) Do
    Begin
      fRead(fptr,tbyte[1],1);
      If tbyte[1]=13 Then
        Begin
          GotoXY(x,wherey+1);
          If wherey>25 Then Break;
        End
      Else
        Begin
          Write(chr(tbyte[1]));
          If wherex>79 Then Break;
        End;
    End;
  fClose(fptr);
  TDFWritecharcl := fchar.width;
End;

Procedure TDFWrite(x,y:Byte; s:String);
Var 
  i     : Byte;
  sx,sy : Byte;
Begin
  GotoXY(x,y);
  sx := x;
  sy := y;
  Case font.fonttype Of 
    2:
       Begin
         For i:=1 To Length(s) Do
           Begin
             sx := sx+TDFWritecharBL(sx,y,s[i])+font.spacing;
           End;
       End;
    1:
       Begin
         For i:=1 To Length(s) Do
           Begin
             sx := sx+TDFWritecharCL(sx,y,s[i])+font.spacing;
           End;
       End;
  End;
End;

Procedure TDFTypeWrite(x,y:Byte; s:String; d:Integer);
Var 
  i     : Byte;
  sx,sy : Byte;
Begin
  GotoXY(x,y);
  sx := x;
  sy := y;
  Case font.fonttype Of 
    2:
       Begin
         For i:=1 To Length(s) Do
           Begin
             sx := sx+TDFWritecharBL(sx,y,s[i])+font.spacing;
             Delay(d);
           End;
       End;
    1:
       Begin
         For i:=1 To Length(s) Do
           Begin
             sx := sx+TDFWritecharCL(sx,y,s[i])+font.spacing;
             Delay(d);
           End;
       End;
  End;
End;

// Main Block

Begin
  ClrScr;
  DataPath := JustPath(ProgName);
  gettdfheader(datapath+'drgx.tdf');
  // Init the font to use
  font.spacing := 1;
  TDFWrite(1,2,'Shall we play');
  // Write a String
  TDFWrite(30,6,'a game...');

  gettdfheader(datapath+'acidscapesl.tdf');
  font.spacing := 1;
  TDFWrite(3,9,'repeaters');
  TDFWrite(3,15,'Mystic');
  TDFWrite(23,20,'BBS');
  GotoXY(1,25);
  Pause;

End;