+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: bplus (https://qb64phoenix.com/forum/forumdisplay.php?fid=36)
+---- Thread: 4x4 Square Elimination Puzzle (/showthread.php?tid=4519)
4x4 Square Elimination Puzzle - bplus - 03-04-2026
Revisiting an old old game puzzle I made years ago! Then, I filled the board randomly with red and blue squares and had no idea if you could actually get down to only one red and one blue cell. So I revised the BoardSetup code to start with a red and blue cell at a given spot 1,1 and 2,1 for 4x4 and reversed engineered clicks to build a puzzle with an exact solution. Trouble WAS most puzzles built this way were trivial to solve ie a sea of red and a sea of blue with no islands of the opposite color to make the puzzle challenging. What I needed was an expansion function that could isolate a cell, one color surrounded by the opposite. Still it takes awhile to get a non trivial puzzle built but finally got it all worked out so you can use a little logic and solve each puzzle perfectly returning the Puzzle state back to the seed start state.
You have solved the Puzzle "good" when you can get it down to 2 cells:
You have solved the Puzzle "better" when you get 2 cells adjacent to each other:
You have Not solved the Puzzle when you see this:
And you have solved the Puzzle Perfectly with exact positioning of red and blue like this:
So here is the Puzzle code:
Code: (Select All)
_Title "4x4 Square Elimination Puzzle 2026-03-04" ' b+ port and severely updated mods from
'square elimination v4.bas SmallBASIC 0.12.7 [B+=MGA] 2016-10-03 one of the first games I ever made in BASIC
Randomize Timer
Screen _NewImage(400, 400, 32)
_Delay .25
_ScreenMove _Middle
Const BS = 360 'BS = Board Size in pixels notice 360 divisible 4, 9, 5
Dim Shared SPS, SPSm1, SS, State, LastX, LastY, Quit, WatchBoardSetup, MoreBlue, NRed, NBlue, SaveRX, SaveRY
' SPS = Squares Per Side this 4x4 Puzzle comes from a bigger version where you say how many SPS you want.
' SPSm1 = SPS minus 1
' SS = Square Side size in pixels
' State = tracks mouse clicks 0 no cliciks and 1 on 2nd click
' LastX, LastY = last mouse click
' Quit signals done with p[uzzle
' WatchBoardSetup for watching Puzzle builds to create non trivial puzzles
' MoreBlue used to balance number of red squares and blue
' NRed, NBlue track how many of each square used to rate solutions
' SaveRX, SaveRY used to track first red cell found, again for rating a puzzle solution.
ReDim Shared Board(1, 1) ' Board needed dynamic ReDim for various possible sizes
WatchBoardSetup = 0 ' watching board builds step by boring step, even watching just the expansions,
' it takes a lot of builds to get a board with an isolated cell = non trivial puzzle !!
Instructions ' only once for 4x4 puzzle
While _KeyDown(27) = 0
'continue = Instructions 'gets the number of squares per side, SPS
'If continue < 3 Or continue > 20 Then Stop Else SPS = continue
SPS = 4
SPSm1 = SPS - 1
SS = BS / SPS
State = 0
Cls
BoardSetup
Update
Quit = 0
Do ' puzzle Loop
While _MouseInput: Wend
mx = _MouseX - 20: my = _MouseY: mb = _MouseButton(1)
k$ = InKey$
If k$ = "q" Or _KeyDown(27) Then Quit = 1
If mb And mx < BS And my < BS Then
_Delay .25
col = Int(mx / SS)
row = Int(my / SS)
If State = 0 Then
If (Board(col, row) = -1 Or Board(col, row) = 1) Then
LastX = col: LastY = row: State = 1
End If
Else
moov = Moved(LastX, LastY, col, row)
Select Case moov
Case 1 ' Moved up
For i = LastY To SPSm1
Board(LastX, i - 1) = Board(LastX, i)
Next
Board(LastX, SPSm1) = 0
Case 2 ' Moved right
For i = LastX To 0 Step -1
Board(i + 1, LastY) = Board(i, LastY)
Next
Board(0, LastY) = 0
Case 3 ' Moved down
For i = LastY To 0 Step -1
Board(LastX, i + 1) = Board(LastX, i)
Next
Board(LastX, 0) = 0
Case 4 ' Moved left
For i = LastX To SPSm1
Board(i - 1, LastY) = Board(i, LastY)
Next
Board(SPSm1, LastY) = 0
End Select
LastX = -10: LastY = -10: State = 0
End If
Update
_Limit 30
End If 'mouse on board
Loop Until Quit
Wend
System
Sub BoardSetup
'attempting to setup Board so that it is possible to eliminate squares down to 2 one of each color
'and not be a trivial puzzle to solve ie 1 sea of red and one sea of blue, no islands of opposite color.
' ideally islands of blue in sea of red and vice versa BTW it doesn't work for 3x3.
'
' Non trivial solutions have a least one isolated cell, that's what we will display for puzzle.
' If WatchBoardSetup Then Sleep code was for watching puzzle builds kinda fun except for stopping all
ReDim Board(SPSm1, SPSm1) ' clears array
' seed
Board(SPSm1 \ 2, SPSm1 \ 2) = -1 ' red cell at 1,1 for 4x4 board
Board(SPSm1 \ 2 + 1, SPSm1 \ 2) = 1 ' blue cell at 2, 1 for 4x4 board
DrawBoard
Do While EmptySpace ' drawing board to show program is thinking up a non trivial puzzle, takes awhile
try = 0
While 1
x = Int(Rnd * SPS): y = Int(Rnd * SPS)
ok = 0
If Board(x, y) = turn Then
ok = Expand(x, y) ' <<< without one good one of these, the puzzle will be trivial!
If ok Then
DrawBoard
If WatchBoardSetup Then Sleep
End If
ElseIf Board(x, y) = 0 Then ' this works but takes awhile to isolate
'ElseIf Board(x, y) <> turn Then ' no this makes it harder to isolate
' ' Do I need ElseIf ? would I not get a harder board without it
' ' NO IT IS NEEDED! What if we try first? eh not terrible but...
If LikeColorNextTo(turn, x, y) And Rnd < .1 Then ' decrease these with rnd
Board(x, y) = turn: DrawBoard: ok = -1
''dummy = Expand(x, y) ' test for more expansions, nope! ?
End If
End If
If ok = 0 Then
try = try + 1
If try > SPSm1 ^ 3 Then
If turn = -1 Then turn = 1 Else turn = -1
try = 0
End If
Else
Exit While
End If
Wend
If MoreBlue Then turn = -1 Else turn = 1
Loop
' will this work? yes back this up 2026-03-02_11_11A
' now that board is set does it have an isolated cell? if not a 3x3 board
If SPS <> 3 _AndAlso BoardHasIsolatedCell = 0 Then BoardSetup ' get us a non trivial board
' backup = SEG 2026-03-02_11_41A
End Sub
Function EmptySpace
For y = 0 To SPSm1
For x = 0 To SPSm1
If Board(x, y) = 0 Then EmptySpace = -1: Exit Function
Next
Next
End Function
Function BoardHasIsolatedCell
BoardHasIsolatedCell = 0 ' assume NOT and see if can find exception
For y = 0 To SPSm1
For x = 0 To SPSm1
If LikeColorNextTo(Board(x, y), x, y) = 0 Then BoardHasIsolatedCell = -1: Exit Function
Next
Next
End Function
Function LikeColorNextTo (colr, x, y) ' for setup
If x - 1 >= 0 Then
If Board(x - 1, y) = colr Then LikeColorNextTo = -1: Exit Function
End If
If x + 1 <= SPSm1 Then
If Board(x + 1, y) = colr Then LikeColorNextTo = -1: Exit Function
End If
If y - 1 >= 0 Then
If Board(x, y - 1) = colr Then LikeColorNextTo = -1: Exit Function
End If
If y + 1 <= SPSm1 Then
If Board(x, y + 1) = colr Then LikeColorNextTo = -1: Exit Function
End If
' else LikeColorNextTo returns 0
End Function
Function Expand (x, y) ' this will leave x, y same color
'and slide all cells in a direction that has an opening if there is one
startDir = Int(Rnd * 4) + 1 ' pick random direction
dir = startDir
Do ' try each dir until we find an opening to expand
Select Case dir
Case 1 ' Move up
If y <> 0 Then ' y is not at top so look for space
For yy = y - 1 To 0 Step -1
If Board(x, yy) = 0 Then 'yes a space, expand this dir
For yyy = yy To y - 1 ' reassign board cells but not x, y
Board(x, yyy) = Board(x, yyy + 1)
Next
Expand = -1: Exit Function
End If
Next yy
End If
Case 2 ' Move right
If x <> SPSm1 Then ' not all the way right so look for space to right
For xx = x + 1 To SPSm1
If Board(xx, y) = 0 Then 'yes a space, expand this dir
For xxx = xx To x + 1 Step -1 'reassign from right to left
Board(xxx, y) = Board(xxx - 1, y) ' but leave x, y as is
Next
Expand = -1: Exit Function
End If
Next xx
End If
Case 3 ' Move down
If y <> SPSm1 Then ' going down board, look for space to expand
For yy = y + 1 To SPSm1
If Board(x, yy) = 0 Then 'expand this dir
For yyy = yy To y + 1 Step -1 ' expand from bottom up
Board(x, yyy) = Board(x, yyy - 1) ' by reassign to above value
Next
Expand = -1: Exit Function
End If
Next yy
End If
Case 4 ' Move left
If x <> 0 Then ' x is not at left of board, look for space
For xx = x - 1 To 0 Step -1
If Board(xx, y) = 0 Then 'yes a space! expand this dir
For xxx = xx To x - 1 ' reassign from left to right
Board(xxx, y) = Board(xxx + 1, y)
Next
Expand = -1: Exit Function
End If
Next xx
End If
End Select
dir = dir + 1 ' still here? then dir failed so try next one unless we are back to startDir
If dir = 5 Then dir = 1 ' dir 1 to 4 only
Loop Until dir = startDir ' failed to expand at x, y we are done here returning 0
End Function
Sub DrawBoard
Line (0, 0)-(BS + 1, BS + 1), &HFF000000, BF
NRed = 0: NBlue = 0
For y = 0 To SPSm1
For x = 0 To SPSm1
If Board(x, y) = -1 Then
c~& = &HFFFF0000: NRed = NRed + 1
If NRed = 1 Then SaveRX = x: SaveRY = y ' <<< save these shared values for rating solution
End If
If Board(x, y) = 1 Then c~& = &HFF0000FF: NBlue = NBlue + 1
If Board(x, y) = 0 Then c~& = &HFF000000
Line (x * SS + 21, y * SS + 1)-Step(SS - 2, SS - 2), c~&, BF
Next
Next
If NBlue > NRed Then MoreBlue = -1 Else MoreBlue = 0 ' flag for balancing red and blue
_Display
End Sub
Sub Update ()
Cls
DrawBoard
If PuzzleDone% Then ' messagebox that no moves are left and soluition is: good, better or perfect!
rate = 1 ' = no more moves left
' has a perfect puzzle been played?
' 2 cells remain = good
If NBlue + NRed = 2 Then
rate = 2
' the red is at 1,1 and the blue at 2,1 = Perfect!!!
If Board(1, 1) = -1 _AndAlso Board(2, 1) = 1 Then
rate = 3
Else
' they are next to each other even better
' when I am drawing the board and counting cells I could save the location of
' the first red cell SaveRX, SaveRY
If LikeColorNextTo(1, SaveRX, SaveRY) Then rate = 4
End If
End If ' 2 cells
Select Case rate
Case 1: _MessageBox "Puzzle Done", "No more moves are available.", "info"
Case 2: _MessageBox "Puzzle Done", "Good job, only 2 Squares left!", "info"
Case 3: _MessageBox "Puzzle Done", "A Perfect Puzzle solution!!!", "info"
Case 4: _MessageBox "Puzzle Done", "Better than Good Solution, the 2 cells are adjacent.", "info"
End Select
Quit = 1
Else
_PrintString (46, 370), "esc or q to quit board and get new one."
If State = 1 Then ' highlite first cell clicked
Line (LastX * SS + 21, LastY * SS)-Step(SS - 1, SS - 1), &HFFFFFFFF, B
End If
_Display
End If
End Sub
Function Moved (x1, y1, x2, y2) ' moved returns the direction of move for sliding cells
Moved = 0 ' not a legal move!
If Board(x1, y1) = Board(x2, y2) Then 'same color and next to each other
If x1 = x2 Then 'cols match
If y1 - y2 = 1 Then Moved = 1 'up
If y2 - y1 = 1 Then Moved = 3 'down
Else
If y1 = y2 Then 'rows match
If x1 - x2 = 1 Then Moved = 4 'left
If x2 - x1 = 1 Then Moved = 2 'right
End If
End If
End If
End Function
Sub Instructions
Cls
Print '"12345678901234567890123456789012345678901234567890"
Print " The 4x4 Square Elimination Puzzle:"
Print
Print " The object is to eliminate as many squares as"
Print " possible. A perfect puzzle leaves one red square"
Print " and one blue square on the board next to each"
Print " other: red on left at 1,1 blue on right 2,1."
Print " that was how this Puzzle was seeded."
Print
Print " To eliminate a square, click the square to be"
Print " removed. It will be highlighted, then click a"
Print " like colored square directly above, below, left"
Print " or right of the highlighted square. The square"
Print " will be removed and all the squares behind it"
Print " (if any) will be slid over one space."
Print
Print " If you change your mind after clicking a square,"
Print " click that square again or a square of opposite"
Print " color or a square of like color but not next to"
Print " the square you clicked, to start again."
Print
Print
Print " Press any to continue... zzz"
Sleep
End Sub
Function PuzzleDone%
PuzzleDone% = -1 ' just find 2 like colored squares next to each other = there is a move left
For y = 0 To SPSm1
For x = 0 To SPSm1
If Board(x, y) Then ' not a blank square
If x + 1 <= SPSm1 Then ' horizontal move is left
If Board(x, y) = Board(x + 1, y) Then PuzzleDone% = 0: Exit Function
End If
If y + 1 <= SPSm1 Then ' vertical move is left
If Board(x, y) = Board(x, y + 1) Then PuzzleDone% = 0: Exit Function
End If
End If
Next
Next
End FunctionI'd say good luck but like with Sudoku, it's all just Logic!
RE: 4x4 Square Elimination Puzzle - bplus - 03-04-2026
PS here is a Puzzle I've yet to figure out:
RE: 4x4 Square Elimination Puzzle - bplus - 03-04-2026
Ah-ha! key first 2 moves:
And you are on Easy Street!
helper sub to replace BoardSetup:
Code: (Select All)
Sub boardsetup1
ReDim Board(3, 3)
Board(0, 0) = -1: Board(1, 0) = -1: Board(2, 0) = -1: Board(3, 0) = -1
Board(0, 1) = -1: Board(1, 1) = 1: Board(2, 1) = 1: Board(3, 1) = 1
Board(0, 2) = -1: Board(1, 2) = 1: Board(2, 2) = -1: Board(3, 2) = 1
Board(0, 3) = -1: Board(1, 3) = 1: Board(2, 3) = 1: Board(3, 3) = 1
End SubTo practice
RE: 4x4 Square Elimination Puzzle - bplus - 03-05-2026
The first time I encountered this one I just did it, tried to repeat and went brain dead.
Maybe someone can figure out the first few key moves?
replace BoardSetup call with call for this, boardsetup2
Code: (Select All)
Sub boardsetup2
ReDim Board(3, 3)
Board(0, 0) = -1: Board(1, 0) = -1: Board(2, 0) = -1: Board(3, 0) = -1
Board(0, 1) = -1: Board(1, 1) = -1: Board(2, 1) = -1: Board(3, 1) = 1
Board(0, 2) = 1: Board(1, 2) = 1: Board(2, 2) = 1: Board(3, 2) = 1
Board(0, 3) = 1: Board(1, 3) = 1: Board(2, 3) = 1: Board(3, 3) = -1
End Sub