mishap22 font routines.bas

#lang "qb"
Option GoSub

'MISHAP22 Engine: font routines (ps5)
'MISER'S HOUSE ANTHOLOGY PROJECT - MISHAP22 ENGINE - MISHAP22.BAS

CONST H = "0123456789ABCDEF"
CONST PI = 3.141592654#

DECLARE SUB LOADFONT (BYVAL INDEX AS INTEGER, BYVAL HEXDAT AS STRING)
DECLARE SUB DRAWFONT (BYVAL TXTDAT AS STRING)
DECLARE FUNCTION HEXTOLONG(BYVAL HEXDAT AS STRING) AS LONG
DECLARE FUNCTION GLYPHADDR(BYVAL INDEX AS LONG) AS LONG
DECLARE FUNCTION HEX2BYTE(BYVAL VALUE AS STRING) AS LONG
DIM SHARED FONT(0 TO GLYPHADDR(256)-1) AS INTEGER
DECLARE FUNCTION INPUTFONT (BYVAL TXTDAT AS STRING) AS STRING

FUNCTION INPUTFONT (BYVAL TXTDAT AS STRING) AS STRING
    DIM X AS INTEGER
    DIM Y AS INTEGER
    DIM C AS STRING
    DIM CI AS STRING
    DIM T AS INTEGER
    X = POS(0)
    Y = CSRLN
    C = INKEY$
    CI = ""
    PRINT
    X = POS(0)
    Y = CSRLIN - 1
    DO
        GAMEHUD
        LOCATE Y, X
        T = INT(TIMER * 4!) AND 1
        LOCATE Y, X
        DRAWFONT (CI + MID$(CHR$(254) + CHR$(255), T + 1, 1))
        C = INKEY$'
        IF C = CHR$(8) AND LEN(CI) > 0 THEN
            LOCATE Y, X + LEN(CI)
            LINE ((POS(0) - 1) * 8, (CSRLIN - 1) * 8)-(POS(0) * 8 - 1, CSRLIN * 8 - 1), 0, BF
            CI = LEFT$(CI, LEN(CI) - 1)
        ELSEIF C = CHR$(13) THEN
            LOCATE Y, X + LEN(CI)
            LINE ((POS(0) - 1) * 8, (CSRLIN - 1) * 8)-(POS(0) * 8 - 1, CSRLIN * 8 - 1), 0, BF
            INPUTFONT = CI
            EXIT DO
        ELSE
            IF LEN(C) = 1 AND LEN(CI) < 38 THEN
                IF ASC(C) >= 32 AND ASC(C) <= 127 THEN
                    CI = CI + C
                END IF
            END IF
        END IF
    LOOP
    PRINT
END FUNCTION

FUNCTION HEX2BYTE(BYVAL VALUE AS STRING) AS LONG
    HEX2BYTE = (((INSTR(1, UCASE$(H), LEFT$(VALUE, 1)) - 1) AND 15) * 16) OR ((INSTR(1, UCASE$(H), MID$(VALUE, 2, 1)) - 1) AND 15)
END FUNCTION

FUNCTION HEXTOLONG(BYVAL HEXDAT AS STRING) AS LONG
    DIM P AS LONG
    P = ((INSTR(1, UCASE$(H), UCASE$(MID$(HEXDAT, Y * 2 + 1, 1))) - 1) AND 15) * 16
    P = P OR (INSTR(1, UCASE$(H), UCASE$(MID$(HEXDAT, Y * 2 + 2, 1))) - 1) AND 15
    HEXTOLONG=P
END FUNCTION
FUNCTION GLYPHADDR(BYVAL INDEX AS LONG) AS LONG
    GLYPHADDR=40*INDEX
END FUNCTION
SUB LOADFONT (BYVAL INDEX AS INTEGER, BYVAL HEXDAT AS STRING)
    'DIM H AS STRING
    'H = "0123456789ABCDEF"
    IF INDEX < 0 OR INDEX > 255 THEN
        EXIT SUB
    END IF
    CLS
    PALETTE 15, 0
    DIM X AS INTEGER
    DIM Y AS INTEGER
    DIM LINESTYLE AS INTEGER
    FOR Y = 0 TO 7
        LINESTYLE=HEXTOLONG(HEXDAT)
        LINE (0, Y)-(15, Y), 8, , P
    NEXT
    GET (8, 0)-(15, 7), FONT%(GLYPHADDR(INDEX))
    LINE (8, 0)-(15, 7), 0, BF
    FOR Y = 0 TO 7
        LINESTYLE=HEXTOLONG(HEXDAT)
        LINE (0, Y)-(15, Y), 7, , LINESTYLE
    NEXT
    PUT (8, 0), FONT(GLYPHADDR(INDEX)), OR
    GET (8, 0)-(15, 7), FONT(GLYPHADDR(INDEX))
    PALETTE 15, (63 * 65536) OR (63 * 256) OR 63
END SUB

SUB DRAWFONT (BYVAL TXTDAT AS STRING)
    DIM X AS INTEGER
    DIM Y AS INTEGER
    DIM BUF AS STRING
    DIM LP AS LONG
    DIM RP AS LONG
    X = POS(0)
    Y = CSRLIN
    IF LEN(TXTDAT) = 0 THEN
        PRINT
        EXIT SUB
    END IF
    BUF = TXTDAT + SPACE$(1)
    DO
        IF LEN(BUF) = 0 THEN EXIT DO
        RP = 1
        WHILE RP < 42 AND RP > 0
            LP = RP
            RP = INSTR(LP + 1, BUF, SPACE$(1))
        WEND
        FOR RP = 1 TO LP - 1
            X = POS(0)
            Y = CSRLIN
            IF X < 40 THEN
                LOCATE CSRLIN, POS(0) + 1
            ELSEIF Y < 25 THEN
                LOCATE CSRLIN + 1, 1
            ELSE
                LOCATE 25, 1
            END IF
            IF ASC(MID$(BUF, RP, 1)) <> 32 THEN
                PUT ((X - 1) * 8, (Y - 1) * 8), FONT(ASC(MID$(BUF, RP, 1)) * 40), PSET
            ELSE
                LINE ((X - 1) * 8, (Y - 1) * 8)-(X * 8 - 1, Y * 8 - 1), 0, BF
            END IF
        NEXT
        X = POS(0)
        Y = CSRLIN
        IF Y < 25 THEN
            LOCATE CSRLIN, 1
        ELSE
            LOCATE 25, 1
        END IF
        PRINT
        BUF = RIGHT$(BUF, LEN(BUF) - LP)
    LOOP
END SUB