05-16-2022, 12:52 PM
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