Here's Fontmokey version 0e.e1
I've been fiddling with this for a while now. It's really... really crude but functional. I've already used it to create fonts for other programs that actually function.
This scans and encodes a true type font and reproduces it with characters 1 to 255. Saving it out as a what I'm calling a dash font with extension .qdf.
It doesn't just re-encode a bitmap font from one format to another it also has the ability to edit each of the characters (with a terrible but functional editor).
There's even a help function built into the main program and the character editor. Because...it really needs it.
you are going to want to take this and save it in a file called timmy.qdf (unless you want to edit the program to get around that which is what I did before I had a dash font).
now the actual program. Call it whatever you want. It's going to need that timmy.qdf file in the same directory if you want it to run without having to do a bunch of editing.
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
' 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
If you want another program to use the dashfont this creates you will need to carry over the shared variables and thre subs drawstring, drawchar, and loadqdf.
It's crude, it's fairly simple, and while not done yet it is entirely useable so I'm sharing it here.
hello, my computer under linux has a lot of memory. to speed it up as much as possible i have configured half of the memory in ramdisk. i have examined the source code of qb64, it would be nice to have an option at compile time to create temp directories in the ramdisk. i think it could speed up the compilation of the programs by a factor 10 or more...
Let's talk about DIM for a moment! To help us have this conversation, let's refer to the following code, which you can compile and stare at in your IDE if you want, just to test and make certain that the syntax is, indeed, correct.
Code: (Select All)
Dim a, b, c
Dim d As Integer, e As Double, f As Single
Dim g, h, i As _Float
Dim As String j, k, l
Now, let's break down what we're doing here, line by line.
Our first line of code is:
Code: (Select All)
Dim a, b, c
This is the simplest type of DIM statement, and it simply says that we're going to officially DIM and name three variables to whatever the default type is. Without any DEF or _DEFINE statement, these three variables are all going to be the default type of SINGLE.
Code: (Select All)
Dim d As Integer, e As Double, f As Single
Here, we're assigning a set type of each variable in that single DIM statement. d is an integer. e is a double. f is single. Easy enough to follow along with the logic behind this statement, right?
Code: (Select All)
Dim g, h, i As _Float
Now this line gets a little tricky for some people, as they confuse it with the newest syntax for DIM. They think that the way it's written, all the variables on this line are _FLOAT. They're not! Just compare this line to the one above it, and then apply the same logic as the first DIM statement we looked at. What types are the three variables here?
g is implicitly defined to be our default variable type -- SINGLE, in this case. So is h. i, on the other hand, is explicitly defined by the user to be a _Float.
Code: (Select All)
Dim As String j, k, l
And here, we have the new syntax for how one can DIM variables. If you notice, the type comes first on the left, with all the variables of this explicit type to be to the right of the type definition. j, k, and l are all String type variables.
See the difference in the 3rd and 4th lines' syntax, and understand why they're two completely different things?
If you want to define a large number of variables as a single type all at once, use the DIM AS <TYPE> syntax. Anything else would be incorrect.
I'm a bit confused, appropriately, about the DIM function.
I read that we can dim a whole range of vars, like a to z, as a group in one go, but I don't seem to be able to.
Is this implemented yet, or am I wrong again?
This little program is a demo for simple rounded rectangle routines. It'll draw buttons too (but i didn't code them to be clickable here).
Code: (Select All)
'simple rounded rectangles
Screen _NewImage(800, 480, 32)
Dim Shared klr(0 To 255) As _Unsigned Long
buildrefcolors
rbrect 1, 1, 798, 462, 4, 2, klr(4), klr(16) 'the demo screen is in a rounded rectangle
roundrect 20, 20, 100, 50, 12, klr(12)
_PrintString (150, 20), "roundrect at 20,20 100 wide and 50 high, corner radius 12"
roundrect 20, 100, 100, 50, 200, klr(6)
_PrintString (150, 100), "roundrect at 20,100 100 wide and 50 high, corner radius 200"
_PrintString (150, 117), " the radius is trimmed down if is larger than height or width"
rbrect_button 20, 250, 100, 30, 6, 4, klr(11), klr(22), "A Button"
_PrintString (150, 250), "Rounded bordered rectangle as a button image , "
_PrintString (150, 267), "similar to above but text is inserted and centered in sub"
rbrect_button 20, 320, 100, 30, 300, 3, klr(11), klr(22), "Second Btn"
_PrintString (150, 320), "same as above but with over-sized radius to get round sides"
End Sub
Sub roundrect (xx, yy, ww, HH, r, c As _Unsigned Long)
dr = r
If dr > ww / 2 Then dr = ww / 2 - 1
If dr > HH / 2 Then dr = HH / 2 - 1
x1 = xx: x2 = xx + ww - 1
y1 = yy: y2 = yy + HH - 1
'draw the circles at each corner inside the rectangle coordiates
CircleFill x1 + dr, y1 + dr, dr, c
CircleFill x2 - dr, y1 + dr, dr, c
CircleFill x1 + dr, y2 - dr, dr, c
CircleFill x2 - dr, y2 - dr, dr, c
'connect them with properly sized rectangles
Line (x1 + dr, y1)-(x2 - dr, y2), c, BF
Line (x1, y1 + dr)-(x2, y2 - dr), c, BF
End Sub
Sub buildrefcolors
'reference colors
'very slightly cooled EGA palette
_Source tiles&
klr(0) = Point(1, 1)
'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) = _RGB(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) = _RGB(250, 250, 250) 'ega_white
'filling the rest with greyscale
For c = 16 To 255
klr(c) = _RGB32(c, c, c)
Next c
End Sub
Sub CircleFill (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
'sub by SMcNeill makes a filled circle without worrying about using the paint comamnd to fill an empty circle
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
Hi guys.
I still need help.
I play a 1991 DOS game that has been modded a bit. Because of that, the setup/installer program doesn't function anymore.
Installation can be done with xcopy, but that is a bit crude and unselective. (windows and Linux users can use drag and drop combined with dosbox)
So only for DOS users there is 'need' for something better. It would be nice to have a complete game again with all parts functional as intended.
The setup part is already rewritten (in QB), so only the installation part is needed (in QB, because it's for DOS and DOS only).
It needs to be able to.
1 - install(copy) the game (set file list from file) from A, to B.
2 - recognize track files and be able to list them (so one, a selection or all can be moved/copied/deleted from A to B)
3 - recognize car files (4 per car) and be able to list them (so one, a selection or all can be moved/copied/deleted from A to B)
4 - list all files that are not game, track or car and be able to list them (so one, a selection or all can be moved/copied/deleted from A to B)
5 - unpack zip files to any location.
6 - Backup (part eg game ,tracks or cars) of the installation.
7 - store deleted files in a recycle bin Dir.
I hope there are still some old school programmers active.