04-25-2022, 10:55 PM (This post was last modified: 06-12-2022, 02:23 PM by bplus.)
Smallish Games 100 - 300 LOC with at most a image or sound file.
Bowling
@johnno56 was very helpful with this way back when we were at SmallBASIC forum. I left a copy of that SmallBASIC code (the bas that starts with SB) for nostalgia. This one seems different than usual computer game.
I went though and refreshed the code in this game since Johnno was asking about it.
Code: (Select All)
Option _Explicit
_Title "MasterMind 2022" ' b+ 2022-06-11 make over b+ trans 2022-06-10
'Mastermind v7.bas 2016-02-27 [B+=MGA] for SmallBASIC 0.12.2
'
Randomize Timer
Const xmax = 800, ymax = 632, cx = xmax / 2, cy = ymax / 2
Const diam = ymax / 10 ' originally SB version was built around the bigger of xmax and ymax
Const radi = ymax / 20 ' and these dimensions all flowed from that
Const BullCowX = cx - 4 * diam - 60
Const FrameLX = BullCowX + 5 * 8 ' frame holds ball guess so Frame Left X
Const ControlPanelLX = cx + 8 ' cp = Control Panel? so Control Panel Left X
Const ControlPanelRX = cx + 2 * 8 + 2 * diam
Const black = _RGB32(0, 0, 0)
Const white = _RGB32(255, 255, 255)
Const gray = _RGB32(190, 190, 205)
Const boardC = _RGB32(150, 150, 165)
Const boardC2 = _RGB32(80, 80, 95)
Const deck$ = "RGBYOP" 'here are 6 color initials Red Green Blue Yellow Orange Purple
Dim Shared secret$, gues$(1 To 4), clr$ ' globals
Dim Shared As Long restartF, guesses, lc ' globals yes need both lc and guesses, I guess
Dim As Long i, quit, mx, my, mb ' locals
restart:
restartF = 0: lc = 0: guesses = 0
secret$ = "": For i = 1 To 4: secret$ = secret$ + Mid$(deck$, Int(Rnd * 6) + 1, 1): Next 'one line to make secret$
'_Title secret$ ' for debugging
Line (cx - ymax / 2, 0)-(cx + ymax / 2, ymax), boardC, BF
clr$ = "R" 'screen prep and initialization
drawcontrols
Color white, boardC
_PrintString (cx + 66, 20), "MasterMind: 4 Color Code"
_PrintString (cx + 10, 16 + 30), "B = Bull, Right Color and Right Spot"
_PrintString (cx + 10, 2 * 16 + 35), "C = Cow, Right Color and Wrong Spot"
Line (FrameLX - 4, 0)-(cx - 4, ymax), boardC2, BF
drawframe
quit = 0
While quit = 0 'the game begins
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
If mx > ControlPanelLX And mx < ControlPanelRX And my > 1.5 * diam And my < 9 * diam Then 'click in control panel
If my < 2.5 * diam Then 'guess button clicked
handleGuess
If restartF Then GoTo restart
ElseIf my < 4 * diam Then 'clicked a color update in control panel or quit
clr$ = "R": updatecolor
ElseIf my < 5 * diam Then
clr$ = "G": updatecolor
ElseIf my < 6 * diam Then
clr$ = "B": updatecolor
ElseIf my < 7 * diam Then
clr$ = "Y": updatecolor
ElseIf my < 8 * diam Then
clr$ = "O": updatecolor
ElseIf my < 9 * diam Then
clr$ = "P": updatecolor
End If 'mouse in control box
ElseIf mx > FrameLX And mx < FrameLX + 4 * diam And my > lc * diam And my < lc * diam + diam Then 'mouse click in the guess boxes
If mx < FrameLX + diam Then
gues$(1) = clr$
ball FrameLX + radi, lc * diam + radi, clr$
ElseIf mx < FrameLX + 2 * diam Then
gues$(2) = clr$
ball FrameLX + 1.5 * diam, lc * diam + radi, clr$
ElseIf mx < FrameLX + 3 * diam Then
gues$(3) = clr$
ball FrameLX + 2.5 * diam, lc * diam + radi, clr$
ElseIf mx < FrameLX + 4 * diam Then
gues$(4) = clr$
ball FrameLX + 3.5 * diam, lc * diam + radi, clr$
End If 'mouse in guess frame
End If ' mouse positions on click
End If 'mousebutton
checkguess
_Limit 100
Wend
Sub handleGuess ()
Dim guess$, s$, tx, ty
Dim As Long OK, i
OK = 1: guess$ = ""
For i = 1 To 4
If gues$(i) = "" Then
OK = 0
Else
guess$ = guess$ + gues$(i)
End If
Next
If OK Then
Color black, boardC
guesses = guesses + 1
_PrintString (BullCowX, lc * diam + radi - .5 * 16), countingCattle$(secret$, guess$)
If guess$ = secret$ Or guesses = 10 Then
Line (ControlPanelLX, 1.5 * diam)-(ControlPanelRX, 2.5 * diam), boardC, BF 'erase button
Color black, boardC
If guess$ = secret$ Then
s$ = "You won after" + Str$(guesses) + " guesses!"
tx = ControlPanelLX + 60
ty = 2 * diam - 8
End If
If guesses = 10 Then
s$ = "The code was: " + secret$
tx = ControlPanelLX + 76
ty = 2 * diam - 8
End If
_PrintString (tx, ty), s$
s$ = "zzz... press any"
tx = ControlPanelLX + 85
ty = 2 * diam + 16
_PrintString (tx, ty), s$
Sleep
Color white, black: Cls: restartF = -1
End If
lc = lc + 1 ' do I need lc if guesses is keeping count too? yeah it's too confusing taking it out
drawframe
For i = 1 To 4: gues$(i) = "": Next
End If 'guess$ OK ends handling guess$
End Sub
Sub checkguess
Dim As Long OK, i
Dim s$, tx, ty
OK = 1
For i = 1 To 4
If gues$(i) = "" Then OK = 0
Next
If OK = 1 Then
Line (ControlPanelLX, 1.5 * diam)-(ControlPanelRX, 2.5 * diam), white, BF
Line (ControlPanelLX + 1, 1.5 * diam + 1)-(ControlPanelRX, 2.5 * diam), gray, BF 'guess box
Color black, gray
s$ = "Guess"
tx = ControlPanelLX + (ControlPanelRX - ControlPanelLX) / 2 - 8 * (Len(s$)) / 2
ty = 2 * diam - 8
_PrintString (tx, ty), s$
Else
Line (ControlPanelLX, 1.5 * diam)-(ControlPanelRX, 2.5 * diam), boardC, BF
End If
End Sub
Sub drawframe ()
Dim sc, i, rr, cc
sc = 64 / (radi - 5)
For i = 0 To 3
For rr = radi - 5 To 0 Step -1
cc = rr * sc
fcirc FrameLX + diam * i + radi, lc * diam + radi, rr, _RGB32(cc, cc, cc + 15)
Next
Next
End Sub
Sub drawcontrols
Dim As Long cplr
cplr = ControlPanelLX + radi
ball cplr, 3.5 * diam, "R"
ball cplr, 4.5 * diam, "G"
ball cplr, 5.5 * diam, "B"
ball cplr, 6.5 * diam, "Y"
ball cplr, 7.5 * diam, "O"
ball cplr, 8.5 * diam, "P"
updatecolor
End Sub
Sub updatecolor ()
Dim As Long ymult
Line (ControlPanelLX + diam + 8, 3 * diam)-(cx + ymax / 2, 9 * diam), boardC, BF
ymult = InStr(deck$, clr$)
Color black, boardC
_PrintString (ControlPanelLX + diam + 8, (ymult + 2) * diam + radi - .5 * 16), "< = Selected Color"
End Sub
Function countingCattle$ (secrt$, guss$) ' 2022 reworked and fixed
Dim build$, copyS$, copyG$
Dim As Long bulls, cows, i, j
copyS$ = secrt$: copyG$ = guss$ ' don't mess with originals
For i = 1 To 4 ' remove matching letters from both by changing the letters
If Mid$(copyS$, i, 1) = Mid$(copyG$, i, 1) Then bulls = bulls + 1: Mid$(copyS$, i, 1) = " ": Mid$(copyG$, i, 1) = "_"
Next
For i = 1 To 4 ' go through letters of guess
For j = 1 To 4 'every match with secret is removed from copy of secret and of guess
If Mid$(copyS$, j, 1) = Mid$(copyG$, i, 1) Then
cows = cows + 1: Mid$(copyS$, j, 1) = " ": Mid$(copyG$, i, 1) = "_"
Exit For
End If
Next
Next
build$ = String$(bulls, "B") + String$(cows, "C")
If build$ = "" Then build$ = "X"
countingCattle$ = build$
End Function
Sub ball (x, y, c$)
Dim sc, start, r
sc = 32 / radi: start = Int(32 / sc) - 2
For r = start To 0 Step -1
If c$ = "R" Then
fcirc x, y, r, _RGB32(255 - 6 * r * sc, 0, 0)
ElseIf c$ = "B" Then
fcirc x, y, r, _RGB32(0, 0, 255 - 6 * r * sc)
ElseIf c$ = "G" Then
fcirc x, y, r, _RGB32(0, 220 - 6 * r * sc, 0)
ElseIf c$ = "O" Then
fcirc x, y, r, _RGB32(255 - 3 * r * sc, 150 - 3 * r * sc, 0)
ElseIf c$ = "Y" Then
fcirc x, y, r, _RGB32(255 - 4 * r * sc, 255 - 4 * r * sc, 0)
ElseIf c$ = "P" Then
fcirc x, y, r, _RGB32(255 - 7 * r * sc, 0, 130 - 2 * r * sc)
End If
Next
End Sub
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
I made a Nonogram Trainer here to get up to speed on solving these kinds of puzzles. You can start with trivial 1x1 and work your way up to 9x9 puzzles. Then you might be ready for RokCoder's puzzle with the works!
Instructions: after choosing the number of cells per side you want to try, you will be presented a grid with number along each row and col. Those numbers represent a run of white squares in that row or col. By clicking the cells on or off, your goal is to match those runs in rows and cols.
Code: (Select All)
_Title "Nonogram Trainer" ' b+ 2023-01-12
DefLng A-Z
Randomize Timer
Dim Shared As _Unsigned Long White, Black, Blue
White = &HFFFFFFFF: Black = &HFF000000: Blue = &HFF0000FF
ReDim Shared Sq, Game(1 To 1, 1 To 1), Board(1 To 1, 1 To 1), RowRuns$(1 To 1), ColRuns$(1 To 1)
Screen _NewImage(800, 600, 32)
makeGame
Do
10 If _MouseInput Then GoTo 10
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
_Delay .2
If mx > 20 And mx <= Sq * 20 + 40 Then
If my > 20 And my <= Sq * 20 + 40 Then
x = Int(mx / 20): y = Int(my / 20)
If Board(x, y) Then Board(x, y) = 0 Else Board(x, y) = 1
If Board(x, y) Then Color White Else Color Black
Line (x * 20, y * 20)-Step(20, 20), , BF
Line (x * 20, y * 20)-Step(20, 20), Blue, B
End If
End If
End If
If Solved Then _MessageBox "Solved", "Hurray you've solved the puzzle!": makeGame
_Limit 60
Loop Until _KeyDown(27)
Sub makeGame
Cls
inputAgain:
Input "How many cells per square side (1 to 9) "; test
If test < 1 Or test > 9 Then GoTo inputAgain Else Cls: Sq = test
ReDim Game(1 To Sq, 1 To Sq), Board(1 To Sq, 1 To Sq), RowRuns$(1 To Sq), ColRuns$(1 To Sq)
Line (18, 18)-(Sq * 20 + 22, Sq * 20 + 22), White, B
For y = 1 To Sq
For x = 1 To Sq
If Rnd < .5 Then Game(x, y) = 0 Else Game(x, y) = 1
Line (x * 20, y * 20)-Step(20, 20), Blue, B
Next
Next
Color White
For i = 1 To Sq
RowRuns$(i) = Runs$(1, i, Game())
_PrintString (Sq * 20 + 30, i * 20 + 4), RowRuns$(i)
ColRuns$(i) = Runs$(0, i, Game())
Next
For i = 1 To Sq
row = Sq + 1: lastp = 1: start = 1
p = InStr(ColRuns$(i), " ")
While p
_PrintString (i * 20 + 6, row * 20 + 10), Mid$(ColRuns$(i), start, 1)
start = start + 2: row = row + 1
p = InStr(start, ColRuns$(i), " ")
Wend
_PrintString (i * 20 + 6, row * 20 + 10), Mid$(ColRuns$(i), start)
Next
End Sub
Function Runs$ (rowTF, number, arr())
If rowTF Then
If arr(1, number) Then flag = 1
For i = 2 To Sq
If arr(i, number) Then
If flag Then flag = flag + 1 Else flag = 1
Else
If flag Then
If Len(b$) Then b$ = b$ + " " + _Trim$(Str$(flag)) Else b$ = _Trim$(Str$(flag))
flag = 0
End If
End If
Next
If flag Then
If Len(b$) Then b$ = b$ + " " + _Trim$(Str$(flag)) Else b$ = _Trim$(Str$(flag))
End If
Else
If arr(number, 1) Then flag = 1
For i = 2 To Sq
If arr(number, i) Then
If flag Then flag = flag + 1 Else flag = 1
Else
If flag Then
If Len(b$) Then b$ = b$ + " " + _Trim$(Str$(flag)) Else b$ = _Trim$(Str$(flag))
flag = 0
End If
End If
Next
If flag Then
If Len(b$) Then b$ = b$ + " " + _Trim$(Str$(flag)) Else b$ = _Trim$(Str$(flag))
End If
End If
Runs$ = b$
End Function
Function Solved
For i = 1 To Sq
If RowRuns$(i) <> Runs$(1, i, Board()) Then Exit Function 'not done
If ColRuns$(i) <> Runs$(0, i, Board()) Then Exit Function
Next
Solved = -1
End Function
Mastermind is a great game, and this is a very nice implementation of it.
I love logic puzzles (as long as they're reasonably solvable).
"Best Scores" are not appropriate, but maybe some sort of acknowledgement of solving it would be Nice?
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
Please visit my Website at: http://oldendayskids.blogspot.com/
01-13-2023, 03:08 AM (This post was last modified: 01-15-2023, 05:11 AM by bplus.)
Down to 79 Loc
Instructions: after choosing the number of cells per side you want to try, you will be presented a grid with number along each row and col. Those numbers represent a run of white squares in that row or col. By clicking the cells on or off, your goal is to match those runs in rows and cols.
Code: (Select All)
_Title "Nonogram Trainer" ' b+ 2023-01-12
DefLng A-Z
Randomize Timer
Dim Shared As _Unsigned Long White, Black, Blue
White = &HFFFFFFFF: Black = &HFF000000: Blue = &HFF0000FF
ReDim Shared Sq, Game(1 To 1, 1 To 1), Board(1 To 1, 1 To 1), RowRuns$(1 To 1), ColRuns$(1 To 1)
Screen _NewImage(800, 600, 32)
makeGame
Do
10 If _MouseInput Then GoTo 10
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
_Delay .2
If mx > 20 And mx <= Sq * 20 + 40 Then
If my > 20 And my <= Sq * 20 + 40 Then
x = Int(mx / 20): y = Int(my / 20)
If Board(x, y) Then Board(x, y) = 0 Else Board(x, y) = 1
If Board(x, y) Then Color White Else Color Black
Line (x * 20, y * 20)-Step(20, 20), , BF
Line (x * 20, y * 20)-Step(20, 20), Blue, B
End If
End If
End If
If Solved Then _MessageBox "Solved", "Hurray you've solved the puzzle!": makeGame
_Limit 60
Loop Until _KeyDown(27)
Sub makeGame
Cls
inputAgain:
Input "How many cells per square side (1 to 9) "; test
If test < 1 Or test > 9 Then GoTo inputAgain Else Cls: Sq = test
ReDim Game(1 To Sq, 1 To Sq), Board(1 To Sq, 1 To Sq), RowRuns$(1 To Sq), ColRuns$(1 To Sq)
Line (18, 18)-(Sq * 20 + 22, Sq * 20 + 22), White, B
For y = 1 To Sq
For x = 1 To Sq
If Rnd < .5 Then Game(x, y) = 0 Else Game(x, y) = 1
Line (x * 20, y * 20)-Step(20, 20), Blue, B
Next
Next
Color White
For i = 1 To Sq
RowRuns$(i) = Runs$(1, i, Game())
_PrintString (Sq * 20 + 30, i * 20 + 4), RowRuns$(i)
ColRuns$(i) = Runs$(0, i, Game())
Next
For i = 1 To Sq
row = Sq
For j = 1 To Len(ColRuns$(i)) Step 2
row = row + 1
_PrintString (i * 20 + 6, row * 20 + 10), Mid$(ColRuns$(i), j, 1)
Next
Next
End Sub
Function Runs$ (rowTF, number, arr())
For i = 1 To Sq
If (arr(i, number) And rowTF) Or (arr(number, i) And rowTF = 0) Then
If flag Then flag = flag + 1 Else flag = 1
Else
If flag Then
If Len(b$) Then b$ = b$ + " " + _Trim$(Str$(flag)) Else b$ = _Trim$(Str$(flag))
flag = 0
End If
End If
Next
If flag Then
If Len(b$) Then b$ = b$ + " " + _Trim$(Str$(flag)) Else b$ = _Trim$(Str$(flag))
End If
Runs$ = b$
End Function
Function Solved
For i = 1 To Sq
If RowRuns$(i) <> Runs$(1, i, Board()) Then Exit Function 'not done
If ColRuns$(i) <> Runs$(0, i, Board()) Then Exit Function
Next
Solved = -1
End Function
03-01-2023, 05:19 AM (This post was last modified: 03-01-2023, 03:50 PM by bplus.)
TriQuad Puzzle from long ago, still like playing once and awhile.
Code: (Select All)
Option _Explicit
_Title "TriQuad Puzzle" 'B+ start 2019-07-17 trans to QB64 from:
' TriQuad.bas SmallBASIC 0.12.8 [B+=MGA] 2017-03-26
' inspired by rick3137's recent post at Naalaa of cute puzzle
' 2019-07 Complete remake for N X N puzzles, not just 3 X 3's.
' post at QB64 forum 2019-10-14
Randomize Timer
Const xmax = 1000, margin = 50 'screen size, margin that should allow a line above and below the puzzle display
Const topLeftB1X = margin, topLeftB2X = xmax / 2 + .5 * margin, topY = margin
'these have to be decided from user input from Intro screen
Dim Shared ymax, N, Nm1, NxNm1, sq, sq2, sq4
ymax = 500 'for starters in intro screen have resizing in pixels including ymax
ReDim Shared B1(2, 2), B2(2, 2) ' B1() box container for scrambled pieces of C(), B2 box container to build solution
ReDim Shared C(8, 3) '9 squares 4 colored triangles, C() contains the solution as created by code, may not be the only one!
Dim mx, my, mb, bx, by, holdF, ky As String, again As String
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 40
intro
restart:
assignColors
holdF = N * N
While 1
Cls
showB (1)
showB (2)
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
Do While mb
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
Loop
If topY <= my And my <= topY + N * sq Then
by = Int((my - topY) / sq)
If topLeftB1X <= mx And mx <= topLeftB1X + N * sq Then 'mx in b1
bx = Int((mx - topLeftB1X) / sq)
If holdF < N * N Then 'trying to put the piece on hold here?
If B1(bx, by) = N * N Then
B1(bx, by) = holdF: holdF = N * N
End If
ElseIf holdF = N * N Then
If B1(bx, by) < N * N Then
holdF = B1(bx, by): B1(bx, by) = N * N
End If
End If
ElseIf topLeftB2X <= mx And mx <= topLeftB2X + N * sq Then 'mx in b2
bx = Int((mx - topLeftB2X) / sq)
If holdF < N * N Then
If B2(bx, by) = N * N Then
B2(bx, by) = holdF: holdF = N * N
End If
ElseIf holdF = N * N Then
If B2(bx, by) < N * N Then
holdF = B2(bx, by): B2(bx, by) = N * N
End If
End If 'my out of range
End If
End If
End If
If solved Then
Color hue(9)
Locate 2, 1: centerPrint "Congratulations puzzle solved!"
_Display
_Delay 3
Exit While
End If
ky = InKey$
If Len(ky) Then
If ky = "q" Then
showSolution
Color hue(9)
Locate 2, 1: centerPrint "Here is solution (for 10 secs), Goodbye!"
_Display
_Delay 10
System
End If
End If
_Display
_Limit 100
Wend
Color hue(9): Locate 2, 1: centerPrint Space$(50): Locate 2, 1
centerPrint "Press enter to play again, any + enter ends... "
_Display
again = InKey$
While Len(again) = 0: again = InKey$: _Limit 200: Wend
If Asc(again) = 13 Then GoTo restart Else System
Function solved
'since it is possible that a different tile combination could be a valid solution we have to check points
Dim x, y
'first check that there is a puzzle piece in every slot of b2
For y = 0 To Nm1
For x = 0 To Nm1
If B2(x, y) = N * N Then Exit Function
Next
Next
'check left and right triangle matches in b2
For y = 0 To Nm1
For x = 0 To Nm1 - 1
If Point(topLeftB2X + x * sq + sq2 + sq4, topY + y * sq + sq2) <> Point(topLeftB2X + (x + 1) * sq + sq4, topY + y * sq + sq2) Then Exit Function
Next
Next
'check to and bottom triangle matches in b2
For y = 0 To Nm1 - 1
For x = 0 To Nm1
'the color of tri4 in piece below = color tri1 of piece above
If Point(topLeftB2X + x * sq + sq2, topY + y * sq + sq2 + sq4) <> Point(topLeftB2X + x * sq + sq2, topY + (y + 1) * sq + sq4) Then Exit Function
Next
Next
'if made it this far then solved
solved = -1
End Function
Sub showSolution
Dim x, y, index
For y = 0 To Nm1
For x = 0 To Nm1
drawSquare index, x * sq + topLeftB2X, y * sq + topY
index = index + 1
Next
Next
End Sub
Sub showB (board)
Dim x, y, index
For y = 0 To Nm1
For x = 0 To Nm1
If board = 1 Then
index = B1(x, y)
drawSquare index, x * sq + topLeftB1X, y * sq + topY
Else
index = B2(x, y)
drawSquare index, x * sq + topLeftB2X, y * sq + topY
End If
Next
Next
End Sub
Sub drawSquare (index, x, y)
Line (x, y)-Step(sq, sq), &HFF000000, BF
Line (x, y)-Step(sq, sq), &HFFFFFFFF, B
If index < N * N Then
Line (x, y)-Step(sq, sq), &HFFFFFFFF
Line (x + sq, y)-Step(-sq, sq), &HFFFFFFFF
Paint (x + sq2 + sq4, y + sq2), hue(C(index, 0)), &HFFFFFFFF
Paint (x + sq2, y + sq2 + sq4), hue(C(index, 1)), &HFFFFFFFF
Paint (x + sq4, y + sq2), hue(C(index, 2)), &HFFFFFFFF
Paint (x + sq2, y + sq4), hue(C(index, 3)), &HFFFFFFFF
End If
End Sub
Sub assignColors ()
'the pieces are indexed 0 to N X N -1 (NxNm1)
' y(index) = int(index/N) : x(index) = index mod N
' index(x, y) = (y - 1) * N + x
Dim i, j, x, y
'first assign a random color rc to every triangle
For i = 0 To NxNm1 'piece index
For j = 0 To 3 'tri color index for piece
C(i, j) = rand(1, 9)
Next
Next
'next match c0 to c3 of square to right
For y = 0 To Nm1
For x = 0 To Nm1 - 1
'the color of tri3 of next square piece to right = color of tri0 to left of it
C(y * N + x + 1, 2) = C(y * N + x, 0)
Next
Next
For y = 0 To Nm1 - 1
For x = 0 To Nm1
'the color of tri4 in piece below = color tri1 of piece above
C((y + 1) * N + x, 3) = C(y * N + x, 1)
Next
Next
' C() now contains one solution for puzzle, may not be the only one
' scramble pieces to box1
Dim t(0 To NxNm1), index 'temp array
For i = 0 To NxNm1: t(i) = i: Next
For i = NxNm1 To 1 Step -1: Swap t(i), t(rand(0, i)): Next
For y = 0 To Nm1
For x = 0 To Nm1
B1(x, y) = t(index)
index = index + 1
B2(x, y) = N * N
'PRINT B1(x, y), B2(x, y)
Next
Next
End Sub
Function hue~& (cn)
Select Case cn
Case 0: hue~& = &HFF000000
Case 1: hue~& = &HFFA80062
Case 2: hue~& = &HFF000050
Case 3: hue~& = &HFFE3333C
Case 4: hue~& = &HFFFF0000
Case 5: hue~& = &HFF008000
Case 6: hue~& = &HFF0000FF
Case 7: hue~& = &HFFFF64FF
Case 8: hue~& = &HFFFFFF00
Case 9: hue~& = &HFF00EEEE
Case 10: hue~& = &HFF663311
End Select
End Function
Function rand% (n1, n2)
Dim hi, lo
If n1 > n2 Then hi = n1: lo = n2 Else hi = n2: lo = n1
rand% = (Rnd * (hi - lo + 1)) \ 1 + lo
End Function
Sub intro 'use intro to select number of pieces
Dim test As Integer
Cls: Color hue(8): Locate 3, 1
centerPrint "TriQuad Instructions:": Print: Color hue(9)
centerPrint "This puzzle has two boxes that contain up to N x N square pieces of 4 colored triangles."
centerPrint "The object is to match up the triangle edges from left Box to fill the Box on the right.": Print
centerPrint "You may move any square piece to an empty space on either board by:"
centerPrint "1st clicking the piece to disappear it,"
centerPrint "then clicking any empty space for it to reappear.": Print
centerPrint "You may press q to quit and see the solution displayed.": Print
centerPrint "Hint: the colors without matching"
centerPrint "complement, are edge pieces.": Print
centerPrint "Good luck!": Color hue(5)
Locate CsrLin + 2, 1: centerPrint "Press number key for square pieces per side (3 to 9, 1 to quit)..."
While test < 3 Or test > 9
test = Val(InKey$)
If test = 1 Then System
Wend
N = test ' pieces per side of 2 boards
Nm1 = N - 1 ' FOR loops
NxNm1 = N * N - 1 ' FOR loop of piece index
'sizing
sq = (xmax / 2 - 1.5 * margin) / N 'square piece side size
sq2 = sq / 2: sq4 = sq / 4
ymax = sq * N + 2 * margin
ReDim B1(Nm1, Nm1), B2(Nm1, Nm1), C(NxNm1, 3)
Screen _NewImage(xmax, ymax, 32)
'_SCREENMOVE 300, 40 'need again?
'PRINT ymax
End Sub
Sub centerPrint (s$)
Locate CsrLin, (xmax / 8 - Len(s$)) / 2: Print s$
End Sub
03-01-2023, 06:49 AM (This post was last modified: 03-01-2023, 10:14 AM by PhilOfPerth.)
(03-01-2023, 05:19 AM)bplus Wrote: TriQuad Puzzle from long ago, still like playing one and a while.
Code: (Select All)
Option _Explicit
_Title "TriQuad Puzzle" 'B+ start 2019-07-17 trans to QB64 from:
' TriQuad.bas SmallBASIC 0.12.8 [B+=MGA] 2017-03-26
' inspired by rick3137's recent post at Naalaa of cute puzzle
' 2019-07 Complete remake for N X N puzzles, not just 3 X 3's.
' post at QB64 forum 2019-10-14
Randomize Timer
Const xmax = 1000, margin = 50 'screen size, margin that should allow a line above and below the puzzle display
Const topLeftB1X = margin, topLeftB2X = xmax / 2 + .5 * margin, topY = margin
'these have to be decided from user input from Intro screen
Dim Shared ymax, N, Nm1, NxNm1, sq, sq2, sq4
ymax = 500 'for starters in intro screen have resizing in pixels including ymax
ReDim Shared B1(2, 2), B2(2, 2) ' B1() box container for scrambled pieces of C(), B2 box container to build solution
ReDim Shared C(8, 3) '9 squares 4 colored triangles, C() contains the solution as created by code, may not be the only one!
Dim mx, my, mb, bx, by, holdF, ky As String, again As String
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 40
intro
restart:
assignColors
holdF = N * N
While 1
Cls
showB (1)
showB (2)
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
Do While mb
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
Loop
If topY <= my And my <= topY + N * sq Then
by = Int((my - topY) / sq)
If topLeftB1X <= mx And mx <= topLeftB1X + N * sq Then 'mx in b1
bx = Int((mx - topLeftB1X) / sq)
If holdF < N * N Then 'trying to put the piece on hold here?
If B1(bx, by) = N * N Then
B1(bx, by) = holdF: holdF = N * N
End If
ElseIf holdF = N * N Then
If B1(bx, by) < N * N Then
holdF = B1(bx, by): B1(bx, by) = N * N
End If
End If
ElseIf topLeftB2X <= mx And mx <= topLeftB2X + N * sq Then 'mx in b2
bx = Int((mx - topLeftB2X) / sq)
If holdF < N * N Then
If B2(bx, by) = N * N Then
B2(bx, by) = holdF: holdF = N * N
End If
ElseIf holdF = N * N Then
If B2(bx, by) < N * N Then
holdF = B2(bx, by): B2(bx, by) = N * N
End If
End If 'my out of range
End If
End If
End If
If solved Then
Color hue(9)
Locate 2, 1: centerPrint "Congratulations puzzle solved!"
_Display
_Delay 3
Exit While
End If
ky = InKey$
If Len(ky) Then
If ky = "q" Then
showSolution
Color hue(9)
Locate 2, 1: centerPrint "Here is solution (for 10 secs), Goodbye!"
_Display
_Delay 10
System
End If
End If
_Display
_Limit 100
Wend
Color hue(9): Locate 2, 1: centerPrint Space$(50): Locate 2, 1
centerPrint "Press enter to play again, any + enter ends... "
_Display
again = InKey$
While Len(again) = 0: again = InKey$: _Limit 200: Wend
If Asc(again) = 13 Then GoTo restart Else System
Function solved
'since it is possible that a different tile combination could be a valid solution we have to check points
Dim x, y
'first check that there is a puzzle piece in every slot of b2
For y = 0 To Nm1
For x = 0 To Nm1
If B2(x, y) = N * N Then Exit Function
Next
Next
'check left and right triangle matches in b2
For y = 0 To Nm1
For x = 0 To Nm1 - 1
If Point(topLeftB2X + x * sq + sq2 + sq4, topY + y * sq + sq2) <> Point(topLeftB2X + (x + 1) * sq + sq4, topY + y * sq + sq2) Then Exit Function
Next
Next
'check to and bottom triangle matches in b2
For y = 0 To Nm1 - 1
For x = 0 To Nm1
'the color of tri4 in piece below = color tri1 of piece above
If Point(topLeftB2X + x * sq + sq2, topY + y * sq + sq2 + sq4) <> Point(topLeftB2X + x * sq + sq2, topY + (y + 1) * sq + sq4) Then Exit Function
Next
Next
'if made it this far then solved
solved = -1
End Function
Sub showSolution
Dim x, y, index
For y = 0 To Nm1
For x = 0 To Nm1
drawSquare index, x * sq + topLeftB2X, y * sq + topY
index = index + 1
Next
Next
End Sub
Sub showB (board)
Dim x, y, index
For y = 0 To Nm1
For x = 0 To Nm1
If board = 1 Then
index = B1(x, y)
drawSquare index, x * sq + topLeftB1X, y * sq + topY
Else
index = B2(x, y)
drawSquare index, x * sq + topLeftB2X, y * sq + topY
End If
Next
Next
End Sub
Sub drawSquare (index, x, y)
Line (x, y)-Step(sq, sq), &HFF000000, BF
Line (x, y)-Step(sq, sq), &HFFFFFFFF, B
If index < N * N Then
Line (x, y)-Step(sq, sq), &HFFFFFFFF
Line (x + sq, y)-Step(-sq, sq), &HFFFFFFFF
Paint (x + sq2 + sq4, y + sq2), hue(C(index, 0)), &HFFFFFFFF
Paint (x + sq2, y + sq2 + sq4), hue(C(index, 1)), &HFFFFFFFF
Paint (x + sq4, y + sq2), hue(C(index, 2)), &HFFFFFFFF
Paint (x + sq2, y + sq4), hue(C(index, 3)), &HFFFFFFFF
End If
End Sub
Sub assignColors ()
'the pieces are indexed 0 to N X N -1 (NxNm1)
' y(index) = int(index/N) : x(index) = index mod N
' index(x, y) = (y - 1) * N + x
Dim i, j, x, y
'first assign a random color rc to every triangle
For i = 0 To NxNm1 'piece index
For j = 0 To 3 'tri color index for piece
C(i, j) = rand(1, 9)
Next
Next
'next match c0 to c3 of square to right
For y = 0 To Nm1
For x = 0 To Nm1 - 1
'the color of tri3 of next square piece to right = color of tri0 to left of it
C(y * N + x + 1, 2) = C(y * N + x, 0)
Next
Next
For y = 0 To Nm1 - 1
For x = 0 To Nm1
'the color of tri4 in piece below = color tri1 of piece above
C((y + 1) * N + x, 3) = C(y * N + x, 1)
Next
Next
' C() now contains one solution for puzzle, may not be the only one
' scramble pieces to box1
Dim t(0 To NxNm1), index 'temp array
For i = 0 To NxNm1: t(i) = i: Next
For i = NxNm1 To 1 Step -1: Swap t(i), t(rand(0, i)): Next
For y = 0 To Nm1
For x = 0 To Nm1
B1(x, y) = t(index)
index = index + 1
B2(x, y) = N * N
'PRINT B1(x, y), B2(x, y)
Next
Next
End Sub
Function hue~& (cn)
Select Case cn
Case 0: hue~& = &HFF000000
Case 1: hue~& = &HFFA80062
Case 2: hue~& = &HFF000050
Case 3: hue~& = &HFFE3333C
Case 4: hue~& = &HFFFF0000
Case 5: hue~& = &HFF008000
Case 6: hue~& = &HFF0000FF
Case 7: hue~& = &HFFFF64FF
Case 8: hue~& = &HFFFFFF00
Case 9: hue~& = &HFF00EEEE
Case 10: hue~& = &HFF663311
End Select
End Function
Function rand% (n1, n2)
Dim hi, lo
If n1 > n2 Then hi = n1: lo = n2 Else hi = n2: lo = n1
rand% = (Rnd * (hi - lo + 1)) \ 1 + lo
End Function
Sub intro 'use intro to select number of pieces
Dim test As Integer
Cls: Color hue(8): Locate 3, 1
centerPrint "TriQuad Instructions:": Print: Color hue(9)
centerPrint "This puzzle has two boxes that contain up to N x N square pieces of 4 colored triangles."
centerPrint "The object is to match up the triangle edges from left Box to fill the Box on the right.": Print
centerPrint "You may move any square piece to an empty space on either board by:"
centerPrint "1st clicking the piece to disappear it,"
centerPrint "then clicking any empty space for it to reappear.": Print
centerPrint "You may press q to quit and see the solution displayed.": Print
centerPrint "Hint: the colors without matching"
centerPrint "complement, are edge pieces.": Print
centerPrint "Good luck!": Color hue(5)
Locate CsrLin + 2, 1: centerPrint "Press number key for square pieces per side (3 to 9, 1 to quit)..."
While test < 3 Or test > 9
test = Val(InKey$)
If test = 1 Then System
Wend
N = test ' pieces per side of 2 boards
Nm1 = N - 1 ' FOR loops
NxNm1 = N * N - 1 ' FOR loop of piece index
'sizing
sq = (xmax / 2 - 1.5 * margin) / N 'square piece side size
sq2 = sq / 2: sq4 = sq / 4
ymax = sq * N + 2 * margin
ReDim B1(Nm1, Nm1), B2(Nm1, Nm1), C(NxNm1, 3)
Screen _NewImage(xmax, ymax, 32)
'_SCREENMOVE 300, 40 'need again?
'PRINT ymax
End Sub
Sub centerPrint (s$)
Locate CsrLin, (xmax / 8 - Len(s$)) / 2: Print s$
End Sub
Nice one (again!)
I haven't mastered it yet, but hope to soon - I solved it once already (with 3x3)
I experimented with adding a "tries" counter, but it's a bit hard to check if it works when I can't even solve it!
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
Please visit my Website at: http://oldendayskids.blogspot.com/
07-14-2023, 08:11 PM (This post was last modified: 07-14-2023, 08:22 PM by bplus.)
Again Charlie's post causes me to dig into my files
4x4 Sliding Blocks Puzzle: use arrow keys to move the block to fill the hole ie right arrow to slide the block left of hole, up arrow to move block below hole... actually we just have numbers here not tiles.
No fancy graphics in this 34 LOC game:
Code: (Select All)
_Title "Sliding Blocks MOD 4x4 Galileo" 'rev 2019-04-20
Randomize Timer
Dim Shared delta(4)
delta(1) = 4: delta(2) = 1: delta(3) = -1: delta(4) = -4
Dim Shared board$, hole
board$ = "123456789ABCDEF0": solve$ = board$: hole = 16
For i = 1 To 200: move Int(Rnd * 4 + 1): Next
Do
print_board
If board$ = solve$ Then Locate 8, 4: Print "solved!": Exit Do
KH& = _KeyHit
Select Case KH&
Case 18432: move 1 'up
Case 20480: move 4 'down
Case 19200: move 2 'left
Case 19712: move 3 'right
End Select
_Display
_Limit 30
Loop
Sub print_board ()
Cls: Locate 2, 1: Print " ";
For i = 1 To Len(board$)
If i = hole Then Print " "; Else n$ = Right$(" " + Str$(Val("&H" + Mid$(board$, i, 1))) + " ", 4): Print n$;
If i Mod 4 = 0 Then Print: Print " ";
Next
Print
End Sub
Sub move (d)
newHole = hole + delta(d)
If newHole >= 1 And newHole <= 16 And (hole Mod 4 = newHole Mod 4) Or Int((hole - 1) / 4) = Int((newHole - 1) / 4) Then
Mid$(board$, hole, 1) = Mid$(board$, newHole, 1): Mid$(board$, newHole, 1) = "0": hole = newHole
End If
End Sub
