Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
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
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
Posts: 2,696
Threads: 327
Joined: Apr 2022
Reputation:
217
I tend to do this type of thing by converting my text to an image and then I can scale that image it as needed:
Code: (Select All) Screen _NewImage(800, 700, 32)
_ScreenMove 250, 0
For i = 1 To 4
HW(i) = TextToImage("Hello World", 16, &HFFFFFF00, 0, i)
Next
Cls
Print "The first thing to showcase with these two routines is just how simple it is to turn"
Print "text into an image with TextToImage."
Sleep
Print
Print "First, let's print it forwards:"
_PutImage (250, 48), HW(1)
Sleep
Print
Print "Then, let's print it backwards:"
_PutImage (250, 80), HW(2)
Sleep
Print
Print "Then, let's print it up to down:"
_PutImage (270, 112), HW(3)
Sleep
Locate 8, 40: Print "And let's finish with down to up:"
_PutImage (580, 112), HW(4)
Sleep
Locate 20, 1
Print
Print
Print "TextToImage simply transforms text into an image for us, with a few built in options"
Print "to it for the direction we want we text to print."
Print "It's as simple as a call with:"
Print " Handle = TextToImage(text$, fonthandle, fontcolor, backgroundcolor, mode"
Print
Print " text$ is the string which we want to print. (In this case 'Hello World'"
Print " fonthandle is the handle of the font which we _LOADFONT for use."
Print " (In this case, I choose the default _FONT 16.)"
Print " fontcolor is the color which we want our text in. (Here, it's YELLOW.)"
Print " backgroundcolor is the background which we want for the text time. (Clear this time.)"
Print " mode is how we decide to print forwards, backwards, up to down, or down to up."
Print
Print "Once we have an image handle, we can use that image just the same as we can with any other."
Print "For those who don't need to do anything more than display the text as an image,"
Print "feel free to use it as I have in the first part of this program with _PUTIMAGE."
Print
Print "Trust me -- TextToImage works just fine with _PUTIMAGE."
Print
Print "But.... If you need more..."
Sleep
Cls , 0
Print "There's always DisplayImage to help you out!"
DisplayImage HW(1), 300, 30, 1, 1, 0, 1
Print
Print "Display your image at a scale!"
Sleep
Print
Print "Twice as wide! ";
DisplayImage HW(1), 300, 60, 2, 1, 0, 1
Sleep
Print "Twice as tall! "
DisplayImage HW(1), 500, 60, 1, 2, 0, 1
Sleep
Print
Print "At an angle!"
DisplayImage HW(1), 280, 90, 1, 1, -45, 1
Sleep
Print: Print: Print: Print: Print
Print "Make it rotate!"
_Delay .2
_KeyClear
Do
Line (355, 155)-Step(100, 100), &HFF000000, BF
DisplayImage HW(1), 400, 200, 1, 1, angle, 0
angle = (angle + 1) Mod 360
_Limit 30
_Display
Loop Until _KeyHit
_AutoDisplay
Print
Print
Print
Print
Print "You can basically use DisplayImage just as you'd normally use RotoZoom, EXCEPT..."
Sleep
Print "You can choose which CORNER of the image you want to display at your coordinates."
Print
Line (350, 350)-Step(100, 100), -1, B
Circle (400, 400), 10, -1
Sleep
Print "Top Left corner! ";
DisplayImage HW(1), 400, 400, 2, 2, 0, 1
Sleep
Print "Bottom Left corner! ";
DisplayImage HW(1), 400, 400, 2, 2, 0, 2
Sleep
Print "Top Right corner! ";
DisplayImage HW(1), 400, 400, 2, 2, 0, 3
Sleep
Print "Bottom Right corner! "
DisplayImage HW(1), 400, 400, 2, 2, 0, 4
Sleep
_FreeImage HW(1)
HW(1) = TextToImage("Hello World", 16, &HFFFF0000, &HFF0000FF, 1)
Print "Or Centered!"
DisplayImage HW(1), 400, 400, 2, 2, 0, 0
Circle (400, 400), 10, -1
Sleep
Cls
Print "With TextToImage, you can turn text into an image... It's that simple!"
Print
Print "With DisplayImage, you have a ton of options for how to display ANY image"
Print " (NOT just for use with text images!!)"
Print
Print "Scale them, stretch them, rotate them, position them by various corners..."
Print
Print "Between these two routines, I generally don't need anything else when working"
Print " with images in my programs. ;)"
Print
Print
Print "And that's THE END of this demo. Post any questions you have on the forums for me!"
' (Image As Long, x As Integer, y As Integer, xscale As Single, yscale As Single,
' angle As Single, mode As _Byte)
Function TextToImage& (text$, font&, fc&, bfc&, mode As _Byte)
'text$ is the text that we wish to transform into an image.
'font& is the handle of the font we want to use.
'fc& is the color of the font we want to use.
'bfc& is the background color of the font.
'Mode 1 is print forwards
'Mode 2 is print backwards
'Mode 3 is print from top to bottom
'Mode 4 is print from bottom up
'Mode 0 got lost somewhere, but it's OK. We check to see if our mode is < 1 or > 4 and compensate automatically if it is to make it one (default).
If mode < 1 Or mode > 4 Then mode = 1
dc& = _DefaultColor: bgc& = _BackgroundColor
D = _Dest
F = _Font
T2Idown = CsrLin: T2Iright = Pos(0)
If font& <> 0 Then _Font font&
If mode < 3 Then
'print the text lengthwise
w& = _PrintWidth(text$): h& = _FontHeight
Else
'print the text vertically
For i = 1 To Len(text$)
If w& < _PrintWidth(Mid$(text$, i, 1)) Then w& = _PrintWidth(Mid$(text$, i, 1))
Next
h& = _FontHeight * (Len(text$))
End If
TextToImage_temp& = _NewImage(w&, h&, 32)
TextToImage = TextToImage_temp&
_Dest TextToImage_temp&
If font& <> 0 Then _Font font&
Color fc&, bfc&
Select Case mode
Case 1
'Print text forward
_PrintString (0, 0), text$
Case 2
'Print text backwards
temp$ = ""
For i = 0 To Len(text$) - 1
temp$ = temp$ + Mid$(text$, Len(text$) - i, 1)
Next
_PrintString (0, 0), temp$
Case 4
'Print text upwards
'first lets reverse the text, so it's easy to place
temp$ = ""
For i = 0 To Len(text$) - 1
temp$ = temp$ + Mid$(text$, Len(text$) - i, 1)
Next
'then put it where it belongs
For i = 1 To Len(text$)
fx = (w& - _PrintWidth(Mid$(temp$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
_PrintString (fx, _FontHeight * (i - 1)), Mid$(temp$, i, 1)
Next
Case 3
'Print text downwards
For i = 1 To Len(text$)
fx = (w& - _PrintWidth(Mid$(text$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
_PrintString (fx, _FontHeight * (i - 1)), Mid$(text$, i, 1)
Next
End Select
_Dest D
Color dc&, bgc&
_Font F
Locate T2Idown, T2Iright
End Function
Sub DisplayImage (Image As Long, x As Integer, y As Integer, xscale As Single, yscale As Single, angle As Single, mode As _Byte)
'Image is the image handle which we use to reference our image.
'x,y is the X/Y coordinates where we want the image to be at on the screen.
'angle is the angle which we wish to rotate the image.
'mode determines HOW we place the image at point X,Y.
'Mode 0 we center the image at point X,Y
'Mode 1 we place the Top Left corner of oour image at point X,Y
'Mode 2 is Bottom Left
'Mode 3 is Top Right
'Mode 4 is Bottom Right
Dim px(3) As Integer, py(3) As Integer, w As Integer, h As Integer
Dim sinr As Single, cosr As Single, i As _Byte
w = _Width(Image): h = _Height(Image)
Select Case mode
Case 0 'center
px(0) = -w \ 2: py(0) = -h \ 2: px(3) = w \ 2: py(3) = -h \ 2
px(1) = -w \ 2: py(1) = h \ 2: px(2) = w \ 2: py(2) = h \ 2
Case 1 'top left
px(0) = 0: py(0) = 0: px(3) = w: py(3) = 0
px(1) = 0: py(1) = h: px(2) = w: py(2) = h
Case 2 'bottom left
px(0) = 0: py(0) = -h: px(3) = w: py(3) = -h
px(1) = 0: py(1) = 0: px(2) = w: py(2) = 0
Case 3 'top right
px(0) = -w: py(0) = 0: px(3) = 0: py(3) = 0
px(1) = -w: py(1) = h: px(2) = 0: py(2) = h
Case 4 'bottom right
px(0) = -w: py(0) = -h: px(3) = 0: py(3) = -h
px(1) = -w: py(1) = 0: px(2) = 0: py(2) = 0
End Select
sinr = Sin(angle / 57.2957795131): cosr = Cos(angle / 57.2957795131)
For i = 0 To 3
x2 = xscale * (px(i) * cosr + sinr * py(i)) + x: y2 = yscale * (py(i) * cosr - px(i) * sinr) + y
px(i) = x2: py(i) = y2
Next
_MapTriangle (0, 0)-(0, h - 1)-(w - 1, h - 1), Image To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(w - 1, 0)-(w - 1, h - 1), Image To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
Definitely a good way to do it.
Posts: 660
Threads: 142
Joined: Apr 2022
Reputation:
58
08-30-2022, 08:15 PM
(This post was last modified: 08-30-2022, 08:22 PM by James D Jarvis.)
Added the means to scan in a portion of a true type font (currently only a subset or the all of the characters from 0 to 255)
Added a rich_print command to handle changes in the text output using a set of tags embedded in the text.
Code: (Select All) 'Scale_print version 0.1
'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
'=================================================================================
'$Dynamic
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
Dim Shared charset(0), color_background, color_foreground
charset(0) = 0
t_wid = 16 'tile width set here in main routine if could be moved inside of scan816
color_background = 0
color_foreground = 15
_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
Input A$
Cls
addfont 0, 255, "lucon.ttf" 'use a ttf font
scale_tile 10, 100, tile(256 + Asc("A")), 12, 1, 1
Print charset(0)
Print charset(1)
rich_print 100, 100, "ABCDEFG\CT13\123\CS1\ABC\CS0\\CT2\123\T#412\\SH2\\SW3\abc\CT15\\SH1\\SW1.4\HeLlo"
rich_print 200, 200, "\CT4\\SH4\\SW2\ Big Text \MX20\\MY400\ \SH1\\SW0.5\little text"
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 scan is the dedault font
' addfont scan in true type font
' rich_print print text with embeed tags to control text output settings
' scale_dat print a scaled character tile but onlt using orignally scanned pixel colors
'
' clantag$ an internal function used to process tags in rich_print
'=================================================================================
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
k1 = klr
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)
If klr > 127 Then klr = 15
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
Sub addfont (fstart, fend, fontn$)
'load and scan a ttf font and rescale it slghtly to fit a 16x16 tile
'this will append the tile set with character entries from fstart to fend
Dim p(t_wid - 1, t_wid - 1) As Integer
tsize = UBound(tile)
fadd = fend - fstart + 1
ReDim _Preserve tile(tsize + fadd) As String
cs = UBound(charset)
ReDim _Preserve charset(cs + 1)
charset(cs + 1) = tsize + 1
fontpath$ = Environ$("SYSTEMROOT") + "\fonts\" + fontn$
style$ = ""
fontsize% = t_wid
font& = _LoadFont(fontpath$, fontsize%, style$)
_Font font&
For c = tsize + fstart To tsize + fend
pixelWidth% = _PrintWidth(Chr$(c - tsize))
'pixelWidth% = _PrintWidth("W")
fyd = 1
fxd = t_wid / (pixelWidth%) 'this will stetcch a non-mom font slightyl to fill width
klr = -1
Cls
Locate 1, 1
Print Chr$(c - tsize)
For y = 0 To t_wid - 1
For x = 0 To t_wid - 1
p(x, y) = Point(Int(x / fxd), Int(y / fyd))
Next
Next
klr = p(0, 0)
If klr > 127 Then klr = 15
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
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
_Font 16 'select inbuilt 8x16 default font
_FreeFont font&
End Sub
Sub scale_dat (px As Integer, py As Integer, im$, HH, WW)
'print tile im$ starting at point px,py
'HH and WW are scale factors
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 - 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 rich_print (x, y, txt$)
'prints richly formatted text using a simple set of tags identified by a paif of \
'valid tags
'-------------
'\\ print a single \
'\CTnn\ change the text color to the value nn
'\CSn\ reference characters starting with the charcter start postion for loaded fonts \CS0\ is the default font
'\T#nnn\ print tile #nnn as per scanned data (it will not be recolored)
'\SHn\ set horizontal scale for folowing characters
'\SWn\ set width for following characters
'\MXnn\ move x print coridate to location nn
'\MYnn\ move y print coridate to location nn
'
c = 0
bk = color_background
fk = color_foreground
px = x
py = y
wscale = 1
hscale = 1
cset = 0
Do
tag = 0
c = c + 1
a$ = Mid$(txt$, c, 1)
If a$ = "\" Then
b$ = ""
c2 = c
Do
c2 = c2 + 1
bb$ = Mid$(txt$, c2, 1)
b$ = b$ + bb$
If bb$ = "\" Then tag = 1
Loop Until c2 = Len(txt$) Or tag = 1
If tag = 1 Then
Print b$
If b$ = "\" Then
scale_tile px, py, tile(charset(cset) + Asc(a$)), fk, hscale, wscale
px = px + (16 * wscale)
End If
If InStr(b$, "CT") Then
b$ = cleantag(b$, 2)
fk = Val(b$)
End If
If InStr(b$, "CS") Then
b$ = cleantag(b$, 2)
cset = Val(b$)
End If
If InStr(b$, "T#") Then
b$ = cleantag(b$, 2)
scale_dat px, py, tile(Val(b$)), hscale, wscale
px = px + wscale * t_wid
End If
If InStr(b$, "SH") Then
b$ = cleantag(b$, 2)
hscale = Val(b$)
End If
If InStr(b$, "SW") Then
b$ = cleantag(b$, 2)
hscale = Val(b$)
End If
If InStr(b$, "MX") Then
b$ = cleantag(b$, 2)
px = Val(b$)
End If
If InStr(b$, "MY") Then
b$ = cleantag(b$, 2)
py = Val(b$)
End If
c = c2
Else
scale_print px, py, "ERROR:NO CLOSING TAG", 14, 1, 0.5
c = c2
End If
Else
If c <= Len(txt$) Then scale_tile px, py, tile(charset(cset) + Asc(a$)), fk, hscale, wscale
px = px + (t_wid * wscale)
If px + (t_wid * wscale) >= xmax Then
px = x
py = py + (t_wid * hscale)
End If
End If
Loop Until c = Len(txt$)
End Sub
Function cleantag$ (A$, ww)
al = Len(A$)
b$ = Right$(A$, Len(A$) - ww)
cleantag$ = Left$(b$, Len(b$) - 1)
End Function
|
