08-30-2022, 03:09 PM
(This post was last modified: 08-30-2022, 08:17 PM by James D Jarvis.)
Some scalable text routines and a little demo program. This is meant to work with 8bit color (currently only supports a palette of colors from 0 to 127 due to encoding).
Basically, the default font is scanned and encoded into a string array that is later decoded to display the characters as part of a set of tiles. The default font is rescaled to 16 by 16 but can be redrawn at any size desired.
to do:
output a set of data statements to be copied and included in another program
ADDED loading a ttf and allow it to be added to the tileset
maybe a graphical editor to edit individual character tile ... this might be done in another program.
EDIT: updated see latest post to see most up to date version
Basically, the default font is scanned and encoded into a string array that is later decoded to display the characters as part of a set of tiles. The default font is rescaled to 16 by 16 but can be redrawn at any size desired.
to do:
output a set of data statements to be copied and included in another program
ADDED loading a ttf and allow it to be added to the tileset
maybe a graphical editor to edit individual character tile ... this might be done in another program.
EDIT: updated see latest post to see most up to date version
Code: (Select All)
'Scale_print
'by James D. Jarvis
'scans default font and setup up routines to rescale output as a base tile of 16 x 16 pixels
'meant for use to create a larger editable display font without needing to make use of external font files
'
'=================================================================================
'header, needed in any programs that will make use of the subroutines
'=================================================================================
Dim Shared xmax
xmax = 800 'max horizontal screen size, reset as you wish
Screen _NewImage(xmax, 500, 256)
Dim Shared tile(256) As String 'note.... if you want to create a larger tile set you can as scan816 sub will just fill the first 255 entries
Dim Shared t_wid As _Byte 'really doesn't really have to be a bytefor these routines or program but is for compatibility with another program of mine
t_wid = 16 'tile width set here in main routine if could be moved inside of scan816
_ControlChr Off
'=================================================================================
'demo program
''=================================================================================
scan816 'scan the 8by16 default font and store it in an array of tiles that are 16 by 16 pixels in size
Randomize Timer 'for later demo output not needed by the routines otherwise
'a simple example tile to show one way to make an extended charcter set
tile(256) = Chr$(120) + Chr$(144) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130) + Chr$(130) + Chr$(128) + Chr$(140) + Chr$(120) + Chr$(130)
ptile 100, 100, tile(Asc("A")) 'just print the tile as scanned.
For x = 1 To 40
ptile (x - 1) * 16, 150, tile(Int(Rnd * 256)) 'showing how to
Next x
For x = 1 To 40
cptile (x - 1) * 16, 200, tile(33 + x), Int(1 + Rnd * 64) 'print a randomly generated series of characters randomly colored
Next x
tile_print 400, 10, " ÉÍÊÍ» ", 0 'print a string as scanned with no spacing
Input "press enter ", any$
Cls
scale_print 50, 50, "x8 by x2.5 text", 9, 8, 2.5 'print a colorized and scaled string
scale_print 10, 250, "x2 by x5", 10, 2, 5 'print a colorized and scaled string
_PrintString (50, 320), "aBcDeFgHi" 'just plain old _printstring for reference
scale_print 50, 350, "x1 by 0,5 text", 12, 1, 0.5 'print a tiny string
tile_print 50, 366, "String with spacing of 8 pixels", 8 'print a string with an extra 8 pixels between each tile
scale_print 0, 0, "press enter", 8, 1, 1
Locate 1, 23: Input any$
Cls
s = 0.1
Do 'show a string being scaled
_Limit 60
Cls
scale_print 0, 0, "AbC123", 15, s, s
s = s + .1
_Display
Loop Until s > 30
scale_print 0, 0, "press enter", 9, 1, 0.5
Locate 1, 13: Input any$
Cls
scale_print 10, 100, "Bonus Tile(256) :", 14, 1, 1
scale_tile 286, 100, tile(256), 15, 1, 1
scale_print 10, 117, "(just to show an example of a custom tile)", 8, 1, 0.5
End
'=================================================================================
'scale_print subroutines
'
' tile_print prints a string with added spacing between character tiles
' scale_print prinst a scaled and recolored string of character tiles
' scale_tile prints a single rescaled and recolored character tile
' ptile prints a single character tile as scanned
' cptile prints a single rrcolored character tile
' scan816
'=================================================================================
Sub tile_print (x, y, A$, spacing)
'print text as scanned, with spacing between the characters
px = x
py = y
cc = 0
For c = 1 To Len(A$)
cc = cc + 1
If px + (cc - 1) * 16 >= xmax Then
cc = 1
py = py + 16
End If
ptile px + (cc - 1) * (16 + spacing), py, tile(Asc(Mid$(A$, c, 1)))
Next
End Sub
Sub scale_print (x, y, A$, klr, Hscale, Wscale)
'print string A$ Hscale and Vscale are in relative values (1.0 would be 100%)
'klr can be 0 to 127 from the standard 8 bit palette
'text can wrap back to x if the string would print beyond the screen edge
px = x
py = y
cc = 0
For c = 1 To Len(A$)
cc = cc + 1
If px + (cc - 1) * (16 * Wscale) >= xmax Then
cc = 1
py = py + 16 * Hscale
End If
scale_tile px + (cc - 1) * (16 * Wscale), py, tile(Asc(Mid$(A$, c, 1))), klr, Hscale, Wscale
Next
End Sub
Sub scale_tile (px As Integer, py As Integer, im$, klr, HH, WW)
'print tile tt starting at point px,py
'klr can be 0 to 127 from the standard 8 bit palette
x = 0
For c = 1 To Len(im$)
n = Asc(Mid$(im$, c, 1)) - 128
If n < 1 Then aklr = Abs(n)
If n > 0 Then
If aklr > 0 Then
x2 = x + n
Line (px + ((x - 1) * WW), py + ((Y - 1) * HH))-(px + ((x2 - 1) * WW), py + ((Y - 1) * HH + HH - 1)), klr, BF
x = x2
Else
x = x + n
End If
End If
If x >= t_wid Then
x = 0
Y = Y + 1
End If
Next c
End Sub
Sub ptile (px As Integer, py As Integer, im$)
'print tile im$ starting at point px,py
x = 0
For c = 1 To Len(im$)
n = Asc(Mid$(im$, c, 1)) - 128
If n < 1 Then klr = Abs(n)
If n > 0 Then
If klr > 0 Then
x2 = x + n
Line (px + x, py + Y)-(px + x2, py + Y), klr
x = x2
Else
x = x + n
End If
End If
If x >= t_wid Then
x = 0
Y = Y + 1
End If
Next c
End Sub
Sub cptile (px As Integer, py As Integer, im$, klr)
'print tile im$ starting at point px,py
'recolor tile out put to color klr
'klr can be 0 to 127 from the standard 8 bit palette
x = 0
For c = 1 To Len(im$)
n = Asc(Mid$(im$, c, 1)) - 128
If n < 1 Then aklr = Abs(n)
If n > 0 Then
If aklr > 0 Then
x2 = x + n
Line (px + x, py + Y)-(px + x2, py + Y), klr
x = x2
Else
x = x + n
End If
End If
If x >= t_wid Then
x = 0
Y = Y + 1
End If
Next c
End Sub
Sub scan816
'scan the default font and load it into tile entries 0 to 255
'reads colors 0-127 in standard 8 bit palette
'each character will be rescaled to a tile 16 by 16 pixels in size
Dim p(t_wid, t_wid) As Integer 't_wid is set to 16 in main program
For c = 0 To 255
klr = -1
Cls
Locate 1, 1
Print Chr$(c)
For y = 0 To t_wid - 1
For x = 0 To t_wid - 1
p(x, y) = Point(Int(x / 2), y)
Next
Next
klr = p(0, 0)
tile(c) = Chr$(128 - klr)
For y = 0 To t_wid - 1
x = -1
Do
x = x + 1
If p(x, y) = klr Then n = n + 1
If p(x, y) <> klr Then
tile(c) = tile(c) + Chr$(128 + n)
klr = p(x, y)
If klr > 127 Then klr = 15 'if scanned color is over palette entry 127 it gets set to 15 for white in standard palette
tile(c) = tile(c) + Chr$(128 - klr)
n = 1
End If
If x = t_wid - 1 Then
tile(c) = tile(c) + Chr$(128 + n)
n = 0
End If
Loop Until x = t_wid - 1
Next
Next c
End Sub