## Unique Sudoku Solver

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
NorbyDroid
Posts: 72
Joined: May 21, 2016 22:55

### Unique Sudoku Solver

Not sure if this is ready for posting, but here it is.

This is the start of a unique solver where it doesn't use brute force or recursion to solve the puzzles. Instead, it uses different solving techniques like Hidden Singles, Hidden Pairs, etc. to try and solve the puzzles. Currently only Hidden Singles are available and can solve 4 of the 6 included puzzles.

Five puzzles are included:
1 Wikipedia Example

2 Simple Puzzle #1
3 Easy Puzzle #1
4 Medium Puzzle #1
5 Hard Puzzle #1
6 Genius Puzzle #1
Puzzles 2-6 are puzzles from the Boy Howdy Sudoku app on iOS.

Code: Select all

``````Dim As Integer wScreen=56*8, hScreen=40*16
ScreenRes wScreen, hScreen, 32

Dim As Integer wText=wScreen\8, hText=hScreen\16
Width wText, hText

Sub Pause
Sleep 100: If InKey=Chr(27) Then End
End Sub

Sub VirtPrint(x As Integer, y As Integer, Text As String, Colour As ULong)
If x<1 Or y<1 Or x>56*8 Or y>40*16 Then Exit Sub

Color Colour: Locate y, x, 0: Print Text;
End Sub

Sub Setup(Puzzle As String, Grid() As Integer, BoardArt() As String, NumArt() As String, _
Colour As ULong)

Dim As Integer ff=FreeFile
Open "Droidoku.bin" For Binary As #ff
BoardArt(0)=Space(4): Get #ff, , BoardArt(0)

Dim As Integer w=Asc(Mid(BoardArt(0), 2, 1)), h=Asc(Mid(BoardArt(0), 3, 1))
For t As Integer=1 To h: BoardArt(t)=Space(w): Get #ff, , BoardArt(t): Next
Close #ff

Dim As Integer x=Grid(0, 0), y=Grid(0, 1)

Color Colour
For t As Integer=0 To h-1: VirtPrint x, y+t, BoardArt(t+1), Colour: Next

For y As Integer=1 To 9
For x As Integer=1 To 9: Grid(x, y)=Val(Mid(Puzzle, 9*(y-1)+x, 1)): Next
Next
End Sub

Function Possible(Row As Integer, Col As Integer, Value As Integer, Grid() As Integer) As Integer
Dim As String RowScan, ColScan, RegScan, tStr

For Row As Integer=1 to 9
If Grid(Row, Col) Then RowScan=RowScan+Hex(Grid(Row, Col))
Next

' Value found?  Return 0 (Unable to use the Value)
If InStr(RowScan, Hex(Value)) Then Return 0

For Col  As Integer=1 To 9
If Grid(Row, Col) Then ColScan=ColScan+Hex(Grid(Row, Col))
Next

' Value found?  Return 0 (Unable to use the Value)
If InStr(ColScan, Hex(Value)) Then Return 0

' Get the Region start position
Dim As Integer t1=(Row-1)\3, tx=3*t1+1, t2=(Col-1)\3, ty=3*t2+1

For Col As Integer=0 to 2
For Row As Integer=0 to 2
If Grid(tx+Row, ty+Col) Then RegScan=RegScan+Hex(Grid(tx+Row, ty+Col))
Next
Next

' Value found?  Return 0 (Unable to use the Value)
If InStr(RegScan, Hex(Value)) Then Return 0

Return 1
End Function

Function Solved(Grid() As Integer) As Integer
For Col As Integer=1 to 9
For Row As Integer=1 To 9
' Is the Cell empty?  Return 0 (Puzzle unsolved)
If Grid(Row, Col)=0 Then Return 0
Next
Next

' No Empty cells - Puzzle solved
Return 1
End Function

Sub Position(Row As Integer, Col As Integer)
Dim As Integer tx=(Row-1)\3+1, ty=(Col-1)\3
VirtPrint 48, 38, "  Row  "+Hex(Row), RGB(255, 255, 255)
VirtPrint 48, 39, "Column "+Hex(Col), RGB(255, 255, 255)
VirtPrint 48, 40, "Region "+Hex(3*ty+tx), RGB(255, 255, 255)
End Sub

Sub ShowMarks(Row As Integer, Col As Integer, Mark As String)
Dim As Integer cx=6*(Row-1)+2, cy=4*(Col-1)+2

' Show Pencil Marks
For t As Integer=1 To Len(Mark)
Dim As Integer Value=Val(Mid(Mark, t, 1))
Dim As Integer tx=(Value-1) Mod 3, ty=(Value-1)\3

VirtPrint 2*tx+cx, cy+ty, Hex(Value), RGB(255, 215, 0)
Next
End Sub

Sub Pencil(Grid() As Integer, Marks() As String, Tag As Integer=0)
For Col As Integer=1 To 9
For Row As Integer=1 to 9
Position Row, Col

' Pencil Marks
Marks(Row, Col)=""

' Is the Cell empty?
If Grid(Row, Col)=0 Then
' Check all Possible Values 1-9
For Value As Integer=1 To 9
' If Possible add the value to the Pencil Marks
If Possible(Row, Col, Value, Grid()) Then
Marks(Row, Col)=Marks(Row, Col)+Hex(Value)
If Tag Then ShowMarks Row, Col, Marks(Row, Col)
EndIf
Next
EndIf
Next
Next
End Sub

' Shows where on the Grid it is working (not used)
Sub TagCell(x As Integer, y As Integer, Tag As Integer)
If Tag Then
For t As Integer=2 to 4: VirtPrint x+2, y+t, Space(5), RGB(255, 215, 0): Next
Else
VirtPrint x+2, y+2, "|\ /|", RGB(255, 0, 0)
VirtPrint x+2, y+3, "|   |", RGB(255, 0, 0)
VirtPrint x+2, y+4, "|/ \|", RGB(255, 0, 0)
EndIf

Pause
End Sub

Sub ShowGrid(Grid() As  Integer)
Dim As Integer x=Grid(0, 0), y=Grid(0, 1)

For Col As Integer=1 To 9
For Row As Integer=1 To 9
Dim As Integer cx=6*(Row-1), cy=4*(Col-1)

If Grid(Row, Col) Then
VirtPrint cx+x+1, cy+y+1, Space(5), RGB(255, 0, 0)
VirtPrint cx+x+1, cy+y+2, "  "+Hex(Grid(Row, Col))+"  ", RGB(255, 0, 0)
VirtPrint cx+x+1, cy+y+3, Space(5), RGB(255, 0, 0)
EndIf
Next
Next
End Sub

Sub HiddenSingles(Grid() As Integer, Marks() As String)
VirtPrint 2, 38, "Hidden Singles....", RGB(25, 255, 255)

' Get Pencil Marks - 1 is optional and will place them on the grid
Pencil Grid(), Marks(), 1

' Go through the entire Grid
For Col As Integer=1 To 9
For Row As Integer=1 to 9
Position Row, Col

' If only one pencil mark, then this is a Hidden Single
If Len(Marks(Row, Col))=1 Then
Grid(Row, Col)=Val(Marks(Row, Col))

Dim As Integer cx=6*(Row-1), cy=4*(Col-1)
VirtPrint cx+Grid(0, 0)+1, cy+Grid(0, 1)+1, Space(5), RGB(0, 255, 0)
VirtPrint cx+Grid(0, 0)+1, cy+Grid(0, 1)+2, "  "+Hex(Grid(Row, Col))+"  ", RGB(0, 255, 0)
VirtPrint cx+Grid(0, 0)+1, cy+Grid(0, 1)+3, Space(5), RGB(0, 255, 0)
EndIf
Next
Next
End Sub

Sub HiddenPairs(Grid() As Integer, Marks() As String)
VirtPrint 2, 38, "Hidden Pairs....", RGB(25, 255, 255)

' Get Pencil Marks - 1 is optional and will place them on the grid
Pencil Grid(), Marks(), 1
End Sub

Dim As String Puzzle(8)
' Empy Puzzle
Puzzle(1)="000000000000000000000000000000000000000000000000000000000000000000000000000000000"

' Wikipedia Puzzle
Puzzle(1)="530070000600195000098000060800060003400803001700020006060000280000419005000080079"

' Simple Puzzle
Puzzle(2)="000006007001902340890000012046013500010090060009560720970000035065708200200400000"

' Easy Puzzle
Puzzle(3)="900835001000009500073200800350401706100000002709308054008007230005600000400952008"

' Medium Puzzle
Puzzle(4)="300150040570030020804000000000091070290000051080370000000000603050040092060028004"

' Hard Puzzle
Puzzle(5)="970050000201090700400800010007029000300000009000640200010008005005060102000010083"

' Genius Puzzle
Puzzle(6)="600001000490080060008070200007200085000108000830007600003010900080090013000400006"

Dim As String Style
Dim As Integer Done

Dim As Integer Grid(9,9)
Grid(0, 0)=1: Grid(0, 1)=1

Dim As String BoardArt(56), NumArt(10), Marks(9, 9)

For t As Integer=1 To 6
Setup Puzzle(t), Grid(), BoardArt(), NumArt(), RGB(255, 215, 0)
ShowGrid Grid()

Select Case t
Case 1: Style="Wikipedia"
Case 2: Style="Simple"
Case 3: Style="Easy"
Case 4: Style="Medium"
Case 5: Style="Hard"
Case 6: Style="Genius"
End Select

Dim As Integer Stuck=0

While Not Done
VirtPrint 2, 40, "Solving "+Style+" Puzzle....", RGB(255, 215, 0): Pause
HiddenSingles Grid(), Marks()

If Stuck=20 Then
'HiddenPairs Grid(), Marks()
EndIf

If Solved(Grid()) Then Exit While
Wend

For t As Integer=0 To 2
VirtPrint 2, 38+t, Space(54), RGB(255, 215, 0)
Next

Sleep
Next

Sleep
``````