scale_print

[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

[SMcNeill]

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

[James D Jarvis]

Definitely a good way to do it.

[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