TheGameCreators - CodeBase

Return to the CodeBase listing

Category: Miscellaneous

Version: 0.1

Information

Uploaded: 6th Sep 2010 16:53

Modified: 7th Sep 2010 20:05

Author: CSL

Summary

Sudoku Puzzle Solver

Full Description

About Sudoku Solver This is work in progress - Program works as it is now in attempting to solve nearly all easy-level (haven't found an Easy that the program hasn't solved) and some medium Sudoku puzzles. It has also a 33% success rate so far for harder puzzles. It attempts to solve puzzles using the regular solving techniques of candidate elimination and alternative techniques such as Naked and Hidden Singles. I'm still working on the Naked Pairs technique code, which has been commented for now. I've included several puzzles of various levels of difficulty, obtained from different Sudoku books for the program to solve. The program will pick up the first uncommented puzzle from the DATA statements, and will ignore anything else. I left one Sudoku puzzle data uncommented for demonstration purposes. You may enter your own partially solved Sudoku puzzles in the DATA statements, but make sure to comment out the previous puzzle DATA lines. Please refer to the program comments for additional information.

DarkBASIC Professional Source 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

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

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

Download

Please login to download

Comments

No comments yet.

CodeBase - Sudoku Solver

Information

Summary

Full Description

DarkBASIC Professional Source Code

Download

Screen Shot

Author

Comments

Author Name:	CSL
CodeBase Entries:	3