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:
I'd say good luck but like with Sudoku, it's all just Logic!
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!
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever
