QB64 Surabikku - Sliding block puzzle

[bplus]

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 Sub

A few screen shots with successes in boards higher than 3x3