07-18-2005, 02:39 AM
[syntax="qbasic"]
DEFINT A-Z
SUB fontedit (font(), gamedir$)
STATIC default$
DIM f(255), copybuf(4), menu$(3)
menu$(0) = "Previous Menu"
menu$(1) = "Edit Font..."
menu$(2) = "Import Font..."
menu$(3) = "Export Font..."
last = -1
FOR i = 32 TO 255
last = last + 1
f(last) = i
NEXT i
mode = -1
menuptr = 0
top = 0
ptr = -1 * linesize
linesize = 14
setkeys
DO
setwait timing(), 100
setkeys
tog = tog XOR 1
SELECT CASE mode
CASE -1
IF keyval(1) > 1 THEN EXIT DO
dummy = usemenu(menuptr, 0, 0, 3, 22)
IF keyval(57) > 1 OR keyval(28) > 1 THEN
IF menuptr = 0 THEN EXIT DO
IF menuptr = 1 THEN mode = 0
IF menuptr = 2 THEN GOSUB importfont
IF menuptr = 3 THEN GOSUB exportfont
END IF
CASE 0
IF keyval(1) > 1 THEN mode = -1
IF keyval(72) > 1 THEN ptr = large(ptr - linesize, -1 * linesize)
IF keyval(80) > 1 THEN ptr = small(ptr + linesize, last)
IF keyval(75) > 1 THEN ptr = large(ptr - 1, 0)
IF keyval(77) > 1 THEN ptr = small(ptr + 1, last)
IF keyval(57) > 1 OR keyval(28) > 1 THEN
IF ptr < 0 THEN
mode = -1
ELSE
mode = 1
x = 0: y = 0
END IF
END IF
IF keyval(29) > 0 AND keyval(19) > 1 THEN romfontchar font(), ptr
CASE 1
IF keyval(1) > 1 OR keyval(28) > 1 THEN mode = 0
IF keyval(72) > 1 THEN y = loopvar(y, 0, 7, -1)
IF keyval(80) > 1 THEN y = loopvar(y, 0, 7, 1)
IF keyval(75) > 1 THEN x = loopvar(x, 0, 7, -1)
IF keyval(77) > 1 THEN x = loopvar(x, 0, 7, 1)
IF keyval(57) > 1 THEN
setbit font(), 0, (f(ptr) * 8 + x) * 8 + y, (readbit(font(), 0, (f(ptr) *
END IF
END SELECT
IF mode >= 0 THEN
'--copy and paste support
IF (keyval(29) > 0 AND keyval(82) > 1) OR ((keyval(42) > 0 OR keyval(54) > 0
IF ((keyval(42) > 0 OR keyval(54) > 0) AND keyval(82) > 1) OR (keyval(29) >
END IF
IF mode = -1 THEN
standardmenu menu$(), 3, 22, menuptr, 0, 0, 0, dpage, 0
END IF
IF mode >= 0 THEN
xoff = 8: yoff = 8
FOR i = 0 TO last
textcolor 7, 8
IF ptr >= 0 THEN
IF mode = 0 THEN
IF (i MOD linesize) = (ptr MOD linesize) OR (i \ linesize) = (ptr \ lines
END IF
IF ptr = i THEN textcolor 14 + tog, 0
END IF
printstr CHR$(f(i)), xoff + (i MOD linesize) * 9, yoff + (i \ linesize) * 9
NEXT i
textcolor 7, 0
IF ptr < 0 THEN textcolor 14 + tog, 0
printstr menu$(0), 8, 0, dpage
IF ptr >= 0 THEN
xoff = 150
yoff = 4
rectangle xoff, yoff, 160, 160, 8, dpage
FOR i = 0 TO 7
FOR j = 0 TO 7
z = readbit(font(), 0, (f(ptr) * 8 + i) * 8 + j)
IF z THEN rectangle xoff + i * 20, yoff + j * 20, 20, 20, 7, dpage
NEXT j
NEXT i
IF mode = 1 THEN rectangle xoff + x * 20, yoff + y * 20, 20, 20, 2 + 8 * re
textcolor 15, 0
printstr "ASCII" + STR$(f(ptr)), 20, 190, dpage
IF f(ptr) < 32 THEN
printstr "RESERVED", 120, 190, dpage
ELSE
FOR i = 2 TO 53 _
IF f(ptr) = keyv(i, 2) THEN printstr "ALT+" + UCASE$(CHR$(keyv(i, 0))), 1_
IF f(ptr) = keyv(i, 3) THEN printstr "ALT+SHIFT+" + UCASE$(CHR$(keyv(i, 0_
NEXT i _
IF f(ptr) = 32 THEN printstr "SPACE", 120, 190, dpage _
END IF
END IF _
END IF _
_
SWAP vpage, dpage _
setvispage vpage _
clearpage dpage _
dowait _
LOOP _
GOSUB savefont
EXIT SUB
loadfont:
DEF SEG = VARSEG(font(0)): BLOAD game$ + ".fnt", VARPTR(font(0))
setfont font()
RETURN
savefont:
DEF SEG = VARSEG(font(0)): BSAVE game$ + ".fnt", VARPTR(font(0)), 2048
RETURN
copychar:
FOR i = 0 TO 63
setbit copybuf(), 0, i, readbit(font(), 0, f(ptr) * 64 + i)
NEXT i
RETURN
pastechar:
FOR i = 0 TO 63
setbit font(), 0, f(ptr) * 64 + i, readbit(copybuf(), 0, i)
NEXT i
RETURN
importfont:
newfont$ = browse$(0, default$, "*.ohf", "")
IF newfont$ <> "" THEN
copyfile newfont$ + CHR$(0), game$ + ".fnt" + CHR$(0), buffer()
'--never overwrite 0 thru 31
FOR i = 0 TO 2047
setbit buffer(), 0, i, readbit(font(), 0, i)
NEXT i
GOSUB loadfont
FOR i = 0 TO 2047
setbit font(), 0, i, readbit(buffer(), 0, i)
NEXT i
menuptr = 1
mode = 0
END IF
RETURN
exportfont:
setkeys
newfont$ = "newfont"
DO
setwait timing(), 100
setkeys
tog = tog XOR 1
IF keyval(1) > 1 THEN EXIT DO
old$ = newfont$
strgrabber newfont$, 8
IF old$ <> newfont$ THEN
'--make sure only legal DOS filename chars are used
lastchar = ASC(UCASE$(RIGHT$("_" + newfont$, 1)))
SELECT CASE lastchar
CASE 48 TO 57, 65 TO 90, 95, 126
'--legal chars
CASE 32
'--replace space with underscore
newfont$ = old$ + "_"
CASE ELSE
'--illegal chars
newfont$ = old$
END SELECT
END IF
IF keyval(28) > 1 THEN
GOSUB savefont
copyfile game$ + ".fnt" + CHR$(0), gamedir$ + "\" + newfont$ + ".ohf" + CHR$(0), buffer()
textcolor 7, 0
printstr "Input a filename to save to", 0, 0, dpage
printstr "[" + gamedir$ + "\" + newfont$ + ".ohf]", 0, 8, dpage
textcolor 14 + tog, 1
printstr newfont$, 0, 16, dpage
SWAP vpage, dpage
setvispage vpage
clearpage dpage
dowait
LOOP
RETURN
END SUB[/syntax]
DEFINT A-Z
SUB fontedit (font(), gamedir$)
STATIC default$
DIM f(255), copybuf(4), menu$(3)
menu$(0) = "Previous Menu"
menu$(1) = "Edit Font..."
menu$(2) = "Import Font..."
menu$(3) = "Export Font..."
last = -1
FOR i = 32 TO 255
last = last + 1
f(last) = i
NEXT i
mode = -1
menuptr = 0
top = 0
ptr = -1 * linesize
linesize = 14
setkeys
DO
setwait timing(), 100
setkeys
tog = tog XOR 1
SELECT CASE mode
CASE -1
IF keyval(1) > 1 THEN EXIT DO
dummy = usemenu(menuptr, 0, 0, 3, 22)
IF keyval(57) > 1 OR keyval(28) > 1 THEN
IF menuptr = 0 THEN EXIT DO
IF menuptr = 1 THEN mode = 0
IF menuptr = 2 THEN GOSUB importfont
IF menuptr = 3 THEN GOSUB exportfont
END IF
CASE 0
IF keyval(1) > 1 THEN mode = -1
IF keyval(72) > 1 THEN ptr = large(ptr - linesize, -1 * linesize)
IF keyval(80) > 1 THEN ptr = small(ptr + linesize, last)
IF keyval(75) > 1 THEN ptr = large(ptr - 1, 0)
IF keyval(77) > 1 THEN ptr = small(ptr + 1, last)
IF keyval(57) > 1 OR keyval(28) > 1 THEN
IF ptr < 0 THEN
mode = -1
ELSE
mode = 1
x = 0: y = 0
END IF
END IF
IF keyval(29) > 0 AND keyval(19) > 1 THEN romfontchar font(), ptr
CASE 1
IF keyval(1) > 1 OR keyval(28) > 1 THEN mode = 0
IF keyval(72) > 1 THEN y = loopvar(y, 0, 7, -1)
IF keyval(80) > 1 THEN y = loopvar(y, 0, 7, 1)
IF keyval(75) > 1 THEN x = loopvar(x, 0, 7, -1)
IF keyval(77) > 1 THEN x = loopvar(x, 0, 7, 1)
IF keyval(57) > 1 THEN
setbit font(), 0, (f(ptr) * 8 + x) * 8 + y, (readbit(font(), 0, (f(ptr) *
END IF
END SELECT
IF mode >= 0 THEN
'--copy and paste support
IF (keyval(29) > 0 AND keyval(82) > 1) OR ((keyval(42) > 0 OR keyval(54) > 0
IF ((keyval(42) > 0 OR keyval(54) > 0) AND keyval(82) > 1) OR (keyval(29) >
END IF
IF mode = -1 THEN
standardmenu menu$(), 3, 22, menuptr, 0, 0, 0, dpage, 0
END IF
IF mode >= 0 THEN
xoff = 8: yoff = 8
FOR i = 0 TO last
textcolor 7, 8
IF ptr >= 0 THEN
IF mode = 0 THEN
IF (i MOD linesize) = (ptr MOD linesize) OR (i \ linesize) = (ptr \ lines
END IF
IF ptr = i THEN textcolor 14 + tog, 0
END IF
printstr CHR$(f(i)), xoff + (i MOD linesize) * 9, yoff + (i \ linesize) * 9
NEXT i
textcolor 7, 0
IF ptr < 0 THEN textcolor 14 + tog, 0
printstr menu$(0), 8, 0, dpage
IF ptr >= 0 THEN
xoff = 150
yoff = 4
rectangle xoff, yoff, 160, 160, 8, dpage
FOR i = 0 TO 7
FOR j = 0 TO 7
z = readbit(font(), 0, (f(ptr) * 8 + i) * 8 + j)
IF z THEN rectangle xoff + i * 20, yoff + j * 20, 20, 20, 7, dpage
NEXT j
NEXT i
IF mode = 1 THEN rectangle xoff + x * 20, yoff + y * 20, 20, 20, 2 + 8 * re
textcolor 15, 0
printstr "ASCII" + STR$(f(ptr)), 20, 190, dpage
IF f(ptr) < 32 THEN
printstr "RESERVED", 120, 190, dpage
ELSE
FOR i = 2 TO 53 _
IF f(ptr) = keyv(i, 2) THEN printstr "ALT+" + UCASE$(CHR$(keyv(i, 0))), 1_
IF f(ptr) = keyv(i, 3) THEN printstr "ALT+SHIFT+" + UCASE$(CHR$(keyv(i, 0_
NEXT i _
IF f(ptr) = 32 THEN printstr "SPACE", 120, 190, dpage _
END IF
END IF _
END IF _
_
SWAP vpage, dpage _
setvispage vpage _
clearpage dpage _
dowait _
LOOP _
GOSUB savefont
EXIT SUB
loadfont:
DEF SEG = VARSEG(font(0)): BLOAD game$ + ".fnt", VARPTR(font(0))
setfont font()
RETURN
savefont:
DEF SEG = VARSEG(font(0)): BSAVE game$ + ".fnt", VARPTR(font(0)), 2048
RETURN
copychar:
FOR i = 0 TO 63
setbit copybuf(), 0, i, readbit(font(), 0, f(ptr) * 64 + i)
NEXT i
RETURN
pastechar:
FOR i = 0 TO 63
setbit font(), 0, f(ptr) * 64 + i, readbit(copybuf(), 0, i)
NEXT i
RETURN
importfont:
newfont$ = browse$(0, default$, "*.ohf", "")
IF newfont$ <> "" THEN
copyfile newfont$ + CHR$(0), game$ + ".fnt" + CHR$(0), buffer()
'--never overwrite 0 thru 31
FOR i = 0 TO 2047
setbit buffer(), 0, i, readbit(font(), 0, i)
NEXT i
GOSUB loadfont
FOR i = 0 TO 2047
setbit font(), 0, i, readbit(buffer(), 0, i)
NEXT i
menuptr = 1
mode = 0
END IF
RETURN
exportfont:
setkeys
newfont$ = "newfont"
DO
setwait timing(), 100
setkeys
tog = tog XOR 1
IF keyval(1) > 1 THEN EXIT DO
old$ = newfont$
strgrabber newfont$, 8
IF old$ <> newfont$ THEN
'--make sure only legal DOS filename chars are used
lastchar = ASC(UCASE$(RIGHT$("_" + newfont$, 1)))
SELECT CASE lastchar
CASE 48 TO 57, 65 TO 90, 95, 126
'--legal chars
CASE 32
'--replace space with underscore
newfont$ = old$ + "_"
CASE ELSE
'--illegal chars
newfont$ = old$
END SELECT
END IF
IF keyval(28) > 1 THEN
GOSUB savefont
copyfile game$ + ".fnt" + CHR$(0), gamedir$ + "\" + newfont$ + ".ohf" + CHR$(0), buffer()
textcolor 7, 0
printstr "Input a filename to save to", 0, 0, dpage
printstr "[" + gamedir$ + "\" + newfont$ + ".ohf]", 0, 8, dpage
textcolor 14 + tog, 1
printstr newfont$, 0, 16, dpage
SWAP vpage, dpage
setvispage vpage
clearpage dpage
dowait
LOOP
RETURN
END SUB[/syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~
I love Quick Basic better then Python...
And Python is new.........
Oh yea catch ARPGME
I love Quick Basic better then Python...
And Python is new.........
Oh yea catch ARPGME