This is my latest attempt at a word-game. It uses my Random-Access word list R_ALL15, which is attached (I hope).
It uses a text-to-speech subroutine that was posted by bplus recently.
Code: (Select All)
Screen _NewImage(1040, 768, 32) ' Chars Per Row is 80, 36 rows
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f&
Common Shared CPR, Name$(), NP, Score(), Words$(), Win$
CPR = 1040 / _PrintWidth("X") ' Chars Per Line used for centring text and wiping lines
_ScreenMove (_DesktopWidth - 1040) / 2, 100
Instructions
Randomize Timer
Dim Name$(4), Letter$(100), Value(27), UsedWds$(20), Hand$(20)
Bad$ = "o2l16fedc": OK$ = "o3l64ceg": Win$ = "o3l32cego4ceg"
Play Win$
StockSetup:
Data "A","A","A","A","A","A","B","B","B","C","C","C","C","D","D","D","D","E","E","E"
Data "E","E","E","E","F","F","F","G","G","G","G","H","H","H","H","I","I","I","I","I"
Data "I","J","K","K","K","L","L","L","L","M","M","M","M","N","N","N","N","N","O","O"
Data "O","O","O","P","P","P","P","Q","R","R","R","R","R","S","S","S","S","S","T","T"
Data "T","T","T","U","U","U","U","V","V","V","W","W","W","X","X","Y","Y","Y","Z","Z"
For a = 1 To 100: Read Letter$(a): Next
ShuffleLetters:
For Shuf = 1 To 3 ' shuffle 3 times, just to be sure
For a = 1 To 100
swp = Int(Rnd * 100) + 1
Swap Letter$(a), Letter$(swp)
Next
Next
First = 1
LetterValues: ' for A to Z
Data 1,5,3,3,1,6,4,4,1,9,6,2,4,2,1,4,9,1,1,1,1,7,7,8,5,8
For a = 1 To 26: Read Value(a): Next
NP = 1
GetNames:
WIPE "15"
Locate 15, 15: Print "Enter a name for player"; NP; "(Enter for no more)";
Input Name$(NP) ' get a name
If Len(Name$(NP)) < 1 Then GoTo GotThem
Name$(NP) = UCase$(Name$(NP)) ' change to Upper Case
If Len(Name$(NP)) > 7 Then Name$(NP) = Left$(Name$(NP), 7)
WIPE "15": Centre Name$(NP), 15: _Delay .5 ' display name briefly
NP = NP + 1 ' inc number of players
If NP > 4 Then NP = 5: Cls: GoTo GotThem ' limit to 4 players
GoTo GetNames
ShowUsedWords:
Show = 1
WIPE "15": Locate 15, 30: Print "Keep used letters visible (y/n)?"
While k$ = "": k$ = InKey$: Wend
If UCase$(k$) = "N" Then Show = 0
ShowValues:
Cls: yellow: Centre "Letter Values", 31
Txt$ = " "
For a = 1 To 26: Txt$ = Txt$ + Chr$(a + 64) + " ": Next
Centre Txt$, 32
Txt$ = " "
For a = 1 To 26: Txt$ = Txt$ + LTrim$(Str$(Value(a))) + " ": Next ' show letter-values
white: Centre Txt$, 33
ShowScores:
Txt$ = " "
For a = 1 To NP
Txt$ = Txt$ + " " + Name$(a) + ":" + Str$(Score(a)) + " "
Next
yellow: Centre Txt$, 2
PlayerTurn:
Hand = Hand + 1
If Hand > Hands Then Finish
Plr = Plr + 1: If Plr > NP Then Plr = 1 ' cycle players
First = (Hand - 1) * 10 - 1
If First > NP * 20 Then First = 0
For a = 1 To 10
Hand$(a) = Letter$(First + a)
Next
Locate 8, 35
For a = 1 To 10: Print Hand$(a);: Next
Txt$ = Name$(Plr) + " playing"
WIPE "0516": yellow: Centre Txt$, 5
GetWord:
yellow: Centre "Type your word", 11
Locate 13, 37: white: Input Wrd$
Wrd$ = UCase$(Wrd$)
l = Len(Wrd$)
WIPE "1113": Centre Wrd$, 13
CheckLength:
If l < 2 Then
Play Bad$: Wrd$ = "": wdval = 0: l = 0
red: Centre " Too short, or no word entered", 15
yellow: Sleep 1: GoTo GetScore
End If
NonAlphas:
For a = 1 To l
L$ = Mid$(Wrd$, a, 1)
If L$ < "A" Or L$ > "Z" Then ' if non-alpha,
Play Bad$: Wrd$ = "": wdval = 0: l = 0
red: Centre "Only letters may be used", 15
yellow: Sleep 1: GoTo GetScore
End If
Next
BadLetrs:
For a = 1 To l ' for each letter of wrd$
L$ = Mid$(Wrd$, a, 1)
Fail = 1 ' flag as failed
For b = 1 To 10 ' for each letter in hand$ L$ = Mid$(Wrd$, a, 1)
If L$ = Hand$(b) Then
Hand$(b) = " "
Fail = 0
Exit For
End If
Next
If Fail = 1 Then
Play Bad$: Wrd$ = "": wdval = 0: l = 0
red: Centre "Bad letter", 15
yellow: Sleep 2: Exit For
End If
Next
If Fail = 1 Then GoTo GetScore
CheckWord:
Found = 0 ' set Found flag to fail
Open "R_ALL15" For Random As #1 Len = 19
FL = LOF(1) \ 19 + 1 ' number of words in file
bot = 0: top = FL
While Abs(top - bot) > 1
srch = Int((top + bot) / 2)
Get #1, srch, a$
a$ = UCase$(a$)
Select Case a$
Case Is = Wrd$
Found = 1
Exit While
Case Is < Wrd$
bot = srch
Case Is > Wrd$
top = srch
End Select
Wend
Close
If Found = 0 Then
Txt$ = Wrd$ + " is not a legal word"
Play Bad$: Wrd$ = "": wdval = 0: l = 0
red: Centre Txt$, 15
yellow: Sleep 2: GoTo GetScore ' score zero
Else
Play OK$
For a = 1 To l
L$ = Mid$(Wrd$, a, 1)
wdval = wdval + a + Value(Asc(L$) - 64)
Next
End If
If UsedWds > 0 Then ' if this is not the first good word,
CheckDup: ' check if duplicate
Dup = 0
For a = 1 To UsedWds
If UsedWds$(a) = Wrd$ Then
Txt$ = Wrd$ + " has already been used"
Play Bad$: Wrd$ = ""
wdval = 0: l = 0: Dup = 1
red: Centre Txt$, 15
yellow: Sleep 2 ' score zero
Exit For
End If
Next
If Dup = 1 Then GoTo GetScore
End If
GetScore:
If Show <> 0 Then
Locate 28, 1
For a = 1 To UsedWds: Print UsedWds$(a); " ";: Next ' show used words
End If
Close
Sleep 2
Txt$ = "Hand " + LTrim$(Str$(Hand + 1)) + " of " + LTrim$(Str$(Hands))
Centre Txt$, 18
Txt$ = "You scored" + Str$(wdval)
yellow: Centre Txt$, 16
Score(Plr) = Score(Plr) + wdval
wdval = 0
Sleep 1
WIPE "1315"
GoTo PlayerTurn
Sub Finish
Play Win$
Cls
yellow: Centre "Scores", 6: white
Txt$ = " "
For a = 1 To NP
Txt$ = Txt$ + " " + Name$(a) + ":" + Str$(Score(a)) + " "
Next
yellow: Centre Txt$, 8: white
winr = 1
For a = 2 To NP
If Score(a) > Score(winr) Then winr = a
Next
Locate 10, 1
For a = 1 To NP
Print Tab(30); Name$(a); Tab(45); Words$(a)
Next
Txt$ = "Well done, " + Name$(winr)
yellow: Centre Txt$, 15
Sleep
Run
End Sub
Sub WIPE (LN$) ' LN$ is string with 2 digits for each line to be wiped
If Len(LN$) = 1 Then LN$ = "0" + LN$ ' catch single-digit line numbers
For a = 1 To Len(LN$) - 1 Step 2
WL = Val(Mid$(LN$, a, 2)) ' get 2 digit number of lineto be wiped
Locate WL, 1: Print Space$(CPR - 1); ' print line of spaces on the line
Next
End Sub
Sub Centre (Txt$, LineNum) ' centres text on selected line
ctr = Int(CPR / 2 - Len(Txt$) / 2) + 1 ' centre is half of Chars Per Line minus half Txt$ length
Locate LineNum, ctr
Print Txt$;
End Sub
Sub white
Color _RGB(255, 255, 255)
End Sub
Sub yellow
Color _RGB(255, 255, 0)
End Sub
Sub red
Color _RGB(255, 0, 0)
End Sub
Sub Instructions
Centre "Hear the instructions (y/n)", 12
k$ = ""
While k$ = "": k$ = InKey$: Wend
yellow: Centre "Scramble", 5
Centre "A word game for up to 4 players", 6
white: Print: Print
Print " The game uses a Stack of 100 tiles, each holding a letter with a value of"
Print " from 1 to 9 points, and these are shuffled before the game begins.": Print
Print " A Set of 10 tiles is prepared and presented to a player for their turn,"
Print " and they try to form a word (minimum 2 letters) from these tiles. Every"
Print " player plays all Sets of letters, but in a different order, and they all"
Print " have the same number of "; Chr$(34); "first bite at the cherry"; Chr$(34); " for Sets"; ".": Print
Print " Each word is checked, and if it is a real word, points are awarded for the"
Print " tiles used. If not, no points are scored (but no penalty is applied).": Print
Print " Points are also scored for the length of the word: 1 point for the first"
Print " letter, 2 points for the next, 3 for the next etc. so a 6-letter word will"
Print " score 1+2+3+4+5+6, or 21 points, plus the letter-value points.": Print
Print " Each word may only be used once - even from different Sets. At the start,"
Print " players agree on whether used words will remain visible or not during the"
Print " game. If not, memory becomes another factor in winning. Words that are"
Print " repeated score no points (but no penalty is applied).": Print
Print " The game ends when all players have played all Sets, and the player with"
Print " the most points wins."
yellow
If UCase$(k$) = "Y" Then
_KeyClear
speak ("The game uses a Stack of 100 tiles, each holding a letter with a value of from 1 to 9 points, and these are shuffled before the game begins.")
If _KeyHit >= 0 Then GoTo Done
speak ("A Set of 10 tiles is prepared and presented to a player for their turn, and they try to form a word (minimum 2 letters) from these tiles.")
speak ("Every player plays all Sets of letters, but in a differnt order, and they all have the same number of first bite at the cherry for Sets")
speak ("Each word is checked, and if it is a real word, points are awarded for the tiles used. If not, no points are scored (but no penalty is applied).")
speak ("Points are also scored for the length of the word: 1 point for the first letter, 2 points for the next, 3 for the next etc.")
speak ("So a 6-letter word will score 1+2+3+4+5+6, or 21 points, plus the letter-value points.")
speak ("Each word may only be used once - even from different Sets.")
speak ("At the start, players agree on whether used words will remain visible or not during the game.")
speak ("If not, memory becomes another factor in winning. Words that are repeated score no points (but no penalty is applied).")
speak ("The game ends when all players have played all Sets, and the player with the most points wins.")
End If
Centre "Press a key when ready", 31: Sleep
Done: Cls
End Sub
Sub speak (message As String)
Shell _Hide "Powershell -Command " + Chr$(34) + "Add-Type -AssemblyName System.Speech; (New-Object System.Speech.Synthesis.SpeechSynthesizer).Speak('" + message + "');" + Chr$(34)
End Sub
Hello everyone, I always follow you and continue to appreciate the project and everyone's effort to improve and keep our beloved QB64 alive! I’m sharing with you a code that I thought of and partially developed (and obviously then refined with the help of AI) to interpret a string with a calculation expression, just like scientific calculators do with expressions. I believe it is useful and I hope it helps someone. If you test the code, everything will be clearer. Pass to the function - in the example, this first function is not there because the expression is in the main code - something like: a# = calc# ("1 + (variable#(73) ^ 2 + (variable#(74) + variable#(88) / 100) ) * 100") where variable#() are obviously the variables to be processed. Feel free to modify the expression by adding and removing operators, and you will (always?) get the correct result.
Let me know! Maybe something like this already exists and I just don't know about it yet, or perhaps it's not as useful as it seems to me.
Here's what I have so far, for printing text in a big font.
Then to smoothly scroll, I'd have to redraw slightly shifted over.
Is there a better way to do this?
I'm not crazy about this relying on an array or drawing a rectangle for every pixel, it seems like it could be easier and more efficient.
I vaguely recall seeing different examples of printing a bigger font and smoothly scrolling big text to a hires screen, but can't seem to find them.
Code: (Select All)
Dim in$
Dim iChar As Integer
Dim sChar$
Dim iStartX As Integer
Dim x%, y%
Dim fgColor~&
Dim bgColor~&
Dim scale%
ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
Sub PrintBigText (imgDest&, in$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha() As Integer)
Dim iChar As Integer
Dim sChar$
Dim x1%, y1%
' Make sure we have a valid image handle
If imgDest& < -1 Or imgDest& > 0 Then
' Make sure scale% >0
If scale% > 0 Then
' Make sure sChar$ is not blank and arrAlpha is DIMmed
''ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
if len(in$)>0 and _
lbound(arrAlpha,1)>=32 and ubound(arrAlpha,1) <=127 _
and lbound(arrAlpha,2) =1 and ubound(arrAlpha,2) = _FontWidth _
and lbound(arrAlpha,3) =1 and ubound(arrAlpha,3) = _FontHeight then
x1% = x%: y1% = y%
For iChar = 1 To Len(in$)
sChar$ = Mid$(in$, iChar, 1)
PrintBigChar imgDest&, sChar$, x1%, y1%, fgColor~&, bgColor~&, scale%, arrAlpha()
x1% = x1% + (_FontWidth * scale%) ' move forward 1 character
Next iChar
End If
End If
End If
End Sub ' PrintBigText
' /////////////////////////////////////////////////////////////////////////////
' Usage:
' PrintBigChar imgDest&, sChar$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha()
Sub PrintBigChar (imgDest&, sChar$, x%, y%, fgColor~&, bgColor~&, scale%, arrAlpha() As Integer)
Dim iChar As Integer
Dim x1%, y1%, x2%, y2%
' Make sure we have a valid image handle
If imgDest& < -1 Or imgDest& > 0 Then
' Make sure scale% >0
If scale% > 0 Then
' Make sure sChar$ is not blank and arrAlpha is DIMmed
''ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
if len(sChar$)>0 and _
lbound(arrAlpha,1)>=32 and ubound(arrAlpha,1) <=127 _
and lbound(arrAlpha,2) =1 and ubound(arrAlpha,2) = _FontWidth _
and lbound(arrAlpha,3) =1 and ubound(arrAlpha,3) = _FontHeight then
' Make sure ASCII code is in the range of our array
iChar = Asc(Left$(sChar$, 1))
If (iChar >= LBound(arrAlpha, 1)) And (iChar <= UBound(arrAlpha, 1)) Then
' Print sChar$ as big letter at x%, y% in color fg~&, bg~&
y1% = y%
For sy = 1 To _FontHeight
x1% = x% ' start each line at beginning
y2% = y1% + (scale% - 1) ' calculate y endpoint
For sx = 1 To _FontWidth
x2% = x1% + (scale% - 1) ' calculate x endpoint
If arrAlpha(iChar, sx, sy) = _TRUE Then
Line (x1%, y1%)-(x2%, y2%), fgColor~&, BF
Else
Line (x1%, y1%)-(x2%, y2%), bgColor~&, BF
End If
x1% = x1% + scale% ' move x over by scale%
Next sx
y1% = y1% + scale% ' move y down by scale%
Next sy
End If
End If
End If
End If
End Sub ' PrintBigChar
Sub GetBigFont (arrAlpha() As Integer)
Dim imgChar As Long
Dim iChar As Integer
Dim sx, sy As Integer
Dim c~&
Dim r As Integer
ReDim arrAlpha(32 To 127, 1 To _FontWidth, 1 To _FontHeight) As Integer
InitImage imgChar, _FontWidth, _FontHeight, _RGB32(0, 0, 0)
For iChar = 32 To 127
_Dest imgChar
_Source imgChar
Color _RGB32(255, 0, 0), _RGB32(0, 0, 0)
_PrintString (0, 0), Chr$(iChar)
For sy = 0 To (_FontHeight - 1)
For sx = 0 To (_FontWidth - 1)
c~& = Point(sx, sy)
r = _Red32(c~&): ' g = _Green32(c~&) : b = _Blue32(c~&) : a = _Alpha32(c~&)
If r = 255 Then
arrAlpha(iChar, sx + 1, sy + 1) = _TRUE
Else
arrAlpha(iChar, sx + 1, sy + 1) = _FALSE
End If
Next sx
Next sy
Next iChar
If imgChar< -1 Or imgChar > 0 Then _FreeImage imgChar
End Sub ' GetBigFont
I have my PI-5 hooked up to a large screen 3840x2160 and changed the default display setting for large screen, I don't know the actual aspect ratio as there were only 3 options, set default for large, medium or small screen
setting the default for large screen works well except for QB64pe, if I change the Font size in pixels from 19 to 21 then the IDE looks ok but the programs display in a tiny window with tiny fonts, same when using $Console:Only
any plans to make QB64pe DPI aware ?
Posted by: SierraKen - 03-25-2025, 05:56 AM - Forum: Games
- No Replies
Tonight I put this game together. It has no graphics like Simon does, or colors, but instead it uses numbers. It also uses completely different numbers for each turn.
It might take 1 or 2 tries to get the hang of it. Don't ask me why I made the limit 1000 turns, most likely nobody on Earth could remember 1000 numbers in sequence with only seeing them for 2 seconds each. I just wanted to be sure. LOL
Code: (Select All)
_Title "Numbers Memory Game by SierraKen"
Screen _NewImage(800, 600, 32)
Dim num(1001)
Dim num2(1001)
begin:
turns = 0
Cls
Clear
Print: Print: Print
Print " Numbers Memory Game by SierraKen"
Print: Print: Print
Print " Remember all of the numbers the computer shows."
Print " Each turn has different numbers."
Print " One number is added per turn."
Print: Print: Print
Input " Press Enter to begin."; a$
Cls
Randomize Timer
Do
turns = turns + 1
For n = 1 To turns
num(n) = Int(Rnd * 9) + 1
Locate 15, 50: Print "Turn: " + Str$(turns)
Locate 20, 50: Print num(n)
_Delay 2
Cls
_Delay 1
Next n
For n = 1 To turns
Locate 20, 50: Print "Number " + Str$(n) + ": ";: Input num2(n)
If num2(n) <> num(n) Then
Sound 100, 2, , , 3
Locate 24, 50: Print "Wrong Answer!"
Locate 26, 50: Print "Right Answer: "; num(n)
Locate 28, 50: Input "Again (Y/N)"; ag$
If Left$(ag$, 1) = "y" Or Left$(ag$, 1) = "Y" Then GoTo begin
End
End If
Cls
Next n
If turns = 1000 Then End
Loop
'========================= routines =============================================================
Sub SVGcircle (svgimage$, cx, cy, radius, stroke, strokeK~&, fillK~&)
'converst input data to a svg definition of a circle
'fillK~k& and strokK~& are the 32 biut colors for the fill color and the stroke colors of the circle
'stroke is the thickness of the perimieter fof the circle
'SVGdraw must be used following this routine to display the shape drawn
r& = _Red32(fillK~&): g& = _Green32(fillK~&): b& = _Blue32(fillK~&): a& = _Alpha32(fillK~&)
fk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
fo$ = _Trim$(Str$(a& / 255))
r& = _Red32(strokeK~&): g& = _Green32(strokeK~&): b& = _Blue32(strokeK~&):: a& = _Alpha32(strokeK~&)
sk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
so$ = _Trim$(Str$(a& / 255))
svgimage$ = svgimage$ + "<circle cx='" + Tnum$(cx) + "' cy='" + Tnum$(cy) + "' r='" + Tnum$(radius) + "'fill-opacity='" + fo$ + "' fill='" + _Trim$(fk$) + "'"
svgimage$ = svgimage$ + "'stroke-opacity='" + so$ + "' stroke='" + _Trim$(sk$) + "' stroke-width='" + _Trim$(Str$(stroke)) + "' />"
End Sub
Sub SVGtriangle (svgimage$, x1, y1, x2, y2, x3, y3, stroke, strokeK~&, fillK~&)
'converst input data to a svg definition of a triangle
'fillK~k& and strokK~& are the 32 biut colors for the fill color and the stroke colors of the circle
'stroke is the thickness of the perimeter of the triangle
'SVGdraw must be used following this routine to display the shape drawn
r& = _Red32(fillK~&): g& = _Green32(fillK~&): b& = _Blue32(fillK~&): a& = _Alpha32(fillK~&)
fk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
fo$ = Tnum$(a& / 255)
r& = _Red32(strokeK~&): g& = _Green32(strokeK~&): b& = _Blue32(strokeK~&):: a& = _Alpha32(strokeK~&)
sk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
so$ = _Trim$(Str$(a& / 255)) 'stroke opacity doesn't seem to be supported but i'm still calulating it for now
svgimage$ = svgimage$ + "<polygon points='" + Str$(x1) + "," + Str$(y1) + Str$(x2) + " ," + Str$(y2) + Str$(x3) + "," + Str$(y3) + " '"
svgimage$ = svgimage$ + "fill-opacity='" + fo$ + "' fill='" + _Trim$(fk$) + "'"
svgimage$ = svgimage$ + "'stroke-opacity='" + so$ + "' stroke='" + _Trim$(sk$) + "' stroke-width='" + Tnum$(stroke) + "' />"
End Sub
Sub SVGpath (svgimage$, Pt(), stroke, strokek~&)
'draw a path described in the single dimensionalarray Pt()
'stroke is thickness of path draw
'strokek~& is color of the stroke to be drawn
'SVGdraw must be used following this routine to display the shape drawn
r& = _Red32(strokek~&): g& = _Green32(strokek~&): b& = _Blue32(strokek~&):: a& = _Alpha32(strokek~&)
sk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
so$ = Tnum$(a& / 255)
totp = UBound(Pt): If totp Mod 2 <> 0 Then totp = totp - 1
dpath$ = "M"
For n = 1 To totp
dpath$ = dpath$ + Str$(Pt(n))
Next n
svgimage$ = svgimage$ + "<path d='" + dpath$ + "'fill-opacity='0' stroke ='" + sk$ + "' stroke-width='" + Tnum$(5) + "' />"
End Sub
Sub SVGfpath (svgimage$, Pt(), stroke, strokek~&, fillK~&)
'draws a filled path described in the single dimensionalarray Pt()
'stroke is thickness of path draw
'strokek~& is color of the stroke to be drawn
'fillK~& is the color to fill the contained space withing the drawn path
'SVGdraw must be used following this routine to display the shape drawn
r& = _Red32(strokek~&): g& = _Green32(strokek~&): b& = _Blue32(strokek~&):: a& = _Alpha32(strokek~&)
sk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
so$ = _Trim$(Str$(a& / 255))
r& = _Red32(fillK~&): g& = _Green32(fillK~&): b& = _Blue32(fillK~&): a& = _Alpha32(fillK~&)
fk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
fo$ = _Trim$(Str$(a& / 255))
totp = UBound(Pt): If totp Mod 2 <> 0 Then totp = totp - 1
dpath$ = "M"
For n = 1 To totp
dpath$ = dpath$ + Str$(Pt(n))
Next n
svgimage$ = svgimage$ + "<path d='" + dpath$ + "' fill='" + fk$ + "' fill-opacity='" + fo$ + "' stroke-linejoin='miter' stroke ='" + sk$ + "' stroke-width='" + Tnum$(stroke) + "' />"
End Sub
Sub SVGpolyA (svgimage$, Pt(), stroke, strokek~&, fillK~&)
'draws a filled polygon described in the single dimensionalarray Pt()
'stroke is thickness of path draw
'strokek~& is color of the stroke to be drawn
'fillK~& is the color to fill the contained space withing the drawn path
'SVGdraw must be used following this routine to display the shape drawn
r& = _Red32(strokek~&): g& = _Green32(strokek~&): b& = _Blue32(strokek~&):: a& = _Alpha32(strokek~&)
sk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
so$ = _Trim$(Str$(a& / 255))
r& = _Red32(fillK~&): g& = _Green32(fillK~&): b& = _Blue32(fillK~&): a& = _Alpha32(fillK~&)
fk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
fo$ = _Trim$(Str$(a& / 255))
totp = UBound(Pt): If totp Mod 2 <> 0 Then totp = totp - 1
dpath$ = "M"
For n = 1 To totp Step 2
dpath$ = dpath$ + Str$(Pt(n)) + "," + Str$(Pt(n + 1))
Next n
svgimage$ = svgimage$ + "<polygon points='" + dpath$ + " '"
svgimage$ = svgimage$ + " fill='" + fk$ + "' fill-opacity='" + fo$ + "'stroke-linejoin='miter' stroke ='" + sk$ + "' stroke-width='" + Tnum$(stroke) + "' />"
End Sub
Sub SVGellipse (svgimage$, cx, cy, rx, ry, stroke, strokeK~&, Fillk~&)
'converst input data to a svg definition of a circle
'fillK~k& and strokK~& are the 32 biut colors for the fill color and the stroke colors of the circle
'stroke is the thickness of the perimieter fof the circle
'SVGdraw must be used following this routine to display the shape drawn
r& = _Red32(Fillk~&): g& = _Green32(Fillk~&): b& = _Blue32(Fillk~&): a& = _Alpha32(Fillk~&)
fk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
fo$ = _Trim$(Str$(a& / 255))
r& = _Red32(strokeK~&): g& = _Green32(strokeK~&): b& = _Blue32(strokeK~&):: a& = _Alpha32(strokeK~&)
sk$ = _Trim$("#" + hexpad$(r&) + hexpad$(g&) + hexpad$(b&))
so$ = _Trim$(Str$(a& / 255))
svgimage$ = svgimage$ + "<ellipse cx='" + Tnum$(cx) + "' cy='" + Tnum$(cy) + "' rx='" + Tnum$(rx) + "' ry='" + Tnum$(ry)
svgimage$ = svgimage$ + "' fill-opacity='" + fo$ + "' fill='" + _Trim$(fk$) + "'"
svgimage$ = svgimage$ + "'stroke-opacity='" + so$ + "' stroke='" + _Trim$(sk$) + "' stroke-width='" + _Trim$(Str$(stroke))
svgimage$ = svgimage$ + " transform='rotate(" + Tnum$(erot) + ")' />"
End Sub
Function Tnum$ (num)
'returns a numbers as a trimmed string (I worte this because it is briefer in the strings used to define the SVGs)
Tnum$ = _Trim$(Str$(num))
End Function
Function hexpad$ (k&)
'makes sure a hexidecimal value of a number is returned as 2 characters
If k& < 16 Then
hexpad$ = "0" + Hex$(k&)
Else
hexpad$ = Hex$(k&)
End If
End Function
Sub SVGdraw (svgi$, px, py)
'completes an svg layer perviously defined in svgimage$ and display it starting fron the point px.py
'is meant to fill a screen
Dim simg&
'get the screen size and build the header
svgheader$ = "<svg width='" + _Trim$(Str$(_Width)) + "' height='" + _Trim$(Str$(_Height)) + "' >"
svgfooter$ = "</SVG>"
svgimage$ = unpackSVG$(svgi$)
If svgimage$ = "NOT_A_PACKED_SVG" Then
SVGdrawing$ = svgheader$ + svgi$ + svgfooter$ 'attacjing the header,mains svg definiton string and the footer
simg& = _LoadImage(SVGdrawing$, 32, "memory") 'loads the completed SVgdrawing described in the string
_PutImage (px, py), simg& 'put the drawing on the screen
_FreeImage simg& 'free up the memory
Else
SVGdrawing$ = svgheader$ + svgimage$ + svgfooter$ 'attacjing the header,mains svg definiton string and the footer
simg& = _LoadImage(SVGdrawing$, 32, "memory") 'loads the completed SVgdrawing described in the string
_PutImage (px, py), simg& 'put the drawing on the screen
_FreeImage simg& 'free up the memory
End If
End Sub
Function SVGpack$ (svg$)
dc$ = _Deflate$(svg$, 10)
SVGpack$ = "SVG64" + _Base64Encode$(dc$)
End Function
Function unpackSVG$ (packed$)
unp$ = "NOT_A_PACKED_SVG"
If Left$(packed$, 5) = "SVG64" Then
datal = Len(packed$) - 5
s0$ = Right$(packed$, datal)
s1$ = _Base64Decode$(s0$)
unp$ = _Inflate$(s1$)
End If
unpackSVG$ = unp$
End Function
Function rand0 (num)
'returns a random # from 0 to num
rand0 = Int(Rnd * (num + 1))
End Function
this one has an embedded SVG image drawn with Adobe Illustartor. It makes used of deflate/inflate and base64 encoding for sharing data via posts.
Code: (Select All)
'Packed SVG example
'this program requires QB64-Phoenix Edition 4.1 or later
'
'displayes an encoded SVG graphic
'the oriignal data was compressed by use of the _deflate$ commad and _base64encode$ to make it safe to share as a text file on HTML
'
Screen _NewImage(1200, 600, 32)
_FullScreen _SquarePixels , _Smooth
'the following lines are a packed SVg file The original SVG was draewn in Adobe Iluustrator and simplified by hand
'to embed in a program and encoded for compression and safe transmission as tetx file
esvg$ = "SVG64eNrdXN2P5MZx/1cGyIMSoDlh9XcDToDzCHpSngzkXaDXvkVGOuF2odj316c+u5uc2Zt1LECwdZglh0M2q6vr81fV+t3PP7x+PP3xP07f/BfA2TsP23o"
esvg$ = esvg$ + "GJ5+gn4SfeF0XCOd2xZ+WcPXntkT66yJdceEX+hGf9Ys+i0dPzy70rD/nxZ/TL/lcr3SBBtwWfQMes97Z8FjxbrqOlLhVKJG/OHpZ6De/4Lscfpa0AZJDz3t8M5KBo+"
esvg$ = esvg$ + "E0Nh4Zn8pKTVt4PH4HOGDagL/RvaC0eqUoLkqe10+aPjhJGVQeokfs1qCfwt+Bbwx8C80P5of5W9B3JqUBJhqC0ABMDDMPzwNNHz+ZGY2/4SQKHouj9cDjBsyA6iL+Hhyxq"
esvg$ = esvg$ + "2zGQs9/AzMy6hIXPvKLL5EEABcU/+DvER/Fk0pDEgfxFaCfiHxGzhOn+Arwh+5grtEPldiAF4nKQKxWsYpMQ7Fludqst91KO10Xp+tCA+JVHsbtecWyNj3t9WmRX2CJIvYkB"
esvg$ = esvg$ + "1sk2cGziJ+CaxLxA3jblehqLL40PV4WRzeDyxMZphIs1gfyov6Wr0gkCeOVWM9SvAgRwEK7LsmE8UDyPAkRXpms/JqEb9fVJWK9qCQuQ8UpZifqELfBW2ABQkpM3VDvgIe/"
esvg$ = esvg$ + "EgnwkX79Zcmomyw/uIR8J1LtZwFfVFK3RcxAXuTdjaTQtDjqnZXPVSNNEhILNDAZ+CzOIJ8zvT5fhc2FKGMLoxpWbczMF2Qq9GLSHhJuz8wkbc94xGkgTz4SLatQuYiCk"
esvg$ = esvg$ + "bj0mYgeIie2rreF7qS/m0xq8bw0cYn8dn448p1NFJqntU6Km9VY1E34zuaLWOiIwEBmaAFVZxEHHPxK37LMsgkJzGXP8w2DvqjMz2ymhI3MXxIwWinVOJ7Dwm/Cv8G4QBxwsiCiloePt2"
esvg$ = esvg$ + "HnC2bCePL2JatNK2JbB4Fi20RepkG6xIAO4HUQMYGHH5JJz6Zj8q/VrWrL9Vn+okSQMIhk04fEuH6v7uvL6Zt//8/fDa8WAyl5/P6N43T7n56vV3ziXz58u5a1n"
esvg$ = esvg$ + "L6R530mo+GJ7CAGZSGtS0gHaV0jBWcHKNwi4V7MnCxiTwr/kFiUKxqe2l2OuKMkvNlALANpNQ+R+Mm6ydAFhy5sCWB4jaaerA4fyGLnJyEtyklQp5H5elCPF5nvkde"
esvg$ = esvg$ + "yikqEs7gu0Y/IvPfb5NvqooadJnQUlKQ3NfOKUT9VFs/WM+rYafFmMESGxOkGkU5QgfJqZIIoC/0gSu412ghibC6+Es9REgqJA/mqvoKy1k/X6/PPL0+n188//PTyp0+"
esvg$ = esvg$ + "ff8RV/vGH18/Pf/lXHG+t4UTEtwinfpCrHpkUSzsVXK+a/w0FxCSmXi45fIcXtr/g17DS2V/xLKGq4vlnuop8plO6jMt0K3V5DRVCl7riUpvimKpGnez3Isvmr0HCGbI"
esvg$ = esvg$ + "n5M7I47D2XBe9MapvvbMQxH1/8YHEip5HJnl+pdNXv4NZrTVkCw6xrt7Hp2X1p90XuwOFpIV6QslLX2EbKmTtjPPGNuaVsC2e2yO2xYzqgdSHrVv8ykIsfo+YRg6DvjD"
esvg$ = esvg$ + "HmGFX+TlqiOnVCIXZCF0i6rNwKhZS5kZn9jbh1een7fXEM0HBRop4IoGIvse+BU6kdcWXmJ4WgNPuC/5ayzn65k+Ahi3WCjPnSooXT+/43+c/vn5k3mT89vHp+c8fX0k"
esvg$ = esvg$ + "E6etMEmpDeCdJaY0lRyVp+oK/4lxjK+W9JNV7JO1W7/eB/vXVQ8mrnGEkiUcLGUG0sMRzkk6nd7xDNmMCVuTakKh+kKtoC9DA43TCUSIvH1rJuSuyZ6axRMbE5yyTeiq"
esvg$ = esvg$ + "q3B7TUkOOREuKlayJHuQq1HMooZ0CTti3rxATxZYYMW0oSDNimK4ji7uSMYtDpfC3qldl1RD7Ki4ELgGj4upCosgMj3G6vakyYBjHjkxtf3Lqlx0FMOy9+G4e2rOhIZc"
esvg$ = esvg$ + "p6Ym8SmJ3r4FRGIGbBAhOk5tNlFCCKkl2KIwiPxY1+KqaXtD97QpBnOAmCQlFtZgJUdSJvnMXcffEYcrG/JyVsedx4p0Sv4hMJbtQ5ZqXly9hThTDZGaLBTqHaO4SGg6"
esvg$ = esvg$ + "FXMX4nYUbRcD1hbkTkNSV/vUl5IC/so+mSJMyw8gxRNzYCdI5z5yOlBOMFBk0V6w32YfkDlWj9Ci5g8U2wmvOmC3ns6wmcDREs0sS325zzmuh8zaFe2H4f+Ecr97CsU"
esvg$ = esvg$ + "uXhTm9jpdA84w0rky+9TNkwx2Gdc0RhlE26yX+AY3xC5Irkpk48OhRRmAueY6+wAI4ySEl2WLc4Q+BPSW5jD76PTpKi9l3OmhUyMJ8N2bZcY5JFmFCUqLKpmQHPUuec+"
esvg$ = esvg$ + "A7SMkQ9KzOrGjYGfX6iLB3HBeRZR3jfF9Vu0mkz0+BkygyaLJMsIN3kvBjTqJcIpGSiBSVEEV0Eg1JeGSilrKpGUqSoR1FCOY8804+osplSpZM95KKmGWEecoI52e2Q1"
esvg$ = esvg$ + "KT7CLcy21IItHskFfSM9dX9xAMBPGDZJ8h8elXPK9fAbrn7V/w14KMSS2eAkYvEHZuIoVYMEodjtfPbvdOpNn4vx5pUmATvYFxRS06x4lmAbxKYVAkjW7optPgu6K2Ay"
esvg$ = esvg$ + "ZkJOqH4b0N+BxZxXAO4yssUk2yGhYfEik6lm1gLkWxlSaC3VcqiSxtGubxOkuO7dV5yPdEZoWtW9LMxsS82+R5pcMULrMfkOxG0nMCHKqlpRZIMzbB0Bybd6I40ksC"
esvg$ = esvg$ + "x4skfMrlezaC/+urwW4gMflwABo4IL0q8Ve9dlV9nqCiomyr3QokHYnTs6uc0whFR+ho67tH4ADtePybRthRb9/Fjg1LNmNIvsO28Q5YOKzpwK02NRNBTQXosWwGQS"
esvg$ = esvg$ + "+CDYuY5IE0aAar96dx/4hGRKQn+GJvlA5JRFpE+IO9w/dUWp4w2Ecye4OVLKMNJBNohVU6Uj+LDyVKQrk84yi/0eyOoFlTGNVmHHg1SJfiUS7+4aU8z"
esvg$ = esvg$ + "NIcp6KE76Z08kjqHjEYl1VuFJA3WsXo+no+XnlKn2Ivs8AUYldxsr+hcuyFASQC7aKQ+EpRUfiVFvL7gOyAX9dYvW+ES+BqAwathRaUEAhdnC+P3DOGD41cSN"
esvg$ = esvg$ + "ykkhI586B8JkqwfDdM1DxFva93RjGvqGOgVKoyBKFvisw7CXWlehTu1DdYPW8KMF7sr9eKmtRY2sKiK+kA+UzgCpagphWBxjTLfJjMRuvuvGluRxbh"
esvg$ = esvg$ + "IXaAmQByuJ3n8uVcs4FRYuuRAzlT5tpVRdu+T7FH1rkXldB7YwQdgyMg+/6uMXIfI+n7d8e/cQw/Vp7vTRIzSVy1HZYszGXYbBAx57ZToiGFS83wk1N1"
esvg$ = esvg$ + "H9YaFMQVdaQiFczxYRrjSnC/mObxrWe7OW6HqqjlKWgDKykA1iEp2at0llxf7C8PxYIVLrP5+Gda6nmJrPTIafgxMrcSfHIKSPz2S60xHv07Fs614Kf2MlOGr2dm"
esvg$ = esvg$ + "O/M7Fj0GgQtg24MXUUn4LfmwTGt0xOSzFGmOJct/QtGNEz1Gx1xdF3ABLuwqGfiJlMJxUtVX93EARAWgzQRQcgjPOWSevFrW7BMmGux6cQKbhJtuCdDiG2jxTUqy0nqSt"
esvg$ = esvg$ + "OhWeN7y5rSHTpyWajT7lcYKulo1isjOPqzBzls50SSoaYLejtqe1XS2OaVvjNl6E367LO6V+XIWpDAoNZzrcnRgxkO9MTpyk1/LubPCudEyMSkcSkXduxnkmdQNLD4EjS"
esvg$ = esvg$ + "aDVfrth2CtBPpEeytL30GwfgKKiiGMQeE9eV/QWrMA4EFfVWedzPqphFIybMrERE1t0AxdfKOqYqIsP9EZYoEkcPcqyh8+pA9pAnARAwmj9p4U+gIlNh8QFK+S5w8y57W"
esvg$ = esvg$ + "2bEA5TA1P1TTz6O4VxjPUxk+Ae5o7B9j6CA4TpfCocB8h/GY3rDmsRxraLCQYD8lP0e6IMGJ9dfBwvxMgjGWzoBB0XXWJ4PBD6bDee0Rj7jbQvqVFupuMVFPTolg3yvum"
esvg$ = esvg$ + "kag23UQG2eEGrXgDvfh1NNOrZooXCxIzNc2+q7bkNB5+ZOZN6zVehUFcFzfvcNk9GPYdFb4irIxZdMFsKXiWVBJWBtxFbO9VKC7Zhzb8L0ZoN3lCEIAAOMUIpEmMLmc2b"
esvg$ = esvg$ + "mnrTXJWHgJrn7LWEdDFFcYkA+CCNtAU6ZHbbnuXxMHcNO2N6pJxsGq7nLofUSQFJkHhS4xD2QVEdQ6gy+vV7As8CNRMh7dSy0Zk7mUKY4kxR3w49Mos5YRfxYeh5FoMHx"
esvg$ = esvg$ + "5fBB9e81pOBYNiSDM8/N13l8uadnXZNAPE8V7R0Af4zveKE9c5fPr+cLzo0R2Ox/u+vHP8v2O8VnMOvdACtDY+sZUqTrwaSIRGjYsvLGrcV+bScFdBO6jSHyDy066Po2/"
esvg$ = esvg$ + "8dP3r9fmnpxFt/B7/fcC3/vzp+afXF0L4qYsC49QTn3gqyELYnfGPdIKHyOICdDPgd/vvZnZ9CWV2bAaw4L8BZ+yMlksr47m8BBXDyF6z/LKwbgGbAL5z0Tu1gKfqzpfp"
esvg$ = esvg$ + "gf+mkXG+RAjSsT1/3q5Pt5RwSZomYCXpQJL7mS6SeD2qiKeKZTHSX+A2ET3IVerjKoUqHbnk8HZBXFsa+O143v5/1XnSnvMKAUJ9WlZcpN0X6m6BtfiYuaEF7VUIxSf68"
esvg$ = esvg$ + "hXCoDNlZQbdkvWwKgNc2S2WLR1rg6N+2KuFMPcNq7PJb1ULB2g0hRdzIJ8M0HL7JKG3uSp2G9ycYok1jYdx/JQQGJwUJogib/tr2QKKt1psd63E1hmlgN4BDItvFfi5gB"
esvg$ = esvg$ + "05QqUOoSiIw/3ioD/WATUxG3XKGeZMvUMUejpoIU1vBLBIJB56BJz1CAD3uVKPgJwV0l4Tivf0ZuXSSMM8dbz0g1xFFG6t9YTDJfiahhHK3DWscofRu1pODqKcuUq6aU7"
esvg$ = esvg$ + "UkUaKKv2LOF6OZFUExWLT4vYG1TlJZu9qLa2hR+ra77z4F/2mTSHJng9TlpEsMKwjG9EOQ5iafsUtWBBSprJ5lcDtHC9AHp7rfMDoPIdyMuPHxT6NqNKxCbd3ksz4SBr4"
esvg$ = esvg$ + "yK6GmXY1zCnC8dLYPLdJUupjJgBGnq3wEUf7EzgzdaN35beMlZtO55W7eIaTKWH33JqhZzLDx7zgVNd68KdG/t6TZ+bL2hdybxcOujqSIw5jF+bS9dC/YMDIVyRgFynKn"
esvg$ = esvg$ + "W+0CQ0VrxTJU9h+AarO4WTQ0TY5wzjCJviwwUc6V4OYjIE7FW2B6sKIsLq0XHEYIfsxqioWJmncCHULq0QFGI5W2Cx0nBLJZKK+zWV+FnFNDeWqzDtq6po7faA9Jkjli6"
esvg$ = esvg$ + "ouz2Lxtx3pfteRvmc/lUA52aYSKLEGXGfSQ3byPhYKELY7Lk9xn+6iNMkryrww4UDJWZFTN/joHgtueiGd7HlbUjwo7FywH51nNw6c38WtSZQSJQ3H8uihhhnU2PerpLm"
esvg$ = esvg$ + "StvW9VJLbggpNPdYee0PxJWqPdKEdP5k4FVzn2Zd70eiK/3XucjEpjwTcOuCsDTxvangTN3a3pTf1xwn7MYxmt52kSHuFDVJ0N0jkbrHezBMOe7SypvHZ1oj9yRzg3Ham"
esvg$ = esvg$ + "DBWpatv88Eaym0aybw2HwlT1k3YrA3fBQUdFLQgpc5fkZjh01Pcn+W3T3QVOdxc4212gmwucbi5w+71KIsUyhuwtWKICOk13s4CE9p1ZMFXbqpnGOC2dZdXSBCb5Ag0nS"
esvg$ = esvg$ + "S4E1vzGOwhAxJUnqXCOQv26Twh1/dEOC96JQb2+m9caRhLL4zj8mUuZsmDbfgmnEtevOfXboEyxoaB9kFlB3Cob5yIrUJRe5T6nOwrUO6WtwBvZTWz7PZcGAI+SMkwO8R"
esvg$ = esvg$ + "D7GpR/iH5NEGe3ZU1TcxfUtFHEv9kIdw9EM3xV9ZEMe9f5MDWN6dLtEwPVNpjSiDRPHhEokjBu9uRmMeq07Ox6zNhCvInWnCitik73TAjIY6wzPHUzunpqMqUhcaptVLl"
esvg$ = esvg$ + "uyzI+BwjQ73fwWQV9h+72Tbb3gow4NTf1pyz+6j0QIzpz08a7uX8sTEvbPWATDnw1uLEmUXH9jP9ue2nai06cNl34fWo6Gltedm3AVvO/3VM2NrHJZr4u92qUh+scM9Wo"
esvg$ = esvg$ + "fbcnrccY271mzmUE+Brve4UU803iZ65YKpSQyDZTJweQ5ekSN/CiP3/6aVi9XC68seXl9fOn/3miS+uqvlQuLYbRhXHpx+fXp8/XZzwQuLLOaJPiYafj8S0cab9XBnFdC"
esvg$ = esvg$ + "NrFMrbxRslr1BSTZxGpS8ZsadTWPo7IDR9Yr00U/a6EFQP7MBn7PRuuUuY8tdWST/3AVwG9WcXpYKE/l+r3oKbyTfZp9H1DyPxoWSqMnUPlXv/IPo4JNGEIWqj1mhUlPt"
esvg$ = esvg$ + "ZN6hxJoYmkTgh0V3bhslDkY6EdFNyjwANCPwsMqh2J+PbbNQ1oj/u9aBODbvClKH6l3coTXg3Owk+x/wo3zJiCGeaimTEHg7ZubxdKbreJy7QjZxW8U5c+wiLd/kstPcS"
esvg$ = esvg$ + "MRTJUaapHDFULausRdZFuqEiTBGllAyqn9Ik/tuqUVkIbNRT7vwYUjXj9dtgcbhGvEB4siJAOvM0soTzMhVU3bWq0SLbZhsVt2D1pW6vTjkuYGr+S9AJTDkxOq+gxUSLY"
esvg$ = esvg$ + "LuzQ6ExqK567hW1qD/ekJqI09nIYWFlTdwamTZuV/ZI05ClWQLVamldRCZKubXd66POUjdku7rOVn/OGf12VeJeQKW3mvpNiiFLNsgvkRLxGEVG2FiCJ8SGJx3Jx36ZtG"
esvg$ = esvg$ + "atXEoO2kN8DMCiwNtKzgGpGuvxPBrLiGmEQmd5NYpmzmaUHScbD7rbsnfsYYspQ0tTWE7ao9rlypM9kN7cvFc8xcRpADv1+SfRMRNMF0oAYXZehh9ImrezTZqCbjs"
esvg$ = esvg$ + "N7hU5Wqy1wZNCo7CFlGEHmxk59rWgLoHfkNmseJahsRBP3QcqGi07TQ+plf07aodWa+lv/8QHbTn07VI82ONgKChOwrXJNq4K7fSaTZG5aUGWF5BuybYt+Q3poX1glUn"
esvg$ = esvg$ + "mHU2aiXSf/8UQpIvFxShh2/Y8UsVT6neOU0s/kmUs/c3fO3iMijdDq9rao6xYMl7UBFawR6g1JMN5l5V0VWQiEofGmikZn4Pqrmcj/A0X9oTA="
'
'lets display the image
SVGdraw esvg$, 100, 100
Print "press any key to see the SVG code"
Sleep
Print unpackSVG$(esvg$)
'_Clipboard$ = unpackSVG$(esvg$) 'uncommnet if you want to dump the unencoded SVG defiiniton paste in a file (without the header and footer)
_Delay .5
Print
Print "pretty large isn't it? The SVg files prodcued by Adobe Illustrator are pretty verbose"
Print "The packed SVG from the string esvg$ in the code is "; Len(esvg$); "characters in size."
Print "The unpacked SVG is "; Len(unpackSVG$(esvg$)); " characters in size."
Print "<press any key>"
Sleep
x = 0
For s = 1 To 8
SVGdrawscale esvg$, x, 0, s 'displaying the SVG image at varios scales
x = x + (s * 32)
Next s
Print "The chief advantage is scalability. Images may be scaled without pixelation."
Sleep
System
Function SVGpack$ (svg$)
'takes an SVG descrpiton (any string really) and deflaets it to save space
'the deflated data is convereted to base64 encoding to male is safe to share as text
dc$ = _Deflate$(svg$, 10)
SVGpack$ = "SVG64" + _Base64Encode$(dc$)
End Function
Function unpackSVG$ (packed$)
unp$ = "NOT_A_PACKED_SVG"
If Left$(packed$, 5) = "SVG64" Then
datal = Len(packed$) - 5
s0$ = Right$(packed$, datal)
s1$ = _Base64Decode$(s0$)
unp$ = _Inflate$(s1$)
End If
unpackSVG$ = unp$
End Function
Sub SVGdraw (svgi$, px, py)
'completes an svg layer perviously defined in svgimage$ and display it starting fron the point px.py
'is meant to fill a screen
Dim simg&
'get the screen size and build the header
svgheader$ = "<svg width='" + _Trim$(Str$(_Width)) + "' height='" + _Trim$(Str$(_Height)) + "' >"
svgfooter$ = "</SVG>"
svgimage$ = unpackSVG$(svgi$)
If svgimage$ = "NOT_A_PACKED_SVG" Then
SVGdrawing$ = svgheader$ + svgi$ + svgfooter$ 'attacjing the header,mains svg definiton string and the footer
simg& = _LoadImage(SVGdrawing$, 32, "memory") 'loads the completed SVgdrawing described in the string
_PutImage (px, py), simg& 'put the drawing on the screen
_FreeImage simg& 'free up the memory
Else
SVGdrawing$ = svgheader$ + svgimage$ + svgfooter$ 'attacjing the header,mains svg definiton string and the footer
simg& = _LoadImage(SVGdrawing$, 32, "memory") 'loads the completed SVgdrawing described in the string
_PutImage (px, py), simg& 'put the drawing on the screen
_FreeImage simg& 'free up the memory
svgimage$ = ""
End If
End Sub
Sub SVGdrawscale (svgi$, px, py, scale)
'completes an svg layer perviously defined in svgimage$ and display it starting fron the point px.py
'is meant to fill a screen
'scale changes the scale of the drawing 1.0 is 100% while 0.5 would be 50& and 4 would be 400%
Dim simg&
'get the screen size and build the header
svgheader$ = "<svg width='" + _Trim$(Str$(_Width)) + "' height='" + _Trim$(Str$(_Height)) + "' ><g transform='scale(" + _Trim$(Str$(scale)) + ")' >"
svgfooter$ = " </g></SVG>"
svgimage$ = unpackSVG$(svgi$)
If svgimage$ = "NOT_A_PACKED_SVG" Then
SVGdrawing$ = svgheader$ + svgi$ + svgfooter$ 'attacjing the header,mains svg definiton string and the footer
simg& = _LoadImage(SVGdrawing$, 32, "memory") 'loads the completed SVgdrawing described in the string
_PutImage (px, py), simg& 'put the drawing on the screen
_FreeImage simg& 'free up the memory
Else
SVGdrawing$ = svgheader$ + svgimage$ + svgfooter$ 'attacjing the header,mains svg definiton string and the footer
simg& = _LoadImage(SVGdrawing$, 32, "memorym") 'loads the completed SVgdrawing described in the string
_PutImage (px, py), simg& 'put the drawing on the screen
_FreeImage simg& 'free up the memory
svgimage$ = ""
End If
End Sub
Working in Screen 0 with displaying hardware images under or over software images.
This is what works for me, but in case I'm missing a better method, I'd thought I'd ask before committing this method for future applications.
Code: (Select All)
_Title "Hardware Image Under and Over Demo"
Dim As Long t, HardwarePage ' This TYPE is per wiki but default single works just as well. Go figure.
Screen 0 ' Active display screen.
Palette 7, 63 ' Increases the color white intensity to maximum.
Cls , 7 ' Make a white screen.
Color 1, 7: Locate 2, 1: Print " We want to keep a white screen for this demo. Press any key...": Sleep: _KeyClear
t = _NewImage(_Width * _FontWidth, _Height * _FontHeight, 32) ' Creation screen.
_Dest t ' Make creation screen the active, but hidden (not the display) screen.
Cls , _RGB(255, 255, 255) ' Make the creation screen bright white.
HardwarePage = _CopyImage(t, 33) ' Hardware screen layer #1 to create a white background.
_FreeImage t ' Free the creation screen from memory.
t = _NewImage(150, 150, 32) ' Creation screen of our hardware image 150 x 150 BLOCK.
_Dest t ' Yes, we need to do this again, becaue we opened a new screen.
Line (0, 0)-(150, 150), _RGB32(0, 0, 150), BF ' This solid blue BLOCK will become our Hardware image.
block = _CopyImage(t, 33) ' Copy our blue BLOCK to hardware memory.
_FreeImage t ' Free the creation screen from memory.
_Dest 0 ' Get back to the displayscreen.
_DisplayOrder _Hardware , _Software ' Place hardware layer under software layer.
DisplayOrder$ = "HardwareUnderSoftware" ' Assign this array to keep track of display order switching.
_PaletteColor 5, _RGB32(255, 255, 255, 0) ' Assigns color 5 as transparent white, which appears 'black' without an underlay added, software screen.
Cls , 5 ' Apply transparent 'black' screen to software layer.
Color 14, 4: a$ = " Software Banner to Display Over and Under Hardware Block ": Locate 12, 13: Print a$ ' Place software image on transparent page.
'---------------------------------------------------------------------------------------------------------------------------------------------------
Color 7, 0: Locate 2, 1: Print " Notice the screen is now black."
Print " Don't worry, we will get our white screen back in a flash!"
Print " Press a key to continue then press keys to toggle the display order...": Sleep: _KeyClear: Locate 2, 1: Color 0, 5: Print Space$(_Width * 3)
'---------------------------------------------------------------------------------------------------------------------------------------------------
Do
_Limit 30
b$ = InKey$
If Len(b$) Then
switch` = Not switch` 'This _bit variable is flipped when a key is pressed.
If switch` And DisplayOrder$ = "HardwareUnderSoftware" Then _DisplayOrder _Software , _Hardware: DisplayOrder$ = "HardwareOverSoftware"
If switch` = 0 And DisplayOrder$ = "HardwareOverSoftware" Then _DisplayOrder _Hardware , _Software: DisplayOrder$ = "HardwareUnderSoftware"
If b$ = Chr$(27) Then System ' End routine and close program window.
End If
If DisplayOrder$ = "HardwareUnderSoftware" Then _PutImage (0, 0), HardwarePage ' Our hardware BLOCK will now be displayed on this white surface.
_PutImage (250, 110), block ' Sends our blue BLOCK to the screen.
_Display
Loop
Now if we make the software image(s) first, instead of after changing the display order, no problemo. We just copy that screen as follows...
Code: (Select All)
_Title "Hardware Image Under and Over Demo 2"
Dim As Long t, HardwarePage ' This TYPE is per wiki but default single works just as well. Go figure.
Screen 0 ' Active display screen.
_PaletteColor 5, _RGB32(255, 255, 255, 0) ' Assigns color 5 as transparent white, which appears 'black' without an underlay added, software screen.
Cls , 5 ' Make a transparent background for our software image.
Color 14, 4: a$ = " Software Banner to Display Over and Under Hardware Block ": Locate 12, 13: Print a$ ' Place software image on transparent page.
s& = _CopyImage(0) ' Copy the software image.
t = _NewImage(_Width * _FontWidth, _Height * _FontHeight, 32) ' Creation screen.
_Dest t ' Make creation screen the active, but hidden (not the display) screen.
Cls , _RGB(255, 255, 255) ' Make the creation screen bright white.
HardwarePage = _CopyImage(t, 33) ' Hardware screen layer #1 to create a white background.
_FreeImage t ' Free the creation screen from memory.
t = _NewImage(150, 150, 32) ' Creation screen of our hardware image 150 x 150 BLOCK.
_Dest t ' Yes, we need to do this again, becaue we opened a new screen.
Line (0, 0)-(150, 150), _RGB32(0, 0, 150), BF ' This solid blue BLOCK will become our Hardware image.
block = _CopyImage(t, 33) ' Copy our blue BLOCK to hardware memory.
_FreeImage t ' Free the creation screen from memory.
_Dest 0 ' Get back to the displayscreen.
_DisplayOrder _Hardware , _Software ' Place hardware layer under software layer.
DisplayOrder$ = "HardwareUnderSoftware" ' Assign this array to keep track of display order switching.
PCopy s&, 0 ' Send the copied software image to the display screen.
Do
_Limit 30
b$ = InKey$
If Len(b$) Then
switch` = Not switch` 'This _bit variable is flipped when a key is pressed.
If switch` And DisplayOrder$ = "HardwareUnderSoftware" Then _DisplayOrder _Software , _Hardware: DisplayOrder$ = "HardwareOverSoftware"
If switch` = 0 And DisplayOrder$ = "HardwareOverSoftware" Then _DisplayOrder _Hardware , _Software: DisplayOrder$ = "HardwareUnderSoftware"
If b$ = Chr$(27) Then System ' End routine and close program window.
End If
If DisplayOrder$ = "HardwareUnderSoftware" Then _PutImage (0, 0), HardwarePage ' Our hardware BLOCK will now be displayed on this white surface.
_PutImage (250, 110), block ' Sends our blue BLOCK to the screen.
_Display
Loop
Now maybe there's a better approach (way) to do this, as well.
Pete
PS: A BIG THANKS to Steve. I was on my tablet, on top of the Empire State building, trying to sort all of this out in a 1,500 line program. Steve talked me down!
Nothing beats the feeling of coding your own project successfully except maybe having a child, writing a book, painting a masterpiece, ... well I guess the list could be endless
Here's an idea I worked on recently that I will save you from showing the code I came up with.
I wanted to practice meditation more and I always liked following your breath exercises so:
I started with what I call a "Tesla Breath" Tesla loved numbers 3, 6, 9
1. Inhale for count of 3
2. Hold count of 6
3. Exhale for count of 9
not exactly box breathing but we want to be genuii like Tesla right?
4. then I added mod to slow the counts down over time so that you breath significantly slower when you finish than from when you start.
5. then I added positive words list to display while counting out Inhales, Holds and Exhales. A randomly selected word for each count. This list is separate from bas source to edit whenever you like or maybe change the flavor of meditation with a whole different list.
6. next up in last session I realized I need to build in a timer for a minimum session length to set at start.
So that's my idea for a neat little project you can make All Your Own!
I'm sure many of you have already made this game, but I wanted to see if I could do it without any help.
You got 120 seconds to see how many times you can use the mouse to click the button. Plus there's the option to start over.
Code: (Select All)
Screen _NewImage(800, 600, 32)
begin:
score = 0
buttonx = 370
buttony = 300
text$ = "Click"
_Title "Click The Button Game by SierraKen"
c = 10
For bb = 0 To 30
c = c + 10
Line (buttonx + bb, buttony + bb)-(buttonx2 - bb, buttony2 - bb), _RGB32(100 + c, 100 + c, 100 + c), B
Next bb
Color _RGB32(0, 0, 0)
_PrintString (buttonx + 32, buttony + 17), text$
dir = 1
t = Timer
Do
_Limit 350
buttonx2 = buttonx + 100
buttony2 = buttony + 50
ti = Timer - t
c = 10
For bb = 0 To 30
c = c + 10
Line (buttonx + bb, buttony + bb)-(buttonx2 - bb, buttony2 - bb), _RGB32(100 + c, 100 + c, 100 + c), B
Next bb
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
_PrintString (buttonx + 32, buttony + 17), text$
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Score: "; score
Locate 2, 1: Print "Time Left: "; Int(120 - ti)
If Int(120 - ti) < 1 Then
Locate 30, 50
Print "The End"
Locate 34, 50
Input "Again (Y/N)"; ag$
If Left$(ag$, 1) = "y" Or Left$(ag$, 1) = "Y" Then GoTo begin:
End
End If
While _MouseInput: Wend
mousex = _MouseX
mousey = _MouseY
mouseLeftButton = _MouseButton(1)
If mouseLeftButton Then
Clear_MB 1
If mousex > buttonx And mousex < buttonx2 And mousey > buttony And mousey < buttony2 Then
c = 110
_AutoDisplay
For bb = 0 To 30
c = c - 10
Line (buttonx + bb, buttony + bb)-(buttonx2 - bb, buttony2 - bb), _RGB32(100 + c, 100 + c, 100 + c), B
Next bb
_Delay .1
For bb = 0 To 30
c = c + 10
Line (buttonx + bb, buttony + bb)-(buttonx2 - bb, buttony2 - bb), _RGB32(100 + c, 100 + c, 100 + c), B
Next bb
_Delay .05
c = 10
For bb = 0 To 30
c = c + 10
Line (buttonx + bb, buttony + bb)-(buttonx2 - bb, buttony2 - bb), _RGB32(100 + c, 100 + c, 100 + c), B
Next bb
_Delay .1
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
_PrintString (buttonx + 32, buttony + 17), text$
Sound 900, 1, , , 6
score = score + 1
Color _RGB32(255, 255, 255), _RGB32(0, 0, 0)
Locate 1, 1: Print "Score: "; score
buttonx = Int(Rnd * 650) + 49
buttony = Int(Rnd * 500) + 19
End If
End If
changedir = Int(Rnd * 100) + 1
If changedir > 95 Then
dir = Int(Rnd * 8) + 1
End If
If dir = 1 Then buttony = buttony + 1
If dir = 2 Then buttony = buttony - 1
If dir = 3 Then buttonx = buttonx + 1
If dir = 4 Then buttonx = buttonx - 1
If dir = 5 Then buttony = buttony + 1: buttonx = buttonx + 1
If dir = 6 Then buttony = buttony - 1: buttonx = buttonx - 1
If dir = 7 Then buttonx = buttonx + 1: buttony = buttony + 1
If dir = 8 Then buttonx = buttonx - 1: buttony = buttony - 1
If buttonx > 700 And dir = 3 Then dir = 4
If buttonx > 700 And dir = 7 Then dir = 8
If buttonx < 50 And dir = 4 Then dir = 3
If buttonx < 50 And dir = 8 Then dir = 7
If buttony > 520 And dir = 1 Then dir = 2
If buttony > 520 And dir = 5 Then dir = 6
If buttony < 50 And dir = 2 Then dir = 1
If buttony < 50 And dir = 8 Then dir = 7
_Display
Cls , _RGB32(0, 0, 0)
Loop until Inkey$ = CHR$(27)
Sub Clear_MB (var As Integer)
Do Until Not _MouseButton(var)
While _MouseInput: Wend
Loop
