QB64 Surabikku - Sliding block puzzle

[Dav]

QB64 Surabikku is a clone of an online sliding block puzzle I was playing called Surabikku.  Click the arrows to slide the blocks until the puzzle board looks the same as the smaller image shown.  Simple to play but not so simple to solve.  May update this to use images instead of blocks, one day.

- Dav

EDIT: bplus made an update to this puzzle, you can find it HERE.  Thanks, bplus!

Code: (Select All)

'=============
'SURABIKKU.BAS
'=============
'QB64 version of a SURABIKKU like puzzle.
'Use Arrows to slide pieces so board matches the solved image.
'Coded by Dav, MAY/2022
    
SCREEN _NEWIMAGE(1024, 675, 32)

'=== define deminsions for board

DIM SHARED row, col, size: row = 3: col = 3: size = 175
DIM SHARED boxes: boxes = row * col
    
'=== define box value, x/y, values...

DIM SHARED bv&(boxes) 'box values (scrambled)
DIM SHARED slv&(boxes) 'box values (solved)
DIM SHARED bx1(boxes), by1(boxes) 'top x/y cords of box
DIM SHARED bx2(boxes), by2(boxes) ' bottom x/y cords of box

'=== make color box images

DIM SHARED red&, blu&, grn&
red& = _NEWIMAGE(size, size, 32): _DEST red&: CLS , _RGB(255, 0, 0)
blu& = _NEWIMAGE(size, size, 32): _DEST blu&: CLS , _RGB(0, 0, 255)
grn& = _NEWIMAGE(size, size, 32): _DEST grn&: CLS , _RGB(0, 255, 0)

_DEST 0: _DISPLAY
    
'=== init box x.y values

bc = 1 'counter
FOR r = 1 TO row
    FOR c = 1 TO col
        x = 75 + (c * size): y = 75 + (r * size)
        bx1(bc) = x - size: bx2(bc) = x ' generate x/y values
        by1(bc) = y - size: by2(bc) = y
        bc = bc + 1
    NEXT
NEXT
    
'=== assign scrambled up box values

bv&(1) = red&: bv&(2) = grn&: bv&(3) = red&
bv&(4) = blu&: bv&(5) = grn&: bv&(6) = blu&
bv&(7) = grn&: bv&(8) = blu&: bv&(9) = red&
    
'=== assign solved box values

slv&(1) = red&: slv&(2) = red&: slv&(3) = grn&
slv&(4) = red&: slv&(5) = blu&: slv&(6) = grn&
slv&(7) = blu&: slv&(8) = blu&: slv&(9) = grn&
    
    
'=== draw puzzle

CLS , _RGB(32, 32, 32)
FOR b = 1 TO boxes
    _PUTIMAGE (bx1(b), by1(b))-(bx2(b), by2(b)), bv&(b)
    LINE (bx1(b), by1(b))-(bx2(b), by2(b)), _RGB(0, 0, 0), B
NEXT

'=== 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 solved puzzle on right

_PUTIMAGE (725, 300)-(800, 375), slv&(1)
_PUTIMAGE (800, 300)-(875, 375), slv&(2)
_PUTIMAGE (875, 300)-(950, 375), slv&(3)
_PUTIMAGE (725, 375)-(800, 450), slv&(4)
_PUTIMAGE (800, 375)-(875, 450), slv&(5)
_PUTIMAGE (875, 375)-(950, 450), slv&(6)
_PUTIMAGE (725, 450)-(800, 525), slv&(7)
_PUTIMAGE (800, 450)-(875, 525), slv&(8)
_PUTIMAGE (875, 450)-(950, 525), slv&(9)
    
'=== 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
    
_DISPLAY

slidespeed = 300

DO

    IF _MOUSEBUTTON(1) = 0 THEN clicked = 0

    mi = _MOUSEINPUT: mx = _MOUSEX: my = _MOUSEY

    IF _MOUSEBUTTON(1) = -1 AND clicked = 0 THEN
    
        clicked = 1
    
        '===== if top-left button clicked...
        IF mx > 75 AND mx < 250 AND my > 0 AND my < 75 THEN
            '=== slide column up
            FOR y = 0 TO size
                '=== just move bottom two images up
                _PUTIMAGE (bx1(4), by1(4) - y), bv&(4)
                _PUTIMAGE (bx1(7), by1(7) - y), bv&(7)
                '=== expand bottom location with top image
                _PUTIMAGE (bx1(7), by2(7) - y)-(bx2(7), by2(7)), bv&(1)
                '=== redraw boxes around them, for looks
                LINE (bx1(1), by1(1))-(bx2(1), by2(1)), _RGB(0, 0, 0), B
                LINE (bx1(4), by1(4))-(bx2(4), by2(4)), _RGB(0, 0, 0), B
                LINE (bx1(7), by1(7))-(bx2(7), by2(7)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(1): t2& = bv&(4): t3& = bv&(7) 'old values
            bv&(1) = t2&: bv&(4) = t3&: bv&(7) = t1& 'new values
        END IF
    
        '===== if bottom-left button clicked...
        IF mx > 75 AND mx < 250 AND my > 600 AND my < 675 THEN
            '=== slide column down
            FOR y = 0 TO size
                '=== expand top location with bottom image
                _PUTIMAGE (bx1(1), by1(1))-(bx2(1), by2(1) + y), bv&(7)
                '=== just move top two images down
                _PUTIMAGE (bx1(1), by1(1) + y), bv&(1)
                _PUTIMAGE (bx1(4), by1(4) + y), bv&(4)
                '=== redraw boxes around them, for looks
                LINE (bx1(1), by1(1))-(bx2(1), by2(1)), _RGB(0, 0, 0), B
                LINE (bx1(4), by1(4))-(bx2(4), by2(4)), _RGB(0, 0, 0), B
                LINE (bx1(7), by1(7))-(bx2(7), by2(7)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(1): t2& = bv&(4): t3& = bv&(7) 'old values
            bv&(1) = t3&: bv&(4) = t1&: bv&(7) = t2& 'new values
        END IF
    
        '===== if top-middle button clicked...
        IF mx > 250 AND mx < 425 AND my > 0 AND my < 75 THEN
            '=== slide column up
            FOR y = 0 TO size
                '=== just move bottom two images up
                _PUTIMAGE (bx1(5), by1(5) - y), bv&(5)
                _PUTIMAGE (bx1(8), by1(8) - y), bv&(8)
                '=== expand bottom location with top image
                _PUTIMAGE (bx1(8), by2(8) - y)-(bx2(8), by2(8)), bv&(2)
                '=== redraw boxes around them, for looks
                LINE (bx1(2), by1(2))-(bx2(2), by2(2)), _RGB(0, 0, 0), B
                LINE (bx1(5), by1(5))-(bx2(5), by2(5)), _RGB(0, 0, 0), B
                LINE (bx1(8), by1(8))-(bx2(8), by2(8)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(2): t2& = bv&(5): t3& = bv&(8) 'old values
            bv&(2) = t2&: bv&(5) = t3&: bv&(8) = t1& 'new values
        END IF
    
        '===== if bottom-middle button clicked...
        IF mx > 250 AND mx < 425 AND my > 600 AND my < 675 THEN
            '=== slide column down
            FOR y = 0 TO size
                '=== expand top location with bottom image
                _PUTIMAGE (bx1(2), by1(2))-(bx2(2), by2(2) + y), bv&(8)
                '=== just move top two images down
                _PUTIMAGE (bx1(2), by1(2) + y), bv&(2)
                _PUTIMAGE (bx1(5), by1(5) + y), bv&(5)
                '=== redraw boxes around them, for looks
                LINE (bx1(2), by1(2))-(bx2(2), by2(2)), _RGB(0, 0, 0), B
                LINE (bx1(5), by1(5))-(bx2(5), by2(5)), _RGB(0, 0, 0), B
                LINE (bx1(8), by1(8))-(bx2(8), by2(8)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(2): t2& = bv&(5): t3& = bv&(8) 'old values
            bv&(2) = t3&: bv&(5) = t1&: bv&(8) = t2& 'new values
        END IF
    
        '===== if top-right button clicked...
        IF mx > 425 AND mx < 600 AND my > 0 AND my < 75 THEN
            '=== slide column up
            FOR y = 0 TO size
                '=== just move bottom two images up
                _PUTIMAGE (bx1(6), by1(6) - y), bv&(6)
                _PUTIMAGE (bx1(9), by1(9) - y), bv&(9)
                '=== expand bottom location with top image
                _PUTIMAGE (bx1(9), by2(9) - y)-(bx2(9), by2(9)), bv&(3)
                '=== redraw boxes around them, for looks
                LINE (bx1(3), by1(3))-(bx2(3), by2(3)), _RGB(0, 0, 0), B
                LINE (bx1(6), by1(6))-(bx2(6), by2(6)), _RGB(0, 0, 0), B
                LINE (bx1(9), by1(9))-(bx2(9), by2(9)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(3): t2& = bv&(6): t3& = bv&(9) 'old values
            bv&(3) = t2&: bv&(6) = t3&: bv&(9) = t1& 'new values
        END IF
    
        '===== if bottom-right button clicked...
        IF mx > 425 AND mx < 600 AND my > 600 AND my < 675 THEN
            '=== slide column down
            FOR y = 0 TO size
                '=== expand top location with bottom image
                _PUTIMAGE (bx1(3), by1(3))-(bx2(3), by2(3) + y), bv&(9)
                '=== just move top two images down
                _PUTIMAGE (bx1(3), by1(3) + y), bv&(3)
                _PUTIMAGE (bx1(6), by1(6) + y), bv&(6)
                '=== redraw boxes around them, for looks
                LINE (bx1(3), by1(3))-(bx2(3), by2(3)), _RGB(0, 0, 0), B
                LINE (bx1(6), by1(6))-(bx2(6), by2(6)), _RGB(0, 0, 0), B
                LINE (bx1(9), by1(9))-(bx2(9), by2(9)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(3): t2& = bv&(6): t3& = bv&(9) 'old values
            bv&(3) = t3&: bv&(6) = t1&: bv&(9) = t2& 'new values
        END IF
    
        '===== if left-top button clicked...
        IF mx > 0 AND mx < 75 AND my > 75 AND my < 250 THEN
            '=== slide column left
            FOR x = 0 TO size
                '=== just move right two images left
                _PUTIMAGE (bx1(2) - x, by1(2)), bv&(2)
                _PUTIMAGE (bx1(3) - x, by1(3)), bv&(3)
                '=== and expand far right location with far left image
                _PUTIMAGE (bx2(3) - x, by1(3))-(bx2(3) - x, by2(3)), bv&(1)
                '=== redraw boxes around them, for looks
                LINE (bx1(1), by1(1))-(bx2(1), by2(1)), _RGB(0, 0, 0), B
                LINE (bx1(2), by1(2))-(bx2(2), by2(2)), _RGB(0, 0, 0), B
                LINE (bx1(3), by1(3))-(bx2(3), by2(3)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(1): t2& = bv&(2): t3& = bv&(3) 'old values
            bv&(1) = t2&: bv&(2) = t3&: bv&(3) = t1& 'new values
        END IF
    
        '===== if right-top button clicked...
        IF mx > 600 AND mx < 675 AND my > 75 AND my < 250 THEN
            '=== slide column left
            FOR x = 0 TO size
                '=== just move left two images right
                _PUTIMAGE (bx1(1) + x, by1(1)), bv&(1)
                _PUTIMAGE (bx1(2) + x, by1(2)), bv&(2)
                '=== and expand far left location with far right image
                _PUTIMAGE (bx1(1), by1(1))-(bx1(1) + x, by2(1)), bv&(3)
                '=== redraw boxes around them, for looks
                LINE (bx1(1), by1(1))-(bx2(1), by2(1)), _RGB(0, 0, 0), B
                LINE (bx1(2), by1(2))-(bx2(2), by2(2)), _RGB(0, 0, 0), B
                LINE (bx1(3), by1(3))-(bx2(3), by2(3)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(1): t2& = bv&(2): t3& = bv&(3) 'old values
            bv&(1) = t3&: bv&(2) = t1&: bv&(3) = t2& 'new values
        END IF
    
        '===== if left-middle button clicked...
        IF mx > 0 AND mx < 75 AND my > 250 AND my < 425 THEN
            '=== slide column left
            FOR x = 0 TO size
                '=== just move right two images left
                _PUTIMAGE (bx1(5) - x, by1(5)), bv&(5)
                _PUTIMAGE (bx1(6) - x, by1(6)), bv&(6)
                '=== and expand far right location with far left image
                _PUTIMAGE (bx2(6) - x, by1(6))-(bx2(6) - x, by2(6)), bv&(4)
                '=== redraw boxes around them, for looks
                LINE (bx1(4), by1(4))-(bx2(4), by2(4)), _RGB(0, 0, 0), B
                LINE (bx1(5), by1(5))-(bx2(5), by2(5)), _RGB(0, 0, 0), B
                LINE (bx1(6), by1(6))-(bx2(6), by2(6)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(4): t2& = bv&(5): t3& = bv&(6) 'old values
            bv&(4) = t2&: bv&(5) = t3&: bv&(6) = t1& 'new values
        END IF
    
        '===== if right-middle button clicked...
        IF mx > 600 AND mx < 675 AND my > 250 AND my < 425 THEN
            '=== slide column left
            FOR x = 0 TO size
                '=== just move left two images right
                _PUTIMAGE (bx1(4) + x, by1(4)), bv&(4)
                _PUTIMAGE (bx1(5) + x, by1(5)), bv&(5)
                '=== and expand far left location with far right image
                _PUTIMAGE (bx1(4), by1(4))-(bx1(4) + x, by2(4)), bv&(6)
                '=== redraw boxes around them, for looks
                LINE (bx1(4), by1(4))-(bx2(4), by2(4)), _RGB(0, 0, 0), B
                LINE (bx1(5), by1(5))-(bx2(5), by2(5)), _RGB(0, 0, 0), B
                LINE (bx1(6), by1(6))-(bx2(6), by2(6)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(4): t2& = bv&(5): t3& = bv&(6) 'old values
            bv&(4) = t3&: bv&(5) = t1&: bv&(6) = t2& 'new values
        END IF
    
        '===== if left-bottom button clicked...
        IF mx > 0 AND mx < 75 AND my > 425 AND my < 600 THEN
            '=== slide column left
            FOR x = 0 TO size
                '=== just move right two images left
                _PUTIMAGE (bx1(8) - x, by1(8)), bv&(8)
                _PUTIMAGE (bx1(9) - x, by1(9)), bv&(9)
                '=== and expand far right location with far left image
                _PUTIMAGE (bx2(9) - x, by1(9))-(bx2(9) - x, by2(9)), bv&(7)
                '=== redraw boxes around them, for looks
                LINE (bx1(7), by1(7))-(bx2(7), by2(7)), _RGB(0, 0, 0), B
                LINE (bx1(8), by1(8))-(bx2(8), by2(8)), _RGB(0, 0, 0), B
                LINE (bx1(9), by1(9))-(bx2(9), by2(9)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(7): t2& = bv&(8): t3& = bv&(9) 'old values
            bv&(7) = t2&: bv&(8) = t3&: bv&(9) = t1& 'new values
        END IF
    
        '===== if right-bottom button clicked...
        IF mx > 600 AND mx < 675 AND my > 425 AND my < 600 THEN
            '=== slide column left
            FOR x = 0 TO size
                '=== just move left two images right
                _PUTIMAGE (bx1(7) + x, by1(7)), bv&(7)
                _PUTIMAGE (bx1(8) + x, by1(8)), bv&(8)
                '=== and expand far left location with far right image
                _PUTIMAGE (bx1(7), by1(7))-(bx1(7) + x, by2(7)), bv&(9)
                '=== redraw boxes around them, for looks
                LINE (bx1(7), by1(7))-(bx2(7), by2(7)), _RGB(0, 0, 0), B
                LINE (bx1(8), by1(8))-(bx2(8), by2(8)), _RGB(0, 0, 0), B
                LINE (bx1(9), by1(9))-(bx2(9), by2(9)), _RGB(0, 0, 0), B
                _DISPLAY
                _LIMIT slidespeed
            NEXT
            '=== update/assign new values
            t1& = bv&(7): t2& = bv&(8): t3& = bv&(9) 'old values
            bv&(7) = t3&: bv&(8) = t1&: bv&(9) = t2& 'new values
        END IF
    
        '==== check if puzzle is solved....

        solved = 1 'assume it is first
        FOR s = 1 TO boxes
            '=== if piece doesnt match, not solved
            IF bv&(s) <> slv&(s) THEN solved = 0
        NEXT
        '=== Solved?  END
        IF solved = 1 THEN BEEP: BEEP: END
    
    END IF

LOOP
    
END
    
    
    
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

   

[bplus]

Maybe this will signal TempodiBasic to come back!



Hi Dav, 

Is there just one puzzle for this? or am I missing the scrambler part.

I think you can scramble it like the 15 Puzzle with a bunch of random moves from the sol'n.

[Dav]

There's only the one.  I should update this with a scrambler for more levels.  Yeah good idea.

Yes --I hope TempodiBasic returns!

- Dav

[bplus]

Hi Dav,

Didn't have anything else to do today so started a little mod to add a scrambler for random targets to match.

Uhmmm.... it's turning into a bit of a major overhaul, do you want to see it here if I finish and it works or up there ^^^()^^^
in programs. I already have plans for more cells per side too.

Maybe I should be working on my plate of spaghetti code ;-))

[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/

[Dav]

Nice, @bplus!  You did a lot work on that.  Thank you.  I will post a link to this on the top post here.

- Dav

[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

[SMcNeill]

Maybe this will signal TempodiBasic to come back!

Tempodi posted on my other forums a few days back.  Said he'd be back to coding in BASIC in another month or so.  He's not missing; he's just on vacation.  

[PhilOfPerth]

A great game! Simple to play, as you said, but hard to solve. Not game to try with more than 9 cells yet though... may cause some damage to furniture around here if I do!

[bplus]

A great game! Simple to play, as you said, but hard to solve. Not game to try with more than 9 cells yet though... may cause some damage to furniture around here if I do!

Neither am I! Ha! just wanted to see if I could program it with multiple cells per side, nice challenge PLUS I get to use my arrows as buttons! Never could figure out Rubik's cube either but I had a program that sorta worked converting 3D to 2D and showing all sides after a move.

Great news about TempodiBasic, after last night trials and tributes I am ready for vacation too!