+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://staging.qb64phoenix.com/forumdisplay.php?fid=9)
+---- Thread: Scribble Font Builder (/showthread.php?tid=411)
Scribble Font Builder - James D Jarvis - 05-15-2022
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://staging.qb64phoenix.com/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://staging.qb64phoenix.com/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 SubRE: Scribble Font Builder - James D Jarvis - 05-15-2022
The current demo with a hard coded font.
https://staging.qb64phoenix.com/showthread.php?tid=415
RE: Scribble Font Builder - James D Jarvis - 05-16-2022
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://staging.qb64phoenix.com/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://staging.qb64phoenix.com/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