fancypat

[James D Jarvis]

This isn't a library, it isn't a utility, so I'm sharing it here. This is a recently tweaked version of a mark-up scheme I've been using in programs for years to get a little more out of print or to make it easier for me. I've been using the shortest sub for decades and the rest have evolved over the years depending on my need and exposure to other things such as html. Several years ago I worked up a similar looking markup-up lib but I've long since lost track of that code that was in powerbasic for dos and c and metal for use on macs (never bothered with a windows version).
Embedding draw commands is brand new to me just seems to fit, I'm sure I'll figure out how to make more use of it in the future.

It's called fancypat because fancy print at just seemed too long.

Code: (Select All)

'fancy pat
'print at options
'by James D. Jarvis
' I've been using variations of these for years and felt it was time to share
' it's really just a simple set of option tags embedded in the text and a simple parser
' embedding draw commands in this is the only real new part (for me).
Dim Shared swid, sheight, tmax, tdeep
swid = 800: sheight = 560
Screen _NewImage(swid, sheight, 256) 'can be any size but generally intended for 256 color screens
Dim Shared bkg_klr, frg_klr
Dim Shared gg$(3)
tmax = Int(swid / 8)
tdeep = Int(sheight / 16)
For x = 1 To 3 'builidng sample graphic tiles for demo
    Read gg$(x)
Next x
_ControlChr Off
bkg_klr = 0
frg_klr = 15
Cls
'a super-duper demo
rpat 2, 2, "\c3\\k4\Bob\k0\  is blue on red but this text isn't, \c15\ I'm not even blue anymore."
rpat 2, 4, "\c4\\a202\\a215\\c15\ just printed ascii character 202 and 215  in red."
rpat 2, 6, "\c7\ \pFF0101010101010101010101010101FF\\c15\ is a hex pattern 8 pixels wide. Need a leading space in the string to draw the pattern."
rpat 2, 8, "\c7\ \pFFFF03030303030303FFFF\\c15\is a hex pattern 8 pixels wide, it isn't as deep as the previous one."
rpat 20, 15, "\c14\This is just a long line of text that will wrap around to the next line instead  of throwing up an error when trying to locate text past the edge of the screen."
rpat 2, 12, "\Dc8r4d4l4\BB\Dc11bd15L16\"
rpat 20, 20, "A \Du7l12d12\\a219\\c6\\a220\\c7\\a219\ \c8\ Text, draw, asc chars and color changes in one line."
rpat 10, 10, "\c0\\k4\ I AM NOT A BUTTON ! \Dc15bu1d16l168u16r168bu2br2d20l172u20r172\\k0\\c15\it really isn't (for now)"
rpat 0, 0, "\k0\ \c15\" 'printing to positon 0,0 let's you change colors without putting anything on the sceen
rpat 2, 20, "\c2\\a202\\c15\ - character 202"
rpat 2, 23, "XX" 'this is just to show the relative size of the graphics tile
rpat 2, 24, "  \g3\- this is a 16 pixel wide graphics tile from a predfeined graphic string."

cpat 2, 27, "I'm rpats poor little brother cpat.", 12, 0
cpat 2, 28, "cpat - colored text printed at.", 12, 0
rpat 2, 29, "Oh yeah...\c3\ rpat\c15\ is for \k8\RICH PRINT AT\k0\"


'really feeble graphic tiles just knocked out to demo the concept
Data "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa0000111122223333444455555555666666677777777888888000GG"
Data "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333"
Data "¿8¿7¿0Ÿ2Ÿ4"

'the subs, this is the parts that actually matter
Sub pat (tcol, trow, txt$)
    'print at is just locate rearranged and in one command, it's not even in this demo but I have probably been using it since 88
    'i just feel it is easier to keep track of columns and rows in my head in that order when placing text in a program
    Locate trow, tcol
    Print txt$
End Sub

Sub cpat (tcol, trow, txt$, tklr, tbkg)
    'color print at
    Color tklr, tbkg
    Locate trow, tcol
    Print txt$
    Color frg_klr, bkg_klr
End Sub
Sub rpat (tcol, trow, txt$)
    'rich print at
    n = -1
    c = 0
    Do
        c = c + 1
        A$ = Mid$(txt$, c, 1)
        If A$ <> "\" Then
            n = n + 1
            If tcol + n > tmax Then
                trow = trow + 1
                n = 0
            End If
            If tcol <> 0 Then Locate trow, tcol + n
            If tcol <> 0 Then Print A$
        Else
            B$ = Mid$(txt$, c + 1, 1)
            Select Case B$
                Case "C", "c":
                    D$ = gettag$(txt$, c)
                    Color Val(D$)
                    c = c + Len(D$) + 1
                Case "K", "k":
                    D$ = gettag$(txt$, c)
                    Color , Val(D$)
                    c = c + Len(D$) + 1
                Case "A", "a":
                    D$ = gettag$(txt$, c)
                    DV = Val(D$)
                    Locate trow, tcol + n
                    Print Chr$(DV)
                    n = n + 1
                    c = c + Len(D$) + 1
                Case "P", "p"
                    D$ = gettag$(txt$, c)
                    phex tcol, trow, D$
                    c = c + Len(D$) + 1
                Case "D", "d"
                    D$ = gettag$(txt$, c)
                    n = n + 1
                    xx = ((tcol + n) - 1) * 8
                    yy = (trow - 1) * 16
                    PSet (xx, yy)
                    Draw D$
                    c = c + Len(D$) + 1
                Case "G", "g"
                    D$ = gettag$(txt$, c)
                    DD = Val(D$)
                    gpat tcol, trow, DD
                    c = c + Len(D$) + 1
            End Select
        End If
    Loop Until c > Len(txt$)
End Sub

Function gettag$ (txt$, c)
    D$ = ""
    cc = c + 1
    Do
        cc = cc + 1
        C$ = Mid$(txt$, cc, 1)
        D$ = D$ + C$
    Loop Until C$ = "\"
    gettag$ = Left$(D$, Len(D$) - 1)
End Function


Sub phex (tc, tr, hx$)
    'monochrome pattern
    'I orignally wrote this before _bit was part of qb64, might rework it some day, might not
    xx = (tc - 1) * 8
    yy = (tr - 1) * 16
    For c = 1 To Len(hx$) Step 2
        bt = 0
        For p = 0 To 1
            AA$ = Mid$(hx$, c + p, 1)
            A = Val("&H" + AA$)
            Select Case A
                Case 0: BB$ = "0000"
                Case 1: BB$ = "0001"
                Case 2: BB$ = "0010"
                Case 3: BB$ = "0011"
                Case 4: BB$ = "0100"
                Case 5: BB$ = "0101"
                Case 6: BB$ = "0110"
                Case 7: BB$ = "0111"
                Case 8: BB$ = "1000"
                Case 9: BB$ = "1001"
                Case 10: BB$ = "1010"
                Case 11: BB$ = "1011"
                Case 12: BB$ = "1100"
                Case 13: BB$ = "1101"
                Case 14: BB$ = "1110"
                Case 15: BB$ = "1111"
            End Select
            For b = 1 To 4

                If Mid$(BB$, b, 1) = "1" Then
                    PSet (xx + bt, yy)
                    'remember this uses the last defined color
                Else
                    PSet (xx + bt, yy), bkg_klr
                End If
                bt = bt + 1
            Next b
        Next p
        yy = yy + 1
        bt = 0
    Next c
End Sub

Sub gpat (tc, tr, ggN)
    xx = (tc - 1) * 8
    yy = (tr - 1) * 16
    x = 0
    y = 0
    For c = 1 To Len(gg$(ggN))
        a$ = Mid$(gg$(ggN), c, 1)
        If Asc(a$) < 128 Then
            PSet (xx + x, yy + y), Val(a$)
            x = x + 1
            If x = 16 Then
                x = 0
                y = y + 1
            End If
        Else
            n = Asc(a$) - 127
            c = c + 1
            a$ = Mid$(gg$(ggN), c, 1)
            For nn = 1 To n
                PSet (xx + x, yy + y), Val(a$)
                x = x + 1
                If x = 16 Then
                    x = 0
                    y = y + 1
                End If
            Next nn
        End If
    Next c
End Sub