+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: fancypat (/showthread.php?tid=553)
fancypat - James D Jarvis - 06-14-2022
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