Scribble Font Builder

[James D Jarvis]

I wanted to use a vector drawn font in another program, maybe using the draw command. I started to hardcode the font and I realized that was actually the hard way to do it. So I built this font editor. I realized I could ditch the draw commands for now too (I may or may not return to using them, it's working without that.)
I'm not done with this yet and there is surely a demo program to follow to give folks ideas for their own programs to make use of this font style (or write a better one). 
It's functional at this point. 

Code: (Select All)

'scribble font builder
'a simple editor to build simple vector fonts for use in QB64 programs
'by James D. Jarvis
_Title "Scribble Font Builder v0.01"
Dim Shared S1&, bt&
Dim Shared buttoncount
buttoncount = 0
Dim Shared Klr(0 To 255) As _Unsigned Long
Dim Shared kl As _Unsigned Long
Dim Shared bk As _Unsigned Long
Dim Shared pencolor As _Unsigned Long
Dim Shared penstate, gridstate
Dim Shared cbgrid$(160, 2)
Dim Shared charcode$(0 To 255), current_ch
Dim Shared button(500) As _Unsigned Long 'the color tags for the buttons
Dim Shared fonstspec$ 'not used yet
S1& = _NewImage(640, 480, 32) ' the main screen
Screen S1&
_PrintMode _KeepBackground , S1&
bt& = _NewImage(640, 480, 32) ' the button tracker
penstate = 0
gridstate = 1
buildrefcolors
pencolor = Klr(15)
drawgrid
draw_buttonbar
_Dest S1&
current_ch = Asc("A")
For c = 0 To 255
    charcode$(c) = ""
Next c
_ControlChr Off
displaychar
displaypenstate
showcharcode
lastadd$ = ""
'***********************************************
'main loop
'***********************************************
Do
    ' Screen bt&
    _Limit 1000
    Line (10, 50)-(15, 55), Klr&(kl), BF
    ask$ = InKey$
    If ask$ <> "" Then
        Select Case ask$
            Case Chr$(27), "Q", "q"
                Line (1, 370)-(639, 479), Klr(0), BF
                Locate 25, 25
                Print "  QUIT PROGRAM ?  "
                Locate 26, 25
                Print "press    Y or N"
                Choice$ = pickkey$("YyNn")
                If LCase$(Choice$) = "n" Then
                    'all is well
                    showcharcode
                Else
                    GoTo exitmain
                End If
            Case "<", ","
                current_ch = current_ch - 1
                If current_ch < 0 Then current_ch = 255
                displaychar
                showcharcode
                hidegrid
                drawcode
                Line (140, 70)-(150, 86), Klr(0), BF
            Case ">", "."
                current_ch = current_ch + 1
                If current_ch > 255 Then current_ch = 0
                displaychar
                showcharcode
                hidegrid
                drawcode
                Line (140, 70)-(150, 86), Klr(0), BF
            Case "D", "d"
                penstate = 1
                displaypenstate
            Case "U", "u"
                penstate = 0
                charcode$(current_ch) = charcode$(current_ch) + "U"
                showcharcode
                displaypenstate
        End Select

        ask$ = ""
    End If
    Mouser mx, my, mb
    If mb Then
        Do While mb 'wait for button release
            Mouser mx, my, mb
            _Source bt&
            bk = Point(mx, my)
            _Dest S1&
        Loop
        '******** button handling code ************
        ' check position clicked in button tracking image
        ' get the color in that location
        'i color matches that assigned to button execute button commands
        '***************************************
        For kc = 1 To buttoncount
            If bk = button(kc) Then
                bk = kc
            End If
        Next kc
        If bk > 0 And bk < buttoncount + 1 Then
            Select Case bk
                Case 1 TO 160
                    If penstate = 1 Then
                        add$ = cbgrid$(bk, 1) + cbgrid$(bk, 2)
                        If add$ <> lastadd$ Then
                            charcode$(current_ch) = charcode$(current_ch) + add$
                            lastadd$ = add$
                            showcharcode
                            drawcode
                        End If
                    Else
                        Beep
                    End If
                Case 161 'newfont
                    savefont
                    For c = 0 To 255
                        charcode$(c) = ""
                    Next c
                    current_ch = 65
                    displaychar
                    hidegrid
                    drawcode

                Case 162 'save font
                    savefont
                Case 163 'loadfotn
                    loadfont
                Case 164 'enter asc code
                    Line (1, 370)-(639, 479), Klr(0), BF
                    Locate 25, 25
                    Print "Enter ASC CODE FOR NEW CHARACTER"
                    Locate 26, 25
                    Print "(0 to 255)"
                    Input ncc
                    If ncc > -1 And ncc < 256 Then
                        current_ch = ncc
                        displaychar
                        hidegrid
                        drawcode
                        Line (140, 70)-(150, 86), Klr(0), BF

                    End If
                    showcharcode
                Case 165 'select previous character
                    current_ch = current_ch - 1
                    If current_ch < 0 Then current_ch = 255
                    displaychar
                    showcharcode
                    hidegrid
                    drawcode
                    Line (140, 70)-(150, 86), Klr(0), BF
                Case 166 'select next character
                    current_ch = current_ch + 1
                    If current_ch > 255 Then current_ch = 0
                    displaychar
                    showcharcode
                    hidegrid
                    drawcode
                    Line (140, 70)-(150, 86), Klr(0), BF
                Case 167 'change penstate
                    If penstate = 0 Then
                        penstate = 1
                        displaypenstate
                    Else
                        penstate = 0
                        displaypenstate
                        charcode$(current_ch) = charcode$(current_ch) + "U"
                        showcharcode
                    End If
                Case 168 'grid on or grid off
                    If gridstate = 0 Then
                        gridstate = 1
                    Else
                        gridstate = 0
                    End If
                    hidegrid
                Case 169 'erase current character
                    Line (1, 370)-(639, 479), Klr(0), BF
                    Locate 25, 25
                    Print "ERASE CURENT CHARACTER ?"
                    Locate 26, 25
                    Print "press    Y or N"
                    Choice$ = pickkey$("YyNn")
                    If LCase$(Choice$) = "n" Then
                        showcharcode
                    Else
                        Line (140, 70)-(150, 86), Klr(0), BF
                        charcode$(current_ch) = ""
                        showcharcode
                        hidegrid
                    End If
            End Select

        End If
    End If
Loop Until InKey$ = Chr$(27)
exitmain:
Screen bt&
Sub buildrefcolors
    For c = 0 To 255
        Klr(c) = _RGB32(c, c, c) 'all grey for now
    Next c
    'very slightly cooled EGA palette
    Klr(1) = _RGB32(0, 0, 170) 'ega_blue
    Klr(2) = _RGB32(0, 170, 0) 'ega_green
    Klr(3) = _RGB32(0, 170, 170) 'ega_cyan
    Klr(4) = _RGB32(170, 0, 0) 'ega_red
    Klr(5) = _RGB32(170, 0, 170) 'ega_magenta
    Klr(6) = _RGB32(170, 85, 0) 'ega_brown
    Klr(7) = _RGB32(170, 170, 170) 'ega_litgray
    Klr(8) = _RGB32(85, 85, 85) 'ega_gray
    Klr(9) = _RGB32(85, 85, 250) 'ega_ltblue
    Klr(10) = _RGB32(85, 250, 85) 'ega_ltgreen
    Klr(11) = _RGB32(85, 250, 250) 'ega_ltcyan
    Klr(12) = _RGB32(250, 85, 85) 'ega_ltred
    Klr(13) = _RGB32(250, 85, 250) 'ega_ltmagenta
    Klr(14) = _RGB32(250, 250, 85) 'ega_yellow
    Klr(15) = _RGB32(250, 250, 250) 'ega_white
End Sub
Sub Mouser (x, y, b)
    mi = _MouseInput
    b = _MouseButton(1)
    x = _MouseX
    y = _MouseY
End Sub
Sub drawgrid
    'draws grid on main scrren and button click spots on button tracker image
    xx = 200: YY = 50
    _Dest S1&
    For x = 0 To 9
        Line (xx + x * 20, YY)-(xx + x * 20, YY + 300), Klr(2)
    Next x
    For y = 0 To 15
        Line (xx, YY + y * 20)-(xx + 180, YY + y * 20), Klr(2)
    Next y
    br = 0
    bg = 1
    bb = 1
    _Dest bt&
    For x = 0 To 9
        For y = 0 To 15
            br = br + 1
            button(br) = _RGB32(br, bg, bb)
            Circle (xx + x * 20, YY + y * 20), 6, _RGB32(br, bg, bb)
            Paint (xx + x * 20, YY + y * 20), _RGB32(br, bg, bb), _RGB32(br, bg, bb)
            cbgrid$(br, 1) = Hex$(x)
            cbgrid$(br, 2) = Hex$(y)
        Next y
    Next x
    buttoncount = buttoncount + 160
End Sub
Sub fillbox (x1, y1, x2, y2, thickness, style, fill As _Unsigned Long)
    xa = x1: xb = x2: ya = y1: yb = y2
    For l = 1 To thickness
        Line (xa, ya)-(xb, yb), pencolor, B , style
        xa = xa + 1: xb = xb - 1
        ya = ya + 1: yb = yb - 1
    Next l
    If fill > 0 Then
        Line (xa, ya)-(xb, yb), fill, BF
    End If
End Sub
Sub draw_buttonbar
    br = 200: bg = 0: bb = 2
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 5, 30, 100, 2, "NEW font", Klr(8)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 40, 30, 100, 2, "SAVE font", Klr(8)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 75, 30, 100, 2, "LOAD font", Klr(8)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 110, 30, 100, 2, "CHARACTER", Klr(8)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 145, 30, 30, 2, "<", Klr(2)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 75, 145, 30, 30, 2, ">", Klr(2)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 180, 30, 100, 2, "PEN U/D", Klr(2)
    _Dest bt&
    Line (200, 10)-(380, 40), button(buttoncount), BF 'penstate banner will aslo act as same button
    _Dest S1&
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 215, 30, 100, 2, "Grid ON/OFF", Klr(2)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 240, 30, 100, 2, "Erase", Klr(4)
End Sub
Sub displaypenstate
    xx = 200: YY = 30
    If penstate = 1 Then
        fillbox 200, 10, 380, 40, 2, &HFFFFFFFF, Klr(2)
        text$ = "PEN DOWN"
        px = 290 - _PrintWidth(text$) / 2
        _PrintString (px, 16), text$
    Else
        Line (200, 10)-(380, 40), Klr(20), BF
        fillbox 200, 10, 380, 40, 2, &HF0F0FF0F, Klr(4)
        text$ = "!! PEN UP !!"
        px = 290 - _PrintWidth(text$) / 2
        _PrintString (px, 16), text$
    End If
End Sub
Sub displaychar
    _PrintMode _FillBackground
    _PrintString (52, 150), Chr$(current_ch)
    _PrintMode _KeepBackground
End Sub
Sub drawbutton (bx, by, hh, ww, thick, text$, fill As _Unsigned Long)
    fsize = _FontHeight
    _Dest S1&
    cx = ww / 2
    cy = hh / 2 - fsize / 2
    pw = _PrintWidth(text$)
    pw = Int(pw / 2)
    Color pencolor
    fillbox bx, by, bx + ww - 1, by + hh - 1, thick, &HFFFFFFFF, fill
    _PrintString (bx + cx - pw, by + cy), text$
    _Dest bt&
    Line (bx, by)-(bx + ww - 1, by + hh - 1), button(buttoncount), BF
End Sub
Sub showcharcode
    Line (1, 370)-(639, 479), Klr(0), BF
    tx$ = "Character: " + Chr$(current_ch)
    _PrintString (1, 370), tx$
    _PrintString (1, 390), charcode$(current_ch)
End Sub
Sub drawcode
    xx = 200
    yy = 50
    lx$ = ""
    ly$ = ""
    points = 0
    If Len(charcode$(current_ch)) > 0 Then
        For c = 1 To Len(charcode$(current_ch))
            If Mid$(charcode$(current_ch), c, 1) <> "U" Then
                nx$ = Mid$(charcode$(current_ch), c, 1)
                ny$ = Mid$(charcode$(current_ch), c + 1, 1)
                c = c + 1
                If points = 0 Then
                    lx$ = nx$
                    ly$ = ny$
                    points = points + 1
                Else
                    points = points + 1
                    If points = 2 Then
                        lx = Val(lx$): ly = Val("&H" + ly$)
                        nx = Val(nx$): ny = Val("&H" + ny$)
                        Line (xx + lx * 20, yy + ly * 20)-(xx + nx * 20, yy + ny * 20), Klr(15)
                        points = points - 1
                        lx$ = nx$
                        ly$ = ny$
                    End If
                End If
            Else
                lx$ = ""
                ly$ = ""
                points = 0
            End If
        Next c
    End If
    scribblechar 140, 70, Chr$(current_ch), 1, Klr(15)
End Sub
Sub hidegrid
    xx = 200: yy = 50
    Line (200, 50)-(380, 350), Klr(0), BF
    If gridstate = 0 Then
        'Line (200, 50)-(380, 350), Klr(0), BF
    Else
        For x = 0 To 9
            Line (xx + x * 20, yy)-(xx + x * 20, yy + 300), Klr(2)
        Next x
        For y = 0 To 15
            Line (xx, yy + y * 20)-(xx + 180, yy + y * 20), Klr(2)
        Next y
    End If
    drawcode
End Sub
Sub scribblechar (x, y, t$, s, tk As _Unsigned Long)
    xx = x
    yy = y
    lx$ = ""
    ly$ = ""
    points = 0
    tt = Asc(t$)
    If Len(charcode$(tt)) > 0 Then
        For c = 1 To Len(charcode$(tt))
            If Mid$(charcode$(tt), c, 1) <> "U" Then
                nx$ = Mid$(charcode$(tt), c, 1)
                ny$ = Mid$(charcode$(tt), c + 1, 1)
                c = c + 1
                If points = 0 Then
                    lx$ = nx$
                    ly$ = ny$
                    points = points + 1
                Else
                    points = points + 1
                    If points = 2 Then
                        lx = Val(lx$): ly = Val("&H" + ly$)
                        nx = Val(nx$): ny = Val("&H" + ny$)
                        Line (xx + lx * s, yy + ly * s)-(xx + nx * s, yy + ny * s), tk
                        points = points - 1
                        lx$ = nx$
                        ly$ = ny$
                    End If
                End If
            Else
                lx$ = ""
                ly$ = ""
                points = 0
            End If
        Next c
    End If
End Sub
Function pickkey$ (list$)
    pickflag = 0
    Do
        _Limit 60
        x = _KeyHit
        x = -x
        If x > 0 And x < 256 Then
            A$ = Chr$(x)
            If InStr(list$, A$) Then pickflag = 1
            pickkey$ = A$
        End If
    Loop Until pickflag = 1
End Function
Sub savefont
    Line (1, 370)-(639, 479), Klr(0), BF
    Locate 25, 25
    Print "Save Current Font ?"
    Locate 26, 25
    Print "press    Y or N"
    Choice$ = pickkey$("YyNn")
    If LCase$(Choice$) = "n" Then
        showcharcode
    Else
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "Please Enter a File Name"
        Locate 26, 25
        Input filename$
        fileout$ = filename$
        Open fileout$ For Output As #1
        Write #1, " ****************************************************************************************"
        oline$ = "         " + filename$
        Write #1, oline$
        Write #1, " ****************************************************************************************"
        Write #1, " This A SCribble Font wrtitten for use in QB64 programs"
        Write #1, " please see https://qb64phoenix.com/forum/index.php for more on scribble fonts and QB64PE"
        Write #1, " ****************************************************************************************"
        Write #1, "10x16"
        For c = 0 To 255
            Write #1, charcode$(c)
        Next c
        Close #1
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "File Saved"
        _Delay 0.5
    End If
    showcharcode
End Sub
Sub loadfont
    Line (1, 370)-(639, 479), Klr(0), BF
    Locate 25, 25
    Print "Save Current Font before Loading NEW FONT ?"
    Locate 26, 25
    Print "press    Y or N"
    Choice$ = pickkey$("YyNn")
    If LCase$(Choice$) = "Y" Then
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "Please Enter a File Name"
        Locate 26, 25
        Input filename$
        fileout$ = filename$
        Open fileout$ For Output As #1
        Write #1, " ****************************************************************************************"
        oline$ = "         " + filename$
        Write #1, oline$
        Write #1, " ****************************************************************************************"
        Write #1, " This A SCribble Font wrtitten for use in QB64 programs"
        Write #1, " please see https://qb64phoenix.com/forum/index.php for more on scribble fonts and QB64PE"
        Write #1, " ****************************************************************************************"
        Write #1, "10x16"
        For c = 0 To 255
            Write #1, charcode$(c)
        Next c
        Close #1
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "File Saved"
        _Delay 1
        Choice$ = "n"
    End If
    If LCase$(Choice$) = "n" Then
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "Please Enter a File Name of FONT to LOAD"
        Locate 26, 25
        Input filename$
        fileout$ = filename$
        filein$ = filename$
        Open filein$ For Input As #1
        For headerread = 1 To 6
            Input #1, dummy$
        Next headerread
        Input #1, fontspec$ 'not used yet but keeeping in place for revision
        For cc = 0 To 255
            Input #1, charcode$(cc)
        Next cc
        Close #1
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "FONT LOADED"
        Choice$ = "z"
        _Delay 1
    End If
    showcharcode
End Sub

[James D Jarvis]

The current demo with a hard coded font.

https://qb64phoenix.com/forum/showthread.php?tid=415

[James D Jarvis]

Added a very simple help option and listed the key commands the program accepts. Using U and D to raise and lower the pen is much quicker for the user than clicking on the on screen buttons and doesn't require a mouse move.

Code: (Select All)

'scribble font builder   v0.02
'a simple editor to build simple vector fonts for use in QB64 programs
'by James D. Jarvis
_Title "Scribble Font Builder v0.02"
Dim Shared S1&, bt&
Dim Shared buttoncount
buttoncount = 0
Dim Shared Klr(0 To 255) As _Unsigned Long
Dim Shared kl As _Unsigned Long
Dim Shared bk As _Unsigned Long
Dim Shared pencolor As _Unsigned Long
Dim Shared penstate, gridstate
Dim Shared cbgrid$(160, 2)
Dim Shared charcode$(0 To 255), current_ch
Dim Shared button(500) As _Unsigned Long 'the color tags for the buttons
Dim Shared fonstspec$ 'not used yet
S1& = _NewImage(640, 480, 32) ' the main screen
Screen S1&
_PrintMode _KeepBackground , S1&

bt& = _NewImage(640, 480, 32) ' the button tracker
penstate = 0
gridstate = 1
buildrefcolors
pencolor = Klr(15)
drawgrid
draw_buttonbar
_Dest S1&
current_ch = Asc("A")
For c = 0 To 255
    charcode$(c) = ""
Next c
_ControlChr Off
displaychar
displaypenstate
showcharcode
lastadd$ = ""
Locate 2, 55: Print "Key Commands"
Locate 4, 57: Print "Q - Quit"
Locate 5, 57: Print "U - Pen Up"
Locate 6, 57: Print "D - Pen Down"
Locate 7, 57: Print "< - Last Char."
Locate 8, 57: Print "> - Next Char."
'Locate 9, 57: Print "X - Undo "
Locate 20, 57: Print "? - Help"

'***********************************************
'main loop
'***********************************************
Do
    ' Screen bt&
    _Limit 1000
    Line (10, 50)-(15, 55), Klr&(kl), BF
    ask$ = keyup$
    If ask$ <> "" Then
        Select Case ask$
            Case Chr$(27), "Q", "q"
                Line (1, 370)-(639, 479), Klr(0), BF
                Locate 25, 25
                Print "  QUIT PROGRAM ?  "
                Locate 26, 25
                Print "press    Y or N"
                Choice$ = pickkey$("YyNn")
                If LCase$(Choice$) = "n" Then
                    'all is well
                    showcharcode
                Else
                    GoTo exitmain
                End If
            Case "<", ","
                current_ch = current_ch - 1
                If current_ch < 0 Then current_ch = 255
                displaychar
                showcharcode
                hidegrid
                drawcode
                Line (140, 70)-(150, 86), Klr(0), BF
            Case ">", "."
                current_ch = current_ch + 1
                If current_ch > 255 Then current_ch = 0
                displaychar
                showcharcode
                hidegrid
                drawcode
                Line (140, 70)-(150, 86), Klr(0), BF
            Case "D", "d"
                penstate = 1
                displaypenstate
            Case "U", "u"
                penstate = 0
                charcode$(current_ch) = charcode$(current_ch) + "U"
                showcharcode
                displaypenstate
            Case "X", "x"
                '   codekill = 0
                '   totl = Len(charcode$(current_ch))
                '  If Right$(charcode$(current_ch), 1) = "U" Then
                ' codekill = 1
                'Else
                '   codekill = 2
                '  End If
                ' charcode$(current_ch) = Left$(charcode$(curent_ch), totl - codekill)
                'codekill = 0
                'displaychar
                'showcharcode
                'hidegrid
                'drawcode
                'ask$ = ""
            Case "?", "/" 'help
                showhelp
                showcharcode
        End Select

        ask$ = ""
        lastask$ = ask$
    End If
    Mouser mx, my, mb
    If mb Then
        Do While mb 'wait for button release
            Mouser mx, my, mb
            _Source bt&
            bk = Point(mx, my)
            _Dest S1&
        Loop
        '******** button handling code ************
        ' check position clicked in button tracking image
        ' get the color in that location
        'i color matches that assigned to button execute button commands
        '***************************************
        For kc = 1 To buttoncount
            If bk = button(kc) Then
                bk = kc
            End If
        Next kc
        If bk > 0 And bk < buttoncount + 1 Then
            Select Case bk
                Case 1 TO 160
                    If penstate = 1 Then
                        add$ = cbgrid$(bk, 1) + cbgrid$(bk, 2)
                        If add$ <> lastadd$ Then
                            charcode$(current_ch) = charcode$(current_ch) + add$
                            lastadd$ = add$
                            showcharcode
                            drawcode
                        End If
                    Else
                        Beep
                    End If
                Case 161 'newfont
                    savefont
                    For c = 0 To 255
                        charcode$(c) = ""
                    Next c
                    current_ch = 65
                    displaychar
                    hidegrid
                    drawcode

                Case 162 'save font
                    savefont
                Case 163 'loadfotn
                    loadfont
                Case 164 'enter asc code
                    Line (1, 370)-(639, 479), Klr(0), BF
                    Locate 25, 25
                    Print "Enter ASC CODE FOR NEW CHARACTER"
                    Locate 26, 25
                    Print "(0 to 255)"
                    Input ncc
                    If ncc > -1 And ncc < 256 Then
                        current_ch = ncc
                        displaychar
                        hidegrid
                        drawcode
                        Line (140, 70)-(150, 86), Klr(0), BF

                    End If
                    showcharcode
                Case 165 'select previous character
                    current_ch = current_ch - 1
                    If current_ch < 0 Then current_ch = 255
                    displaychar
                    showcharcode
                    hidegrid
                    drawcode
                    Line (140, 70)-(150, 86), Klr(0), BF
                Case 166 'select next character
                    current_ch = current_ch + 1
                    If current_ch > 255 Then current_ch = 0
                    displaychar
                    showcharcode
                    hidegrid
                    drawcode
                    Line (140, 70)-(150, 86), Klr(0), BF
                Case 167 'change penstate
                    If penstate = 0 Then
                        penstate = 1
                        displaypenstate
                    Else
                        penstate = 0
                        displaypenstate
                        charcode$(current_ch) = charcode$(current_ch) + "U"
                        showcharcode
                    End If
                Case 168 'grid on or grid off
                    If gridstate = 0 Then
                        gridstate = 1
                    Else
                        gridstate = 0
                    End If
                    hidegrid
                Case 169 'erase current character
                    Line (1, 370)-(639, 479), Klr(0), BF
                    Locate 25, 25
                    Print "ERASE CURENT CHARACTER ?"
                    Locate 26, 25
                    Print "press    Y or N"
                    Choice$ = pickkey$("YyNn")
                    If LCase$(Choice$) = "n" Then
                        showcharcode
                    Else
                        Line (140, 70)-(150, 86), Klr(0), BF
                        charcode$(current_ch) = ""
                        showcharcode
                        hidegrid
                    End If
            End Select

        End If
    End If
    'Loop Until InKey$ = Chr$(27)
Loop
exitmain:
System


Sub buildrefcolors
    For c = 0 To 255
        Klr(c) = _RGB32(c, c, c) 'all grey for now
    Next c
    'very slightly cooled EGA palette
    Klr(1) = _RGB32(0, 0, 170) 'ega_blue
    Klr(2) = _RGB32(0, 170, 0) 'ega_green
    Klr(3) = _RGB32(0, 170, 170) 'ega_cyan
    Klr(4) = _RGB32(170, 0, 0) 'ega_red
    Klr(5) = _RGB32(170, 0, 170) 'ega_magenta
    Klr(6) = _RGB32(170, 85, 0) 'ega_brown
    Klr(7) = _RGB32(170, 170, 170) 'ega_litgray
    Klr(8) = _RGB32(85, 85, 85) 'ega_gray
    Klr(9) = _RGB32(85, 85, 250) 'ega_ltblue
    Klr(10) = _RGB32(85, 250, 85) 'ega_ltgreen
    Klr(11) = _RGB32(85, 250, 250) 'ega_ltcyan
    Klr(12) = _RGB32(250, 85, 85) 'ega_ltred
    Klr(13) = _RGB32(250, 85, 250) 'ega_ltmagenta
    Klr(14) = _RGB32(250, 250, 85) 'ega_yellow
    Klr(15) = _RGB32(250, 250, 250) 'ega_white
End Sub
Sub Mouser (x, y, b)
    mi = _MouseInput
    b = _MouseButton(1)
    x = _MouseX
    y = _MouseY
End Sub
Sub drawgrid
    'draws grid on main scrren and button click spots on button tracker image
    xx = 200: YY = 50
    _Dest S1&
    For x = 0 To 9
        Line (xx + x * 20, YY)-(xx + x * 20, YY + 300), Klr(2)
    Next x
    For y = 0 To 15
        Line (xx, YY + y * 20)-(xx + 180, YY + y * 20), Klr(2)
    Next y
    br = 0
    bg = 1
    bb = 1
    _Dest bt&
    For x = 0 To 9
        For y = 0 To 15
            br = br + 1
            button(br) = _RGB32(br, bg, bb)
            Circle (xx + x * 20, YY + y * 20), 6, _RGB32(br, bg, bb)
            Paint (xx + x * 20, YY + y * 20), _RGB32(br, bg, bb), _RGB32(br, bg, bb)
            cbgrid$(br, 1) = Hex$(x)
            cbgrid$(br, 2) = Hex$(y)
        Next y
    Next x
    buttoncount = buttoncount + 160
End Sub
Sub fillbox (x1, y1, x2, y2, thickness, style, fill As _Unsigned Long)
    xa = x1: xb = x2: ya = y1: yb = y2
    For l = 1 To thickness
        Line (xa, ya)-(xb, yb), pencolor, B , style
        xa = xa + 1: xb = xb - 1
        ya = ya + 1: yb = yb - 1
    Next l
    If fill > 0 Then
        Line (xa, ya)-(xb, yb), fill, BF
    End If
End Sub
Sub draw_buttonbar
    br = 200: bg = 0: bb = 2
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 5, 30, 100, 2, "NEW font", Klr(8)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 40, 30, 100, 2, "SAVE font", Klr(8)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 75, 30, 100, 2, "LOAD font", Klr(8)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 110, 30, 100, 2, "CHARACTER", Klr(8)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 145, 30, 30, 2, "<", Klr(2)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 75, 145, 30, 30, 2, ">", Klr(2)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 180, 30, 100, 2, "PEN U/D", Klr(2)
    _Dest bt&
    Line (200, 10)-(380, 40), button(buttoncount), BF 'penstate banner will aslo act as same button
    _Dest S1&
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 215, 30, 100, 2, "Grid ON/OFF", Klr(2)
    buttoncount = buttoncount + 1
    bg = bg + 1
    button(buttoncount) = _RGB32(br, bg, bb)
    drawbutton 5, 240, 30, 100, 2, "Erase", Klr(4)
End Sub
Sub displaypenstate
    xx = 200: YY = 30
    If penstate = 1 Then
        fillbox 200, 10, 380, 40, 2, &HFFFFFFFF, Klr(2)
        text$ = "PEN DOWN"
        px = 290 - _PrintWidth(text$) / 2
        _PrintString (px, 16), text$
    Else
        Line (200, 10)-(380, 40), Klr(20), BF
        fillbox 200, 10, 380, 40, 2, &HF0F0FF0F, Klr(4)
        text$ = "!! PEN UP !!"
        px = 290 - _PrintWidth(text$) / 2
        _PrintString (px, 16), text$
    End If
End Sub
Sub displaychar
    _PrintMode _FillBackground
    _PrintString (52, 150), Chr$(current_ch)
    _PrintMode _KeepBackground
End Sub
Sub drawbutton (bx, by, hh, ww, thick, text$, fill As _Unsigned Long)
    fsize = _FontHeight
    _Dest S1&
    cx = ww / 2
    cy = hh / 2 - fsize / 2
    pw = _PrintWidth(text$)
    pw = Int(pw / 2)
    Color pencolor
    fillbox bx, by, bx + ww - 1, by + hh - 1, thick, &HFFFFFFFF, fill
    _PrintString (bx + cx - pw, by + cy), text$
    _Dest bt&
    Line (bx, by)-(bx + ww - 1, by + hh - 1), button(buttoncount), BF
End Sub
Sub showcharcode
    Line (1, 370)-(639, 479), Klr(0), BF
    tx$ = "Character: " + Chr$(current_ch)
    _PrintString (1, 370), tx$
    _PrintString (1, 390), charcode$(current_ch)
End Sub
Sub drawcode
    xx = 200
    yy = 50
    lx$ = ""
    ly$ = ""
    points = 0
    If Len(charcode$(current_ch)) > 0 Then
        For c = 1 To Len(charcode$(current_ch))
            If Mid$(charcode$(current_ch), c, 1) <> "U" Then
                nx$ = Mid$(charcode$(current_ch), c, 1)
                ny$ = Mid$(charcode$(current_ch), c + 1, 1)
                c = c + 1
                If points = 0 Then
                    lx$ = nx$
                    ly$ = ny$
                    points = points + 1
                Else
                    points = points + 1
                    If points = 2 Then
                        lx = Val(lx$): ly = Val("&H" + ly$)
                        nx = Val(nx$): ny = Val("&H" + ny$)
                        Line (xx + lx * 20, yy + ly * 20)-(xx + nx * 20, yy + ny * 20), Klr(15)
                        points = points - 1
                        lx$ = nx$
                        ly$ = ny$
                    End If
                End If
            Else
                lx$ = ""
                ly$ = ""
                points = 0
            End If
        Next c
    End If
    scribblechar 140, 70, Chr$(current_ch), 1, Klr(15)
End Sub
Sub hidegrid
    xx = 200: yy = 50
    Line (200, 50)-(380, 350), Klr(0), BF
    If gridstate = 0 Then
        'Line (200, 50)-(380, 350), Klr(0), BF
    Else
        For x = 0 To 9
            Line (xx + x * 20, yy)-(xx + x * 20, yy + 300), Klr(2)
        Next x
        For y = 0 To 15
            Line (xx, yy + y * 20)-(xx + 180, yy + y * 20), Klr(2)
        Next y
    End If
    drawcode
End Sub
Sub scribblechar (x, y, t$, s, tk As _Unsigned Long)
    xx = x
    yy = y
    lx$ = ""
    ly$ = ""
    points = 0
    tt = Asc(t$)
    If Len(charcode$(tt)) > 0 Then
        For c = 1 To Len(charcode$(tt))
            If Mid$(charcode$(tt), c, 1) <> "U" Then
                nx$ = Mid$(charcode$(tt), c, 1)
                ny$ = Mid$(charcode$(tt), c + 1, 1)
                c = c + 1
                If points = 0 Then
                    lx$ = nx$
                    ly$ = ny$
                    points = points + 1
                Else
                    points = points + 1
                    If points = 2 Then
                        lx = Val(lx$): ly = Val("&H" + ly$)
                        nx = Val(nx$): ny = Val("&H" + ny$)
                        Line (xx + lx * s, yy + ly * s)-(xx + nx * s, yy + ny * s), tk
                        points = points - 1
                        lx$ = nx$
                        ly$ = ny$
                    End If
                End If
            Else
                lx$ = ""
                ly$ = ""
                points = 0
            End If
        Next c
    End If
End Sub
Function pickkey$ (list$)
    pickflag = 0
    Do
        _Limit 60
        x = _KeyHit
        x = -x
        If x > 0 And x < 256 Then
            A$ = Chr$(x)
            If InStr(list$, A$) Then pickflag = 1
            pickkey$ = A$
        End If
    Loop Until pickflag = 1
End Function
Sub savefont
    Line (1, 370)-(639, 479), Klr(0), BF
    Locate 25, 25
    Print "Save Current Font ?"
    Locate 26, 25
    Print "press    Y or N"
    Choice$ = pickkey$("YyNn")
    If LCase$(Choice$) = "n" Then
        showcharcode
    Else
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "Please Enter a File Name"
        Locate 26, 25
        Input filename$
        fileout$ = filename$
        Open fileout$ For Output As #1
        Write #1, " ****************************************************************************************"
        oline$ = "         " + filename$
        Write #1, oline$
        Write #1, " ****************************************************************************************"
        Write #1, " This A SCribble Font wrtitten for use in QB64 programs"
        Write #1, " please see https://qb64phoenix.com/forum/index.php for more on scribble fonts and QB64PE"
        Write #1, " ****************************************************************************************"
        Write #1, "10x16"
        For c = 0 To 255
            Write #1, charcode$(c)
        Next c
        Close #1
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "File Saved"
        _Delay 0.5
    End If
    showcharcode
End Sub
Sub loadfont
    Line (1, 370)-(639, 479), Klr(0), BF
    Locate 25, 25
    Print "Save Current Font before Loading NEW FONT ?"
    Locate 26, 25
    Print "press    Y or N"
    Choice$ = pickkey$("YyNn")
    If LCase$(Choice$) = "Y" Then
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "Please Enter a File Name"
        Locate 26, 25
        Input filename$
        fileout$ = filename$
        Open fileout$ For Output As #1
        Write #1, " ****************************************************************************************"
        oline$ = "         " + filename$
        Write #1, oline$
        Write #1, " ****************************************************************************************"
        Write #1, " This A SCribble Font wrtitten for use in QB64 programs"
        Write #1, " please see https://qb64phoenix.com/forum/index.php for more on scribble fonts and QB64PE"
        Write #1, " ****************************************************************************************"
        Write #1, "10x16"
        For c = 0 To 255
            Write #1, charcode$(c)
        Next c
        Close #1
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "File Saved"
        _Delay 1
        Choice$ = "n"
    End If
    If LCase$(Choice$) = "n" Then
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "Please Enter a File Name of FONT to LOAD"
        Locate 26, 25
        Input filename$
        fileout$ = filename$
        filein$ = filename$
        Open filein$ For Input As #1
        For headerread = 1 To 6
            Input #1, dummy$
        Next headerread
        Input #1, fontspec$ 'not used yet but keeeping in place for revision
        For cc = 0 To 255
            Input #1, charcode$(cc)
        Next cc
        Close #1
        Line (1, 370)-(639, 479), Klr(0), BF
        Locate 25, 25
        Print "FONT LOADED"
        Choice$ = "z"
        _Delay 1
    End If
    showcharcode
End Sub
Function keyup$
    keyup$ = ""
    x = _KeyHit
    If x < 0 Then
        x = -x
        If x > 0 And x < 256 Then keyup$ = Chr$(x)
    Else
        keyup$ = ""
    End If
End Function
Sub showhelp
    helplast = 0
    'super-minimal help for now
    Line (1, 370)-(639, 479), Klr(0), BF
    View Print 24 To 30
    helpbuttons:
    Print "====  Buttons  ===="
    helpnewfont:
    Print "NEW Font  -  Clears the current font."
    helpsavefont:
    Print "Save Font - Save the font into the same directory as this app, will accept any filename."
    helploadfont:
    Print "Load Font - loads as font from the same directory with any name you choose (no error trapping yet)"
    GoSub helpwait
    helpUD:
    Print "Pen U/D - Toggle to change thr state of the pen. The Alert above the grid will show if pen is up or down."
    Print "            When the pen is UP coordinate clicks will NOT be recorded."
    Print "            When the pen is DOWN coordinate clicks WILL be recorded."
    GoSub helpwait
    helpcharacter:
    Print "Character - opens a prompt for the ascii charcter code of the charcter yuo wish to work on."
    GoSub helpwait
    helpLN:
    Print "'<'  and '>'  - Choose last character or next charcater to work on."
    helpgrid:
    Print "Grid ON/OFF - Toggles the drawing grid on and off."
    helperase:
    Print "ERASE - Erases the current working character scribble data."
    Print " "
    GoSub helpwait
    helpkeys:
    Print "====  Keys  ===="
    helpquit:
    Print "Q - Quits program, after prompt"
    helpup:
    Print "U - Raises the pen so a line will not connect to points on grid clicks."
    Print "If the pen is up coordinate cicks on the grid will NOT be recorded."
    helpdown:
    Print "D - Lowers the pen to indicate consecutive points will be connected on grid clicks"
    helpln2:
    Print "<,> -  Change to the previous character or the nect character being worked on."
    GoSub helpwait


    helplast = 1
    helpwait:
    Input wait$
    wait$ = LCase$(wait$)
    If wait$ = "grid" Or wait$ = "grid on" Or wait$ = "grid off" Or wait$ = "grid on/off" Then GoTo helpgrid
    If wait$ = "q" Or wait$ = "quit" Then GoTo helpquit
    If wait$ = "u" Or wait$ = "up" Then GoTo helpup
    If wait$ = "pen" Or wait$ = "pen u/d" Or wait$ = "pen up" Or wait$ = "pen down" Then GoTo helpUD
    If wait$ = "help" Or wait$ = "?" Or wait$ = "buttons" Then GoTo helpbuttons
    If helplast = 0 Then Return
    View Print
    showcharcode
End Sub