QB64 Project Site

Unseen Machine's QB64 Project Site

Fancy Text in QBasic

I do not know of a way (though i expect there is one) to use fonts in QBasic. So I am always limited to 1 font at 1 size.(QB64 has overcome this with its font functions).

In order to show text of any other size, I first have to display it normally. I then analyse the text pixel by pixel and store its color data into an array. With this array I can now display text in a whole miriad of ways, a few of which of I have coded and are below. My personal favorite is spiral text.

Spiral Text v.01

'spiral text version 0.1 - by unseen machine

DECLARE SUB redraw ()
DECLARE SUB analyse ()

DIM SHARED text AS STRING
text$ = "S P I R A L"

DIM SHARED word(1 TO LEN(text$) * 8, 1 TO 16)
CALL analyse
CLS
CALL redraw

SUB analyse
CLS
SCREEN 12

COLOR 2: LOCATE 1, 1: PRINT text$

DIM px AS INTEGER, py AS INTEGER, cnt AS INTEGER, ltrcnt AS INTEGER

px = 1: py = 1

DO

        word(px, py) = POINT(px, py)

        PSET (px, py), 1
        px = px + 1

        IF px = LEN(text$) * 8 THEN

                px = 1
                py = py + 1

        END IF

LOOP UNTIL py = 16

END SUB

SUB redraw

CLS

DIM row AS INTEGER, cnt AS INTEGER, cstart AS SINGLE, cend AS SINGLE
DIM xrot AS INTEGER, yrot AS INTEGER, SCALE AS INTEGER, pan AS INTEGER

cstart = 0: cend = 6.2

xrot = 6: yrot = 6: SCALE = 3: pan = 30

OUT &H3C8, 1: OUT &H3C9, 10: OUT &H3C9, 10: OUT &H3C9, 60

DO

        row = 2

        DO

                DO

                        FOR i = cend TO cstart STEP -.03

                                x = (SCALE * 60 - (row * xrot / 4)) * TAN(COS(i))
                                y = SIN(SCALE * 60 - (row * yrot)) * TAN(SIN(i)) * pan

                                cnt = cnt + 1

                                IF word(cnt, row) > 0 THEN

                                        CIRCLE (x + 320, y + 220), SCALE + 1, 1
                                        'LINE (x + 320, y + 220)-STEP(12, 12), 1, BF

                                END IF

                                IF cnt = LEN(text$) * 8 THEN cnt = 0: EXIT DO

                        NEXT

                LOOP

                row = row + 1

        LOOP UNTIL row = 16

        cend = cend + .1
        cstart = cstart + .1

        now! = TIMER

        DO

                newnow! = TIMER

        LOOP UNTIL newnow! - now! >= .15

        LINE (1, 100)-(639, 280), 0, BF

LOOP UNTIL INKEY$ = CHR$(27)

END SUB

Rotating Text v.01

Use the arrow keys to change x/y rotation and +/- to change the size. 

'rotating text version 0.1 - by unseen machine

DECLARE SUB redraw ()
DECLARE SUB analyse ()

DIM SHARED text AS STRING
text$ = " ROTATING TEXT!"

DIM SHARED word(1 TO LEN(text$) * 8, 1 TO 16)
CALL analyse
CLS
CALL redraw

SUB analyse
CLS
SCREEN 12

COLOR 2: LOCATE 1, 1: PRINT text$

DIM px AS INTEGER, py AS INTEGER, cnt AS INTEGER, ltrcnt AS INTEGER

px = 1: py = 1

DO

        word(px, py) = POINT(px, py)

        PSET (px, py), 1
        px = px + 1

        IF px = LEN(text$) * 8 THEN

                px = 1
                py = py + 1

        END IF

LOOP UNTIL py = 16

END SUB

SUB redraw

CLS

DIM row AS INTEGER, cnt AS INTEGER, cstart AS SINGLE, cend AS SINGLE
DIM xrot AS INTEGER, yrot AS INTEGER, scale AS INTEGER

cstart = 0: cend = 6.2

xrot = 6: yrot = 6: scale = 3

DO

        OUT &H3C8, 1: OUT &H3C9, 10: OUT &H3C9, 20: OUT &H3C9, 63

        row = 2

        DO

                LOCATE 1, 1: PRINT "X rotation : "; xrot
                LOCATE 2, 1: PRINT "Y rotation : "; yrot
                LOCATE 4, 1: PRINT "Scale (- +) : "; scale

                DO

                        FOR i = cstart TO cend STEP .055

                                x = (scale * 60 - (row * xrot)) * COS(i)
                                y = (scale * 60 - (row * yrot)) * SIN(i)

                                cnt = cnt + 1

                                IF word(cnt, row) > 0 THEN

                                        CIRCLE (x + 320, y + 220), scale, 1

                                END IF

                                IF cnt = LEN(text$) * 8 THEN cnt = 0: EXIT DO

                        NEXT

                LOOP

                row = row + 1

        LOOP UNTIL row = 16

        cend = cend + .1
        cstart = cstart + .1

        SLEEP 1

        CLS

        kb$ = INKEY$

        SELECT CASE kb$

                CASE CHR$(0) + CHR$(80)

                        xrot = xrot - 1

                CASE CHR$(0) + CHR$(72)

                        xrot = xrot + 1

                CASE CHR$(0) + CHR$(75)

                        yrot = yrot - 1

                CASE CHR$(0) + CHR$(77)

                        yrot = yrot + 1

                CASE CHR$(43)

                        scale = scale + 1

                CASE CHR$(45)

                        IF scale > 0 THEN scale = scale - 1

        END SELECT

LOOP UNTIL kb$ = CHR$(27)

END SUB

Large Scrolling Text - v.02

Enter your text (has to be 5 letters or more) or if you just want to see it working press enter at the text entry screen,  Press esc to go to the next mode (there are 6) press esc again to exit

' Large scrolling text version .02 - UNSEEN MACHINE - 19 March 2010
DECLARE SUB shadow ()
DECLARE SUB asamegafont ()
DECLARE SUB justletter ()
DECLARE SUB ledoff ()
DECLARE SUB showletter ()
DECLARE SUB drawled ()
DECLARE SUB analyse ()
DECLARE SUB gettext ()
DECLARE SUB italshad ()
DECLARE SUB italics ()


'These 4 bits(and the assoiting sub)are whats needed to run any chosen sub

DIM SHARED maintext AS STRING, ltrnum AS INTEGER
CALL gettext
DIM SHARED textdata(1 TO LEN(maintext$), 1 TO 16, 1 TO 8) AS INTEGER
CALL analyse


CALL drawled

ltrnum = 1
DO

        CALL showletter

LOOP UNTIL INKEY$ = CHR$(27)

CLS
ltrnum = 1
DO

        CALL justletter

LOOP UNTIL INKEY$ = CHR$(27)

CLS
ltrnum = 1
DO

        CALL asamegafont

LOOP UNTIL INKEY$ = CHR$(27)

CLS
ltrnum = 1
DO

        CALL shadow

LOOP UNTIL INKEY$ = CHR$(27)

CLS
ltrnum = 1
DO

        CALL italics

LOOP UNTIL INKEY$ = CHR$(27)

CLS
ltrnum = 1
DO

        CALL italshad

LOOP UNTIL INKEY$ = CHR$(27)

SUB analyse
SCREEN 12
CLS
DIM pcntr AS INTEGER, px AS INTEGER, py AS INTEGER, cnt AS INTEGER
DIM ltrcnt AS INTEGER, ltr AS STRING * 1, pcntc AS INTEGER

COLOR 15
DO

        ltrcnt = ltrcnt + 1
        ltr$ = MID$(maintext$, ltrcnt, 1)
        LOCATE 1, 1: PRINT ltr$
        px = 0: py = 0: pcntr = 0: pcntc = 0

        DO
                pcntr = pcntr + 1

                DO
                        pcntc = pcntc + 1
                        textdata(ltrcnt, pcntr, pcntc) = POINT(px, py)
                        px = px + 1
                LOOP UNTIL pcntc = 8

                pcntc = 0: px = 0: py = py + 1

        LOOP UNTIL pcntr = 16

LOOP UNTIL ltrcnt = LEN(maintext$)

END SUB

SUB asamegafont
LINE (0, 79)-(679, 360), 0, BF
DIM oldltrnum AS INTEGER, rowcnt AS INTEGER, colcnt AS INTEGER
DIM lx AS INTEGER, ly AS INTEGER
LOCATE 2, 2: PRINT "As a huge font"
lx = 80: ly = 15

oldltrnum = ltrnum

DO
        lx = 80
        oldly = ly
        rowcnt = 0
        DO
                rowcnt = rowcnt + 1
                colcnt = 0
                DO
                        colcnt = colcnt + 1

                        IF textdata(ltrnum, rowcnt, colcnt) > 0 THEN
                                PSET (ly, lx), 3
                                DRAW "bd10l10u20r20d20l10"
                                PSET (ly, lx), 0
                                PAINT (ly, lx), 3, 3
                        END IF

                        ly = ly + 20
                LOOP UNTIL colcnt = 8
                lx = lx + 20: ly = oldly


        LOOP UNTIL rowcnt = 16

        ly = oldly + 180
        ltrnum = ltrnum + 1

LOOP UNTIL ltrnum = oldltrnum + 4

now! = TIMER

DO
        newnow! = TIMER
LOOP UNTIL newnow! - now! >= .8

IF ltrnum < LEN(maintext$) THEN

        ltrnum = oldltrnum + 1

ELSEIF ltrnum >= LEN(maintext$) THEN

        ltrnum = 1

END IF


END SUB

SUB drawled
CLS
LOCATE 2, 2: PRINT "As a LED MATRIX"
DIM ledx AS INTEGER, ledy AS INTEGER, ledcnt AS INTEGER, colcnt AS INTEGER

ledx = 80


DO
        ledy = 10

        DO
                CIRCLE (ledy, ledx), 9, 12
                colcnt = colcnt + 1
                ledcnt = ledcnt + 1
                ledy = ledy + 20
        LOOP UNTIL colcnt = 32

        ledx = ledx + 20
        colcnt = 0
LOOP UNTIL ledcnt = 512

 


END SUB

SUB gettext
SCREEN 0
CLS
LOCATE 2, 30: PRINT "Led scrolling text .02"
LOCATE 5, 2: INPUT "Enter your choosen text : ", maintext$

IF LEN(maintext$) < 5 THEN maintext$ = "- M$ PDS - * WWW.QBASIC.COM * - QB64 - "
maintext$ = "    " + maintext$ + "      "


END SUB

SUB italics

LINE (0, 79)-(679, 360), 0, BF

DIM oldltrnum AS INTEGER, rowcnt AS INTEGER, colcnt AS INTEGER
DIM lx AS INTEGER, ly AS INTEGER, oldly AS INTEGER
ly = 10

oldltrnum = ltrnum

LOCATE 2, 2: PRINT "As a Huge Italic font"
DO

        lx = 80
        oldly = ly
        rowcnt = 0
        DO
                IF rowcnt >= 1 THEN oldly = ly - 2
                rowcnt = rowcnt + 1
                colcnt = 0
                DO
                        colcnt = colcnt + 1

                        IF textdata(ltrnum, rowcnt, colcnt) > 0 THEN
                                PSET (ly, lx), 15
                                DRAW "bd10l10u20r20d20l10"
                                PSET (ly, lx), 0
                                PAINT (ly, lx), 15, 15
                        END IF

                        ly = ly + 20
                LOOP UNTIL colcnt = 8
                lx = lx + 20: ly = oldly

        LOOP UNTIL rowcnt = 16

        ly = oldly + 180
        ltrnum = ltrnum + 1

LOOP UNTIL ltrnum = oldltrnum + 4

now! = TIMER

DO
        newnow! = TIMER
LOOP UNTIL newnow! - now! >= .8

IF ltrnum < LEN(maintext$) THEN

        ltrnum = oldltrnum + 1

ELSEIF ltrnum >= LEN(maintext$) THEN

        ltrnum = 1

END IF

END SUB

SUB italshad
LINE (0, 79)-(679, 360), 0, BF
DIM oldltrnum AS INTEGER, rowcnt AS INTEGER, colcnt AS INTEGER
DIM lx AS INTEGER, ly AS INTEGER, oldly AS INTEGER
ly = 10

oldltrnum = ltrnum
LOCATE 2, 2: PRINT "As a Huge Font with Italics and Shadow effect"
DO
        lx = 80
        oldly = ly
        rowcnt = 0
        DO
                IF rowcnt >= 1 THEN oldly = ly - 2
                rowcnt = rowcnt + 1
                colcnt = 0
                DO
                        colcnt = colcnt + 1

                        IF textdata(ltrnum, rowcnt, colcnt) > 0 THEN
                                PSET (ly + 5, lx + 5), 4
                                DRAW "bd10l10u20r20d20l10"
                                PSET (ly + 5, lx + 5), 0
                                PAINT (ly + 5, lx + 5), 4, 4
                                PSET (ly, lx), 14
                                DRAW "bd10l10u20r20d20l10"
                                PSET (ly, lx), 0
                                PAINT (ly, lx), 14, 14
                        END IF

                        ly = ly + 20
                LOOP UNTIL colcnt = 8
                lx = lx + 20: ly = oldly

        LOOP UNTIL rowcnt = 16

        ly = oldly + 180
        ltrnum = ltrnum + 1

LOOP UNTIL ltrnum = oldltrnum + 4

now! = TIMER

DO
        newnow! = TIMER
LOOP UNTIL newnow! - now! >= .4

IF ltrnum < LEN(maintext$) THEN

        ltrnum = oldltrnum + 1

ELSEIF ltrnum >= LEN(maintext$) THEN

        ltrnum = 1

END IF

END SUB

SUB justletter

DIM oldltrnum AS INTEGER, rowcnt AS INTEGER, colcnt AS INTEGER
DIM lx AS INTEGER, ly AS INTEGER

lx = 80: ly = 10

oldltrnum = ltrnum
LOCATE 2, 2: PRINT "As a Non Matrix LED Diplay"
DO
        lx = 80
        oldly = ly
        rowcnt = 0
        DO
                rowcnt = rowcnt + 1
                colcnt = 0
                DO
                        colcnt = colcnt + 1

                        IF textdata(ltrnum, rowcnt, colcnt) > 0 THEN
                                CIRCLE (ly, lx), 9, 2
                                PAINT (ly, lx), 2, 2
                        END IF

                        ly = ly + 20
                LOOP UNTIL colcnt = 8
                lx = lx + 20: ly = oldly


        LOOP UNTIL rowcnt = 16

        ly = oldly + 180
        ltrnum = ltrnum + 1

LOOP UNTIL ltrnum = oldltrnum + 4

now! = TIMER

DO
        newnow! = TIMER
LOOP UNTIL newnow! - now! >= .6

CALL ledoff

IF ltrnum < LEN(maintext$) THEN

        ltrnum = oldltrnum + 1

ELSEIF ltrnum >= LEN(maintext$) THEN

        ltrnum = 1

END IF

END SUB

SUB ledoff

DIM ledx AS INTEGER, ledy AS INTEGER, ledcnt AS INTEGER, colcnt AS INTEGER

ledx = 80


DO
        ledy = 10

        DO
                IF POINT(ledy, ledx) > 0 THEN PAINT (ledy, ledx), 0, 12
                colcnt = colcnt + 1
                ledcnt = ledcnt + 1
                ledy = ledy + 20
        LOOP UNTIL colcnt = 32

        ledx = ledx + 20
        colcnt = 0
LOOP UNTIL ledcnt = 512


END SUB

SUB shadow
LINE (0, 79)-(679, 360), 0, BF
DIM oldltrnum AS INTEGER, rowcnt AS INTEGER, colcnt AS INTEGER
DIM lx AS INTEGER, ly AS INTEGER

lx = 80: ly = 10

oldltrnum = ltrnum
LOCATE 2, 2: PRINT "As a Huge Font with shadow effect"
DO
        lx = 80
        oldly = ly
        rowcnt = 0
        DO
                rowcnt = rowcnt + 1
                colcnt = 0
                DO
                        colcnt = colcnt + 1

                        IF textdata(ltrnum, rowcnt, colcnt) > 0 THEN
                                PSET (ly + 5, lx + 5), 7
                                DRAW "bd10l10u20r20d20l10"
                                PSET (ly + 5, lx + 5), 0
                                PAINT (ly + 5, lx + 5), 7, 7
                                PSET (ly, lx), 1
                                DRAW "bd10l10u20r20d20l10"
                                PSET (ly, lx), 0
                                PAINT (ly, lx), 1, 1
                        END IF

                        ly = ly + 20
                LOOP UNTIL colcnt = 8
                lx = lx + 20: ly = oldly


        LOOP UNTIL rowcnt = 16

        ly = oldly + 180
        ltrnum = ltrnum + 1

LOOP UNTIL ltrnum = oldltrnum + 4

now! = TIMER

DO
        newnow! = TIMER
LOOP UNTIL newnow! - now! >= .6

IF ltrnum < LEN(maintext$) THEN

        ltrnum = oldltrnum + 1

ELSEIF ltrnum >= LEN(maintext$) THEN

        ltrnum = 1

END IF


END SUB

SUB showletter

DIM oldltrnum AS INTEGER, rowcnt AS INTEGER, colcnt AS INTEGER
DIM lx AS INTEGER, ly AS INTEGER

lx = 80: ly = 10

oldltrnum = ltrnum

DO
        lx = 80
        oldly = ly
        rowcnt = 0
        DO
                rowcnt = rowcnt + 1
                colcnt = 0
                DO
                        colcnt = colcnt + 1

                        IF textdata(ltrnum, rowcnt, colcnt) > 0 THEN
                                PAINT (ly, lx), 4, 12
                        ELSE
                                PAINT (ly, lx), 0, 12
                        END IF

                        ly = ly + 20
                LOOP UNTIL colcnt = 8
                lx = lx + 20: ly = oldly


        LOOP UNTIL rowcnt = 16

        ly = oldly + 180
        ltrnum = ltrnum + 1

LOOP UNTIL ltrnum = oldltrnum + 4

now! = TIMER

DO
        newnow! = TIMER
LOOP UNTIL newnow! - now! >= .6
       
       
IF ltrnum < LEN(maintext$) THEN

        ltrnum = oldltrnum + 1

ELSEIF ltrnum >= LEN(maintext$) THEN

        ltrnum = 1

END IF

 

END SUB