'===========================================================================
' Subject: SCALABLE FONT                     Date: 10-24-98 (14:11)       
' Author:  Anders Olofsson                   Code: QB, QBasic, PDS        
' Origin:  anders.olofsson@mail.bip.net    Packet: GRAPHICS.ABC
'===========================================================================
'
' Scalable font, by Anders Olofsson 1998.
'----------------------------------------------------------------------------
'    
'                  e-mail: anders.olofsson@mail.bip.net
'
'  This program uses single-precision math to scale the font,
'  which is made at runtime in the "sub makefont".
'
'   The font contains all characters 0 to 255 and it requires 4096
'   bytes of stringspace.
'

DEFINT A-Z
DECLARE SUB fCenter (Text$, Y%, XSize%, YSize%, Colour%)
DECLARE SUB makefont ()
DECLARE SUB fPRINT (Text$, X%, Y%, C%, XSize%, YSize%)

DIM SHARED Font(255) AS STRING 'The font, takes 4096 bytes.

SCREEN 12

DIM SHARED Bit(0 TO 7) AS INTEGER, ScreenWid AS INTEGER

 ScreenWid = 640  'Used by centering routine

' Make this program faster:
FOR T = 0 TO 7: Bit(T) = 2 ^ T: NEXT

makefont

PAINT (0, 0), 1

LINE (50, 10)-(600, 80), 4, BF: LINE (50, 10)-(600, 80), 0, B

 fPRINT "Scalable font by:", 60, 20, 15, 30, 50
 fPRINT "Anders Olofsson 1998.", 100, 100, 0, 20, 15
 fPRINT "Anders Olofsson 1998.", 102, 102, 12, 20, 15

 fCenter "This font is fully resizeable and uses bit patterns to store the font.", 130, 8, 20, 10

 fCenter "This program is freeware!!", 170, 22, 28, 14

 fCenter "But if you use it, please write my name somewhere", 200, 8, 24, 11
 fCenter "in your program.", 225, 8, 24, 11

 fCenter "Scalable font, by Anders Olofsson 1998", 280, 12, 24, 13
 fCenter "E-mail: anders.olofsson@mail.bip.net", 310, 8, 40, 12

END

SUB fCenter (Text$, Y, XSize, YSize, Colour)
 fPRINT Text$, ScreenWid \ 2 - (XSize \ 2) * LEN(Text$), Y, Colour, XSize, YSize
END SUB

SUB fPRINT (Text$, X, Y, Colour, XSize, YSize)
X1 = X: T$ = RTRIM$(Text$)

YP! = 15 / YSize: FP! = 7 / XSize

 FOR z = 1 TO LEN(T$)
   S = ASC(MID$(T$, z, 1)): YF! = 0
   FOR pY = 0 TO YSize - 1
    FB! = 0: FB% = 0: FontBits% = ASC(MID$(Font(S), YF% + 1, 1))
    FOR pX = 0 TO XSize - 1
     Clr = -((FontBits% AND Bit(7 - FB%)) <> 0)
     IF Clr THEN PSET (X1 + pX, Y + pY), Colour
     FB! = FB! + FP!: FB% = FB!
    NEXT
    YF! = YF! + YP!: YF% = YF!
   NEXT pY
   X1 = X1 + XSize
 NEXT z

' Original unscalable font-print:
' FOR z = 1 TO LEN(T$)
'   S = ASC(MID$(T$, z, 1))
'   FOR pY = 0 TO 15
'     LINE (X1, Y + pY)-STEP(7, 0), C, , ASC(MID$(Font(S), pY + 1, 1)) * 128
'   NEXT pY
'   X1 = X1 + 8
' NEXT z

END SUB

SUB makefont
COLOR 7
 LOCATE 12, 10: PRINT "Creating internal font...": PALETTE 15, 0: COLOR 15
  FOR A = 0 TO 255
    IF A <> 7 AND A <> 12 THEN LOCATE 1, 1: PRINT CHR$(A)
     B$ = SPACE$(16)
      FOR Y = 0 TO 15
        L = 0
        FOR X = 0 TO 7
         IF POINT(X, Y) THEN L = L XOR Bit(X XOR 7)
        NEXT
       MID$(B$, Y + 1, 1) = CHR$(L)
      NEXT
     Font(Num) = B$
     Num = Num + 1
  NEXT
 PALETTE: CLS
END SUB