scale_print

[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