'===========================================================================
' Subject: WRITE/SCROLL TEXT AS DOT MATRIX   Date: 04-22-99 (07:57)       
' Author:  Dieter Folger                     Code: QB, QBasic, PDS        
' Origin:  folger@bamberg.baynet.de        Packet: GRAPHICS.ABC
'===========================================================================
'-------------------------------------------------------------------------
' DOTTEXT.BAS for QBASIC
' Writes text in mode 13 as dot matrix
' One line can be vertically scrolled (SUB MoveText)
' See demo program for usage
' Note that chars > Ascii 127 do not work
' Freware (c) 1998 by D. Folger
'-------------------------------------------------------------------------
DECLARE SUB MoveText (y%)
DECLARE FUNCTION Bin$ (b%)
DECLARE SUB WriteText (txt$, y%, Col%)
DEFINT A-Z
SCREEN 13
LINE (0, 0)-(360, 190), 8, BF

WriteText "The", 5, 14  'line 5, color 14
WriteText "All Basic Code", 40, 47
WriteText "Archives", 80, 60
WriteText "Created by W. Yu", 110, 11
LOCATE 25, 10: PRINT "Press any key to quit";
MoveText 40 'text on line 40 is vertically scrolled

END

'---------------------------------------------
FUNCTION Bin$ (b) 'QBASIC has no BIN$ function
'---------------------------------------------
DO
    b$ = LTRIM$(STR$(b MOD 2)) + b$
    b = b \ 2
LOOP UNTIL b = 0
Bin$ = RIGHT$("00000000" + b$, 8)
END FUNCTION

'---------------
SUB MoveText (y)
'---------------
DIM TextField1(1 TO 26)
DIM TextField2(1 TO 2740)
DO
   GET (0, y)-(1, y + 16), TextField1
   GET (1, y)-(318, y + 16), TextField2
   PUT (0, y), TextField2, PSET
   PUT (318, y), TextField1, PSET
   k$ = INKEY$
LOOP UNTIL LEN(k$)
END SUB

'-------------------------
SUB WriteText (txt$, y, Col)
'-------------------------
IF LEN(txt$) > 20 THEN txt$ = LEFT$(txt$, 20) '20 chars maximum
x = (320 - LEN(txt$) * 16) \ 2 - 2 'calculate x pos
FOR i = 1 TO LEN(txt$)
    Char = ASC(MID$(txt$, i, 1))
    FOR j = 1 TO 8
        DEF SEG = &HFFA6 'seg of font
        By = PEEK(&HE + Char * 8 + j - 1)'offset of char line byte
        By$ = Bin$(By)
        FOR k = 1 TO 8
            IF MID$(By$, k, 1) = "1" THEN 'then set pixel
               DEF SEG = &HA000 'color video seg
               yy& = y + j * 2: xx = (i - 1) * 16 + x + k * 2
               POKE yy& * 320 + xx, Col 'write pixel into video buffer
               DEF SEG
            END IF
        NEXT
    NEXT
NEXT
DEF SEG
END SUB