Sudoku Solver by CSL6th Sep 2010 16:53
|
|---|
|
Summary Sudoku Puzzle Solver Description About Sudoku Solver Code ` This code was downloaded from The Game Creators
` It is reproduced here with full permission
` http://www.thegamecreators.com
` Project: Sudoku Solver
` Program to solve a 9x9 sudoku
dim sdk(9,9) ` Main array with sudoku puzzle
dim sdkpossol$(9,9) ` Array with possible solutions for each square
dim Section(9,9) ` Array with sections - There are 9 sections across entire puzzle
` Section Layout
` 123
` 456
` 789
` Each section is 3x3
`---
` Arrays to store starting and ending coordinates of each of the 9 sections on sudoku grid
dim rowbeg(9)
dim rowed(9)
dim colbeg(9)
dim coled(9)
remstart
Section 1 - From 1,1 to 3,3,
Section 2 - From 1,4 to 3,6,
Section 3 - From 1,7 to 3,9
Section 4 - From 4,1 to 6,3,
Section 5 - From 4,4 to 6,6,
Section 6 - From 4,7 to 6,9
Section 7 - From 7,1 to 9,3
Section 8 - From 7,4 to 9,6
Section 9 - From 7,7 to 9,9
remend
` Arrays used in Naked Pairs logic, CheckNakedPairsRow()
dim pair(9)
dim pairrow(9)
dim paircol(9)
` ---
` Globals
global sdksolved = 0 `If 1, complete sudoku has been solved
global ct# ` Counts how many squares have been solved
global oldct# = 0 `Previous pass solved count. Used to determine if no solution is available
global stuck = 0 `To make sure program doesn't stay in an infinite loop
global possol$ = "" `Possible solutions, holds original value of sdkpsol$() array
global newpossol$ ` Updated possible solutions on a square
global row = 0
global col = 0
global xc = 30
global yr = 35
global tx = 400 `Text Output position
global ty = 40 `Text Output position
global scan = 0
global slen = 0
global sectnum
global sdksol$ = "123456789" ` Possible solutions on a square
`----
set text font "Courier New"
set text size 30
`----
cls
BuildSudoku()
text 35,375, "Press any key to start solving..."
wait key
`**************************************************
` Begin - Main Program
while (sdksolved = 0) and (stuck <= 3)
SolveSudoku()
endwhile
if sdksolved
text 35,450, "Sudoku solved, press any key..."
wait key
endif
cls
DisplaySudoku()
if sdksolved then text 35,375, "Solution..."
if stuck then text 35,375, "Stuck, no solution found...yet"
wait key
` Begin - For debugging only - remove when program completed
` Display all squares with possible solutions
cls
for r =1 to 9
for c = 1 to 9
if len(sdkpossol$(r,c)) > 1
print "sdkpossol$(",r,",",c,")","=",sdkpossol$(r,c)
wait key
endif
next c
next r
` End - for debugging
end
` End - Main Program
`**************************************************
Function BuildSudoku()
REM Fill sudoku with partial solution in data statements
for r = 1 to 9
for c = 1 to 9
read sdk(r,c)
text c*xc, r*yr,str$(sdk(r,c))
next c
next r
rem sudoku data, 0 is an unsolved square
remstart
`Ultimate Sudoku, Brain Tingling, page 8, Easy 5
`Solution for verification on page 511
data 5,0,0,0,0,7,2,0,0
data 0,6,0,0,9,0,0,3,7
data 0,8,9,0,0,4,1,0,0
`
data 0,1,0,3,2,8,0,0,0
data 9,0,0,0,0,1,6,2,0
data 0,0,3,0,0,9,0,8,0
`
data 0,7,1,0,0,0,0,6,4
data 0,0,5,7,0,0,0,1,0
data 4,9,0,5,0,0,0,0,0
remend
`
remstart
`Ultimate Sudoku, Brain Tingling, page 255, Intermediate 248
`Solution for verification on page 560
data 5,7,0,6,0,0,0,9,2
data 8,9,1,0,4,2,0,0,0
data 0,0,0,5,0,0,0,8,0
`
data 6,0,7,0,2,3,0,1,0
data 0,1,0,4,0,6,2,7,0
data 4,0,0,0,0,8,0,0,6
`
data 0,0,0,2,0,9,5,0,0
data 7,6,0,1,0,0,0,2,9
data 3,0,0,0,0,0,7,0,0
remend
`
`Ultimate Sudoku, Brain Tingling, page 509, Extreme 251
`Solution for verification on page 608
data 2,0,0,0,0,0,0,0,1
data 0,0,0,5,0,9,0,7,2
data 4,9,0,0,3,0,5,0,0
`
data 5,0,0,0,0,4,0,0,0
data 0,1,0,0,0,0,0,4,0
data 0,8,0,0,5,1,2,6,0
`
data 0,3,0,7,0,5,6,0,9
data 9,0,0,0,8,0,0,0,0
data 0,4,0,0,9,0,0,2,0
`
remstart
`Sudoku Puzzles Volume 112, page 85, 4 stars (hardest)
`Solution for verification on page 98
` Not solvable by program on 8/17/2010 morning
` Corrected logic and now is solvable!!!
`
data 0,0,6,0,0,1,0,0,5
data 9,0,0,2,0,0,0,4,0
data 8,0,0,0,0,0,0,6,7
`
data 0,0,9,0,5,7,0,0,0
data 0,2,0,0,0,0,0,7,0
data 0,0,0,3,1,0,5,0,0
`
data 3,5,0,0,0,0,0,0,6
data 0,9,0,0,0,4,0,0,8
data 2,0,0,7,0,0,3,0,0
remend
`
`------------------------------------------------------
`
remstart
`Ultimate Sudoku, Brain Tingling, page 382, Hard 249
`Solution for verification on page 585
` *** Stuck ***
`
data 1,9,0,0,0,0,4,0,0
data 0,3,0,0,0,1,0,9,2
data 0,6,8,0,0,0,0,7,3
`
data 0,5,0,1,0,8,0,0,0
data 2,0,0,0,9,0,0,1,5
data 8,0,7,2,4,0,0,0,0
`
data 9,2,1,0,5,6,0,0,0
data 0,0,5,7,0,0,0,0,6
data 0,0,0,0,0,9,0,0,0
`
remend
remstart
`Sudoku Volume 112, puzzle 143, Level: Very Hard
` *** Stuck ***
`
data 0,0,0,8,0,0,0,9,0
data 0,0,0,0,9,1,0,0,2
data 0,9,0,0,2,7,0,8,3
`
data 5,0,2,0,0,0,3,0,9
data 0,4,0,0,3,0,0,7,0
data 3,0,7,0,0,0,4,0,8
`
data 2,3,0,7,8,0,0,4,0
data 9,0,0,2,4,0,0,0,0
data 0,7,0,0,0,9,0,0,0
remend
` ------------------------
` Create array containing possible solutions for each square
for r=1 to 9
for c=1 to 9
square = sdk(r,c) `Read array with partial sudoku solution
if square > 0 ` If square is already solved
sdkpossol$(r,c) = str$(square) `Place the solution there
else `If not solved (square = 0)...
sdkpossol$(r,c) = sdksol$ `... then place "123456789" - possible solutions (at start)
endif
next c
next r
` Builds Sudoku Section grid
sectionnum = 1
For sectr = 1 to 7 step 3
For sectc = 1 to 7 step 3
For r = sectr to sectr + 2
For c = sectc to sectc + 2
Section(r,c) = sectionnum
Next c
Next r
inc sectionnum
Next sectc
Next sectr
` Sets starting and ending coordinates for each of the 9 sudoku sections (3x3 blocks)
` Used to determine where to begin and end a section scan for solutions
section = 1
For begr = 1 to 7 step 3
For begc = 1 to 7 step 3
rowbeg(section) = begr
rowed(section) = begr + 2
colbeg(section)=begc
coled(section)= begc + 2
inc section
Next begc
Next begr
endfunction `BuildSudoku
`
Function SolveSudoku()
` Main function used to solve the Sudoku puzzle
`
text 35,400, "Solving Sudoku..."
ct# = 0 ` Keeps count of solved squares
for r = 1 to 9
for c = 1 to 9
possol$ = sdkpossol$(r,c) ` Take a look at the array with the solution candidates
slen = len(possol$)
if slen > 1 ` If there are solution candidates on square
` Perform horizontal scan to start eliminating solution candidates on row r
for colm = 1 to 9 `Scan all columns on row r
scan = sdk(r,colm) `Check number on sudoku grid at r,colm
if scan > 0 `If this square is solved...
ReduceSolutions(r,c) ` eliminate it from the solution candidates on r,c
endif ` if scan > 0
next colm
endif ` if slen > 1
if slen > 1 ` If there are still solution candidates on square...
` ... then perform a vertical scan
for rowm = 1 to 9 `Scan all rows on column c
scan = sdk(rowm,c)
if scan > 0
ReduceSolutions(r,c)
endif ` if scan > 0
next rowm
endif ` if slen > 1
if slen > 1
` Perform a section scan (3x3 grid)
sectnum = Section(r,c) `Assign section number based on coordinate being scanned
for rowm = rowbeg(sectnum) to rowed(sectnum)
for colm = colbeg(sectnum) to coled(sectnum)
scan = sdk(rowm, colm)
if scan > 0
ReduceSolutions(r,c)
endif
next colm
next rowm
endif ` if slen > 1
if slen = 1 `if we solved a square...
if sdk(r,c) = 0 then sdk(r,c) = val(possol$) `... but the sudoku array is not updated, then proceed to update
inc ct#
` Check if sudoku puzzle has been solved
if ct# = 81
sdksolved = 1
exitfunction
endif
endif `if slen = 1
next c
next r
`If ct# (solved square count) hasn't increased since previous pass then we need to use alternate methods to solve the sudoku puzzle
rem if oldct# = ct# then stuck = 1 else oldct# = ct#
if oldct# = ct# ` If no new solved squares since previous pass
inc stuck ` Proceed with alternate logic for stuck sudoku
if stuck = 1
CheckUniqueSection() ` Use Hidden Single approach on a 3x3 section of the puzzle
if stuck = 1 ` Try next approach only if we are still stuck
CheckUniqueRow() ` Use Hidden Single approach on a specific row of the puzzle
if stuck =1
CheckUniqueCol() ` Use Hidden Single approach on a specific column of the puzzle
endif
endif
endif
else
oldct# = ct#
endif
remstart Naked Pairs - still unimplemented
if stuck = 2
CheckNakedPairsRow()
endif
remend
endfunction `SolveSudoku
`
Function DisplaySudoku()
cls
for rds=1 to 9
for cds=1 to 9
text cds * xc, rds * yr,str$(sdk(rds,cds))
next cds
next rds
endfunction `DisplaySudoku
`
function ReduceSolutions(r,c)
` Purpose of this function is to eliminate possible solution candidates
` in a particular square on the sudoku puzzle.
for i = 1 to slen
chk$ = mid$(possol$,i) ` Checks if number found is still on the possible solution string possol$
if val(chk$) = scan ` If the value on the scan (sdk()) square is also on the possible solutions (chk) string
` then eliminate that value from the possible solutions
possol$ = delete$(possol$, Pos(possol$,chk$),1)
sdkpossol$(r,c) = possol$
slen = len(possol$)
endif ` if val(chk$) = scan
next i
endfunction `ReduceSolutions(r,c)
`
function CheckUniqueSection()
` Uses Hidden Single approach on a 3x3 section of the puzzle
` Checks each 3x3 section in clockwise order
`** First 1 -> 2 -> 3
` 4 -> 5 -> 6
` 7 -> 8 -> 9 **Last
` It takes all unsolved squares within 3x3 grid and looks for a unique number in that grid
` A square is solved when there's a unique (single) number between All Unsolved squares in a 3x3 grid
` If a solution is found, logic stops and exits function, then goes back again to try solving the sudoku by conventional methods
oct = 0 ` Tallies how many occurrences of a number within section
for sectnm = 1 to 9 `Check each 3x3 section (9 sections total) for a unique number within all possible solution cadidates.
for rowm = rowbeg(sectnm) to rowed(sectnm)
for colm = colbeg(sectnm) to coled(sectnm)
chk$ = sdkpossol$(rowm, colm) ` Possible solutions before beginning
nlen = len(chk$)
if nlen > 1 `Only check unsolved squares (more than one possible solution candidate)
for ss =1 to nlen `Check each character against all other numbers on 3x3 section
cn$ = mid$(chk$,ss)
for rm = rowbeg(sectnm) to rowed(sectnm) `Compare each square...
for cm = colbeg(sectnm) to coled(sectnm) `...with the rest of the squares on the same section
if (rm <> rowm) or (cm <> colm) ` don't check within same coordinates
temp$ = sdkpossol$(rm, cm)
if len(temp$) > 1 `only compare against unsolved squares
oc = Occurs(temp$,cn$) `Count occurrences of character cn$ within section
oct = oct + oc
endif ` if len(temp$)
endif ` if (rm <> rowm)...
next cm
next rm
if oct = 0 `If number is unique (found zero occurrences anywhere on the 3x3 section)...
sdkpossol$(rowm,colm) = cn$ `... then we solved this square, update the array with the unique number
sdk(rowm,colm) = val(cn$)
stuck = 0 ` no longer stuck
exitfunction ` stop here if square is solved
endif ` if oct
oct = 0
next ss `Check next character
endif `if nlen > 1
next colm
next rowm
next sectnm
endfunction ` CheckUniqueSection()
function CheckUniqueRow()
` Uses Hidden Single approach on a specific row of the puzzle (left to right horizontal check)
oct = 0 ` Tallies how many occurrences of a number within a row
for rowm = 1 to 9
for colm = 1 to 9
chk$ = sdkpossol$(rowm, colm) ` Check possible solution candidates before beginning
nlen = len(chk$)
if nlen > 1
for ss =1 to nlen `Check character by character
cn$ = mid$(chk$,ss)
for cm = 1 to 9 `...with the rest of the squares on the same ROW
if (cm <> colm) ` don't check within same column
temp$ = sdkpossol$(rowm, cm)
if len(temp$) > 1 `only compare against unsolved squares
oc = Occurs(temp$,cn$) `Count occurrences of character cn$ within section
oct = oct + oc
endif ` if len(temp$)
endif ` if (cm <> colm)...
next cm
if oct = 0 `If number is unique (found no occurrences)
sdkpossol$(rowm,colm) = cn$ `update the array with the unique number
sdk(rowm,colm) = val(cn$)
stuck = 0
exitfunction
endif ` if oct
oct = 0
next ss `Check next character
endif `if nlen > 1
next colm
next rowm
endfunction `CheckUniqueRow()
function CheckUniqueCol()
` Uses Hidden Single approach on a specific column of the puzzle (top to bottom vertical check)
oct = 0 ` Tallies how many occurrences of a number within a COLUMN
for rowm = 1 to 9
for colm = 1 to 9
chk$ = sdkpossol$(rowm, colm) ` Possible solutions before beginning
nlen = len(chk$)
if nlen > 1
for ss =1 to nlen `Check character by character
cn$ = mid$(chk$,ss)
for rm = 1 to 9 `...with the rest of the squares on the same ROW
if (rm <> rowm) ` don't check within same ROW
temp$ = sdkpossol$(rm, colm)
if len(temp$) > 1 `only compare against unsolved squares
oc = Occurs(temp$,cn$) `Count occurrences of character cn$ within section
oct = oct + oc
endif ` if len(temp$)
endif ` if (rm <> rowm)...
next rm
if oct = 0 `If number is unique (found no occurrences)
sdkpossol$(rowm,colm) = cn$ `update the array with the unique number
sdk(rowm,colm) = val(cn$)
stuck = 0
exitfunction
endif ` if oct
oct = 0
next ss `Check next character
endif `if nlen > 1
next colm
next rowm
endfunction `CheckUniqueCol()
function CheckNakedPairsRow()
` Started: 8/21/2010
if pairtriple > 3 then pairtriple = 2
solvd = 0
cls
for rowm = 1 to 9
for colm = 1 to 9
` First check if less than 7 solved squares (for naked pairs)
if nlen = 1 then inc solvd
next colm
if solvd <= 9 - pairtriple + 1
` Now check for pairs only
pairct = 0
for clm = 1 to 9
chk$ = sdkpossol$(rowm, clm)
if len(chk$) = pairtriple
inc pairct
pair(pairct) = val(chk$)
pairrow(pairct) = rowm
paircol(pairct) = clm
endif
next clm
` Find two (or three) identical pairs (triples)
foundpair = 0
for i = 1 to pairct
for clm = 1 to pairct
if clm <> i
if pair(i) = pair(clm)
foundpair = 1
pair1 = pair(i)
pair2 = pair(clm)
endif
endif
next clm
next i
if foundpair = 1
del$ = str$(pair(i))
possol$ = delete$(possol$, Pos(possol$,chk$),1)
endif
else
print solvd," squares solved on row ", rowm
endif `if solvd <= 6
solvd = 0
next rowm
wait key
endfunction `CheckNakedPairsRow()
Function Pos(s$, c$)
REM *** result stays at 0 if no match found ***
result = 0
REM *** Make sure we're looking for a single character ***
first$ = MID$(c$,1)
REM *** FOR each character in s$ DO ***
FOR c = 1 to LEN(s$)
REM *** IF that character matches what we're after THEN ***
IF MID$(s$,c) = first$
REM *** set result to this position and exit loop ***
result = c
EXIT
ENDIF
NEXT c
ENDFUNCTION result
Function Delete$(s$, start, num)
REM *** IF invalid position, result is original string ***
IF start < 1 or start > LEN(s$)
result$ = s$
ELSE
REM *** Construct result from left of deleted section ***
REM *** and right of deleted section ***
result$ = LEFT$(s$, start-1)
result$ = result$+RIGHT$(s$,LEN(s$)-(start+num-1))
ENDIF
ENDFUNCTION result$
Function Occurs(s$,c$)
REM *** None found so far ***
result = 0
REM *** Make sure only one character ***
first$ = MID$(c$,1)
REM *** FOR each character in s$ DO ***
FOR c = 1 to LEN(s$)
REM *** IF it matches req'd character, add 1 to result ***
IF MID$(s$,c) = first$
result = result + 1
ENDIF
NEXT c
ENDFUNCTION result
|