|
| View previous topic :: View next topic |
| Author |
Message |
| Lunatic
 | | Joined: 11 Mar 2007 | | Posts: 166 | | : | | Location: Ghent - Belgium |
Items |
|
 Posted: Sun Apr 15, 2007 12:52 pm Post subject: Dancing Links and Visual Basic (with example code) |
 |
|
Hi,
I tried to write a fast solver (for sudoku generating purposes) with Dancing Links in Visual Basic, but was blocked by the fact that Visual Basic doesn't provide the use of pointers, as VB is a "save" language. Attempting to get round this problem, I came up with the following alternative, based on the 4 line brute solver in combination with the "undo" routine from my own developed MPQ Sudoku...
There's a complete example for brute force solving killer sudokus based on this code further in this thread...
| Code: |
'*********************************************************************************
'General - Declaration
'clue data
Dim CountClues As Integer
Dim ClueAdress(0 To 80) As Integer
Dim CluePtr As Integer
'DLX-alternative brute force data
Dim Sudoku(0 To 80) As Integer 'contains the cluevalues 1 to 9, 0 for unsolved cell
Dim Solution(0 To 80) As Integer
Dim UniqueSolution(0 To 80) As Integer
Dim UnsolvedCells(0 To 80) As Integer
Dim CandidateCount(0 To 80) As Integer
Dim CandidateAvailable(0 To 80, 1 To 9) As Boolean
Dim CandidatePtr(0 To 80) As Integer
Dim CandidateList(0 To 80, 1 To 9) As Integer
'undo data
Dim LogCandidate() As Integer '1 >> 9
Dim LogCell() As Integer '0 >> 80
Dim LogColumn() As Integer '9 bits / column
Dim LogRow() As Integer '9 bits / row
Dim LogBox() As Integer '9 bits / box
Dim Steps As Integer 'counter
'end of General - Declaration
'*********************************************************************************
Function UniqueSud() As Boolean
Dim UnsolvedCellPtr As Integer 'pointer for incremental solving
Dim Boundary As Integer 'limiter pointer
Dim Cell As Integer
Dim Candidate As Integer
Dim NoCandidates As Boolean
Dim Column As Integer
Dim Row As Integer
Dim BoxTopLeft As Integer
Dim SolutionCount As Integer
UniqueSud = False
'initiate arrays
For Cell = 0 To 80
'erase result array
UniqueSolution(Cell) = 0
'set all candidates as available (or possible)
For Candidate = 1 To 9
CandidateAvailable(Cell, Candidate) = True
Next Candidate
'reset candidate counter
CandidateCount(Cell) = 0
'reset candidate pointer
CandidatePtr(Cell) = 0
Next Cell
'reset unsolved cell pointer
UnsolvedCellPtr = -1
'scan clues and setup arrays
For Cell = 0 To 80
'copy data from clue-array
Solution(Cell) = Sudoku(Cell)
If Sudoku(Cell) > 0 Then
'disable impossible candidates
For Candidate = 1 To 9
CandidateAvailable(Cell, Candidate) = False
Next Candidate
Candidate = Sudoku(Cell)
Column = Cell Mod 9
Row = Int(Cell / 9)
BoxTopLeft = (Int(Row / 3) * 27) + (Int(Column / 3) * 3)
For i = 0 To 8
CandidateAvailable(((i * 9) + Column), Candidate) = False
CandidateAvailable(((Row * 9) + i), Candidate) = False
Next i
For i = 0 To 2
For j = 0 To 2
CandidateAvailable((BoxTopLeft + i + (j * 9)), Candidate) = False
Next j, i
Else
UnsolvedCellPtr = UnsolvedCellPtr + 1
UnsolvedCells(UnsolvedCellPtr) = Cell
End If
Next Cell
'set boundary at last used unsolved cell adressholders index
Boundary = UnsolvedCellPtr
'count and sort candidates for each unsolved cell
For i = 0 To Boundary
'setup list of available candidates
For Candidate = 1 To 9
If CandidateAvailable(UnsolvedCells(i), Candidate) Then
CandidateCount(UnsolvedCells(i)) = CandidateCount(UnsolvedCells(i)) + 1
CandidateList(UnsolvedCells(i), CandidateCount(UnsolvedCells(i))) = Candidate
End If
Next Candidate
if CandidateCount(UnsolvedCells(i))=0 then 'empty cell detected
'inform the user (optional)
MsgBox "This Sudoku has no solution", vbOKOnly, "Invalid Sudoku"
Exit Function
end if
Next i
'BRUTE FORCE SOLVING LOOP
'Try to solve the sudoku by increasing the candidate values of the unsolved cells
'if UnsolvedCellPtr becomes -1, than a solution is found
'reset stepcounter (for the undo function)
Steps = 0
'reset solution counter
SolutionCount = 0
Do While UnsolvedCellPtr < (Boundary + 1)
'check for solution
If UnsolvedCellPtr = -1 Then 'solution found
SolutionCount = SolutionCount + 1
'check if this is a second solution
If SolutionCount = 2 Then Exit Do 'more than one solution, leave the loop
'save solution
For i = 0 To 80
UniqueSolution(i) = Solution(i)
Next i
'increase UnsolvedCellPtr to continue search loop to next solution
UnsolvedCellPtr = UnsolvedCellPtr + 1
End If
Cell = UnsolvedCells(UnsolvedCellPtr)
Select Case CandidatePtr(Cell)
Case 0 'next cell
'search for cell with least candidates
For i = 0 To (UnsolvedCellPtr - 1)
If CandidateCount(UnsolvedCells(i)) < _
CandidateCount(UnsolvedCells(UnsolvedCellPtr)) Then
'swap adresses
dummie = UnsolvedCells(i)
UnsolvedCells(i) = UnsolvedCells(UnsolvedCellPtr)
UnsolvedCells(UnsolvedCellPtr) = dummie
End If
Next i
Cell = UnsolvedCells(UnsolvedCellPtr)
CandidatePtr(Cell) = CandidatePtr(Cell) + 1
Solution(Cell) = CandidateList(Cell, CandidatePtr(Cell))
RemoveCandidates Cell, Solution(Cell), (UnsolvedCellPtr - 1)
'set pointer to next cell
UnsolvedCellPtr = UnsolvedCellPtr - 1
'scan for empty cells
NoCandidates = False
If UnsolvedCellPtr > -1 Then
For i = 0 To UnsolvedCellPtr
If CandidateCount(UnsolvedCells(i)) = 0 Then NoCandidates = True
Next i
End If
'if an empty cell is encountered then reset pointer to current cell
If NoCandidates Then UnsolvedCellPtr = UnsolvedCellPtr + 1
Case CandidateCount(Cell) 'all candidates tried, undo, and go to previous cell
Undo UnsolvedCellPtr
'reset candidate pointer
CandidatePtr(Cell) = 0
UnsolvedCellPtr = UnsolvedCellPtr + 1
Case Else 'try next candidate for current cell
Undo (UnsolvedCellPtr - 1)
CandidatePtr(Cell) = CandidatePtr(Cell) + 1
Solution(Cell) = CandidateList(Cell, CandidatePtr(Cell))
RemoveCandidates Cell, Solution(Cell), (UnsolvedCellPtr - 1)
'set pointer to next cell
UnsolvedCellPtr = UnsolvedCellPtr - 1
'scan for empty cells
NoCandidates = False
If UnsolvedCellPtr > -1 Then
For i = 0 To UnsolvedCellPtr
If CandidateCount(UnsolvedCells(i)) = 0 Then NoCandidates = True
Next i
End If
'if an empty cell is encountered then reset pointer to current cell
If NoCandidates Then UnsolvedCellPtr = UnsolvedCellPtr + 1
End Select
Loop
Select Case SolutionCount
Case 0 'no solution
'inform the user (optional)
MsgBox "This Sudoku has no solution", vbOKOnly, "Invalid Sudoku"
Case 1 'only one solution, set return value
UniqueSud = True
'inform the user (optional)
MsgBox "This Sudoku has one unique solution", vbOKOnly, "Valid Sudoku"
'set results in the grid (also optional)
For Cell = 0 To 80
Grid(Cell).Caption = Format(UniqueSolution(Cell))
Grid(Cell).Refresh
Next Cell
Case Else 'more than one solution
'inform the user (optional)
MsgBox "This Sudoku has more than one solution", vbOKOnly, "Invalid Sudoku"
'erase first solution
For i = 0 To 80
UniqueSolution(i) = 0
Next i
End Select
End Function
'*********************************************************************************
Sub RemoveCandidates(Cell As Integer, Candidate As Integer, Ptr As Integer)
Dim Row As Integer
Dim Column As Integer
Dim BoxTopLeft As Integer
Steps = Steps + 1
ReDim Preserve LogCell(1 To Steps)
ReDim Preserve LogCandidate(1 To Steps)
ReDim Preserve LogColumn(1 To Steps)
ReDim Preserve LogRow(1 To Steps)
ReDim Preserve LogBox(1 To Steps)
LogCell(Steps) = Cell
LogCandidate(Steps) = Candidate
LogColumn(Steps) = 0
LogRow(Steps) = 0
LogBox(Steps) = 0
Row = Int(Cell / 9)
Column = Cell Mod 9
BoxTopLeft = (Int(Row / 3) * 27) + (Int(Column / 3) * 3)
'remove all "Candidate" in Row, Column and Box from "Cell"
For j = 0 To Ptr
If CandidateAvailable(UnsolvedCells(j), Candidate) Then
If Int(UnsolvedCells(j) / 9) = Row Then
LogRow(Steps) = LogRow(Steps) Or (2 ^ (UnsolvedCells(j) Mod 9))
CandidateAvailable(UnsolvedCells(j), Candidate) = False
CandidateCount(UnsolvedCells(j)) = 0
For i = 1 To 9
If CandidateAvailable(UnsolvedCells(j), i) Then
CandidateCount(UnsolvedCells(j)) = CandidateCount(UnsolvedCells(j)) + 1
CandidateList(UnsolvedCells(j), CandidateCount(UnsolvedCells(j))) = i
End If
Next i
Else
If UnsolvedCells(j) Mod 9 = Column Then
LogColumn(Steps) = LogColumn(Steps) Or (2 ^ Int(UnsolvedCells(j) / 9))
CandidateAvailable(UnsolvedCells(j), Candidate) = False
CandidateCount(UnsolvedCells(j)) = 0
For i = 1 To 9
If CandidateAvailable(UnsolvedCells(j), i) Then
CandidateCount(UnsolvedCells(j)) = CandidateCount(UnsolvedCells(j)) + 1
CandidateList(UnsolvedCells(j), CandidateCount(UnsolvedCells(j))) = i
End If
Next i
Else
If ((Int(UnsolvedCells(j) / 27) * 27) _
+ (Int((UnsolvedCells(j) Mod 9) / 3) * 3)) = BoxTopLeft Then
LogBox(Steps) = LogBox(Steps) Or _
(2 ^ ((Int((UnsolvedCells(j) - BoxTopLeft) / 9) * 3) + _
((UnsolvedCells(j) - BoxTopLeft) Mod 9)))
CandidateAvailable(UnsolvedCells(j), Candidate) = False
CandidateCount(UnsolvedCells(j)) = 0
For i = 1 To 9
If CandidateAvailable(UnsolvedCells(j), i) Then
CandidateCount(UnsolvedCells(j)) = CandidateCount(UnsolvedCells(j)) + 1
CandidateList(UnsolvedCells(j), CandidateCount(UnsolvedCells(j))) = i
End If
Next i
End If
End If
End If
End If
Next j
End Sub
'*********************************************************************************
Sub Undo(Ptr As Integer)
Dim Row As Integer
Dim Column As Integer
Dim BoxTopLeft As Integer
Solution(LogCell(Steps)) = 0
Row = Int(LogCell(Steps) / 9)
Column = LogCell(Steps) Mod 9
BoxTopLeft = (Int(Row / 3) * 27) + (Int(Column / 3) * 3)
For i = 0 To 8
If (LogRow(Steps) And (2 ^ i)) Then _
CandidateAvailable((Row * 9) + i, LogCandidate(Steps)) = True
If (LogColumn(Steps) And (2 ^ i)) Then _
CandidateAvailable((i * 9) + Column, LogCandidate(Steps)) = True
Next i
For i = 0 To 2
For j = 0 To 2
If (LogBox(Steps) And (2 ^ ((i * 3) + j))) Then _
CandidateAvailable(BoxTopLeft + (i * 9) + j, LogCandidate(Steps)) = True
Next j, i
Steps = Steps - 1
'count and sort candidates for each unsolved cell
For i = 0 To Ptr
CandidateCount(UnsolvedCells(i)) = 0
For j = 1 To 9
If CandidateAvailable(UnsolvedCells(i), j) Then
CandidateCount(UnsolvedCells(i)) = CandidateCount(UnsolvedCells(i)) + 1
CandidateList(UnsolvedCells(i), CandidateCount(UnsolvedCells(i))) = j
End If
Next j
Next i
End Sub
|
_________________
Marc
~~~<><~~~<><~~~<><~~~<><~~~
Last edited by Lunatic on Fri Jul 11, 2008 10:17 am; edited 8 times in total |
|
| Back to top |
|
 |
| garthd
| | Joined: 29 Apr 2006 | | Posts: 32 | | : | |
Items |
|
| Posted: Mon Apr 16, 2007 7:00 am Post subject: VB dancing links |
|
|
Hi
Great code - runs much faster than some backtracking code that I'd tried...
I've been trying to write a DLX solver in VBA - but without much success as I still can't get my head around DLX..
But if you are interested, I've found a resource howing how to create pointers in VB using classes. Do a search in google for "Visual Basic Pointers Tutorials" and look at the third page that google returns.
I'd be interested to see the code if you ever get a 'pure' DLX solver running in VB... |
|
| Back to top |
|
|
| tjacob
| | Joined: 10 Jul 2007 | | Posts: 3 | | : | |
Items |
|
| Posted: Tue Jul 10, 2007 6:50 pm Post subject: |
|
|
Hi Lunatic
I've been looking for a reasonable fast VB solver for checking and generating purposes, and you have the answer!
Since I'm no genius when it comes to bitwise operations, and I'm not too fond of recursion either, your brute force loop is perfect. I have been trying it out, and have found a puzzle it choked on:
| Code: | | 009028700806004005003000004600000000020713450000000002300000500900400807001250300 |
It is a puzzle with no solutions, and your routine halts because of a candidate set to 0. This is easily avoided, by running a naked single search first, but I thought I would let you know.
/tjacob |
|
| Back to top |
|
|
| Lunatic
| | Joined: 11 Mar 2007 | | Posts: 166 | | : | | Location: Ghent - Belgium |
Items |
|
| Posted: Wed Jul 11, 2007 3:50 pm Post subject: |
|
|
Thanks for letting me know. Indeed, the cell at R5C1 has no candidates at all.
I've edited the source in the first post of this topic, added following code in function UniqueSud() , more specific in the part where te candidates from the unsolved cells are counted and sorted.
| Code: |
if CandidateCount(UnsolvedCells(i))=0 then 'empty cell detected
'inform the user (optional)
MsgBox "This Sudoku has no solution", vbOKOnly, "Invalid Sudoku"
Exit Function
end if
|
Marc. |
|
| Back to top |
|
|
| garthd
| | Joined: 29 Apr 2006 | | Posts: 32 | | : | |
Items |
|
| Posted: Sat Feb 09, 2008 10:57 am Post subject: Adapting code to solver killer/kakuro puzzles |
|
|
I've been trying to modify this code to deal with killers - in the loop marked 'scan clues and setup arrays, I've added some new code before these two lines:
| Code: | UnsolvedCellPtr = UnsolvedCellPtr + 1
UnsolvedCells(UnsolvedCellPtr) = Cell |
I have added a loop to add in the constraints for the killer based on the candidates that are allowed by the cage combinations...
| Code: | 'start new code
For i = 1 To 9
If KillerArray(Cell, i) < 0 Then CandidateAvailable(Cell, i) = False
Next
'end new code
UnsolvedCellPtr = UnsolvedCellPtr + 1
UnsolvedCells(UnsolvedCellPtr) = Cell |
I've also added in some code to check the solution matches the killer cage sums before the solutioncount is incremented...
| Code: | | If CheckSolutionConstraints() Then SolutionCount = SolutionCount + 1 |
However, the code now just runshangs without returning any valid solutions to the killer puzzle. I suspect I need to do something with the undo function. Anyone got any ideas? |
|
| Back to top |
|
|
| andreyvul
| | Joined: 12 Feb 2008 | | Posts: 7 | | : | |
Items |
|
| Posted: Wed Feb 13, 2008 3:53 am Post subject: |
|
|
vb.net has IntPtr datatype if that might help
I have no clue how to use it, though  |
|
| Back to top |
|
|
| Jean-Christophe
| | Joined: 19 Mar 2006 | | Posts: 126 | | : | | Location: Belgium |
Items |
|
| Posted: Mon Mar 03, 2008 9:09 pm Post subject: |
|
|
I can't help for VB, but the easiest way to setup DLX for killer is to use combinations rows as explained here:
http://www.setbb.com/sudoku/viewtopic.php?t=1274
There is no need to do a final check of the solution, provided the DLX is setup correctly with cage columns and combinations rows.
_________________
Jean-Christophe
"When you have eliminated the impossible, whatever remains, however improbable, must be the truth." Sherlock Holmes. |
|
| Back to top |
|
|
| Lunatic
| | Joined: 11 Mar 2007 | | Posts: 166 | | : | | Location: Ghent - Belgium |
Items |
|
| Posted: Mon Mar 03, 2008 10:36 pm Post subject: |
|
|
garthd quoted:
| Quote: | | I've been trying to modify this code to deal with killers... |
Hi,
It's been months ago since I last visited this forum  . I was a bit surprised to see some new postings related to the alternative DLX4VB (Dancing Links for Visual Basic) topic  .
So, how about killers ?
Since a killer sudoku is bounded by the normal sudoku rule, has no clues but sum cages instead, it's obvious that just bounded by the normal sudoku rule, we will encounter ALL possible solutions, can't have that. So, indeed we have to exclude those candidates not allowed by the cage combinations. If your KillerArray is a boolean array you can simply copy it into the CandidateAvailable array.
Based on the above restrictions, we can, after counting and sorting the available candidates start the brute force solving loop. For each solution, we have to check if it matches the killer cage sums before the solutioncount is incremented, that's correct too.
Your thinking and your code looks good to me...
Ok, I've edited the code from the first message. I also added a boolean flag called KillerSudoku that must be set to True if it's a killer sudoku, otherwise it must be set to False. The flag must be set before entering the UniqueSud function. |
|
| Back to top |
|
|
| Lunatic
| | Joined: 11 Mar 2007 | | Posts: 166 | | : | | Location: Ghent - Belgium |
Items |
|
| Posted: Thu May 15, 2008 6:32 pm Post subject: |
|
|
Here's the code of a complete example for a brute force killer sudoku solving...
| Code: |
'*********************************************************************************
'General - Declaration
'clue data
Dim CountClues As Integer
Dim ClueAdress(0 To 80) As Integer
Dim CluePtr As Integer
'DLX-alternative brute force data
Dim Sudoku(0 To 80) As Integer 'contains the cluevalues 1 to 9, 0 for unsolved cell
Dim Solution(0 To 80) As Integer
Dim UniqueSolution(0 To 80) As Integer
Dim UnsolvedCells(0 To 80) As Integer
Dim CandidateCount(0 To 80) As Integer
Dim CandidateAvailable(0 To 80, 1 To 9) As Boolean
Dim CandidatePtr(0 To 80) As Integer
Dim CandidateList(0 To 80, 1 To 9) As Integer
'extra data for killer sudokus
Dim KillerArray(0 To 80, 1 To 9) As Boolean
Dim KillerSudoku As Boolean 'flag indicating killer sudokus
Dim CountCages As Integer 'number of cages
Dim CellsCageAdress(0 To 80) As Integer 'Contains number of cage the cell belongs to
'the next array must be Redimmed to (1 To CountCages)
Dim CageSums() As Integer 'contains sums of cages
Dim LogCageCandidates() As Integer 'cage log for eleminated candidates
'undo data
Dim LogCandidate() As Integer '1 >> 9
Dim LogCell() As Integer '0 >> 80
Dim LogColumn() As Integer '9 bits / column
Dim LogRow() As Integer '9 bits / row
Dim LogBox() As Integer '9 bits / box
Dim Steps As Integer 'counter
'end of General - Declaration
'*********************************************************************************
Private Sub Form_Load()
Show
'******************************************
'****** Killer Sudoku Example ******
'******************************************
KillerSudoku = True
CountCages = 27 'number of cages = 27
CellsCageAdress(0) = 1 'cell 0 belongs to cage 1
CellsCageAdress(1) = 1 'cell 1 belongs to cage 1
CellsCageAdress(2) = 2 'cell 2 belongs to cage 2
CellsCageAdress(3) = 3 'cell 3 belongs to cage 3
CellsCageAdress(4) = 4 '...and so on...
CellsCageAdress(5) = 5
CellsCageAdress(6) = 6
CellsCageAdress(7) = 7
CellsCageAdress(8) = 7
CellsCageAdress(9) = 8
CellsCageAdress(10) = 2
CellsCageAdress(11) = 2
CellsCageAdress(12) = 3
CellsCageAdress(13) = 4
CellsCageAdress(14) = 5
CellsCageAdress(15) = 6
CellsCageAdress(16) = 6
CellsCageAdress(17) = 9
CellsCageAdress(18) = 8
CellsCageAdress(19) = 8
CellsCageAdress(20) = 10
CellsCageAdress(21) = 10
CellsCageAdress(22) = 4
CellsCageAdress(23) = 11
CellsCageAdress(24) = 11
CellsCageAdress(25) = 9
CellsCageAdress(26) = 9
CellsCageAdress(27) = 12
CellsCageAdress(28) = 8
CellsCageAdress(29) = 10
CellsCageAdress(30) = 13
CellsCageAdress(31) = 13
CellsCageAdress(32) = 13
CellsCageAdress(33) = 11
CellsCageAdress(34) = 9
CellsCageAdress(35) = 14
CellsCageAdress(36) = 12
CellsCageAdress(37) = 15
CellsCageAdress(38) = 15
CellsCageAdress(39) = 15
CellsCageAdress(40) = 13
CellsCageAdress(41) = 16
CellsCageAdress(42) = 16
CellsCageAdress(43) = 16
CellsCageAdress(44) = 14
CellsCageAdress(45) = 12
CellsCageAdress(46) = 17
CellsCageAdress(47) = 18
CellsCageAdress(48) = 19
CellsCageAdress(49) = 19
CellsCageAdress(50) = 19
CellsCageAdress(51) = 20
CellsCageAdress(52) = 21
CellsCageAdress(53) = 14
CellsCageAdress(54) = 17
CellsCageAdress(55) = 17
CellsCageAdress(56) = 18
CellsCageAdress(57) = 18
CellsCageAdress(58) = 19
CellsCageAdress(59) = 20
CellsCageAdress(60) = 20
CellsCageAdress(61) = 21
CellsCageAdress(62) = 21
CellsCageAdress(63) = 17
CellsCageAdress(64) = 22
CellsCageAdress(65) = 22
CellsCageAdress(66) = 23
CellsCageAdress(67) = 23
CellsCageAdress(68) = 23
CellsCageAdress(69) = 24
CellsCageAdress(70) = 24
CellsCageAdress(71) = 21
CellsCageAdress(72) = 25
CellsCageAdress(73) = 25
CellsCageAdress(74) = 22
CellsCageAdress(75) = 26
CellsCageAdress(76) = 26
CellsCageAdress(77) = 26
CellsCageAdress(78) = 24
CellsCageAdress(79) = 27
CellsCageAdress(80) = 27
ReDim CageSums(1 To CountCages)
CageSums(1) = 10 'sum of cage 1 = 10
CageSums(2) = 14 'sum of cage 2 = 14
CageSums(3) = 9 ' sum of cage 3 = 9
CageSums(4) = 14 '...and so on...
CageSums(5) = 16
CageSums(6) = 9
CageSums(7) = 9
CageSums(8) = 18
CageSums(9) = 27
CageSums(10) = 15
CageSums(11) = 14
CageSums(12) = 14
CageSums(13) = 18
CageSums(14) = 13
CageSums(15) = 12
CageSums(16) = 23
CageSums(17) = 18
CageSums(18) = 15
CageSums(19) = 19
CageSums(20) = 14
CageSums(21) = 19
CageSums(22) = 20
CageSums(23) = 14
CageSums(24) = 12
CageSums(25) = 11
CageSums(26) = 19
CageSums(27) = 9
'set all candidates as available...
For i = 0 To 80
For j = 1 To 9
KillerArray(i, j) = True
Next j, i
'...then remove impossible candidates based on cages...
SetupKillerCandidates
'...and then brute force solve the killer sudoku
If UniqueSud Then Beep
End Sub
'*********************************************************************************
Sub SetupKillerCandidates()
Dim CageNumber As Integer
Dim CageSum As Integer
'counter for number of cells in current cage
Dim NumberOfCageCells As Integer
'adressholders for all cells in current cage
Dim CageCells() As Integer
'available candidates indicators for cells in current cage
Dim CageCellCandidates() As Boolean
'candidate holders for all cells in current cage to combine sums
Dim CageCellCandidate() As Integer
Dim CageCellNumber As Integer 'points to cell under examination
Dim Testable As Boolean 'flag to indicate valid sum combinations
For CageNumber = 1 To CountCages
'get cagesum of current cage
CageSum = CageSums(CageNumber)
'reset counter
NumberOfCageCells = 0
'search cage cells from current cage
For i = 0 To 80
If CellsCageAdress(i) = CageNumber Then 'cell belonging to current cage found
'increase counter
NumberOfCageCells = NumberOfCageCells + 1
'redim arrays and initiate them
ReDim Preserve CageCells(1 To NumberOfCageCells)
CageCells(NumberOfCageCells) = i 'store cell's adress
ReDim CageCellCandidate(1 To NumberOfCageCells)
CageCellCandidate(NumberOfCageCells) = 0
ReDim CageCellCandidates(1 To NumberOfCageCells, 1 To 9)
For j = 1 To 9
CageCellCandidates(NumberOfCageCells, j) = False
Next j
End If
Next i
'make all possible combinations with the candidates from
'the cells belonging to the current cage
CageCellNumber = 1 'start with the first cell
Do Until CageCellNumber = 0 'if 0 then all combinations are tried
'take next candidate for current cell
CageCellCandidate(CageCellNumber) = CageCellCandidate(CageCellNumber) + 1
'check candidate boundery
If CageCellCandidate(CageCellNumber) > 9 Then 'all candidates are tried for this cell
CageCellCandidate(CageCellNumber) = 0 'reset candidate for this cell to 0
CageCellNumber = CageCellNumber - 1 'and move on to previous cell (if any)
Else 'candidate is valid
'check if all cells are re-evaluated
If CageCellNumber = NumberOfCageCells Then 'there is a new combination
'check if any two cells in the cage have the same candidate
Testable = True
For i = 1 To (NumberOfCageCells - 1) 'compare one cell...
For j = (i + 1) To NumberOfCageCells '...with another...
'...if they have the same candidate
If CageCellCandidate(i) = CageCellCandidate(j) Then
'indicate as bad combination
Testable = False
End If
If Not Testable Then Exit For
Next j
If Not Testable Then Exit For
Next i
'if Testable is still true then no contradiction was found,
'so we can make and compare the sum
If Testable Then
'make sum with current candidates
TestSum = 0
For i = 1 To NumberOfCageCells
TestSum = TestSum + CageCellCandidate(i)
Next i
'compare to cagesum
If TestSum = CageSum Then 'sum of candidates matches the cage sum...
'...so indicate those candidates as valid (true)
For i = 1 To NumberOfCageCells
CageCellCandidates(i, CageCellCandidate(i)) = True
Next i
End If
End If
Else 'not all cells are re-evaluated so move on to the next cell
CageCellNumber = CageCellNumber + 1
End If
End If
Loop
'update main array (KillerArray)
For i = 1 To NumberOfCageCells
For j = 1 To 9
If CageCellCandidates(i, j) <> KillerArray(CageCells(i), j) Then _
KillerArray(CageCells(i), j) = False
Next j
Next i
Next CageNumber
End Sub
'*********************************************************************************
Function UniqueSud() As Boolean
Dim UnsolvedCellPtr As Integer 'pointer for incremental solving
Dim Boundary As Integer 'limiter pointer
Dim Cell As Integer
Dim Candidate As Integer
Dim NoCandidates As Boolean
Dim Column As Integer
Dim Row As Integer
Dim BoxTopLeft As Integer
Dim SolutionCount As Integer
UniqueSud = False
'initiate arrays
For Cell = 0 To 80
'erase result array
UniqueSolution(Cell) = 0
'set all candidates as available (or possible)
For Candidate = 1 To 9
CandidateAvailable(Cell, Candidate) = True
Next Candidate
'reset candidate counter
CandidateCount(Cell) = 0
'reset candidate pointer
CandidatePtr(Cell) = 0
Next Cell
'reset unsolved cell pointer
UnsolvedCellPtr = -1
'scan clues and setup arrays
If KillerSudoku Then
For Cell = 0 To 80
'Transfer KillerArray to CandidateAvailable
For Candidate = 1 To 9
CandidateAvailable(Cell, Candidate) = KillerArray(Cell, Candidate)
Next Candidate
UnsolvedCellPtr = UnsolvedCellPtr + 1
UnsolvedCells(UnsolvedCellPtr) = Cell
Next Cell
Else 'this is for regular sudokus
For Cell = 0 To 80
'copy data from clue-array
Solution(Cell) = Sudoku(Cell)
If Sudoku(Cell) > 0 Then
'disable impossible candidates
For Candidate = 1 To 9
CandidateAvailable(Cell, Candidate) = False
Next Candidate
Candidate = Sudoku(Cell)
Column = Cell Mod 9
Row = Int(Cell / 9)
BoxTopLeft = (Int(Row / 3) * 27) + (Int(Column / 3) * 3)
For i = 0 To 8
CandidateAvailable(((i * 9) + Column), Candidate) = False
CandidateAvailable(((Row * 9) + i), Candidate) = False
Next i
For i = 0 To 2
For j = 0 To 2
CandidateAvailable((BoxTopLeft + i + (j * 9)), Candidate) = False
Next j, i
Else
UnsolvedCellPtr = UnsolvedCellPtr + 1
UnsolvedCells(UnsolvedCellPtr) = Cell
End If
Next Cell
End If
'set boundary at last used unsolved cell adressholders index
Boundary = UnsolvedCellPtr
'count and sort candidates for each unsolved cell
For i = 0 To Boundary
'setup list of available candidates
For Candidate = 1 To 9
If CandidateAvailable(UnsolvedCells(i), Candidate) Then
CandidateCount(UnsolvedCells(i)) = CandidateCount(UnsolvedCells(i)) + 1
CandidateList(UnsolvedCells(i), CandidateCount(UnsolvedCells(i))) = Candidate
End If
Next Candidate
If CandidateCount(UnsolvedCells(i)) = 0 Then 'empty cell detected
'inform the user (optional)
MsgBox "This Sudoku has no solution", vbOKOnly, "Invalid Sudoku"
Exit Function
End If
Next i
'BRUTE FORCE SOLVING LOOP
'Try to solve the sudoku by increasing the candidate values of the unsolved cells
'if UnsolvedCellPtr becomes -1, than a solution is found
'reset stepcounter (for the undo function)
Steps = 0
'reset solution counter
SolutionCount = 0
Do While UnsolvedCellPtr < (Boundary + 1)
DoEvents
'check for solution
If UnsolvedCellPtr = -1 Then 'solution found
SolutionCount = SolutionCount + 1
'check if this is a second solution
If SolutionCount = 2 Then Exit Do 'more than one solution, leave the loop
'save solution
For i = 0 To 80
UniqueSolution(i) = Solution(i)
Next i
'increase UnsolvedCellPtr to continue search loop to next solution
UnsolvedCellPtr = UnsolvedCellPtr + 1
End If
Cell = UnsolvedCells(UnsolvedCellPtr)
Select Case CandidatePtr(Cell)
Case 0 'next cell
'search for cell with least candidates
For i = 0 To (UnsolvedCellPtr - 1)
If CandidateCount(UnsolvedCells(i)) < _
CandidateCount(UnsolvedCells(UnsolvedCellPtr)) Then
'swap adresses
dummie = UnsolvedCells(i)
UnsolvedCells(i) = UnsolvedCells(UnsolvedCellPtr)
UnsolvedCells(UnsolvedCellPtr) = dummie
End If
Next i
Cell = UnsolvedCells(UnsolvedCellPtr)
CandidatePtr(Cell) = CandidatePtr(Cell) + 1
Solution(Cell) = CandidateList(Cell, CandidatePtr(Cell))
RemoveCandidates Cell, Solution(Cell), (UnsolvedCellPtr - 1)
'set pointer to next cell
UnsolvedCellPtr = UnsolvedCellPtr - 1
'scan for empty cells
NoCandidates = False
If UnsolvedCellPtr > -1 Then
For i = 0 To UnsolvedCellPtr
If CandidateCount(UnsolvedCells(i)) = 0 Then NoCandidates = True
Next i
End If
'if an empty cell is encountered then reset pointer to current cell
If NoCandidates Then UnsolvedCellPtr = UnsolvedCellPtr + 1
Case CandidateCount(Cell) 'all candidates tried, undo, and go to previous cell
Undo UnsolvedCellPtr
'reset candidate pointer
CandidatePtr(Cell) = 0
UnsolvedCellPtr = UnsolvedCellPtr + 1
Case Else 'try next candidate for current cell
Undo (UnsolvedCellPtr - 1)
CandidatePtr(Cell) = CandidatePtr(Cell) + 1
Solution(Cell) = CandidateList(Cell, CandidatePtr(Cell))
RemoveCandidates Cell, Solution(Cell), (UnsolvedCellPtr - 1)
'set pointer to next cell
UnsolvedCellPtr = UnsolvedCellPtr - 1
'scan for empty cells
NoCandidates = False
If UnsolvedCellPtr > -1 Then
For i = 0 To UnsolvedCellPtr
If CandidateCount(UnsolvedCells(i)) = 0 Then NoCandidates = True
Next i
End If
'if an empty cell is encountered then reset pointer to current cell
If NoCandidates Then UnsolvedCellPtr = UnsolvedCellPtr + 1
End Select
Loop
Select Case SolutionCount
Case 0 'no solution
'inform the user (optional)
MsgBox "This Sudoku has no solution", vbOKOnly, "Invalid Sudoku"
Case 1 'only one solution, set return value
UniqueSud = True
'inform the user (optional)
MsgBox "This Sudoku has one unique solution", vbOKOnly, "Valid Sudoku"
'the unique solution is now in the array UniqueSolution(0 to 80)
Case Else 'more than one solution
'inform the user (optional)
MsgBox "This Sudoku has more than one solution", vbOKOnly, "Invalid Sudoku"
'erase first solution
For i = 0 To 80
UniqueSolution(i) = 0
Next i
End Select
End Function
'*********************************************************************************
Sub RemoveCandidates(Cell As Integer, Candidate As Integer, Ptr As Integer)
Dim Row As Integer
Dim Column As Integer
Dim BoxTopLeft As Integer
'data for killer sudokus
Dim CageNumber As Integer
Dim CageSum As Integer
Dim NumberOfCageCells As Integer 'counter for number of cells in current cage
Dim NumberOfUnsolvedCageCells As Integer 'counter for number of unsolved cells in current cage
Dim CageCells() As Integer 'holds adresses of all cells in current cage
Dim CageCellCandidates() As Boolean 'will indicate available candidates for cells in current cage
Dim CageCandPtr() As Integer 'pointer for available candidates
Dim CageCellCandidate() As Integer 'candidate holders for all cells in current cage to combine sums
Dim CageCellNumber As Integer 'points to cell under examination
Dim Testable As Boolean 'flag to indicate valid sum combinations
Steps = Steps + 1
ReDim Preserve LogCell(1 To Steps)
ReDim Preserve LogCandidate(1 To Steps)
ReDim Preserve LogColumn(1 To Steps)
ReDim Preserve LogRow(1 To Steps)
ReDim Preserve LogBox(1 To Steps)
ReDim Preserve LogCageCandidates(0 To 80, 1 To Steps)
LogCell(Steps) = Cell
LogCandidate(Steps) = Candidate
LogColumn(Steps) = 0
LogRow(Steps) = 0
LogBox(Steps) = 0
For i = 0 To 80
LogCageCandidates(i, Steps) = 0
Next i
Row = Int(Cell / 9)
Column = Cell Mod 9
BoxTopLeft = (Int(Row / 3) * 27) + (Int(Column / 3) * 3)
'remove all "Candidate" in Row, Column and Box from "Cell"
For j = 0 To Ptr
If CandidateAvailable(UnsolvedCells(j), Candidate) Then
If Int(UnsolvedCells(j) / 9) = Row Then
LogRow(Steps) = LogRow(Steps) Or (2 ^ (UnsolvedCells(j) Mod 9))
CandidateAvailable(UnsolvedCells(j), Candidate) = False
CandidateCount(UnsolvedCells(j)) = 0
For i = 1 To 9
If CandidateAvailable(UnsolvedCells(j), i) Then
CandidateCount(UnsolvedCells(j)) = CandidateCount(UnsolvedCells(j)) + 1
CandidateList(UnsolvedCells(j), CandidateCount(UnsolvedCells(j))) = i
End If
Next i
Else
If UnsolvedCells(j) Mod 9 = Column Then
LogColumn(Steps) = LogColumn(Steps) Or (2 ^ Int(UnsolvedCells(j) / 9))
CandidateAvailable(UnsolvedCells(j), Candidate) = False
CandidateCount(UnsolvedCells(j)) = 0
For i = 1 To 9
If CandidateAvailable(UnsolvedCells(j), i) Then
CandidateCount(UnsolvedCells(j)) = CandidateCount(UnsolvedCells(j)) + 1
CandidateList(UnsolvedCells(j), CandidateCount(UnsolvedCells(j))) = i
End If
Next i
Else
If ((Int(UnsolvedCells(j) / 27) * 27) _
+ (Int((UnsolvedCells(j) Mod 9) / 3) * 3)) = BoxTopLeft Then
LogBox(Steps) = LogBox(Steps) Or _
(2 ^ ((Int((UnsolvedCells(j) - BoxTopLeft) / 9) * 3) + _
((UnsolvedCells(j) - BoxTopLeft) Mod 9)))
CandidateAvailable(UnsolvedCells(j), Candidate) = False
CandidateCount(UnsolvedCells(j)) = 0
For i = 1 To 9
If CandidateAvailable(UnsolvedCells(j), i) Then
CandidateCount(UnsolvedCells(j)) = CandidateCount(UnsolvedCells(j)) + 1
CandidateList(UnsolvedCells(j), CandidateCount(UnsolvedCells(j))) = i
End If
Next i
End If
End If
End If
End If
Next j
If KillerSudoku Then 'update cage cell candidates from "Cell's" cage
'get cagenumber
CageNumber = CellsCageAdress(Cell)
'get cagesum of current cage
CageSum = CageSums(CageNumber)
'reset counter for cage cells
NumberOfCageCells = 0
'search cage cells from current cage
For i = 0 To 80
If CellsCageAdress(i) = CageNumber Then 'cell belonging to current cage found
'increase counter
NumberOfCageCells = NumberOfCageCells + 1
'redim arrays and initiate them
ReDim Preserve CageCells(1 To NumberOfCageCells)
CageCells(NumberOfCageCells) = i 'store cell's adress
ReDim CageCandPtr(1 To NumberOfCageCells)
CageCandPtr(NumberOfCageCells) = 0 '
ReDim CageCellCandidate(1 To NumberOfCageCells)
CageCellCandidate(NumberOfCageCells) = 0
ReDim CageCellCandidates(1 To NumberOfCageCells, 1 To 9)
For j = 1 To 9
CageCellCandidates(NumberOfCageCells, j) = False
Next j
End If
Next i
'reset counter for unsolved cage cells
NumberOfUnsolvedCageCells = 0
'check every cell of the current cage...
For i = 1 To NumberOfCageCells
For j = 0 To Ptr
If CageCells(i) = UnsolvedCells(j) Then '...if it is unsolved
'increase unsolved cell counter
NumberOfUnsolvedCageCells = NumberOfUnsolvedCageCells + 1
'swap adresses to list the unsolved cells first and the solved cells last
dummie = CageCells(i)
CageCells(i) = CageCells(NumberOfUnsolvedCageCells)
CageCells(NumberOfUnsolvedCageCells) = dummie
Exit For
End If
Next j
Next i
If NumberOfUnsolvedCageCells = 0 Then Exit Sub 'if no unsolved cells, then exit
'if there are solved cells...
If NumberOfUnsolvedCageCells < NumberOfCageCells Then
'...collect there only candidate from the solution array
For i = (NumberOfUnsolvedCageCells + 1) To NumberOfCageCells
CageCellCandidate(i) = Solution(CageCells(i))
Next i
End If
'make all possible combinations with the candidates from the cells belonging to the current cage
CageCellNumber = 1 'start with the first unsolved cell
Do Until CageCellNumber = 0 'if 0 then all combinations are tried
'increase the candidate pointer for the current unsolved cell
CageCandPtr(CageCellNumber) = CageCandPtr(CageCellNumber) + 1
'check candidate pointer boundery
If CageCandPtr(CageCellNumber) > CandidateCount(CageCells(CageCellNumber)) Then 'all candidates are tried for this cell
CageCandPtr(CageCellNumber) = 0 'reset candidate pointer for this cell to 0
CageCellNumber = CageCellNumber - 1 'and move on to previous unsolved cell (if any)
Else 'candidate pointer is valid
'get candidate from list of candidates
CageCellCandidate(CageCellNumber) = CandidateList(CageCells(CageCellNumber), CageCandPtr(CageCellNumber))
'check if all unsolved cells are re-evaluated
If CageCellNumber = NumberOfUnsolvedCageCells Then 'there is a new combination
'check if any two cells in the cage have the same candidate
Testable = True
For i = 1 To (NumberOfCageCells - 1) 'compare one cell...
For j = (i + 1) To NumberOfCageCells '...with another...
'...if they have the same candidate
If CageCellCandidate(i) = CageCellCandidate(j) Then
'indicate as bad combination
Testable = False
End If
If Not Testable Then Exit For
Next j
If Not Testable Then Exit For
Next i
'if Testable is still true then no contradiction was found, so we can make and compare the sum
If Testable Then
'make sum with current candidates
TestSum = 0
For i = 1 To NumberOfCageCells
TestSum = TestSum + CageCellCandidate(i)
Next i
'compare to cagesum
If TestSum = CageSum Then 'sum of candidates matches the cage sum...
'...so indicate those candidates as valid (true)
For i = 1 To NumberOfUnsolvedCageCells
CageCellCandidates(i, CageCellCandidate(i)) = True
Next i
End If
End If
Else 'not all cells are re-evaluated so move on to the next unsolved cell
CageCellNumber = CageCellNumber + 1
End If
End If
Loop
'update main array (CandidateAvailable)
For i = 1 To NumberOfUnsolvedCageCells
For j = 1 To 9
If CageCellCandidates(i, j) <> CandidateAvailable(CageCells(i), j) Then
'make log for backtracking (Undo)
LogCageCandidates(CageCells(i), Steps) = LogCageCandidates(CageCells(i), Steps) Or (2 ^ j)
CandidateAvailable(CageCells(i), j) = False
CandidateCount(CageCells(i)) = 0
For k = 1 To 9
If CandidateAvailable(CageCells(i), k) Then
CandidateCount(CageCells(i)) = CandidateCount(CageCells(i)) + 1
CandidateList(CageCells(i), CandidateCount(CageCells(i))) = k
End If
Next k
End If
Next j
Next i
End If
End Sub
'*********************************************************************************
Sub Undo(Ptr As Integer)
Dim Row As Integer
Dim Column As Integer
Dim BoxTopLeft As Integer
If KillerSudoku Then
For i = 0 To 80
If LogCageCandidates(i, Steps) > 0 Then
For j = 1 To 9
If (LogCageCandidates(i, Steps) And (2 ^ j)) > 0 Then
CandidateAvailable(i, j) = True
End If
Next j
End If
Next i
End If
Solution(LogCell(Steps)) = 0
Row = Int(LogCell(Steps) / 9)
Column = LogCell(Steps) Mod 9
BoxTopLeft = (Int(Row / 3) * 27) + (Int(Column / 3) * 3)
For i = 0 To 8
If (LogRow(Steps) And (2 ^ i)) Then _
CandidateAvailable((Row * 9) + i, LogCandidate(Steps)) = True
If (LogColumn(Steps) And (2 ^ i)) Then _
CandidateAvailable((i * 9) + Column, LogCandidate(Steps)) = True
Next i
For i = 0 To 2
For j = 0 To 2
If (LogBox(Steps) And (2 ^ ((i * 3) + j))) Then _
CandidateAvailable(BoxTopLeft + (i * 9) + j, LogCandidate(Steps)) = True
Next j, i
Steps = Steps - 1
'count and sort candidates for each unsolved cell
For i = 0 To Ptr
CandidateCount(UnsolvedCells(i)) = 0
For j = 1 To 9
If CandidateAvailable(UnsolvedCells(i), j) Then
CandidateCount(UnsolvedCells(i)) = CandidateCount(UnsolvedCells(i)) + 1
CandidateList(UnsolvedCells(i), CandidateCount(UnsolvedCells(i))) = j
End If
Next j
Next i
End Sub
'*********************************************************************************
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
End
End Sub
|
_________________
Marc
~~~<><~~~<><~~~<><~~~<><~~~
Last edited by Lunatic on Mon May 19, 2008 6:37 pm; edited 1 time in total |
|
| Back to top |
|
|
| Lunatic
| | Joined: 11 Mar 2007 | | Posts: 166 | | : | | Location: Ghent - Belgium |
Items |
|
| Posted: Sun May 18, 2008 6:35 pm Post subject: |
|
|
Sorry, but the copy/paste action with the code above somehow went wrong, it is fixed now
_________________
Marc
~~~<><~~~<><~~~<><~~~<><~~~ |
|
| Back to top |
|
|
| garthd
| | Joined: 29 Apr 2006 | | Posts: 32 | | : | |
Items |
|
| Posted: Mon May 19, 2008 1:32 pm Post subject: |
|
|
| Code: | | Sorry, but the copy/paste action with the code above somehow went wrong, it is fixed now |
Maybe there is still a problem from the copy and paste, as the end of the subroutine 'RemoveCandidates' still doesn't look right...there is a loop without a do, a loop that nests two references to 'For j = 1 To 9' and a hanging 'end if' without a matching if
| Code: | Loop
'update main array (CandidateAvailable)
For i = 1 To NumberOfUnsolvedCageCells
For j = 1 To 9
If CageCellCandidates(i, j) <CandidateAvailable> 0 Then
For j = 1 To 9
If (LogCageCandidates(i, Steps) And (2 ^ j)) > 0 Then
CandidateAvailable(i, j) = True
End If
Next j
End If
Next i
End If |
|
|
| Back to top |
|
|
| hobiwan
| | Joined: 11 Feb 2008 | | Posts: 83 | | : | |
Items |
|
| Posted: Mon May 19, 2008 6:13 pm Post subject: |
|
|
| Seems to be a problem with '<' and '>'. Try "Disable HTML in this post". |
|
| Back to top |
|
|
| Lunatic
| | Joined: 11 Mar 2007 | | Posts: 166 | | : | | Location: Ghent - Belgium |
Items |
|
| Posted: Mon May 19, 2008 7:48 pm Post subject: |
|
|
Should be fixed...again
Tnx for letting me know. 
BTW, on my very old and slow PC (PIII - 800MHz) it takes about 12 MINUTES to solve the example.
I guess the code could be improved, but after all, it's a raw attempt. Especially the cell adresses of every cage can be seperately pre-assembled in some arrays, so it won't be longer needed to collect them each time again in the 'RemoveCandidates' routine. Just checking if Solution(x) is 0 or not, should be enough to distinguish the solved cagecells from the unsolved ones. 
A prescan, based on naked and/or hidden subsets invoked before running the 'UniqueSud' function, can erase some candidates which will reduce the solving time. After all, there is a naked pair at R1C6-R2C6, and a naked triple at R5C6-R5C7-R5C8 after running 'SetupKillerCandidates',
I mean, there is allways room for some logic based candidate eleminations before running brute force. 
_________________
Marc
~~~<><~~~<><~~~<><~~~<><~~~ |
|
| Back to top |
|
|
|
|
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum
|
Powered by phpBB © 2001, 2005 phpBB Group
Igloo Theme Version 1.0 :: Created By: Andrew Charron |
FAQ
Search
Memberlist
Usergroups
Register
Profile
Log in
Log in to check your private messages
