(05-06-2022, 03:25 PM)Dav Wrote: Nice, @bplus! You did a lot work on that. Thank you. I will post a link to this on the top post here.
- Dav
Thanks I took the program one more step into the impossible by allowing 3 to 8 cells per side. Now it's like a 2D Rubics cube!
Code: (Select All)
Option _Explicit
'=====================
_Title "Surabikku"
'=====================
Randomize Timer
'QB64 version of a SURABIKKU like puzzle.
'Use Arrows to slide pieces so board matches the solved image.
'Coded by Dav, MAY/2022
' 2022-05-05 b+ mod to enable more than 1 puzzle, overhaul arrow swapping code
' 2022-05-06 b+ mod 2 enable more cells per side, another major overhaul
'================================ Note: =======================================
' ZZZ <<< this means we are sleeping and await a keypress to start next game
'==============================================================================
DefLng A-Z
Screen _NewImage(1024, 675, 32)
_ScreenMove 100, 60 'away from sides
Dim Shared CPS, size ' Cells Per Side
getCPS: '=== define deminsions for board
Cls
Dim s$
s$ = "This Surabikku Game allows 3 to 8 cells per side on it's board."
_PrintString ((_Width - _PrintWidth(s$)) / 2, 300), s$
s$ = "=< 0 quits, Please enter the number of cells per side (3 to 8) you'd like to play"
_PrintString ((_Width - _PrintWidth(s$)) / 2, 320), s$
Locate 23, 62
Input "", CPS
If CPS <= 0 Then End
If CPS > 2 And CPS < 9 Then size = Int(525) / CPS Else Beep: GoTo getCPS
Dim Shared As _Unsigned Long C(1 To 9)
C(1) = &HFFFF0000 ' red
C(2) = &HFFEEEEEE ' white
C(3) = &HFF0000FF ' blue
C(4) = &HFF008800 ' green
C(5) = &HFFFF00AA ' purple
C(6) = &HFFFFFF00 ' yellow
C(7) = &HFF884422 ' brown
C(8) = &HFF00FF88 ' mint green
C(9) = &HFF999999 ' arrow gray
Dim Shared As _Unsigned Long board(1 To CPS, 1 To CPS), soln(1 To CPS, 1 To CPS)
Dim Shared arrowX(1 To CPS * 4), arrowY(1 To CPS * 4), arrowS(1 To CPS * 4), arrowCR(1 To CPS * 4)
Dim r, c, arrowN, i, mb, mx, my, solved
' start with legal board to scramble like flag to get 3 colors out there
For r = 1 To CPS
For c = 1 To CPS
board(c, r) = C(c)
Next
Next
'=== print info
Cls
PPRINT 668, 28, 25, _RGB(128, 128, 128), 255, "QB64 SURABIKKU"
PPRINT 665, 25, 25, _RGB(255, 255, 0), 255, "QB64 SURABIKKU"
PPRINT 725, 75, 20, _RGB(128, 128, 128), 255, "Click Arrow."
PPRINT 725, 110, 20, _RGB(128, 128, 128), 255, "Move Blocks."
PPRINT 725, 250, 20, _RGB(255, 255, 255), 255, "Make it like:"
arrowN = 1
'=== draw top arrows
For i = 1 To CPS
arrowX(arrowN) = (i - 1) * size + .5 * size + 75
arrowY(arrowN) = 38
arrowS(arrowN) = 1
arrowCR(arrowN) = i
BlockArrow arrowX(arrowN), arrowY(arrowN), 3, 40, C(9)
Line (arrowX(arrowN) - 25, arrowY(arrowN) - 25)-Step(50, 50), C(9), B
arrowN = arrowN + 1
Next
'=== draw bottom arrows
For i = 1 To CPS
arrowX(arrowN) = (i - 1) * size + .5 * size + 75
arrowY(arrowN) = 638
arrowS(arrowN) = 2
arrowCR(arrowN) = i
BlockArrow arrowX(arrowN), arrowY(arrowN), 1, 40, C(9)
Line (arrowX(arrowN) - 25, arrowY(arrowN) - 25)-Step(50, 50), C(9), B
arrowN = arrowN + 1
Next
'=== draw left arrows
For i = 1 To CPS
arrowY(arrowN) = (i - 1) * size + .5 * size + 75
arrowX(arrowN) = 38
arrowS(arrowN) = 3
arrowCR(arrowN) = i
BlockArrow arrowX(arrowN), arrowY(arrowN), 2, 40, C(9)
Line (arrowX(arrowN) - 25, arrowY(arrowN) - 25)-Step(50, 50), C(9), B
arrowN = arrowN + 1
Next
'=== draw right arrows
For i = 1 To CPS
arrowY(arrowN) = (i - 1) * size + .5 * size + 75
arrowX(arrowN) = 638
arrowS(arrowN) = 4
arrowCR(arrowN) = i
BlockArrow arrowX(arrowN), arrowY(arrowN), 0, 40, C(9)
Line (arrowX(arrowN) - 25, arrowY(arrowN) - 25)-Step(50, 50), C(9), B
arrowN = arrowN + 1
Next
restart:
NewGame
Do
If _KeyDown(27) Then End ' the escape clause
While _MouseInput: Wend
mb = _MouseButton(1): mx = _MouseX: my = _MouseY
If mb Then
For i = 1 To 4 * CPS
If mx > arrowX(i) - 25 And mx < arrowX(i) + 25 Then
If my > arrowY(i) - 25 And my < arrowY(i) + 25 Then
Move i
updateBoard
End If
End If
Next
_Delay .25
End If
solved = -1 ' check for win
For r = 1 To CPS
For c = 1 To CPS
If board(c, r) <> soln(c, r) Then solved = 0: GoTo skip
Next
Next
skip:
_Limit 60
Loop Until solved
PPRINT 145, 308, 40, &HFF000033, &H00000000, "You did it!"
PPRINT 305, 485, 40, &HFF000033, &H00000000, "ZZZ" ' <<< this means we are sleeping and await a keypress
_Display
Sleep
GoTo restart
Sub PPRINT (x, y, size, clr&, trans&, text$)
'This sub outputs to the current _DEST set
'It makes trans& the transparent color
'x/y is where to print text
'size is the font size to use
'clr& is the color of your text
'trans& is the background transparent color
'text$ is the string to print
'=== get users current write screen
Dim orig&, bit, t, pprintimg&, x1, x2, y1, y2
orig& = _Dest
'=== if you are using an 8 or 32 bit screen
bit = 32: If _PixelSize(0) = 1 Then bit = 256
'=== step through your text
For t = 0 To Len(text$) - 1
'=== make a temp screen to use
pprintimg& = _NewImage(16, 16, bit)
_Dest pprintimg&
'=== set colors and print text
Cls , trans&: Color clr&
Print Mid$(text$, t + 1, 1);
'== make background color the transprent one
_ClearColor _RGB(0, 0, 0), pprintimg&
'=== go back to original screen to output
_Dest orig&
'=== set it and forget it
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 Move (arrowNum) ' overhaul Dav's
Dim t As _Unsigned Long
Dim ars, cr, i
ars = arrowS(arrowNum)
cr = arrowCR(arrowNum)
Select Case ars
Case 1 ' top row = 1
t = board(cr, 1)
For i = 2 To CPS
board(cr, i - 1) = board(cr, i)
Next
board(cr, CPS) = t
Case 2 ' bottom row = 2
t = board(cr, CPS)
For i = CPS To 2 Step -1
board(cr, i) = board(cr, i - 1)
Next
board(cr, 1) = t
Case 3 ' left col
t = board(1, cr)
For i = 2 To CPS
board(i - 1, cr) = board(i, cr)
Next
board(CPS, cr) = t
Case 4 'right col
t = board(CPS, cr)
For i = CPS To 2 Step -1
board(i, cr) = board(i - 1, cr)
Next
board(1, cr) = t
End Select
End Sub
Sub updateBoard ' overhaul Dav's
Dim r, c
For r = 1 To CPS
For c = 1 To CPS
Line (75 + (c - 1) * size, 75 + (r - 1) * size)-Step(size, size), board(c, r), BF
Line (75 + (c - 1) * size, 75 + (r - 1) * size)-Step(size, size), &HFF000000, B
Next
Next
_Display
End Sub
Sub displayTarget ' overhaul Dav's
Dim s, r, c
s = .4 * size
For r = 1 To CPS
For c = 1 To CPS
Line (725 + (c - 1) * s, 300 + (r - 1) * s)-Step(s, s), soln(c, r), BF
Line (725 + (c - 1) * s, 300 + (r - 1) * s)-Step(s, s), &HFF000000, B
Next
Next
End Sub
Sub scrambleBoard ' so we can now do more that one game
Dim i
For i = 1 To CPS * 2
Move Int(Rnd * 4 * CPS) + 1
Next
End Sub
Sub NewGame ' so we can now do more that one game
Dim r, c
scrambleBoard
For r = 1 To CPS ' save a soln
For c = 1 To CPS
soln(c, r) = board(c, r)
Next
Next
scrambleBoard
displayTarget
updateBoard
End Sub
' This is a blocklike arrow to use instead of a tile any size, any color: cx, cy is center of square.
' It can be only draw in East = 0, South = 1, West = 2, North = 3 Directions for ESWN03 variable.
' Assuming want to put inside a square = sqrSize and of cource c is for color.
Sub BlockArrow (cX, cY, ESWN03, sqrSize, c As _Unsigned Long) ' 4 directions East, South, West, North 0,1,2,3
'This sub needs:
' Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim m14, m13, m12, m23, m34, x0, y0
m14 = sqrSize * .25
m13 = sqrSize * .3333
m12 = sqrSize * .5
m23 = sqrSize * .6667
m34 = sqrSize * .75
x0 = cX - m12
y0 = cY - m12
Select Case ESWN03
Case 0 'east
Line (x0, y0 + m13)-Step(m23, m13), c, BF
ftri x0 + m23, y0, x0 + sqrSize, y0 + m12, x0 + m23, y0 + sqrSize, c
Case 1
Line (x0 + m13, y0)-Step(m13, m23), c, BF
ftri x0, y0 + m23, x0 + m12, y0 + sqrSize, x0 + sqrSize, y0 + m23, c
Case 2
Line (x0 + m13, y0 + m13)-Step(m23, m13), c, BF
ftri x0 + m13, y0, x0, y0 + m12, x0 + m13, y0 + sqrSize, c
Case 3
Line (x0 + m13, y0 + m13)-Step(m13, m23), c, BF
ftri x0, y0 + m13, x0 + m12, y0, x0 + sqrSize, y0 + m13, c
End Select
End Sub
'' BEST saves dest and optimized with Static a& and alpha colors work better
'2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End SubA few screen shots with successes in boards higher than 3x3
b = b + ...