A program can be at one of two promotion levels: development or production.
When at the development level, there are two versions of the program available: development and production.
When at the production level, there is only the one version of the program: production. Until edited, at which point it is back at the development level.
That aside:
We may want a program to look/behave differently depending on what version we are running/exporting. This is where the "dev" and "prod" preprocessor directives come in.
Sample code:
Code: (Select All)
<<dev """
greet$ = "howdy buds, this is the development version of the program"
""">>
<<prod """
greet$ = "good day ladies and gentlement, this is the production version of the program"
""">>
print greet$
In the sample code above, greet$ will have one value when we are running the development version, and a different value when running the production version.
Today's Keyword of the Day is the first which has poor Steve shaking his head and sighing deeply over our documentation and wiki entries on it. Guys, do me a favor and toss the wiki examples out of your brains, as they're NOT what you want to do with _MOUSEINPUT at all.
Let me illustrate with the first example from the wiki:
Code: (Select All)
DO
DO WHILE _MOUSEINPUT ' Check the mouse status
PRINT _MOUSEX, _MOUSEY, _MOUSEBUTTON(1), _MOUSEWHEEL
LOOP
LOOP UNTIL INKEY$ <> ""
Seems to work as advertised, so what's the problem here?
Nothing should go inside your _MOUSEINPUT loop, except for a _MOUSEWHEEL counter!
Let me show you why:
Code: (Select All)
Do
Locate 1
i = 1
Do While _MouseInput ' Check the mouse status
Locate i, 1: Print _MouseX, _MouseY, _MouseButton(1), _MouseWheel
i = i + 1
Loop
If i <> 1 Then For z = i To 20: Locate z, 1: Print Space$(60): Next
Locate 21, 1: Print _MouseX, _MouseY, _MouseButton(1)
_Limit 120
Loop Until InKey$ <> ""
Take the first code and imagine trying to actually do something with it. Printing it inside that example loop isn't actually doing anything constructive for us -- it's just displaying all the mouse's minute movements as it crosses the screen. If we're going to check the mouse against a button, or some such, that we've draw upon our screen, we'll need to settle on o single value for that mouse position which we compare against -- and that's going to be AFTER WE EXIT THE LOOP.
Code: (Select All)
Do While _MOUSEINPUT
Loop
^The above says we're not going to actually do anything with our _MOUSEX and _MOUSEY values... We'll only respond to them outside the loop.
And, as you can see from my second set of code, the end result is *always* going to print the same values as the last pass inside the loop did...
So why would we waste time processing a couple of dozen events, assigning them to overwrite the same values over and over and whatnot, when we're just going to toss those values out the door at the end of the loop??
IF both sets of the following code produce the same results, which is more efficient for us?
Code: (Select All)
While _MouseInput
x = _MOUSEX: y = _MOUSEY
Wend
Code: (Select All)
While _MouseInput; Wend
x = _MouseX: y = _MouseY
Both are going to generate the exact same values for x and y, so which is more efficient for us? The first code is going to assign several dozen temporary values to x and y, before exiting and giving us a final value for x and y. The second code skips all that intermittent assignment and just gives us the final result after the mouseinput loop.
Our second example in the wiki is just as poorly written, and is just as bad of an example.
Code: (Select All)
SCREEN 12
DO ' main program loop
' your program code
DO WHILE _MOUSEINPUT'mouse status changes only
x = _MOUSEX
y = _MOUSEY
IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN
IF _MOUSEBUTTON(2) THEN
PSET (x, y), 15
LOCATE 1, 1: PRINT x, y
END IF
END IF
LOOP
' your program code
LOOP UNTIL INKEY$ = CHR$(27)
Once again, the example is processing all sorts of crap inside that _MOUSEINPUT loop that it doesn't need to. Compile it. Run it. Watch how it behaves. And then compare to the following:
Code: (Select All)
Screen 12
Do ' main program loop
' your program code
Do While _MouseInput: Loop 'mouse status changes only
' your program code
x = _MouseX
y = _MouseY
If x > 0 And x < 640 And y > 0 And y < 480 Then
If _MouseButton(2) Then
PSet (x, y), 15
Locate 1, 1: Print x, y
End If
End If
Loop Until InKey$ = Chr$(27)
The only thing that needs to go inside a _MOUSEINPUT loop is possibly a counter to deal with _MOUSEWHEEL. Everything else should go outside it, or else you're going to end up lagging up your program to the point of uselessness.
MouseInput code should generally look like one of the two varieties below:
Code: (Select All)
While _MouseInput: Wend
Code: (Select All)
While _MouseInput
scrollwheel = scrollwheel + _MOUSEWHEEL
Wend
Attempting to process other code inside that mouseinput loop is just asking for trouble. Our wiki examples work for what they're showing, but what they're showing is about the worst possible structure I could imagine for use with _MOUSEINPUT. Honestly, they must've just written into the wiki when _MOUSEINPUT was first added into the wiki and nobody knew much about it.. As it stands now, those examples need an overhaul to show how to actually use them properly.
Just published a small update to the last release of QBJS. I've added a screen pixel cache to improve the performance of programs that heavily utilize PSET for rendering.
For example, @vince's American flag now majestically waves at a more acceptable rate. Not quite as fast as native QB64 on my box, but a lot closer than before.
Also, there have been a number of posts recently of "Bubble Universes" which also run a lot faster:
Note: If you are not seeing an improvement when you try these examples, you might need to do a SHIFT+Refresh to clear the cached version in your browser.
I don't know much about this topic of accessing PC/Mac/Linux devices.
Is it possible to capture a still image from a USB camera from within a QB64 program? Or would this be incredibly complicated? Obviously the easiest thing to do is just manually capture the image (using the camera software) then _loadimage into QB64.
I'm wondering if QB64 could be used to capture a new image at a certain time interval and discard the previous image.
I would like to ask a question to the community here.
How easy is it for QB64 to support the Greek language?
That is, what is written in quotation marks.
For example,
PRINT "Den ypostirizo ellinikoys xaraktires>"
PRINT "I do not support Greek characters."
PRINT "Δεν υποστηρίζω ελληνικούς χαρακτηρισμούς."
SLEEP
Copy this little example and you'll see exactly what I mean.
I would like one day to be able to make my own programs and insert Greek characters where needed.
Mini-Robo-Mixer generates a sprite sheet of robots.
Code: (Select All)
'Mini-Robo-Mixer v0.1
'By James D. Jarvis November 2022
'This program uses BASIMAGE coded by Dav for QB64GL 1.4, MAY/2020
'
'generate a sprite sheet of monsters
'each is 64 by 64 pixels but code here can be modified to change that
'
'press c or s to save a sprite sheet to the clipboard so you can paste it into a paint program
'and save is whatever format you desire
'pres <esc> to quit
'
'License: Share sprite sheets as long as they include generated credit bar in image
'any programs using original code or graphics from source or generated by program
' please include the following (or equivalent) line somwhere in comments and documentation:
'Includes Art and/or Code from Mini-Robo-Mixer v0.1 created by James D. Jarvis
'
Randomize Timer
Dim Shared ms&
ms& = _NewImage(512, 360, 32)
Screen ms&
_Title "Mini-Robo-Mixer V0.1"
Dim Shared part&
Dim Shared kk1 As _Unsigned Long
Dim Shared kk2 As _Unsigned Long
Dim Shared kk3 As _Unsigned Long
Dim Shared kk4 As _Unsigned Long
Dim Shared kk5 As _Unsigned Long
Dim Shared kk6 As _Unsigned Long
Dim Shared clr~&
part& = BASIMAGE1&
Type robobody_type
head As Integer
larm As Integer
rarm As Integer
torso As Integer
leg As Integer
k1 As _Unsigned Long
k2 As _Unsigned Long
k3 As _Unsigned Long
k4 As _Unsigned Long
k5 As _Unsigned Long
k6 As _Unsigned Long
xsiz As Integer
ysiz As Integer
End Type
robot_limit = 40
Dim klrset(12, 3) As Integer
Dim Shared rlook(robot_limit) As robobody_type
_Source part&
'read the colors from the color reference bar whichever color is in the top left corner will be transparent
clr~& = Point(0, 0) 'find background color of image
kk1 = Point(0, 1): kk2 = Point(0, 2): kk3 = Point(0, 3): kk4 = Point(0, 4): kk5 = Point(0, 5): kk6 = Point(0, 6)
_Dest part&
Line (0, 0)-(0, 8), clr~& 'erase the color reference bar from the bit map
_ClearColor clr~&, ms& 'set background color as transparent
_ClearColor clr~&, part&
_Source ms&
_Dest ms&
Do
Cls
'build a color set for the sprite sheet
For k = 1 To 12
klrset(k, 1) = Int(Rnd * 100 + 150)
If Rnd * 7 < 3 Then klrset(k, 2) = klrset(k, 1) Else klrset(k, 2) = Int(Rnd * 100 + 150)
If Rnd * 7 < 3 Then klrset(k, 3) = klrset(k, 1) Else klrset(k, 3) = Int(Rnd * 100 + 150)
Next k
mmx = 0: mmy = 0
For m = 1 To robot_limit
'create a new set of monster sprites
'included image source has 16 options for head,arms,torso, and legs
rlook(m).head = Int(1 + Rnd * 20)
rlook(m).larm = Int(1 + Rnd * 20)
If Rnd * 10 < 3 Then rlook(m).rarm = rlook(m).larm Else rlook(m).rarm = Int(1 + Rnd * 20)
rlook(m).torso = Int(1 + Rnd * 20)
rlook(m).leg = Int(1 + Rnd * 20)
'determing colors for this specific monster sprite
kp = 1 + Int(Rnd * 12)
kr = klrset(kp, 1): kg = klrset(kp, 2): kb = klrset(kp, 3)
kr2 = Int(kr / 2): kg2 = Int(kg / 2): kb2 = Int(kb / 2)
kp = 1 + Int(Rnd * 6)
kr3 = klrset(kp, 1) - 5: kg3 = klrset(kp, 2) - 10: kb3 = klrset(kp, 3) - 15
kr4 = Int(kr3 / 2): kg4 = Int(kg3 / 2): kb4 = Int(kb3 / 2)
kp = 1 + Int(Rnd * 6)
kr5 = klrset(kp, 1) - 20: kg5 = klrset(kp, 2) - 15: kb5 = klrset(kp, 3) - 7
kr6 = Int(kr5 / 2): kg6 = Int(kg5 / 2): kb6 = Int(kb5 / 2)
draw_robot mmx, mmy, m, 6
mmx = mmx + 64
If mmx >= _Width Then
mmx = 0
mmy = mmy + 64
End If
Next m
md$ = "Robot Sprite Sheet generated " + Date$ + " at " + Time$
md2$ = "Mini-Robot-Mixer V0.1 by James D. Jarvis"
_PrintString (0, 321), md$
_PrintString (0, 337), md2$
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
If kk$ = "C" Or kk$ = "c" Or kk$ = "S" Or kk$ = "s" Then
_ClipboardImage = ms&
_Delay 0.3
Locate 1, 1: Print "Sprite Sheet Saved to Clipboard"
Sleep 3
End If
Loop Until kk$ = Chr$(27)
_FreeImage part&
System
Sub draw_robot (Mx, my, mid, scale)
'generate a monster image from source sprite sheet part& and render to the programs main screen ms&
tempi& = _NewImage(64, 64, 32)
'tempi& creates a temporary one sprite image for rendering
_ClearColor clr~&, tempi&
_Dest tempi&
Cls
_Source tempi&
'repaint source image with generate color values for new monster sprite
For y = 0 To 63
For x = 0 To 63
Select Case Point(x, y)
Case kk1
PSet (x, y), rlook(mid).k1
Case kk2
PSet (x, y), rlook(mid).k2
Case kk3
PSet (x, y), rlook(mid).k3
Case kk4
PSet (x, y), rlook(mid).k4
Case kk5
PSet (x, y), rlook(mid).k5
Case kk6
PSet (x, y), rlook(mid).k6
End Select
Next x
Next y
'generated image in tempi& is rendered to ms& as a 64 by 64 sprite
_PutImage (Mx, my)-(Mx + 63, my + 63), tempi&, ms&
_Source ms&
_Dest ms&
_FreeImage tempi&
End Sub
Data "BIG","SMALL","LION","TIGER","CAR","TRUCK","BLACK","WHITE","WEED","FLOWER","BEDROOM","KITCHEN","COPPER","BRASS","DESERT","OASIS","MILK","HONEY","HORSE","SHEEP"
Data "BADGE","MEDAL","MARRY","DIVORCE","SHED","HOUSE","WAR","PEACE","SUIT","DRESS","BOX","CARTON","ROAD","STREET","DUNCE","GENIUS","CUP","PLATE","STEAK","EGGS"
Data "ORB","SCEPTRE","TOWN","VILLAGE","BURGER","CHIPS","YOUTH","MAIDEN","OLD","NEW","FAKE","GENUINE","TEA","COFFEE","DRESS","SKIRT","PLANTS","WEEDS","PENCIL","CRAYON"
Data "GLASS","BEAKER","GUITAR","PIANO","SLATE","STONE","CORD","ROPE","JUNGLE","DESERT","PANTRY","CUPBOARD","BROOM","SHOVEL","FOOD","DRINK","ORANGE","LEMON","SINNER","SAINT"
AlchemyDescription:
Print
Color 14
Print Tab(36); "ALCHEMY": Color 15
Print
Print " Alchemy (al/ke/mi) can be defined as the process of changing something into"
Print " something different in a mystical way, such as changing ";: Color 14: Print "STONE";: Color 15
Print " into ";: Color 14: Print "GOLD.": Color 15
Print
Print " This game calls upon your skills in this art, to change a word into a"
Print " totally different one, with the least number of changes."
Print
Print " In the usual word-swap game, you repeatedly change one letter of a word for a"
Print " different one, creating a new word, until the target word is produced."
Print
Print " But in Alchemy, you have another tool available to you for the transformation."
Print " You can also ";: Color 14: Print "add";: Color 15: Print " or ";: Color 14: Print "remove";: Color 15: Print " a letter, before re-arranging them, so the word may"
Print " change in length several times as you progress."
Print
Print " As an example, we can change STONE into GOLD with 4 changes:"
Color 14: Print Tab(23); "STONE - TONE - GONE - LONG - GOLD": Color 15
Print
Print " If the wordslists directory is present, each word entered is checked against"
Print " these. If not, they are assumed to be legitimate words."
Print " The wordlist files are the Complete Collins Scrabble Words (2019)."
Print: Color 14
Print Tab(29); "Press a key to continue"
While InKey$ = "": Wend
Play ok$
LoadPairs
Choice: ' invites replacing best scores in file with defaults
Color 14
Locate 23, 17
Print "Would you like to delete all previous results (y/n)";
Sleep
Color 15: y$ = UCase$(InKey$)
If y$ = "Y" Then
Refresh
Play ok$
LoadPairs
End If
SetPair: ' Select pair of words
LoadPairs
Color 14: Print Tab(22); "Which pair would you like, from A to T";
getpair:
pair$ = UCase$(InKey$)
If pair$ < "A" Or pair$ > "T" Then GoTo getpair
If pair$ = Chr$(27) Then Stop
pairnumber = Asc(pair$) - 64
Locate 23, 15: Print "Would you like to peek at the previous best solution (y/n)"
showchain:
k$ = InKey$
If k$ = "" Then GoTo showchain
If UCase$(k$) = "Y" Then ShowBest
StartGame:
Cls
remain = 21: tries = 0: fail = 0 ' start each game with 21 tries remaining
first$ = firstwords$(pairnumber): last$ = lastwords$(pairnumber)
train$(pairnumber) = first$
target = targets(pairnumber): name$ = names$(pairnumber) ' get selected pair details
prev$ = first$ ' pretend the first was a previous try
Color 14
Locate 1, 39 - Int(Len(first$) / 2): Print first$; Tab(52); "Record:"; target ' display the first word in yellow on row 2
Color 15
For a = 2 To maxtries + 1: Locate a, 35
Print String$(9, "."): Next ' show 9 dots for each try (rows 2 to 21)
Color 14
Locate 22, 39 - Int(Len(last$) / 2): Print last$; ' display the last word in yellow on row 23
tryvert = 2 ' row 3 will take the first try
InviteTry:
If tries = maxtries Then
Play fail$
WIPE "23": Color 3:
Locate 23, 21: Print "You've Used up all of your tries, sorry!"
WIPE "24"
Color 15
Sleep 3
GoTo StartGame ' ran out of tries, restart the same pair
Else
Locate tryvert, 35: Print String$(9, "."); Tab(46); Space$(30)
WIPE "23": Color 14 ' refresh remaining tries advice
Locate 23, 27
Print "You have"; 20 - tries; "tries remaining"
Locate tryvert, 3 ' display invite at tab 10 of current try-line
Print "Your word (q to quit)";
End If
DealWithTry:
Locate tryvert, 25
Input try$ ' show ? outside try-line and set try to first dot
Color 15
try$ = UCase$(try$)
If try$ = "Q" Then Stop
If try$ < "A" Or try$ > "Z" Then Play fail$: GoTo SetPair
tries = tries + 1
Locate tryvert, 35: Print Space$(12)
Locate tryvert, 39 - Int(Len(try$) / 2): Print try$
CheckWord ' Call Sub to Check the Player's Word
DealWithCheck:
Locate tryvert, 1: Print Space$(35)
If fail = 1 Then
Locate tryvert, 35: Print " "
Color 3
Locate tryvert, 39 - Len(try$) / 2
Print try$
Color 15
tryvert = tryvert + 1
GoTo InviteTry
Else
If try$ = last$ Then
Finished
GoTo SetPair
Else
Locate 23, 30
Print Space$(50)
tryvert = tryvert + 1
GoTo InviteTry
End If
End If
Sub Refresh
Restore
target = 21: name$ = "UNSOLVED!"
Open "alchpairs" For Output As #1
For a = 1 To 20
train$(a) = "UNSOLVED!"
Read first$, last$
Write #1, first$, last$, target, name$, train$(a)
Print first$; " "; last$; target; name$
Next
Close
Cls
End Sub
Sub WIPE (ln$) ' call with ln$ string of 2-digit line numbers only eg "012223" for lines 1, 22 and 23
For a = 1 To Len(ln$) - 1 Step 2
Locate Val(Mid$(ln$, a, 2)): Print Space$(80);
Next
End Sub
Sub LoadPairs
Restore
Cls
Color 14: Print Tab(37); "Word Pairs"
Print Tab(20); "Pair"; Tab(30); "From"; Tab(41); "To"; Tab(50); "Best"; Tab(62); "By"
Color 15
If _FileExists("alchpairs") Then
Open "alchpairs" For Input As #1
For a = 1 To 20
Input #1, firstwords$(a), lastwords$(a), targets(a), names$(a), train$(a) ' loads word-pairs from "alchpairs" file
Color 14: Print Tab(20); Chr$(a + 64);: Color 15: Print Tab(30); firstwords$(a); Tab(40); lastwords$(a); Tab(50); targets(a); Tab(60); names$(a)
Next
Close #1
Else Refresh
End If
End Sub
Sub ShowBest
Cls: Locate 12, 2
If train$(pairnumber) = "UNSOLVED!" Then Print Tab(35);
Print train$(pairnumber): Sleep 2: Cls
End Sub
Sub CheckWord
added = 0: added$ = "": removed = 0: removed$ = "": fail = 0 ' initialise added, removed and fail flag
Locate tryvert, 48: Print Space$(32)
Locate tryvert, 48
CountAdded:
temp$ = prev$ ' use temp$ as sacrificial to keep prev$ intact while checking for added
For a = 1 To Len(try$) ' for each letter in try$...
l$ = Mid$(try$, a, 1) ' take a letter l$ of temp$
po = InStr(temp$, l$) ' find its position po in temp$ (if any)
If po < 1 Then ' if not found...
added = added + 1
added$ = added$ + l$ ' count it and add to added$
Else
Mid$(temp$, po, 1) = " "
End If
Next
CountRemoved:
temp$ = try$ ' use temp$ as sacrificial to keep prev$ intact while checking for added
For a = 1 To Len(prev$) ' for each letter in try$...
l$ = Mid$(prev$, a, 1) ' take a letter l$ of temp$
po = InStr(temp$, l$) ' find its position po in temp$ (if any)
If po < 1 Then ' if not found...
removed = removed + 1
removed$ = removed$ + l$ ' add it to added$
Else
Mid$(temp$, po, 1) = " "
End If
Next
If added > 1 Then Color 3 Else Color 15
Print "Added "; added$;
If removed > 1 Then Color 3 Else Color 15
Print Tab(60); "Removed "; removed$ ' show letters that have been added or removed, colour cyan if too many
DictionaryCheck:
If Not _DirExists("wordlists") Then isaword = 1: GoTo checksfinished
WIPE "23"
filename$ = "wordlists/" + Left$(try$, 1) ' select dictionary file of first letter of try-word
Open filename$ For Input As #1
getaword:
isaword = 0
While Not EOF(1)
Input #1, dictword$ ' read each word from dictionary
If try$ = dictword$ Then isaword = 1: Exit While ' if word is found, don't look any further
Wend
Close
checksfinished:
Locate 23, 1
If added > 1 Or removed > 1 Or isaword = 0 Then ' if more than one letter added or removed, or word not found, set fail flag
Play fail$
Color 3 ' colour of try changed to cyan if word failed
Print Tab(35); "Word failed";
Color 15
fail = 1
Else
Play ok$
Print Tab(37); "Word ok"; ' otherwise, declare word as ok and make this the new prev$
prev$ = try$
train$(pairnumber) = train$(pairnumber) + "-" + try$
End If
Sleep 1
WIPE "23"
End Sub
Sub Finished
Play ok$: Play ok$
Locate tryvert, 35: Print Space$(12)
Locate tryvert, 39 - Len(try$) / 2: Print try$
WIPE "2223"
Locate 22, 21: Color 14: Print "You did it in"; tries; "changes. Target was"; targets(pairnumber)
Sleep 2
If tries >= targets(pairnumber) Then ' if target is not beaten,
Exit Sub ' go back for next game
Else
targets(pairnumber) = tries ' change the target for that pair to the new best score
Cls
Locate 10, 4
Input "Enter a name for the Best Scores list (or <ENTER> for anonymous)"; winname$ ' get the player's name
If Len(winname$) < 2 Then winname$ = "ANONYMOUS" ' if <ENTER> (or only one character) is given, name is Anonymous
names$(pairnumber) = UCase$(winname$) ' change the name for that pair to the new name
Open "alchpairs" For Output As #1
For a = 1 To 20
Write #1, firstwords$(a), lastwords$(a), targets(a), names$(a), train$(a) ' re-write the alchpairs file with the new details
Next
Close
End If
Cls
Locate 10, 40 - Len(train$(pairnumber)) / 2: Print train$(pairnumber)
Print: Print Tab(36); "Press a key"
Sleep
End Sub
Make5.bas is a small puzzle game where you try to clear the board by removing pieces of the same color. You remove them by making combinations of 5 or more pieces of the same color in the same row or column. Click on the ball to move, then click where you want to move it to. Only large balls can be moved.
Points are scored for pieces that you clear off the board. When the board gets full and no possible moves left then the game is over. See how many points you can make before it's over.
This is an updated and enhanced version of the one posted at the old forum. This new one auto sizes to fit users desktop (not hard coded to a small resolution), the Hi Score is now saved to file, matches are now found both ways at the same time (row+col), and the board and pieces have a better look.
- Dav
Code: (Select All)
'=========
'MAKE5.bas v2.1
'=========
'A board clearing puzzle game.
'Clear the board of balls and score points.
'Make rows/colums of 5 or more of same color.
'Coded by Dav, JUL/2023 for QB64-Phoenix Edition.
'New for version 2.1:
'
' - Added _ICON call for Linux users.
' (Needed for QB64PE icon to be used by program)
' - Removed slow _MOUSEINPUT polling for faster method.
' - Because mouse is faster, the board size can now be
' bigger on larger desktops (not capped out as before).
'===========
'HOW TO PLAY:
'===========
'Colored balls will appear randomly on the playing board.
'Move bigger balls of same color next to each other to form
'rows and columns of the same color. Make a row/column of 5
'or more of same color to erase them and score points.
'Three new smaller balls will appear after every move.
'The smaller balls will grow into big ones on the next move.
'You may move the big balls on top of the smaller ones.
'The goal is to see how many points you can score before
'running out of board space, in which the game will end.
'This game was originally designed in 600x650.
'Here's a way to adapt that code to adjust larger screens.
'The df is a small display fix for autosizing to desktop.
'The .80 means it will size up to 80% of desktop height
'We will add a *df to any x/y used in a command.
DIM SHARED df: df = (_DESKTOPHEIGHT / 600) * .80
'set original screen size, but use the df value.
SCREEN _NEWIMAGE(600 * df, 650 * df, 32)
DO: LOOP UNTIL _SCREENEXISTS
_TITLE "Make5 Puzzle"
'=== define board info
DIM SHARED rows, cols, size, score, hiscore
rows = 9: cols = 9: size = _WIDTH / cols
DIM SHARED box.v(rows * cols), box.s(rows * cols) 'value, size
DIM SHARED box.x(rows * cols), box.y(rows * cols) 'x/y's
DIM SHARED checks(rows * cols) 'extra array for checking
'
'=== load hi score from file
IF _FILEEXISTS("make5.dat") THEN
scr = FREEFILE
OPEN "make5.dat" FOR BINARY AS #scr
hiscore = CVL(INPUT$(4, scr))
IF hiscore < 0 THEN hiscore = 0 'a failsafe
CLOSE #scr
END IF
'=======
restart:
'=======
PLAY "MBL32O3CEGEC"
score = 0
'CLS , _RGB(13, 13, 13)
bc = 1 'counter
FOR c = 1 TO cols
FOR r = 1 TO rows
x = (r * size) '(df is already computed in the 'size')
y = (50 * df) + (c * size)
box.x(bc) = x - size
box.y(bc) = y - size
box.v(bc) = 0 'zero means no color, empty box
box.s(bc) = 1 ' 1 = small size piece
bc = bc + 1
NEXT
NEXT
MakeNewBalls 3, 1 'put 3 big balls on board
MakeNewBalls 3, 2 'put 3 small balls on board
'====
main:
'====
selected = 0
UpdateBoard
second: 'Go back here when making second choice
_DISPLAY
DO
'wait until mouse button up to continue
WHILE _MOUSEBUTTON(1) <> 0: n = _MOUSEINPUT: WEND
WHILE _MOUSEINPUT: WEND
'highlight box when a box is selected
IF selected = 1 THEN
LINE (box.x(t) + 2, box.y(t) + 2)-(box.x(t) + size - 2, box.y(t) + size - 2), _RGB(RND * 255, RND * 255, RND * 255), B
LINE (box.x(t) + 3, box.y(t) + 3)-(box.x(t) + size - 3, box.y(t) + size - 3), _RGB(RND * 255, RND * 255, RND * 255), B
LINE (box.x(t) + 4, box.y(t) + 4)-(box.x(t) + size - 4, box.y(t) + size - 4), _RGB(RND * 255, RND * 255, RND * 255), B
_DISPLAY
END IF
'If user clicked mouse
IF _MOUSEBUTTON(1) THEN
'see where they clicked
mx = _MOUSEX: my = _MOUSEY
'cycle through all Check blocks...
FOR t = 1 TO (rows * cols)
'if clicked on a box clicked
IF mx >= tx AND mx <= tx2 THEN
IF my >= ty AND my <= ty2 THEN
'if this is a first choice...
IF selected = 0 THEN
'only select boxes not empty, with big size balls
IF box.v(t) <> 0 AND box.s(t) = 2 THEN
selected = 1
SOUND 3000, .1 'made a select
oldt = t
oldtv = box.v(t) 'save picked box number color
GOTO second 'now get second choice
END IF
END IF
IF selected = 1 THEN 'making second choice
'if selected an empty box or small ball
IF box.v(t) = 0 OR box.s(t) = 1 THEN
'Grow small balls
FOR d = 1 TO rows * cols
IF box.v(d) <> 0 AND box.s(d) = 1 THEN box.s(d) = 2
NEXT
UpdateBoard
'copy current box values into checking array
FOR i = 1 TO (rows * cols)
checks(i) = box.v(i)
NEXT
'check Rows for 5 or more done
FOR i = 1 TO (rows * cols) STEP 9
CheckRow i
NEXT
'Check Cols for 5 or more
FOR i = 1 TO 9
CheckCol i
NEXT
'copy checking values back into box values
FOR i = 1 TO (rows * cols)
IF checks(i) = 0 THEN
box.v(i) = 0: box.s(i) = 1
END IF
NEXT
'See how many boxes left to use...
howmany = 0
FOR h = 1 TO rows * cols
'empty ones
IF box.v(h) = 0 THEN howmany = howmany + 1
NEXT
'If not enough spaces left, game over
IF howmany < 3 THEN
LINE (200 * df, 250 * df)-(400 * df, 350 * df), _RGB(0, 0, 0), BF
LINE (200 * df, 250 * df)-(400 * df, 350 * df), _RGB(255, 255, 255), B
PPRINT 233 * df, 285 * df, 18 * df, _RGB(255, 255, 255), 0, "GAME OVER"
PLAY "mbl16o2bagfedc"
_DISPLAY: SLEEP 6
GOTO restart
END IF
'make 3 more random small balls
MakeNewBalls 3, 1
GOTO main
ELSE
'if clicked on another big ball instead...
IF box.s(t) = 2 THEN
'clear previous highlighted selection
selected = 0
UpdateBoard
selected = 1
oldt = t
oldtv = box.v(t) 'save picked box number color
SOUND 3000, .1
GOTO second
END IF
END IF
END IF
END IF
END IF
NEXT
END IF
_DISPLAY
IF INKEY$ = " " THEN GOTO restart
LOOP
SUB CheckRow (num)
'space to hold box nums to clear
REDIM nums(9)
'found some to clear flag
rdone = 0
'set place and num
rc = 1
nums(1) = num
'step through the boxes
FOR r = (num + 1) TO (num + 8)
'if this box is same as previous...
IF box.s(r) = 2 AND box.v(r) = box.v(nums(rc)) THEN
'store this box value in nums too
nums(rc + 1) = r
'increase how many so far
rc = rc + 1
ELSE
'bot same, so reset
IF rdone = 0 THEN
'no more, so start over from here
ERASE nums
REDIM nums(9)
rc = 1: nums(1) = r
ELSE
'no more can exists on line
EXIT FOR
END IF
END IF
'if there was 5 or more found
IF rc >= 5 THEN rdone = 1
NEXT
'if group was found, clear
IF rdone = 1 THEN
PLAY "mbl32o3cdefga"
'step through nums values
FOR d = 1 TO 9
IF nums(d) <> 0 THEN
score = score + 55 '55 points per ball
x = box.x(nums(d)): y = box.y(nums(d))
LINE (x + 2, y + 2)-(x + size - 2, y + size - 2), _RGB(255, 255, 255), BF
_DELAY .025: _DISPLAY
LINE (x + 2, y + 2)-(x + size - 2, y + size - 2), _RGB(64, 64, 64), BF
_DELAY .025: _DISPLAY
checks(nums(d)) = 0 'mark checking array
END IF
NEXT
END IF
ERASE nums
END SUB
SUB CheckCol (num)
'space to hold box nums to clear
REDIM nums(9)
'found some to clear flag
rdone = 0
'set place and num
rc = 1
nums(1) = num
'step through the boxes
FOR r = (num + 9) TO (rows * cols) STEP 9
'if this box is same as previous...
IF box.s(r) = 2 AND box.v(r) = box.v(nums(rc)) THEN
'store this box value in nums too
nums(rc + 1) = r
'increase how many so far
rc = rc + 1
ELSE
'bot same, so reset
IF rdone = 0 THEN
'no more, so start over from here
ERASE nums
REDIM nums(9)
rc = 1: nums(1) = r
ELSE
'no more can exists on line
EXIT FOR
END IF
END IF
'if there was 5 or more found
IF rc >= 5 THEN rdone = 1
NEXT
'if group was found, clear
IF rdone = 1 THEN
PLAY "mbl32o3cdefga"
'step through nums values
FOR d = 1 TO 9
IF nums(d) <> 0 THEN
score = score + 55 'add to score
x = box.x(nums(d)): y = box.y(nums(d))
LINE (x + 2, y + 2)-(x + size - 2, y + size - 2), _RGB(255, 255, 255), BF
_DELAY .025: _DISPLAY
LINE (x + 2, y + 2)-(x + size - 2, y + size - 2), _RGB(64, 64, 64), BF
_DELAY .025: _DISPLAY
checks(nums(d)) = 0 'mark checking array
END IF
NEXT
END IF
'=== draw board based on box values
bc = 1 'counter
FOR cl = 1 TO cols
FOR ro = 1 TO rows
'=== if empty box
IF box.v(bc) = 0 THEN
LINE (box.x(bc) + 2, box.y(bc) + 2)-(box.x(bc) + size - 2, box.y(bc) + size - 2), _RGB(32, 32, 32), BF
ELSE
LINE (box.x(bc) + 2, box.y(bc) + 2)-(box.x(bc) + size - 2, box.y(bc) + size - 2), _RGB(32, 32, 32), BF
'=== draw color ball
x2 = box.x(bc) + (size / 2) 'find middle of box
y2 = box.y(bc) + (size / 2)
IF box.s(bc) = 1 THEN sz = size / 4 ELSE sz = size / 2
SELECT CASE box.v(bc)
CASE IS = 1: r = 255: g = 64: b = 64 'red
CASE IS = 2: r = 64: g = 232: b = 64 'green
CASE IS = 3: r = 64: g = 64: b = 255 'blue
CASE IS = 4: r = 255: g = 255: b = 0 'yellow
CASE IS = 5: r = 255: g = 255: b = 255 'white
END SELECT
'draw colored balls
FOR s = 1 TO (sz - 4) STEP .3
CIRCLE (x2, y2), s, _RGB(r, g, b)
r = r - 1: g = g - 1: b = b - 1
NEXT
END IF
bc = bc + 1
NEXT
NEXT
'overlay a very faint QB64-PE icon on board
_SETALPHA 16, , -11: _PUTIMAGE (0, 50 * df)-(_WIDTH, _HEIGHT), -11
_DISPLAY
_ICON _DISPLAY 'update app icon on taskbar
END SUB
SUB MakeNewBalls (num, ballsize)
'Assign 3 new balls
newball = 0
DO
c = INT((RND * (cols * rows)) + 1)
IF box.v(c) = 0 THEN
box.v(c) = INT((RND * 5) + 1)
box.s(c) = ballsize
newball = newball + 1
END IF
IF newball = num THEN EXIT DO
LOOP
END SUB
SUB PPRINT (x, y, size, clr&, trans&, text$)
orig& = _DEST
bit = 32: IF _PIXELSIZE(0) = 1 THEN bit = 256
FOR t = 0 TO LEN(text$) - 1
pprintimg& = _NEWIMAGE(16, 16, bit)
_DEST pprintimg&
CLS , trans&: COLOR clr&
PRINT MID$(text$, t + 1, 1);
_CLEARCOLOR _RGB(0, 0, 0), pprintimg&
_DEST orig&
x1 = x + (t * size): x2 = x1 + size
y1 = y: y2 = y + size
_PUTIMAGE (x1 - (size / 2), y1)-(x2, y2 + (size / 3)), pprintimg&
_FREEIMAGE pprintimg&
NEXT
END SUB
SUB SaveScore
'Out with the old
IF _FILEEXISTS("make5.dat") THEN KILL "make5.dat"
'In with the new
scr = FREEFILE
OPEN "make5.dat" FOR OUTPUT AS #scr
hi$ = MKL$(hiscore)
PRINT #scr, hi$;
CLOSE #scr
END SUB
Posted by: Dav - 11-21-2022, 01:55 AM - Forum: Games
- Replies (9)
Make5.bas is a small puzzle game where you try to clear the board by removing pieces of the same color. You remove them by making combinations of 5 or more pieces of the same color in the same row or column. Click on the ball to move, then click where you want to move it to. Only large balls can be moved.
Points are scored for pieces that you clear off the board. When the board gets full and no possible moves left then the game is over. See how many points you can make before it's over.
This is an updated and enhanced version of the one posted at the old forum. This new one auto sizes to fit users desktop (not hard coded to a small resolution), the Hi Score is now saved to file, matches are now found both ways at the same time (row+col), and the board and pieces have a better look.
- Dav
Code: (Select All)
'=========
'MAKE5.bas v2.1
'=========
'A board clearing puzzle game.
'Clear the board of balls and score points.
'Make rows/colums of 5 or more of same color.
'Coded by Dav, JUL/2023 for QB64-Phoenix Edition.
'New for version 2.1:
'
' - Added _ICON call for Linux users.
' (Needed for QB64PE icon to be used by program)
' - Removed slow _MOUSEINPUT polling for faster method.
' - Because mouse is faster, the board size can now be
' bigger on larger desktops (not capped out as before).
'===========
'HOW TO PLAY:
'===========
'Colored balls will appear randomly on the playing board.
'Move bigger balls of same color next to each other to form
'rows and columns of the same color. Make a row/column of 5
'or more of same color to erase them and score points.
'Three new smaller balls will appear after every move.
'The smaller balls will grow into big ones on the next move.
'You may move the big balls on top of the smaller ones.
'The goal is to see how many points you can score before
'running out of board space, in which the game will end.
'This game was originally designed in 600x650.
'Here's a way to adapt that code to adjust larger screens.
'The df is a small display fix for autosizing to desktop.
'The .80 means it will size up to 80% of desktop height
'We will add a *df to any x/y used in a command.
DIM SHARED df: df = (_DESKTOPHEIGHT / 600) * .80
'set original screen size, but use the df value.
SCREEN _NEWIMAGE(600 * df, 650 * df, 32)
DO: LOOP UNTIL _SCREENEXISTS
_TITLE "Make5 Puzzle"
'=== define board info
DIM SHARED rows, cols, size, score, hiscore
rows = 9: cols = 9: size = _WIDTH / cols
DIM SHARED box.v(rows * cols), box.s(rows * cols) 'value, size
DIM SHARED box.x(rows * cols), box.y(rows * cols) 'x/y's
DIM SHARED checks(rows * cols) 'extra array for checking
'
'=== load hi score from file
IF _FILEEXISTS("make5.dat") THEN
scr = FREEFILE
OPEN "make5.dat" FOR BINARY AS #scr
hiscore = CVL(INPUT$(4, scr))
IF hiscore < 0 THEN hiscore = 0 'a failsafe
CLOSE #scr
END IF
'=======
restart:
'=======
PLAY "MBL32O3CEGEC"
score = 0
'CLS , _RGB(13, 13, 13)
bc = 1 'counter
FOR c = 1 TO cols
FOR r = 1 TO rows
x = (r * size) '(df is already computed in the 'size')
y = (50 * df) + (c * size)
box.x(bc) = x - size
box.y(bc) = y - size
box.v(bc) = 0 'zero means no color, empty box
box.s(bc) = 1 ' 1 = small size piece
bc = bc + 1
NEXT
NEXT
MakeNewBalls 3, 1 'put 3 big balls on board
MakeNewBalls 3, 2 'put 3 small balls on board
'====
main:
'====
selected = 0
UpdateBoard
second: 'Go back here when making second choice
_DISPLAY
DO
'wait until mouse button up to continue
WHILE _MOUSEBUTTON(1) <> 0: n = _MOUSEINPUT: WEND
WHILE _MOUSEINPUT: WEND
'highlight box when a box is selected
IF selected = 1 THEN
LINE (box.x(t) + 2, box.y(t) + 2)-(box.x(t) + size - 2, box.y(t) + size - 2), _RGB(RND * 255, RND * 255, RND * 255), B
LINE (box.x(t) + 3, box.y(t) + 3)-(box.x(t) + size - 3, box.y(t) + size - 3), _RGB(RND * 255, RND * 255, RND * 255), B
LINE (box.x(t) + 4, box.y(t) + 4)-(box.x(t) + size - 4, box.y(t) + size - 4), _RGB(RND * 255, RND * 255, RND * 255), B
_DISPLAY
END IF
'If user clicked mouse
IF _MOUSEBUTTON(1) THEN
'see where they clicked
mx = _MOUSEX: my = _MOUSEY
'cycle through all Check blocks...
FOR t = 1 TO (rows * cols)
'if clicked on a box clicked
IF mx >= tx AND mx <= tx2 THEN
IF my >= ty AND my <= ty2 THEN
'if this is a first choice...
IF selected = 0 THEN
'only select boxes not empty, with big size balls
IF box.v(t) <> 0 AND box.s(t) = 2 THEN
selected = 1
SOUND 3000, .1 'made a select
oldt = t
oldtv = box.v(t) 'save picked box number color
GOTO second 'now get second choice
END IF
END IF
IF selected = 1 THEN 'making second choice
'if selected an empty box or small ball
IF box.v(t) = 0 OR box.s(t) = 1 THEN
'Grow small balls
FOR d = 1 TO rows * cols
IF box.v(d) <> 0 AND box.s(d) = 1 THEN box.s(d) = 2
NEXT
UpdateBoard
'copy current box values into checking array
FOR i = 1 TO (rows * cols)
checks(i) = box.v(i)
NEXT
'check Rows for 5 or more done
FOR i = 1 TO (rows * cols) STEP 9
CheckRow i
NEXT
'Check Cols for 5 or more
FOR i = 1 TO 9
CheckCol i
NEXT
'copy checking values back into box values
FOR i = 1 TO (rows * cols)
IF checks(i) = 0 THEN
box.v(i) = 0: box.s(i) = 1
END IF
NEXT
'See how many boxes left to use...
howmany = 0
FOR h = 1 TO rows * cols
'empty ones
IF box.v(h) = 0 THEN howmany = howmany + 1
NEXT
'If not enough spaces left, game over
IF howmany < 3 THEN
LINE (200 * df, 250 * df)-(400 * df, 350 * df), _RGB(0, 0, 0), BF
LINE (200 * df, 250 * df)-(400 * df, 350 * df), _RGB(255, 255, 255), B
PPRINT 233 * df, 285 * df, 18 * df, _RGB(255, 255, 255), 0, "GAME OVER"
PLAY "mbl16o2bagfedc"
_DISPLAY: SLEEP 6
GOTO restart
END IF
'make 3 more random small balls
MakeNewBalls 3, 1
GOTO main
ELSE
'if clicked on another big ball instead...
IF box.s(t) = 2 THEN
'clear previous highlighted selection
selected = 0
UpdateBoard
selected = 1
oldt = t
oldtv = box.v(t) 'save picked box number color
SOUND 3000, .1
GOTO second
END IF
END IF
END IF
END IF
END IF
NEXT
END IF
_DISPLAY
IF INKEY$ = " " THEN GOTO restart
LOOP
SUB CheckRow (num)
'space to hold box nums to clear
REDIM nums(9)
'found some to clear flag
rdone = 0
'set place and num
rc = 1
nums(1) = num
'step through the boxes
FOR r = (num + 1) TO (num + 8)
'if this box is same as previous...
IF box.s(r) = 2 AND box.v(r) = box.v(nums(rc)) THEN
'store this box value in nums too
nums(rc + 1) = r
'increase how many so far
rc = rc + 1
ELSE
'bot same, so reset
IF rdone = 0 THEN
'no more, so start over from here
ERASE nums
REDIM nums(9)
rc = 1: nums(1) = r
ELSE
'no more can exists on line
EXIT FOR
END IF
END IF
'if there was 5 or more found
IF rc >= 5 THEN rdone = 1
NEXT
'if group was found, clear
IF rdone = 1 THEN
PLAY "mbl32o3cdefga"
'step through nums values
FOR d = 1 TO 9
IF nums(d) <> 0 THEN
score = score + 55 '55 points per ball
x = box.x(nums(d)): y = box.y(nums(d))
LINE (x + 2, y + 2)-(x + size - 2, y + size - 2), _RGB(255, 255, 255), BF
_DELAY .025: _DISPLAY
LINE (x + 2, y + 2)-(x + size - 2, y + size - 2), _RGB(64, 64, 64), BF
_DELAY .025: _DISPLAY
checks(nums(d)) = 0 'mark checking array
END IF
NEXT
END IF
ERASE nums
END SUB
SUB CheckCol (num)
'space to hold box nums to clear
REDIM nums(9)
'found some to clear flag
rdone = 0
'set place and num
rc = 1
nums(1) = num
'step through the boxes
FOR r = (num + 9) TO (rows * cols) STEP 9
'if this box is same as previous...
IF box.s(r) = 2 AND box.v(r) = box.v(nums(rc)) THEN
'store this box value in nums too
nums(rc + 1) = r
'increase how many so far
rc = rc + 1
ELSE
'bot same, so reset
IF rdone = 0 THEN
'no more, so start over from here
ERASE nums
REDIM nums(9)
rc = 1: nums(1) = r
ELSE
'no more can exists on line
EXIT FOR
END IF
END IF
'if there was 5 or more found
IF rc >= 5 THEN rdone = 1
NEXT
'if group was found, clear
IF rdone = 1 THEN
PLAY "mbl32o3cdefga"
'step through nums values
FOR d = 1 TO 9
IF nums(d) <> 0 THEN
score = score + 55 'add to score
x = box.x(nums(d)): y = box.y(nums(d))
LINE (x + 2, y + 2)-(x + size - 2, y + size - 2), _RGB(255, 255, 255), BF
_DELAY .025: _DISPLAY
LINE (x + 2, y + 2)-(x + size - 2, y + size - 2), _RGB(64, 64, 64), BF
_DELAY .025: _DISPLAY
checks(nums(d)) = 0 'mark checking array
END IF
NEXT
END IF
'=== draw board based on box values
bc = 1 'counter
FOR cl = 1 TO cols
FOR ro = 1 TO rows
'=== if empty box
IF box.v(bc) = 0 THEN
LINE (box.x(bc) + 2, box.y(bc) + 2)-(box.x(bc) + size - 2, box.y(bc) + size - 2), _RGB(32, 32, 32), BF
ELSE
LINE (box.x(bc) + 2, box.y(bc) + 2)-(box.x(bc) + size - 2, box.y(bc) + size - 2), _RGB(32, 32, 32), BF
'=== draw color ball
x2 = box.x(bc) + (size / 2) 'find middle of box
y2 = box.y(bc) + (size / 2)
IF box.s(bc) = 1 THEN sz = size / 4 ELSE sz = size / 2
SELECT CASE box.v(bc)
CASE IS = 1: r = 255: g = 64: b = 64 'red
CASE IS = 2: r = 64: g = 232: b = 64 'green
CASE IS = 3: r = 64: g = 64: b = 255 'blue
CASE IS = 4: r = 255: g = 255: b = 0 'yellow
CASE IS = 5: r = 255: g = 255: b = 255 'white
END SELECT
'draw colored balls
FOR s = 1 TO (sz - 4) STEP .3
CIRCLE (x2, y2), s, _RGB(r, g, b)
r = r - 1: g = g - 1: b = b - 1
NEXT
END IF
bc = bc + 1
NEXT
NEXT
'overlay a very faint QB64-PE icon on board
_SETALPHA 16, , -11: _PUTIMAGE (0, 50 * df)-(_WIDTH, _HEIGHT), -11
_DISPLAY
_ICON _DISPLAY 'update app icon on taskbar
END SUB
SUB MakeNewBalls (num, ballsize)
'Assign 3 new balls
newball = 0
DO
c = INT((RND * (cols * rows)) + 1)
IF box.v(c) = 0 THEN
box.v(c) = INT((RND * 5) + 1)
box.s(c) = ballsize
newball = newball + 1
END IF
IF newball = num THEN EXIT DO
LOOP
END SUB
SUB PPRINT (x, y, size, clr&, trans&, text$)
orig& = _DEST
bit = 32: IF _PIXELSIZE(0) = 1 THEN bit = 256
FOR t = 0 TO LEN(text$) - 1
pprintimg& = _NEWIMAGE(16, 16, bit)
_DEST pprintimg&
CLS , trans&: COLOR clr&
PRINT MID$(text$, t + 1, 1);
_CLEARCOLOR _RGB(0, 0, 0), pprintimg&
_DEST orig&
x1 = x + (t * size): x2 = x1 + size
y1 = y: y2 = y + size
_PUTIMAGE (x1 - (size / 2), y1)-(x2, y2 + (size / 3)), pprintimg&
_FREEIMAGE pprintimg&
NEXT
END SUB
SUB SaveScore
'Out with the old
IF _FILEEXISTS("make5.dat") THEN KILL "make5.dat"
'In with the new
scr = FREEFILE
OPEN "make5.dat" FOR OUTPUT AS #scr
hi$ = MKL$(hiscore)
PRINT #scr, hi$;
CLOSE #scr
END SUB
![[Image: 118.png]](https://i.ibb.co/6Fx3YBZ/118.png)
