[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]

    {
    >I need to Write some Pascal code For a PC that will allow Text mode
    >fonts to be changed (at least on PC's With VGA adapters).

    >Prof. Salmi's FAQ lists a book by Porter and Floyd, "Stretching
    >Turbo Pascal", as having the relevant information, but my local
    >bookstore claims this is out of print.

    You could try borrowing the book from the library.  For instance ours
    will search For books; I rarely buy books.  STP:v5.5 was an exception.
    Here is code (substantially based on Porter and Floyds' code) written
    for version 5.x .  Actually, aside from this stuff, the book wasn't as
    good as I thought it would be.  I believe Ken Porter died and parts of
    the book seem missing.  This code, For instance, isn't well documented
    in the book (althought I think its clear how to use it from these
    Programs).

    You know, after playing With this code I thought I knew it all :D
    It turns out that there is a lot more you can do.  For instance, the
    intensity bit can be used as an extra Character bit to allow
    512-Character fonts.  I have an aging PC Magazine article (that I
    haven't gotten around to playing with) that has some Asm code For the
    EGA.  (I'm hoping the same code will work For the VGA).
    }
    {--[rounded.pas]--}

    Program
      Rounded;
    Uses
      Crt, BitFonts;

    Type
      matrix = Array[0..15] of Byte;

    Const
      URC : matrix = ($00,$00,$00,$00,$00,$00,$00,$C0,$70,$30,$18,$18,$18,$18,$18,$18);
      LLC : matrix = ($18,$18,$18,$18,$0C,$0E,$03,$00,$00,$00,$00,$00,$00,$00,$00,$00);
      LRC : matrix = ($18,$18,$18,$18,$30,$70,$C0,$00,$00,$00,$00,$00,$00,$00,$00,$00);
      ULC : matrix = ($00,$00,$00,$00,$00,$00,$00,$03,$0E,$0C,$18,$18,$18,$18,$18,$18);
    {  ULC : matrix = ($00,$00,$00,$00,$00,$03,$0E,$19,$33,$36,$36,$36,$36,$36,$36,$36);}
    Var
      index,b      : Word;
      package      : fontPackagePtr;
      FontFile     : File of FontPackage;
      EntryFont    : ROMfont;

      Procedure TextBox( left, top, right, bottom, style : Integer );
        Const
          bord : Array[1..2,0..5] of Char = ( ( #196,#179,#218,#191,#217,#192 ),
                                              ( #205,#186,#201,#187,#188,#200 ));
        Var P:Integer;

        begin
          if Style = 0 then Exit; { what the fuck is this For ? }

          { verify coordinates are in ( NW,SE ) corner }
          if left > right then
            begin
              p := left; left := right; right := p;
            end;
          if bottom < top then
            begin
              p := top; top := bottom; bottom := p;
            end;

          { draw top }
          GotoXY( left,top );
          Write( bord[style,2] );
          For p := left+1 to right-1 do
            Write( bord[style,0]);
          Write( bord[style,3] );

          { draw bottomm }
          GotoXY( left,bottom );
          Write( bord[style,5]);
          For p := left+1 to right-1 do
            Write( bord[style,0]);
          Write( bord[style,4]);

          { draw sides }
          For p := top+1 to bottom-1 do
            begin
              GotoXY( left,p );
              Write( bord[style,1] );
              GotoXY( right,p );
              Write( bord[style,1] );
            end;
        end; { Procedure TextBox }

      Procedure replace( ASCII:Word; newChar:matrix );
        Var offset,b:Word;
        begin
          offset := ASCII * VDA.points;
          For b := 0 to VDA.points-1 do
            package^.ch[offset+b] := newChar[b];
        end;

    begin
      if not isEGA then
        begin
          Writeln( 'You can only run this Program on EGA or VGA systems' );
          halt( 1 );
        end;
      {- fetch copy of entry font -}
      EntryFont := CurrentFont;
      Package := FetchHardwareFont( CurrentFont );

      {- replace the corner Characters -}
      replace( 191,URC );
      replace( 192,LLC );
      replace( 217,LRC );
      replace( 218,ULC );

      {- load and active user-modified font -}
      Sound( 1000 );
      LoadUserFont( package );
      NoSound;

      {- Draw a Text box -}
      ClrScr;
    {  CursorOff; }
      TextBox( 20,5,60,20,1 );
      GotoXY( 33,12 ); Write( 'rounded corners' );
    {  WaitForKey;}
      readln;

      {- save user-modified font to File -}
      assign( FontFile, 'HELLO' );
      reWrite( FontFile );
      Write( FontFile,Package^ );
      close( FontFile );

      {- clear and quit -}
      SetHardWareFont( EntryFont );
      ClrScr;
    {  CursorOn;}

    end.

    {--[editfnt2.pas]--}

    Program EditFont;

    Uses Crt, Dos, BitFonts;

    Const
      Block = #220;
      Esc = #27;
    Var
      c,
      Choice : Char;
      EditDone,
      Done,
      Valid  : Boolean;
      Font   : ROMfont;
      package : FontPackagePtr;
      fout : File of FontPackage;
      foutfil : String;

    Function UpperCase( s:String ): String;
      Var i:Byte;
      begin
        For i := 1 to length( s ) do
          s[i] := UpCase( s[i] );
        UpperCase := s;
      end;

    Function HexByte( b:Byte ):String;
      Const DIGIT : Array[0..15] of Char = '0123456789ABCDEF';
      begin
        HexByte := Digit[b SHR 4] + Digit[b and $0F];
      end;

    Function ByteBin( Var bs:String ):Byte;
      Const DIGIT : Array[0..15] of Char = '0123456789ABCDEF';
      Var i,b:Byte;
      begin
        b := 0;
        For i := 2 to length( bs ) do
          if bs[i] = '1' then
            b := b + 2 SHL (i-1);
        if bs[1] = '1' then
          b := b + 1;
        ByteBin := b;
      end;

    Procedure Browse( Font:ROMfont );

    {
        arrow keys to manuever
        Esc to accept
        Enter or space to toggle bit
        C or c to clear a row
        alt-C or ctl-C to clear whole Char

    }
      Const
        MapRow = ' - - - - - - - - ';
        MapTop = 7;

      Var
        ASCII,
        row,
        col,
        index,
        bit   : Word;
        f     : Char_table;
        s     : String;
        error : Integer;

      Procedure putChar( value:Word );
        Var reg:Registers;
        begin
          reg.AH := $0A;
          reg.AL := Byte( value );
          reg.BH := 0;
          reg.BL := LightGray;
          reg.CX := 1;
          intr( $10,reg );
          GotoXY( WhereX+1, WhereY );
        end; { proc putChar }

      begin
        GetMem( Package, SizeOf( Package^ ));
        ClrScr;
        Package := FetchHardwareFont( Font );
        Repeat
          GotoXY( 1,1 );
          Write( 'FONT: ' );
          Case Font of
            ROM8x8  : Writeln( '8 x 8' );
            ROM8x14 : Writeln( '8 x 14' );
            ROM8x16 : Writeln( '8 x 16' );
          end;
          Writeln;
          clreol;
          Write( 'ASCII value to examine? (or QUIT to quit) ' );
          readln( s );
          Val( s,ASCII,error );
          if error <> 0 then
            if UpperCase( s ) = 'QUIT' then
              Done := True
            else
              ASCII := Byte( s[1] );

          { show the Character image }
          clreol;
          Write( '(Image For ASCII ',ASCII,' is ' );
          putChar( ASCII );
          Writeln( ')' );

          { display blank bitmap }
          GotoXY( 1,MapTop );
          For row := 1 to Package^.FontInfo.points do
            Writeln( maprow );

          { explode the image bitmap }
          index := Package^.FontInfo.points * ASCII;
          For row := 0 to Package^.FontInfo.points-1 do
            begin
              For bit := 0 to 7 do
                if (( Package^.Ch[index] SHR bit ) and 1 ) = 1 then
                  begin
                    col := ( 8 - bit ) * 2;
                    GotoXY( col,row+MapTop );
                    Write( block );
                  end;
              GotoXY( 20,row+MapTop );
              Write( hexByte( Package^.Ch[index] )+ 'h' );
              inc( index );
            end;

          { edit font }
          col := 2;
          row := MapTop;
          EditDone := False;
          index := Package^.FontInfo.points * ASCII;

          While ( not Done ) and ( not EditDone ) do
            begin
              GotoXY( col,row );
              c := ReadKey;
              if c = #0 then
                c := ReadKey;

              Case c of

                #03,         { wipe entire letter }
                #46 : begin
                        index := Package^.FontInfo.points * ASCII;
                        For row := MapTop to MapTop+Package^.FontInfo.points-1 do
                          begin
                            Package^.Ch[index] := 0;
                            col := 2;
                            GotoXY( col,row );
                            Write( '- - - - - - -' );
                            GotoXY( 20,row );
                            Write( hexByte( Package^.Ch[index] )+ 'h' );
                            GotoXY( col,row );
                            inc( index );
                          end;
                      end;

                'C',         { wipe row }
                'c' : begin
                        Package^.Ch[index] := 0;
                        col := 2;
                        GotoXY( col,row );
                        Write( '- - - - - - -' );
                        GotoXY( 20,row );
                        Write( hexByte( Package^.Ch[index] )+ 'h' );
                        GotoXY( col,row );
                      end;

                #27 : EditDone := True;  { esc }

                #72 : begin  { up }
                        if row >  MapTop then
                          begin
                            dec( row );
                            dec( index );
                          end;
                      end;

                #80 : begin  { down }
                        if row < ( MapTop + Package^.FontInfo.points - 1 ) then
                          begin
                            inc( row );
                            inc( index );
                          end;
                      end;

                #77 : begin  { right }
                        if col < 16 then
                          inc( col,2 );
                      end;

                #75 : begin  { left }
                        if col > 3 then
                          dec( col,2 );
                      end;

                #13,
                #10,
                ' ' : begin
                        bit := 8 - ( col div 2 );
                        if (( Package^.Ch[index] SHR bit ) and 1 ) = 1 then
                          begin
                            Package^.Ch[index] := ( Package^.Ch[index] ) AND
                                                   ($FF xor ( 1 SHL bit ));
                            Write( '-' )
                          end
                        else
                          begin
                            Package^.Ch[index] := Package^.Ch[index] XOR
                                                  ( 1 SHL bit );
                            Write( block );
                          end;

                        GotoXY( 20,row );
                        Write( hexByte( Package^.Ch[index] )+ 'h' );
                        GotoXY( col,row );
                      end;

              end; { Case }

              LoadUserFont( Package );

            end; { While }

        Until Done;

        GotoXY( 40,7 );
        Write( 'Save to disk? (Y/n) ');
        Repeat
          c := UpCase( ReadKey );
        Until c in ['Y','N',#13];
        if c = #13 then
          c := 'Y';
        Write( c );

        if c = 'Y' then
          begin
            GotoXY( 40,9 );
            ClrEol;
            Write( 'Save as: ');
            readln( foutfil );

    (*        if fexist( foutfil ) then
              begin
                GotoXY( 40,7 );
                Write( 'OverWrite File ''',foutfil,''' (y/N) ');
                Repeat
                  c := UpCase( ReadKey );
                Until c in ['Y','N',#13];
                if c = #13 then
                  c := 'N';
                Write( c );
              end;
    *)
            {$I-}
            assign( fout,foutfil ); reWrite( fout );
            Write( fout,Package^ );
            close( fout );
            {$I+}
            GotoXY( 40,11 );
            if ioResult <> 0 then
              Writeln( 'Write failed!' )
            else
              Writeln( 'Wrote font to File ''',foutfil,'''.' );
          end;

      end; { proc Browse }

    begin

      Done := False;
      { get font to view }
      Repeat
        Valid := False;
        Repeat
          ClrScr;
          Writeln( 'Fonts available For examination: ' );
          Writeln( '    1. 8 x 8' );
          if isEGA then

            Writeln( '    2. 8 x 14' );
          if isVGA then
            Writeln( '    3. 8 x 16' );
          Writeln;
          Write( '    Select by number (or Esc to quit) ' );
          choice := ReadKey;
          if Choice = Esc then
            begin
              ClrScr;
              Exit;
            end;
          if Choice = '1' then Valid := True;
          if ( choice = '2' ) and isEGA then Valid := True;
          if ( Choice = '3' ) and isVGA then Valid := True;
        Until Valid;

        { fetch and display selected font }
        Case choice of
          '1' : Font := ROM8x8;
          '2' : Font := ROM8x14;
          '3' : Font := ROM8x16;
        end;
        Browse( font );
      Until Done;
      GotoXY( 80,25 );
      Writeln;
      Writeln( 'Thanks you For using EditFont which is based on code from' );
      Writeln( '_Stretching Turbo Pascal_ by Kent Porter and Mike Floyd.' );
      Writeln;
      Writeln( 'This Program was developed 12 Apr 92 by Alan D. Mead.' );
    end.

    {--[bitfonts.pas]--}

    Unit BitFonts;
      { support For bit-mapped Text fonts on EGA/VGA }

    Interface

    Type
                  { enumeration of ROM hardware fonts }
      ROMfont = ( ROM8x14, ROM8x8, ROM8x16 );

                  { Characetr definition table }
      CharDefTable = Array[0..4095] of Byte;
      CharDefPtr   = ^CharDefTable;

                  { For geting Text Character generators }
      Char_table = Record
                     points : Byte;       { Char matrix height }
                     def    : CharDefPtr; { address of table }
                   end;

                  { font format }
      FontPackage = Record
                      FontInfo : Char_Table;
                      ch       : CharDefTable;
                    end;
      FontPackagePtr = ^FontPackage;

                  { table maintained by video ROM BIOS at 40h : 84h }
      VideoDataArea = Record
                        rows   : Byte;  { Text rows on screem - 1 }
                        points : Word;    { height of Char matrix }
                        info,               { EGA/VGA status info }
                        info_3,           { EGA/VGA configuration }
                        flags  : Word;               { misc flags }
                      end;           { remainder of table ignored }

                  { globally visible }
    Var
      VDA         : VideoDataArea Absolute $40:$84;   { equipment flags }
      isEGA,
      isVGA,
      isColor     : Boolean;
      CurrentFont : ROMfont; { default hardware font }

    Procedure GetCharGenInfo( font:ROMfont; Var table:Char_table );
    Procedure SetHardWareFont( font:ROMfont );
    Function FetchHardwareFont( font:ROMfont ):FontPackagePtr;
    Procedure LoadUserFont( pkg:FontPackagePtr );

    { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }

    Implementation

    Uses Dos, Crt {, TextScrn} ;

    Var reg:Registers;

    Procedure GetCharGenInfo( font:ROMfont; Var table:Char_table );
      begin
        if isEGA then
          begin
            reg.AH := $11;
            reg.AL := $30;
            Case font of
              ROM8x8  : reg.BH := 3;
              ROM8x14 : reg.BH := 2;
              ROM8x16 : reg.BH := 6;
            end;
            intr( $10,reg );
            table.def := ptr( reg.ES,reg.BP ); { address of definition table }
            Case font of
              ROM8x8  : table.points :=  8;
              ROM8x14 : table.points := 14;
              ROM8x16 : table.points := 16;
            end;
          end;
      end; { proc GetCharGenInfo }

    Procedure SetHardWareFont( font:ROMfont );
      begin
        if isEGA then
          begin
            Case Font of
              ROM8x14 : reg.AL := $11;
              ROM8x8  : reg.AL := $12;
              ROM8X16 : if isVGA then
                          reg.AL := $14
                        else
                          begin
                            reg.AL := $12;
                            font := ROM8x14;
                          end;
            end;
            reg.BL := 0;
            intr( $10,reg );
            CurrentFont := font;
          end;
      end; { proc SetHardwareFont }

    Function FetchHardwareFont( font:ROMfont ):FontPackagePtr;
      { Get a hardware font and place it on heap For user modification }
      Var pkg : FontPackagePtr;
      begin
        new( pkg );
        GetCharGenInfo( font,pkg^.fontinfo );
        pkg^.ch := pkg^.fontinfo.def^;
        FetchHardwareFont := pkg;
      end; { func FetchHardwareFont }

    Procedure LoadUserFont( pkg:FontPackagePtr );
      begin
        reg.AH := $11;
        Reg.AL := $10;
        reg.ES := seg( pkg^.ch );
        reg.BP := ofs( pkg^.ch );
        reg.BH := pkg^.FontInfo.points;
        reg.BL := 0;
        reg.CX := 256;
        reg.DX := 0;
        intr( $10,reg );
      end; { proc LoadUserFont }

    begin  { initialize }

      { determine adapter Type }
      isEGA := False;
      isVGA := False;
      if VDA.info <> 0 then
        begin
          isEGA := True;
          if ( VDA.flags and 1 ) = 1 then
            isVGA := True;
        end;

      { determine monitor Type }
      if isEGA then
        begin
          reg.AH := $12;
          reg.BL := $10;
          intr( $10,reg );
          if reg.BH = 0 then
            isCOLOR := True
          else
            isCOLOR := False;
                                       { ADM: this seems Really shaky! }
          { determine current font }
          if isVGA and ( VDA.rows = 24 ) then
            CurrentFont := ROM8x16
          else
            if isEGA and ( VDA.rows = 24 ) then
              CurrentFont := ROM8x14
            else
              CurrentFont := ROM8x8;
        end
    end.

[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]