Code: (Select All)
' Fontmonkey v0e.e01
' By James D Jarvis
' a crude bitmap font encoder/editor with display routines
' I'm calling the fonts it creates "dashfonts" with a file extenion of .qdf"
Dim Shared fonts As Integer
'Dim Shared chalimit As Integer
fonts = 3 'no good reason this is 3, I want to be able to load more than one font in a program i create using this so leaving this here
Const chalimit = 255 'you could theoretically change this but the universe might explode
Dim Shared char(fonts, chalimit) As String
Dim Shared currentfont
Dim Shared backgroundkolor
Dim Shared foregroundkolor
Dim Shared rcount(40)
Dim Shared ccount(40)
Dim Shared font_kerning(fonts)
Dim Shared chno
Dim Shared cc(40, 40)
backgroundkolor = 0
foregroundkolor = 15
currentfont = 1
For f = 1 To fonts: font_kerning(f) = 0: Next f
Dim Shared sh&
sh& = _NewImage(800, 600, 256)
Screen sh&
Dim Shared rootpath$, fontname$, fsize, f&
' sorry only works in windows without futher editing
rootpath$ = Environ$("SYSTEMROOT") 'normally "C:\WINDOWS"
fontname$ = "comic" 'you are going to want to change this
fontfile$ = rootpath$ + "\Fonts\" + fontname$ + ".ttf" 'TTF file in Windows
fltr$ = "a"
fsize = 20 'I found this size works well for encoding, yuo can of course change this but bear in mind the top size is 40 pixels
Dim Shared fchar$
Dim Shared lastcharwid
lastcharwid = 8
fnam$ = "timmy" 'the default dash font for the program you can of course edit this
loadqdf 1, fnam$ 'loads timmy as default font
loadqdf 2, fnam$ 'loads timmy as backup font
Do
Print
Print
Input "Select a letter (or command word) ", ltt$
If ltt$ = "" Then ltt$ = " "
If Mid$(ltt$, 1, 1) = "-" Then
ch = Val(ltt$) * -1
chno = ch
Else
If Len(ltt$) > 1 Then ltt$ = LCase$(ltt$)
ch = Asc(ltt$)
chno = ch
End If
Locate 1, 1
Print ltt$
drawchar 100, 1, 0, 15, 1, 1, ch
Locate 10, 1
Print char(1, ch)
If ltt$ = "zoom" Then zoom
If ltt$ = "cls" Then Cls
If ltt$ = "save" Then
Cls
Print "please enter a filename"
Input fnam$
savefont 1, fnam$
End If
If ltt$ = "load" Then
Cls
Print "enter name of font to load (no extension please)"
Input fnam$
fname$ = fnam$ + ".qdf"
loadqdf 1, fnam$
End If
If ltt$ = "load2" Then
Cls
currentfont = 2
Print "enter name of font to load (no extension please)"
Input fnam$
fname$ = fnam$ + ".qdf"
loadqdf 2, fnam$
currentfont = 1
End If
If ltt$ = "encode" Then
Cls
Print "enter name of font to encode (no extension please)"
Input fnam$
fname$ = fnam$ + ".qdf"
encodefont fnam$, 20, 1
End If
If ltt$ = "show" Then
Cls
For y = 1 To 10
For cc = 1 To 24
drawchar (cc * 24), y * 25, backgroundkolor, foregroundkolor, 1, 1, (cc + (y - 1) * 24)
Next cc
Next y
For cc = 241 To 255
drawchar ((cc - 240) * 24), 275, backgroundkolor, foregroundkolor, 1, 1, cc
Next cc
End If
If ltt$ = "show2" Then
currentfont = 2
Cls
For y = 1 To 10
For cc = 1 To 24
drawchar (cc * 24), y * 25, backgroundkolor, foregroundkolor, 1, 1, (cc + (y - 1) * 24)
Next cc
Next y
For cc = 241 To 255
drawchar ((cc - 240) * 24), 275, backgroundkolor, foregroundkolor, 1, 1, cc
Next cc
currentfont = 1
End If
If ltt$ = "help" Then
Cls
Print " entering a single character will draw that character in the loaded font"
Print "-# : a negative number will display the positvre value as the asccii character code"
Print "quit : quits the program"
Print "load : will load a dash font as the active working font"
Print "load2 : will load another dash font as the backup font or font to copy from"
Print "encode : will load and encode a ttf font and convert it into a dash font, this font"
Print " becomes the working font but is NOT SAVED until you use the save comand"
Print "zoom : zoom on in and edit characters in the pixel eidtor in the working dash font."
Print "show : displays the working font"
Print "show2 : displays the backup font"
Print "cls : Clean up the screen (eventually this is whole program is getting cleaned up)"
Print "whole words that are not supported will simply display the first character"
Print " "
End If
sampletext$ = "The brown cown jumped over the moon. Written in " + fnam$ + "."
drawstring 2, 300, sampletext$
drawstring 2, 350, "<cls><zoom><quit><load><load2><save><encode><show><show2><help>"
Loop Until ltt$ = "quit"
Cls
'crazystring exit message just for fun
'shows how scaling and color works with the drawchar command
byetext$ = "Goodbye. So long. BYE BYE."
Randomize Timer
lcrz = Len(byetext$)
For r = 1 To 6
Cls
_Limit 2
x = 2: y = 200
For n = 1 To lcrz
lt$ = Mid$(byetext$, n, 1)
ch = Asc(lt$)
drawchar x, y, backgroundcolor, Int(Rnd * 239 + 16), Int(Rnd * 3) + 1, Int(Rnd * 3) + 1, ch
x = x + lastcharwid + Int(Rnd * 4)
_Display
Next n
Next r
drawstring 2, 240, "BYE."
_Delay 1
System
Sub drawstring (xpos, ypos, A$)
nl = Len(A$)
x = xpos: y = ypos
For n = 1 To nl
lt$ = Mid$(A$, n, 1)
ch = Asc(lt$)
drawchar x, y, backgroundkolor, foregroundkolor, 1, 1, ch
x = x + lastcharwid + font_kerning(currentfont)
Next n
End Sub
Sub drawchar (xpos, ypos, bg, fg, drawH, drawW, ch)
'draw a single character
'drawH and DrawW are scaling factors to enlarge the character when drawn, default size is 1
ndashes = 0
cf = currentfont
maxcc = Len(char(cf, ch))
Dim DashPos(maxcc) As Integer
'there will never be this many dashes but we are playing it safe
Dim DNum(maxcc) As Integer
Hpos = InStr(1, char(cf, ch), "H")
Wpos = InStr(Hpos, char(cf, ch), "W")
ndashes = 0
firstdash = InStr(1, char(cf, ch), "B")
If firstdash = 0 Then firstdash = InStr(1, char(cf, ch), "F")
HH$ = Mid$(char(cf, ch), Hpos + 1, Wpos - Hpos - 1)
Horz = Val(HH$)
lastcharwid = Horz
' Print Horz
VV$ = Mid$(char(cf, ch), Wpos + 1, firstdash - Wpos - 1)
Vert = Val(HH$)
' Print Vert
For cc = firstdash To maxcc
p$ = Mid$(char(cf, ch), cc, 1)
If p$ = "B" Then
ndashes = ndashes + 1
DashPos(ndashes) = cc
End If
If p$ = "F" Then
ndashes = ndashes + 1
DashPos(ndashes) = cc
End If
Next cc
lastdash = ndashes
dt = lastdash - 1
DNum(lastdash) = Val(Mid$(char(cf, ch), DashPos(lastdash) + 1, maxcc))
For d = 1 To dt
tnum$ = Mid$(char(cf, ch), DashPos(d) + 1, DashPos(d + 1) - DashPos(d) - 1)
DNum(d) = Val(tnum$)
Next d
x = xpos
y = ypos
If drawH = 1 And drawW = 1 Then
For dd = 1 To lastdash
p$ = Mid$(char(cf, ch), DashPos(dd), 1)
If p$ = "F" Then
For r = 0 To (DNum(dd) - 1)
PSet (x, y), fg
x = x + 1
If x = xpos + Vert Then
y = y + 1
x = xpos
End If
Next r
End If
If p$ = "B" Then
For r = 0 To (DNum(dd) - 1)
PSet (x, y), bg
x = x + 1
If x = xpos + Vert Then
y = y + 1
x = xpos
End If
Next r
End If
Next dd
If ch = 32 Then lastcharwid = 8
End If
If drawH > 1 Or drawW > 1 Then
lastcharwid = lastcharwid * drawW
For dd = 1 To lastdash
p$ = Mid$(char(cf, ch), DashPos(dd), 1)
If p$ = "F" Then
For r = 0 To (DNum(dd) - 1)
Line (x, y)-(x + drawW, y + drawH), fg, BF
x = x + drawW
If x = xpos + Vert * drawW Then
y = y + drawH
x = xpos
End If
Next r
End If
If p$ = "B" Then
For r = 0 To (DNum(dd) - 1)
If noBKG < 1 Then Line (x, y)-(x + drawW, y + drawH), bg, BF
x = x + drawW
If x = xpos + Vert * drawW Then
y = y + drawH
x = xpos
End If
Next r
End If
Next dd
If ch = 32 Then lastcharwid = 8
End If
End Sub
Sub encodefont (fnt$, siz, fontno)
'convert a windows true type font into a dash font
fontfile$ = rootpath$ + "\Fonts\" + fnt$ + ".ttf"
style$ = "" 'font style is not case sensitive
f& = _LoadFont(fontfile$, siz, style$)
_Font f&
zerocc 'cleans up the horrible character grid
Dim frow$(40)
fchar$ = ""
'character zero isn't encoded
' each character is printed and loaded into a simple grid
' program is written with a hard limit of 40 pixels x 40 pixels per character
For ch = 1 To 255
fchar$ = ""
_ControlChr Off
Line (0, 0)-(200, 41), 0, BF
_PrintString (1, 1), Chr$(ch)
For x = 1 To 40
For y = 1 To 40
klr% = Point(x, y)
If klr% > 0 Then klr% = 1
cc(x, y) = klr%
Next y
Next x
rmax = 0
cmax = 0
For xx = 1 To 40: rcount(xx) = 0: ccount(xx) = 0: Next xx
For x = 1 To 40
For y = 1 To 40
If cc(x, y) > 0 Then
ccount(x) = x
PSet (x + 50, y), 12
End If
Next y
Next x
For y = 1 To 40
For x = 1 To 40
If cc(x, y) > 0 Then rcount(y) = y
Next x
Next y
For xx = 1 To 40
If rcount(xx) > rmax Then rmax = rcount(xx)
If ccount(xx) > cmax Then cmax = ccount(xx)
Next xx
For x = 1 To rmax
For y = 1 To cmax
If cc(x, y) <> 0 Then PSet (x + 100, y), 13
Next y
Next x
' if you want to be bored watching each letter as it scans uncomment the following lines
' Locate 10, 1
' Print " rmax "; rmax, " cmax ", cmax
' Input a$
fchar$ = fchar$ + "H" + Str$(cmax) + "W" + Str$(rmax)
penflag$ = "B"
count = 0
For r = 1 To rmax
frow$(r) = "B"
For c = 1 To cmax
If cc(c, r) = 0 Then
If penflag$ = "" Or penflag$ = "F" Then
penflag$ = "B"
If count > 0 Then frow$(r) = frow$(r) + Str$(count)
frow$(r) = frow$(r) + "B"
count = 0
End If
If penflag$ = "B" Then
count = count + 1
End If
End If
If cc(c, r) = 1 Then
If penflag$ = "" Or penflag$ = "B" Then
penflag$ = "F"
If count > 0 Then frow$(r) = frow$(r) + Str$(count)
frow$(r) = frow$(r) + "F"
count = 0
End If
If penflag$ = "F" Then
count = count + 1
End If
End If
Next c
frow$(r) = frow$(r) + Str$(count)
count = 0
penflag$ = ""
fchar$ = fchar$ + frow$(r)
Next r
If ch = 32 Then
spw = Int(fsize * .667)
fchar$ = "H1" + "W" + Str$(spw) + "B" + Str$(spw)
End If
char(fontno, ch) = fchar$
Next ch
_ControlChr On
End Sub
Sub savefont (fntNo, filename$)
fileout$ = filename$ + ".qdf"
Open fileout$ For Output As #1
Write #1, "' ***************************************************"
oline$ = "' " + filename$
Write #1, oline$
Write #1, "' ***************************************************"
Write #1, "' This Dash Font was wrtitten in QB64"
Write #1, "' yup.... can't do much with it otherwise"
For c = 1 To 255
Write #1, char(fntNo, c)
Next c
Close #1
End Sub
Sub loadqdf (fntNo, filename$)
filein$ = filename$ + ".qdf"
Open filein$ For Input As #1
For cc = 1 To 255
Do
Input #1, char(fntNo, cc)
first$ = Mid$(char(fntNo, cc), 1, 1)
Loop Until first$ <> "'"
Next cc
Close #1
End Sub
Sub zoom ()
' Dim cch(40, 40) As Integer
zerocc
Dim frow$(40)
cf = currentfont
redraw:
Cls
tchar$ = char(currentfont, chno)
drawchar 1, 1, 0, 15, 1, 1, chno
For x = 1 To 40
For y = 1 To 40
klr% = Point(x, y)
If klr% > 0 Then klr% = 1
cc(x, y) = klr%
Next y
Next x
ch = chno
Hpos = InStr(1, char(cf, ch), "H")
Wpos = InStr(Hpos, char(cf, ch), "W")
ndashes = 0
firstdash = InStr(1, char(cf, ch), "B")
If firstdash = 0 Then firstdash = InStr(1, char(cf, ch), "F")
HH$ = Mid$(char(cf, ch), Hpos + 1, Wpos - Hpos - 1)
rmax = Val(HH$)
VV$ = Mid$(char(cf, ch), Wpos + 1, firstdash - Wpos - 1)
cmax = Val(VV$)
tchar$ = char(currentfont, chno)
tchar$ = Right$(tchar$, Len(tchar$) - (firstdash - 1))
For rr = 1 To rmax
For cc = 1 To cmax
If cc(rr, cc) > 0 Then
Line (rr * 8 + 50, cc * 8)-(rr * 8 + 6 + 50, cc * 8 + 6), 15, BF
Else
Line (rr * 8 + 50, cc * 8)-(rr * 8 + 6 + 50, cc * 8 + 6), 2, B
End If
Next cc
Next rr
Locate 17, 1
Print tchar$
Locate 3, 1: Print "CHR"
Locate 4, 1: Print chno
Locate 21, 1
Print "choose a letter, -# for ascii code, <done>,<+col>,<+row>,<left>,<right>,<up>"
Print "<down>,<restore>,<trimc>,<trimr>,<setgrid>"
Locate 23, 1
Input a$
cll = Len(a$)
If cll = 1 Then
chno = Asc(a$)
If chno < 1 Then chno = 1
If chno > 255 Then chno = 255
GoTo redraw
End If
If InStr(1, a$, "-") = 1 Then
chno = Val(a$): chno = chno * -1
If chno < 1 Then chno = 1
If chno > 255 Then chno = 255
GoTo redraw
End If
If a$ = "+row" Then
cmax = cmax + 1
tchar$ = "H" + Str$(rmax) + "W" + Str$(cmax) + tchar$ + "B" + Str$(rmax)
char(currentfont, chno) = tchar$
End If
If a$ = "+col" Then
rmax = rmax + 1
dashcc chno, rmax, cmax
End If
If a$ = "trimc" Then
rmax = rmax - 1
dashcc chno, rmax, cmax
End If
If a$ = "trimr" Then
cmax = cmax - 1
dashcc chno, rmax, cmax
End If
If a$ = "setgrid" Then
Cls
Print "current rows "; rmax, "current columns "; cmax
Input "New rows", nr
Input "New columns", nc
If nr < 1 Then nr = 1
If nr > 40 Then nr = 40
If nc < 1 Then nc = 1
If nc > 40 Then nc = 40
cmax = nc
rmax = nr
dashcc chno, rmax, cmax
End If
If a$ = "left" Then
For x = 2 To rmax
For y = 1 To cmax
cc(x - 1, y) = cc(x, y)
Next y
Next x
dashcc chno, rmax, cmax
End If
If a$ = "right" Then
For x = (rmax - 1) To 2 Step -1
For y = 1 To cmax
cc(x, y) = cc(x - 1, y)
Next y
Next x
dashcc chno, rmax, cmax
End If
If a$ = "up" Then
For x = 1 To rmax
For y = 1 To (cmax - 1)
cc(x, y) = cc(x, y + 1)
Next y
Next x
dashcc chno, rmax, cmax
End If
If a$ = "down" Then
For x = 1 To rmax
For y = cmax To 2 Step -1
cc(x, y) = cc(x, y - 1)
Next y
Next x
dashcc chno, rmax, cmax
End If
If a$ = "neg" Then
For x = 1 To rmax
For y = 1 To cmax
If cc(x, y) = 0 Then
cc(x, y) = 1
Else
cc(x, y) = 0
End If
Next y
Next x
dashcc chno, rmax, cmax
End If
If a$ = "help" Then
Cls
Print " entering a single charcter will drawthat character in the loaded font"
Print "-# : a negative number will display the positve value as the asccii character code"
Print "done : returns to the main program where the font can be saved"
Print "mm : activates the mouse editing of the charcater shown, press any key in that mode to stop"
Print " yes, the mouse handling is bad here."
Print "restore : will replace the charcter in the workign font with the one from the backup font"
Print "+col : adds a blank column to a character"
Print "+row : adds a blank row to the charcter"
Print "left : drags the character left one pixel"
Print "right : drags the character right one pixel"
Print "up : drags the character up one pixel"
Print "setgrid : lets the grid for the charcter to be reset anywhere from 1 to 40 pixels"
Print "trimr : trims away the bottom row"
Print "trimc : trims away the right hand column"
Print " "
Print "moving a charcter outside the grid will cause loss of that data as will setting the grid too small"
Print " "
Print "changes must be saved in the main program or they will be lost"
Print " "
Input anyk$
End If
If a$ = "restore" Then
char(currentfont, chno) = char(currentfont + 1, chno)
zerocc
Cls
drawchar 1, 1, 0, 15, 1, 1, chno
For x = 1 To 40
For y = 1 To 40
klr% = Point(x, y)
If klr% > 0 Then klr% = 1
cc(x, y) = klr%
Next y
Next x
dashcc chno, rmax, cmax
End If
If a$ = "mm" Then
'horrible mouse handling here, sorry
md$ = ""
Do While md$ = ""
_Limit 500
mflag = 0
Mouser mx, my, mb
If mb Then
Do While mb 'wait for button release
_Limit 1000
Mouser mx, my, mb
If mx >= 58 And my >= 7 And mx <= (rmax * 8 + 57) And my <= (cmax * 8 + 6) Then
' Beep
cpick = Int((mx - 50) / 8)
rpick = Int((my - 6) / 8) + 1
If cc(cpick, rpick) = 0 Then
cc(cpick, rpick) = 1
mflag = 0
dashcc chno, rmax, cmax
Line (cpick * 8 + 50, rpick * 8)-(cpick * 8 + 6 + 50, rpick * 8 + 6), 15, BF
Else
cc(cpick, rpick) = 0
dashcc chno, rmax, cmax
Line (cpick * 8 + 50, rpick * 8)-(cpick * 8 + 6 + 50, rpick * 8 + 6), 0, BF
Line (cpick * 8 + 50, rpick * 8)-(cpick * 8 + 6 + 50, rpick * 8 + 6), 2, B
End If
Locate 19, 1
Print cpick, rpick
Else
mflag = 1
End If
Loop
End If
md$ = InKey$
Loop
End If
If a$ <> "done" Then GoTo redraw
Cls
End Sub
Sub Mouser (x, y, b)
mi = _MouseInput
b = _MouseButton(1)
x = _MouseX
y = _MouseY
End Sub
Sub zerocc ()
For x = 1 To 40
For y = 1 To 40
cc(x, y) = 0
Next y
Next x
End Sub
Sub dashcc (ch, rmax, cmax)
'this converts the cc array into the dashcode for a character in the font set
fchar$ = ""
fchar$ = fchar$ + "H" + Str$(rmax) + "W" + Str$(cmax)
penflag$ = ""
count = 0
For r = 1 To cmax
frow$ = "B"
For c = 1 To rmax
If cc(c, r) = 0 Then
If penflag$ = "" Or penflag$ = "F" Then
penflag$ = "B"
If count > 0 Then frow$ = frow$ + Str$(count)
frow$ = frow$ + "B"
count = 0
End If
If penflag$ = "B" Then
count = count + 1
End If
Else
If penflag$ = "" Or penflag$ = "B" Then
penflag$ = "F"
If count > 0 Then frow$ = frow$ + Str$(count)
frow$ = frow$ + "F"
count = 0
End If
If penflag$ = "F" Then
count = count + 1
End If
End If
Next c
frow$ = frow$ + Str$(count)
count = 0
penflag$ = ""
fchar$ = fchar$ + frow$
Next r
char(currentfont, ch) = fchar$
End Sub