Sudoku Programmers Forum Index

 
 FAQFAQ   SearchSearch   MemberlistMemberlist   UsergroupsUsergroups   RegisterRegister   ProfileProfile   Log inLog in          Games  Calendar

Log in to check your private messagesLog in to check your private messages   

Dancing Links and Visual Basic (with example code)

 
Post new topic   Reply to topic    Sudoku Programmers Forum Index -> Programming sudoku
View previous topic :: View next topic  
Author Message
Lunatic

Joined: 11 Mar 2007
Posts: 166
:
Location: Ghent - Belgium

Items
PostPosted: Sun Apr 15, 2007 12:52 pm    Post subject: Dancing Links and Visual Basic (with example code) Reply with quote

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
View user's profile Send private message Send e-mail Visit poster's website
garthd

Joined: 29 Apr 2006
Posts: 32
:

Items
PostPosted: Mon Apr 16, 2007 7:00 am    Post subject: VB dancing links Reply with quote

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
View user's profile Send private message
tjacob

Joined: 10 Jul 2007
Posts: 3
:

Items
PostPosted: Tue Jul 10, 2007 6:50 pm    Post subject: Reply with quote

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
View user's profile Send private message
Lunatic

Joined: 11 Mar 2007
Posts: 166
:
Location: Ghent - Belgium

Items
PostPosted: Wed Jul 11, 2007 3:50 pm    Post subject: Reply with quote

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
View user's profile Send private message Send e-mail Visit poster's website
garthd

Joined: 29 Apr 2006
Posts: 32
:

Items
PostPosted: Sat Feb 09, 2008 10:57 am    Post subject: Adapting code to solver killer/kakuro puzzles Reply with quote

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
View user's profile Send private message
andreyvul

Joined: 12 Feb 2008
Posts: 7
:

Items
PostPosted: Wed Feb 13, 2008 3:53 am    Post subject: Reply with quote

vb.net has IntPtr datatype if that might help
I have no clue how to use it, though Sad
Back to top
View user's profile Send private message
Jean-Christophe

Joined: 19 Mar 2006
Posts: 126
:
Location: Belgium

Items
PostPosted: Mon Mar 03, 2008 9:09 pm    Post subject: Reply with quote

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
View user's profile Send private message Visit poster's website
Lunatic

Joined: 11 Mar 2007
Posts: 166
:
Location: Ghent - Belgium

Items
PostPosted: Mon Mar 03, 2008 10:36 pm    Post subject: Reply with quote

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 Embarassed . I was a bit surprised to see some new postings related to the alternative DLX4VB (Dancing Links for Visual Basic) topic Surprised .

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
View user's profile Send private message Send e-mail Visit poster's website
Lunatic

Joined: 11 Mar 2007
Posts: 166
:
Location: Ghent - Belgium

Items
PostPosted: Thu May 15, 2008 6:32 pm    Post subject: Reply with quote

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
View user's profile Send private message Send e-mail Visit poster's website
Lunatic

Joined: 11 Mar 2007
Posts: 166
:
Location: Ghent - Belgium

Items
PostPosted: Sun May 18, 2008 6:35 pm    Post subject: Reply with quote

Sorry, but the copy/paste action with the code above somehow went wrong, it is fixed now Embarassed
_________________
Marc
~~~<><~~~<><~~~<><~~~<><~~~
Back to top
View user's profile Send private message Send e-mail Visit poster's website
garthd

Joined: 29 Apr 2006
Posts: 32
:

Items
PostPosted: Mon May 19, 2008 1:32 pm    Post subject: Reply with quote

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
View user's profile Send private message
hobiwan

Joined: 11 Feb 2008
Posts: 83
:

Items
PostPosted: Mon May 19, 2008 6:13 pm    Post subject: Reply with quote

Seems to be a problem with '<' and '>'. Try "Disable HTML in this post".
Back to top
View user's profile Send private message
Lunatic

Joined: 11 Mar 2007
Posts: 166
:
Location: Ghent - Belgium

Items
PostPosted: Mon May 19, 2008 7:48 pm    Post subject: Reply with quote

Should be fixed...again Embarassed Embarassed Embarassed
Tnx for letting me know. Wink

BTW, on my very old and slow PC (PIII - 800MHz) it takes about 12 MINUTES to solve the example. Sad

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. Idea

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. Cool
_________________
Marc
~~~<><~~~<><~~~<><~~~<><~~~
Back to top
View user's profile Send private message Send e-mail Visit poster's website
Display posts from previous:   
Post new topic   Reply to topic    Sudoku Programmers Forum Index -> Programming sudoku All times are GMT
Page 1 of 1

 
Jump to:  
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
Sudoku Programmers topic RSS feed 


Powered by phpBB © 2001, 2005 phpBB Group

Igloo Theme Version 1.0 :: Created By: Andrew Charron