'*** From GPrintX - E.F.Deel, 1/15/93
   '*** GPrintX2 made to work with Power Basic by
   '*** Peter Helsdon, (UK) 10th March 1994.
   '*** 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.
   DEFINT A-Z

   'Registers.
   %AX=1
   %BX=2
   %CX=3
   %DX=4
   %SI=5
   %DI=6
   %BP=7
   %DS=8
   %ES=9

   'Constants.
   %C1=256
   %C2=32767
   '*** Hi-res VGA mode
   SCREEN 12
   GPXFlg = 0
   '*** Create some boxes just to have a background
   LINE (0, 0)-(199, 199), 2, BF
   'Draw a green box
   LINE (200, 200)-(399, 399), 1, BF
   '...and a blue one
   LINE (400, 0)-(599, 199), 5, BF
   '...and a magenta one

   '*** Show 8x16 Characters
   Text$ = "Hello Eddie! (8x16)"
   'Some text
   Colr = 4
   'red text over existing background (BG=0)
   TSize = 16
   '8X16 characters
   X = 0
   'Start at extreme upper left
   Y = 0

   FOR i = 1 TO 40
   'print string 40 times
      CALL 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$ = "Hello Eddie! (8x14)"
   'Some text
   Colr = 64
   'black text over red background (4*16 + 0)
   TSize = 14
   '8X14 characters
   X = 487
   'Start at upper right
   Y = 0

   FOR i = 1 TO 34
   'print string 34 times
      CALL GPrintX (Text$,(X),Y,Colr,TSize)
      'print it
      X = X - 14
      'decrement <2 columns
      Y = Y + 14
      'increment a line
   NEXT i

   'and do it again

   '*** Show 8x8 Characters
   Text$ = "Hello Eddie! (8x8)"
   'Some text
   Colr = 2
   'green text over existing background (BG = 0)
   TSize = 8
   '8X8 characters
   X = 230
   'Start at top center
   Y = 0

   FOR i = 1 TO 60
   'print string 60 times
      CALL 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
   X=0
   Y=240
   Text$ = "Hello Eddie! (Double Wide)"
   CALL GPrintX (Text$,(X),Y,Colr,TSize)

   '*** Show 16x32 Characters
   Colr = 5
   'Magenta Text over current background
   TSize = 64
   'Double Wide, Double High
   Text$ = "Hello Eddie! (Double Wide, Double High)"
   X=0
   Y=320
   CALL GPrintX (Text$,(X),Y,Colr,TSize)

   DO
   'wait for a keystoke
   LOOP UNTIL INSTAT

   SCREEN 0
   END

   SUB GPrintX (Text$,X,Y,Colr,TSize)
      '*** GRAPHIC TEXT PRINTING SUBROUTINE ***

      Static SaveSze,FontSeg&,FontAdrs&,C2X(),GPXFlg,DX,DY,Font,Expand

      '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
      '   64 = Double wide, double high, 8x16 font
      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
         DIM C2X(15)
         'bit masks for producing double wide characters
         'pre-calculated masks provide max. speed
         C2X(0) = 0
         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
         REG %AX,&H1130

         SELECT CASE TSize
            CASE 8
               REG %BX,&H300
               DY = 8
               Font = 8
            CASE 14
               REG %BX,&H200
               DY = 14
               Font = 14
            CASE 16
               REG %BX,&H600
               DY = 16
               Font = 16
            CASE 32
               REG %BX,&H600
               DX = 16
               DY = 16
               Font = 16
               Expand = 1
            CASE 64
               REG %BX,&H600
               DX = 16
               DY = 32
               Font = 16
               Expand = 2
         END SELECT

         CALL Interrupt &H10
         FontSeg& =CLNG(REG(%ES))
         FontAdrs& =CLNG(REG(%BP))
         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&
      F=Font-1
      XX=X+7
      XXX=X+8
      XXXX=X+15

      FOR n = 1 TO l
      'For each character in string
         cc = ASC(MID$(Text$, n, 1))
         'get character code
         Addr& = Font * cc + FontAdrs&
         'find the address
         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 F
         '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
                  scanline& = C2X(hi) * %C1
                  IF scanline&>%C2 THEN scanline&=scanline&-65536
                  LINE (X, CY)-(X+7, CY), FG, , scanline&
                  'transfer double wide scan
                  scanline& = C2X(lo) * %C1
                  IF scanline&>%C2 THEN scanline&=scanline&-65536
                  'To prevent OVERFLOW.
                  LINE (XXX, CY)-(XXXX, CY), FG, , scanline&
                  'bytes to screen
                  CY = CY + 1
                  'next scan line
               NEXT k

               'again if double high
            ELSE
            'normal characters
               scanline& = scanline& * %C1
               IF scanline&>%C2 THEN scanline&=scanline&-65536
               LINE (X, CY)-(XX, CY),FG, , scanline&
               'tranfer scanline
               CY = CY + 1
               'next scan line
            END IF

         NEXT j

         X = X + DX
         'next character
         XX=X+7
         XXX=X+8
         XXXX=X+15
      NEXT n

   END SUB