'===========================================================================
' Subject: VGA FONTS (USING VGA-BIOS)        Date: 06-07-97 (11:13)       
' Author:  Andras Hoeffken                   Code: QB, PDS                
' Origin:  FidoNet QUIK_BAS Echo           Packet: EGAVGA.ABC
'===========================================================================
'the following tool introduces new features of printing text in 
'SCREEN 12 mode. Especially useful to label e.g. graphical curves.

'VGA_FONT - VGA-(Hardware)Fonts Vs.1.0 for QuickBasic 4.5 and Basic PDS 7.0
'           With SCREEN 12 three fonts are taken from the VGA-BIOS and used to
'           construct 5 different sizes of screen text.

'June 1996  Andras Hoeffken,  2:2480/13.34 @fidonet / ah@confusion.rmc.de

'Adapted to QB4.5 from the original version:
     '*** GPrintX - E.F.Deel, 1/15/93
     '*** Print graphics mode characters in selected
     '*** sizes at any location; with or without background.
     '*** Public domain, use it, abuse it, but don't blame me.
     '*** For Microsoft Professional Basic PDS 7.0 (originally NOT for QB4.5)

     DEFINT A-Z

     TYPE regtype
       ax    AS INTEGER
       bx    AS INTEGER
       cx    AS INTEGER
       dx    AS INTEGER
       bp    AS INTEGER
       si    AS INTEGER
       di    AS INTEGER
       flags AS INTEGER
       ds    AS INTEGER
       es    AS INTEGER
     END TYPE
     DIM SHARED inreg AS regtype, outreg AS regtype
     DECLARE SUB interruptx (inum, inreg AS regtype, outreg AS regtype)
    
     DECLARE SUB GPrintX (Text$, X, Y, Colr, TSize)

     SCREEN 12        'Standard VGA Graphics 480x640x16

     LOCATE 1, 27
     PRINT "Textfonts for SCREEN 12"
     LOCATE 2, 26
     PRINT "(INT 10h, AH=11h, AL=30h)"

     LINE (0, 0)-(199, 199), 2, BF      ' a green box
     LINE (200, 200)-(399, 399), 1, BF  ' a blue
     LINE (400, 0)-(599, 199), 5, BF    ' a magenta

'*** Show 8x16 Characters
     Text$ = "Example of text (8x16)" 'Some text
     Colr = 4                      'red text over existing background (BG=0)
     TSize = 16                    '8X16 characters
     X = 0: Y = 0                  'Start at extreme upper left
     FOR i = 1 TO 40               'print string 40 times
       GPrintX Text$, (X), Y, Colr, TSize    'print it
       X = X + 12                  'increment one & a half columns
       Y = Y + 12                  '... and 3/4 of a line
     NEXT i                        'and do it again

'*** Show 8x14 Characters
     Text$ = "Example of text (8x14)" 'Some text
     Colr = 64                     'black text over red background (4*16 + 0)
     TSize = 14                    '8X14 characters
     X = 487: Y = 0                'Start at upper right
     FOR i = 1 TO 34               'print string 34 times
       GPrintX Text$, (X), Y, Colr, TSize    'print it
       X = X - 16                  'decrement 2 columns
       Y = Y + 14                  'increment a line
     NEXT i                        'and do it again

'*** Show 8x8 Characters
     Text$ = "Example of text (8x8)" 'Some text
     Colr = 2                      'green text over existing background (BG=0)
     TSize = 8                     '8X8 characters
     X = 248: Y = 32               'Start near top center
     FOR i = 1 TO 55               'print string 55 times
       GPrintX Text$, (X), Y, Colr, TSize    'print it
       Y = Y + 8                   'increment a line
     NEXT i                        'and do it again

'*** Show 16x16 Characters
     Colr = 71                     'Gray letters over red background (4*16+7)
     TSize = 32                    'Double Wide
     Text$ = "Example of double wide text (16x16)"
     GPrintX Text$, 0, 240, Colr, TSize

'*** Show 16x32 Characters
     Colr = 7 * 16                 '5 = Magenta Text over current background
     TSize = 64                    'Double Wide, Double High
     Text$ = "Double wide, Double high text (16x32)"
     GPrintX Text$, 0, 270, Colr, TSize

'*** Finish
     GPrintX "Press a key to continue", 456, 310, 7 * 16 + 4, 16
     DO: LOOP UNTIL LEN(INKEY$)    'wait for a keystroke

     SCREEN 0
END '=======================================================================

SUB GPrintX (Text$, X, Y, Colr, TSize) STATIC
   '(STATIC ==> all local variables are defined static!)

   '*** GRAPHIC TEXT PRINTING SUBROUTINE ***
   'X, Y = Graphics mode pixel coordinates
   'Colr = combined FG and BG (BG*16 + FG), BG = 0 leaves existing background
   'TSize is coded text size
   '   8  = 8x8 font
   '   14 = 8x14 font
   '   16 = 8x16 font
   '   32 = Double wide 8x16 font  (--> 16x16)
   '   64 = Double wide, double high, 8x16 font (--> 16x32)

     l = LEN(Text$)
     IF l = 0 THEN EXIT SUB    'abort if no text is given

     IF GPXFlg = 0 THEN        'test avoids re-initializing 2wide masks
       REDIM C2X(15)           'bit masks for producing double wide characters
       C2X(0) = 0              'pre-calculated masks provide max. speed
       C2X(1) = 3: C2X(2) = 12: C2X(3) = 15: C2X(4) = 48: C2X(5) = 51
       C2X(6) = 60: C2X(7) = 63: C2X(8) = 192: C2X(9) = 195: C2X(10) = 204
       C2X(11) = 207: C2X(12) = 240: C2X(13) = 243: C2X(14) = 252
       C2X(15) = 255
       GPXFlg = -1        'Set the flag so we don't do this again next time
     END IF

     IF TSize <> SaveSze THEN 'another test so we don't repeat if not required
       dx = 8: Expand = 0
       SELECT CASE TSize
         CASE 8: Ftype = &H300: Font = 8: DY = 8
         CASE 14: Ftype = &H200: Font = 14: DY = 14
         CASE 16: Ftype = &H600: Font = 16: DY = 16
         CASE 32: Ftype = &H600: Font = 16: DY = 16: dx = 16: Expand = 1
         CASE 64: Ftype = &H600: Font = 16: DY = 32: dx = 16: Expand = 2
       END SELECT
       inreg.ax = &H1130                'AH = 11h: access of an internal font
                                        'AL = 30h: get address of a font
       inreg.bx = Ftype                 'BX = type of font
       CALL interruptx(&H10, inreg, outreg) 'INT 10h, gives:
       FontSeg = outreg.es                  ' segment
       FontAdrs = outreg.bp                 ' offset
       SaveSze = TSize                  'save the size for next time
     END IF

     FG = Colr AND 15                   'split out FG and BG colors
     BG = Colr \ 16

     DEF SEG = FontSeg                  'segment of VGA-BIOS

     FOR i = 1 TO l                     'For each character in string
       cc = ASC(MID$(Text$, i, 1))      'get character code (0...255)
       Addr = Font * cc + FontAdrs      'find the address (in VGA-BIOS)
       CY = Y                           'top of character location
       IF BG THEN LINE (X, Y)-(X + dx - 1, Y + DY - 1), BG, BF'draw background
       FOR j = 0 TO Font - 1            'For each scanline in font
         scanline = PEEK(Addr + j)      'get the scanline byte
         IF Expand THEN                 'Double wide or Double High characters
           lo = scanline AND 15         'low nibble of scanline
           hi = scanline \ 16           'high nibble
           FOR k = 1 TO Expand
             zwi& = CLNG(C2X(hi)) * 256 'long integer: lo byte --> hi byte
             IF zwi& > 32767 THEN scanline = zwi& - 65536 ELSE scanline = zwi&
             LINE (X, CY)-(X + 7, CY), FG, , scanline  'tranfer scanline
             zwi& = CLNG(C2X(lo)) * 256 'long integer: lo byte --> hi byte
             IF zwi& > 32767 THEN scanline = zwi& - 65536 ELSE scanline = zwi&
             LINE (X + 8, CY)-(X + 15, CY), FG, , scanline  'tranfer scanline
             CY = CY + 1                'next scan line
           NEXT k                       'again if double high
         ELSE                           'normal characters
           zwi& = CLNG(scanline) * 256  'long integer: lo byte --> hi byte
           IF zwi& > 32767 THEN scanline = zwi& - 65536 ELSE scanline = zwi&
           LINE (X, CY)-(X + 7, CY), FG, , scanline  'tranfer scanline
           CY = CY + 1                  'next scan line
         END IF
       NEXT j
       X = X + dx                       'next character
     NEXT i
    
     DEF SEG                            'back to DGROUP

END SUB