+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: Dav (https://staging.qb64phoenix.com/forumdisplay.php?fid=34)
+---- Thread: QB64 Surabikku - Sliding block puzzle (/showthread.php?tid=347)
Pages:
1
2
QB64 Surabikku - Sliding block puzzle - Dav - 05-05-2022
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 SUBRE: QB64 Surabikku - Sliding block puzzle - bplus - 05-05-2022
Maybe this will signal TempodiBasic to come back!
![[Image: Surab-Tempodi.png]](https://i.ibb.co/M2MPnXZ/Surab-Tempodi.png)
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.
RE: QB64 Surabikku - Sliding block puzzle - Dav - 05-05-2022
There's only the one. I should update this with a scrambler for more levels. Yeah good idea.
Yes --I hope TempodiBasic returns!
- Dav
RE: QB64 Surabikku - Sliding block puzzle - bplus - 05-06-2022
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 ;-))
RE: QB64 Surabikku - Sliding block puzzle - bplus - 05-06-2022
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 SubThe colors are for our missing friend. https://flagcolor.com/italian-flag-colors/
![[Image: Surabikku-b-mod.png]](https://i.ibb.co/F51D9Sq/Surabikku-b-mod.png)
RE: QB64 Surabikku - Sliding block puzzle - Dav - 05-06-2022
Nice, @bplus! You did a lot work on that. Thank you. I will post a link to this on the top post here.
- Dav
RE: QB64 Surabikku - Sliding block puzzle - bplus - 05-07-2022
(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
RE: QB64 Surabikku - Sliding block puzzle - SMcNeill - 05-07-2022
(05-05-2022, 04:57 PM)bplus Wrote: 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.
RE: QB64 Surabikku - Sliding block puzzle - PhilOfPerth - 05-07-2022
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!
RE: QB64 Surabikku - Sliding block puzzle - bplus - 05-07-2022
(05-07-2022, 06:39 AM)PhilOfPerth Wrote: 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!