QB64 Surabikku - Sliding block puzzle

[bplus]

An Update for this great game:

Code: (Select All)

'=====================
_Title "Surabikku"
'=====================
'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

'================================ 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

'=== define deminsions for board
Dim Shared rows, cols, size: rows = 3: cols = 3: size = 175
Dim Shared As _Unsigned Long board(1 To cols, 1 To rows), soln(1 To cols, 1 To rows), grn, red, wht 'save colors here

' Official Italian Flag colors in honor of a missing friend, TempodiBasic
red = _RGB32(203, 51, 59): grn = _RGB32(0, 122, 51): wht = _RGB32(255, 255, 255)

' start with legal board to scramble like flag to get 3 colors out there
board(1, 1) = grn: board(2, 1) = wht: board(3, 1) = red
board(1, 2) = grn: board(2, 2) = wht: board(3, 2) = red
board(1, 3) = grn: board(2, 3) = wht: board(3, 3) = red

'=== print info
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:"

'=== draw top arrows
For t = 0 To 450 Step 175
    Line (130 + t, 55)-(160 + t, 25), _RGB(128, 128, 128)
    Line (160 + t, 25)-(190 + t, 55), _RGB(128, 128, 128)
    Line (130 + t, 55)-(190 + t, 55), _RGB(128, 128, 128)
Next
'=== draw bottom arrows
For t = 0 To 450 Step 175
    Line (130 + t, 620)-(160 + t, 650), _RGB(128, 128, 128)
    Line (160 + t, 650)-(190 + t, 620), _RGB(128, 128, 128)
    Line (130 + t, 620)-(190 + t, 620), _RGB(128, 128, 128)
Next
'=== draw left arrows
For t = 0 To 450 Step 175
    Line (20, 160 + t)-(50, 130 + t), _RGB(128, 128, 128)
    Line (20, 160 + t)-(50, 190 + t), _RGB(128, 128, 128)
    Line (50, 130 + t)-(50, 190 + t), _RGB(128, 128, 128)
Next
'=== draw right arrows
For t = 0 To 450 Step 175
    Line (620, 130 + t)-(650, 160 + t), _RGB(128, 128, 128)
    Line (620, 190 + t)-(650, 160 + t), _RGB(128, 128, 128)
    Line (620, 130 + t)-(620, 190 + t), _RGB(128, 128, 128)
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
        If my > 0 And my < 75 Then ' top line arrows
            If mx > 75 And mx < 250 Then 'left
                move 1
            ElseIf mx > 250 And mx < 425 Then 'middle
                move 2
            ElseIf mx > 425 And mx < 600 Then 'right
                move 3
            End If
        ElseIf my > 600 And my < 675 Then ' bottom line arrows
            If mx > 75 And mx < 250 Then 'left
                move 7
            ElseIf mx > 250 And mx < 425 Then 'middle
                move 8
            ElseIf mx > 425 And mx < 600 Then 'right
                move 9
            End If
        ElseIf mx > 0 And mx < 75 Then ' left side
            If my > 75 And my < 250 Then 'top
                move 10
            ElseIf my > 250 And my < 425 Then 'middle
                move 11
            ElseIf my > 425 And my < 600 Then 'bottom
                move 12
            End If
        ElseIf mx > 600 And mx < 675 Then ' right side
            If my > 75 And my < 250 Then 'top
                move 4
            ElseIf my > 250 And my < 425 Then 'middle
                move 5
            ElseIf my > 425 And my < 600 Then 'bottom
                move 6
            End If
        End If
        _Delay .2
    End If
    updateBoard
    _Display
    solved = -1 ' check for win
    For r = 1 To rows
        For c = 1 To cols
            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
    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
    Select Case arrowNum
        Case 1: t = board(1, 1): board(1, 1) = board(1, 2): board(1, 2) = board(1, 3): board(1, 3) = t
        Case 2: t = board(2, 1): board(2, 1) = board(2, 2): board(2, 2) = board(2, 3): board(2, 3) = t
        Case 3: t = board(3, 1): board(3, 1) = board(3, 2): board(3, 2) = board(3, 3): board(3, 3) = t

        Case 4: t = board(3, 1): board(3, 1) = board(2, 1): board(2, 1) = board(1, 1): board(1, 1) = t
        Case 5: t = board(3, 2): board(3, 2) = board(2, 2): board(2, 2) = board(1, 2): board(1, 2) = t
        Case 6: t = board(3, 3): board(3, 3) = board(2, 3): board(2, 3) = board(1, 3): board(1, 3) = t

        Case 7: t = board(1, 3): board(1, 3) = board(1, 2): board(1, 2) = board(1, 1): board(1, 1) = t
        Case 8: t = board(2, 3): board(2, 3) = board(2, 2): board(2, 2) = board(2, 1): board(2, 1) = t
        Case 9: t = board(3, 3): board(3, 3) = board(3, 2): board(3, 2) = board(3, 1): board(3, 1) = t

        Case 10: t = board(1, 1): board(1, 1) = board(2, 1): board(2, 1) = board(3, 1): board(3, 1) = t
        Case 11: t = board(1, 2): board(1, 2) = board(2, 2): board(2, 2) = board(3, 2): board(3, 2) = t
        Case 12: t = board(1, 3): board(1, 3) = board(2, 3): board(2, 3) = board(3, 3): board(3, 3) = t
    End Select
End Sub

Sub updateBoard ' overhaul Dav's
    For r = 1 To rows
        For c = 1 To cols
            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
End Sub

Sub displayTarget ' overhaul Dav's
    For r = 1 To rows
        For c = 1 To cols
            Line (725 + (c - 1) * 75, 300 + (r - 1) * 75)-Step(75, 75), soln(c, r), BF
            Line (725 + (c - 1) * 75, 300 + (r - 1) * 75)-Step(75, 75), &HFF000000, B
        Next
    Next
End Sub

Sub scrambleBoard ' so we can now do more that one game
    For i = 1 To 81
        move Int(Rnd * 12) + 1
    Next
End Sub

Sub NewGame ' so we can now do more that one game
    scrambleBoard
    For r = 1 To rows ' save a soln
        For c = 1 To cols
            soln(c, r) = board(c, r)
        Next
    Next
    scrambleBoard
    displayTarget
    updateBoard
End Sub

The colors are for our missing friend. https://flagcolor.com/italian-flag-colors/