Unique Sudoku Solver

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

Unique Sudoku Solver

Post by NorbyDroid »

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

  ' Value not found  Return 1 (able to use the Value)
  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
Post Reply