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   

VB Code for Coloring Technique

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

Joined: 04 May 2009
Posts: 36
:

Items
PostPosted: Mon May 04, 2009 9:15 am    Post subject: VB Code for Coloring Technique Reply with quote

Hello

I have built a Solving game in vb net 2008 and have the usual solving algorithms (Naked & Hidden Pairs,Trips,Quads, X Wing, X-Y wing, X-Y-Z Wing and Swordfish).

Thank you to the many contributors to this forum and others. I have enjoyed learning from your work.

The next technique I would like to implement is the Coloring technique, but I'm just stumped on how to even approach this problem. Does anyone have any VB code they would be willing to share with me? I have looked at the Lummox JR C code, but not being a C programmer, it's tough going.

Many thanks for your help
Back to top
View user's profile Send private message
hobiwan

Joined: 11 Feb 2008
Posts: 83
:

Items
PostPosted: Mon May 04, 2009 4:37 pm    Post subject: Reply with quote

The only thing I can offer is Java code that relies heavily on bitmaps.
Back to top
View user's profile Send private message
Lunatic

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

Items
PostPosted: Mon May 04, 2009 7:02 pm    Post subject: Reply with quote

I can offer VB6 code, I'm currently working on it (translating the comments from Dutch to English), be patient...
_________________
Marc
~~~<><~~~<><~~~<><~~~<><~~~
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: Mon May 04, 2009 8:32 pm    Post subject: Reply with quote

Here it comes...
Two functions:
1) SimpleColoring
2) CandidateRemoved (a sub-function used by SimpleColoring)

Some brief comment...
Except for the array CandidateAtCell() all other variables and arrays are local.

The array CandidateAtCell() is a boolean array with two dimensions
The first dimension adresses the candidates (1 to 9)
The second dimension adresses the cells (0 to 80)
Therefore this array is declared as follow:

Dim CandidateAtCell(1 To 9, 0 To 80) As Boolean

This array is allways kept up-to-date through the solving process
If you use another array, or another way of adressing the cells (row, column) and checking available candidates then you will have to change things to meet with your existing code.

The places where candidates are to be removed are marked within two lines with asterisks. I removed the original code, as it surely will not meet your code.

Code:
Function SimpleColoring() As Boolean

Dim SCRow(0 To 8, 1 To 9) As Integer 'counter for each row / each candidate
Dim SCCol(0 To 8, 1 To 9) As Integer 'counter for each col / each candidate
Dim SCBox(0 To 8, 1 To 9) As Integer 'counter for each box / each candidate

Dim RowLink(0 To 8, 1 To 9) As Boolean 'conjugating indicator for each row / each candidate
Dim RowLinkCells(0 To 8, 1 To 9, 1 To 2) As Integer 'adresses conjugating cells for each row / each candidate
Dim ColLink(0 To 8, 1 To 9) As Boolean 'conjugating indicator for each col / each candidate
Dim ColLinkCells(0 To 8, 1 To 9, 1 To 2) As Integer 'adresses conjugating cells for each col / each candidate
Dim BoxLink(0 To 8, 1 To 9) As Boolean 'conjugating indicator for each box / each candidate
Dim BoxLinkCells(0 To 8, 1 To 9, 1 To 2) As Integer 'adresses conjugating cells for each box / each candidate

Dim IsGridLinkCell(0 To 80, 1 To 9) As Boolean 'indicator listed cells for each cell / each candidate
Dim GridLinkCell(0 To 80, 1 To 9) As Integer 'node cell list for each candidate
Dim NumberGridLinkCells(1 To 9) As Integer 'node cell list counter for each candidate
Dim GridLinkCellType(0 To 80, 1 To 9) As Integer 'link type indicator for listed cells / each candidate
'link type values:
' 0 = not linked
' 1 = ODD node in chain 1
' 2 = EVEN node in chain 1
' 3 = ODD node in chain 2
' 4 = EVEN node in chain 2
' 5 = ODD node in chain 3
' 6 = EVEN node in chain 3
' and so on ....

Dim NumberOfChains As Integer 'chain counter
Dim UnchainedCells As Integer 'unchained cell counter
Dim CellChained As Boolean 'flag

Dim CHRow As Integer
Dim CHCol As Integer
Dim CHBox As Integer
Dim CHLB As Integer

'reset return value
SimpleColoring = False

'reset counters
For i = 0 To 8
For j = 1 To 9
    SCRow(i, j) = 0
    SCCol(i, j) = 0
    SCBox(i, j) = 0
Next j, i

'collect info about conjugating cells (strong links) for each candidate
For ii% = 1 To 9 'loop through all candidates
    NumberGridLinkCells(ii%) = -1 'reset node cell list counter
    For i = 0 To 80 'loop through all cells
        IsGridLinkCell(i, ii%) = False 'set cell as not listed
        GridLinkCellType(i, ii%) = 0 'reset link type indicator: 0 = not linked
        'check if current candidate (ii%) is present at current cell (i)
        If CandidateAtCell(ii%, i) Then
            'candidate present
            SCRow(Int(i / 9), ii%) = SCRow(Int(i / 9), ii%) + 1 'increase according row counter
            SCCol(i Mod 9, ii%) = SCCol(i Mod 9, ii%) + 1 'increase according col counter
            SCBox((Int(i / 27) * 3) + Int((i Mod 9) / 3), ii%) = SCBox((Int(i / 27) * 3) + Int((i Mod 9) / 3), ii%) + 1 'increase according box counter
        End If
    Next i
    For i = 0 To 8 'loop through all row/col/box looking for conjugating candidate
        'Inspect row
        'if current candidate appears twice in current row, then set conjugating indicator as true
        If SCRow(i, ii%) = 2 Then RowLink(i, ii%) = True Else RowLink(i, ii%) = False
        'if indicator is true (conjugating pair in current row) then collect adresses from those two cells
        If RowLink(i, ii%) Then
            linkcell = 0 'reset counter for conjugating cells (link cell)
            For j = 0 To 8 'loop through cells in current row
                'check if current candidate is present at current cell
                If CandidateAtCell((i * 9) + j, ii%) Then
                    'candidate present
                    linkcell = linkcell + 1 'increase link cell counter
                    'save current cell adress
                    RowLinkCells(i, ii%, linkcell) = (i * 9) + j
                    'check if current cell is not allready listed as link cell
                    If Not IsGridLinkCell(RowLinkCells(i, ii%, linkcell), ii%) Then
                        'cell is not listed yet, mark cell as listed
                        IsGridLinkCell(RowLinkCells(i, ii%, linkcell), ii%) = True
                        'increase list counter
                        NumberGridLinkCells(ii%) = NumberGridLinkCells(ii%) + 1
                        'place cell number in list
                        GridLinkCell(NumberGridLinkCells(ii%), ii%) = RowLinkCells(i, ii%, linkcell)
                    End If
                End If
            Next j
        End If
        'Inspect column (similar as row)
        If SCCol(i, ii%) = 2 Then ColLink(i, ii%) = True Else ColLink(i, ii%) = False
        If ColLink(i, ii%) Then
            linkcell = 0
            For j = 0 To 8
                If CandidateAtCell((j * 9) + i, ii%) Then
                    linkcell = linkcell + 1
                    ColLinkCells(i, ii%, linkcell) = (j * 9) + i
                    If Not IsGridLinkCell(ColLinkCells(i, ii%, linkcell), ii%) Then
                        IsGridLinkCell(ColLinkCells(i, ii%, linkcell), ii%) = True
                        NumberGridLinkCells(ii%) = NumberGridLinkCells(ii%) + 1
                        GridLinkCell(NumberGridLinkCells(ii%), ii%) = ColLinkCells(i, ii%, linkcell)
                    End If
                End If
            Next j
        End If
        'inspect box (similar as row/column)
        If SCBox(i, ii%) = 2 Then BoxLink(i, ii%) = True Else BoxLink(i, ii%) = False
        If BoxLink(i, ii%) Then
            linkcell = 0
            For j = 0 To 8
                'calculate current cellnumber in box
                boxcell = (Int(i / 3) * 27) + ((i Mod 3) * 3) + (Int(j / 3) * 9) + (j Mod 3)
                If CandidateAtCell(boxcell, ii%) Then
                    linkcell = linkcell + 1
                    BoxLinkCells(i, ii%, linkcell) = boxcell
                    If Not IsGridLinkCell(BoxLinkCells(i, ii%, linkcell), ii%) Then
                        IsGridLinkCell(BoxLinkCells(i, ii%, linkcell), ii%) = True
                        NumberGridLinkCells(ii%) = NumberGridLinkCells(ii%) + 1
                        GridLinkCell(NumberGridLinkCells(ii%), ii%) = BoxLinkCells(i, ii%, linkcell)
                    End If
                End If
            Next j
        End If
    Next i
Next ii%

'at this point, for each candidate:
' - all strong linked (conjugating) cells are collected in the list called GridLinkCell(counter,candidate)
' - NumberGridLinkCells(candidate) indicates the number of cells in that list
' - GridLinkCellType(counter,candidate) is set to 0 (not linked) for all cells listed in GridLinkCell(counter,candidate)

' - RowLink(row,candidate) = true if there is a conjugating pair (strong link) in row, and then
'   RowLinkCells(row,candidate,1) and RowLinkCells(row,candidate,2) are holding the adresses of those two cells

' - ColLink(col,candidate) = true if there is a conjugating pair (strong link) in col, and then
'   ColLinkCells(col,candidate,1) and ColLinkCells(col,candidate,2) are holding the adresses of those two cells

' - BoxLink(box,candidate) = true if there is a conjugating pair (strong link) in box, and then
'   BoxLinkCells(box,candidate,1) and BoxLinkCells(box,candidate,2) are holding the adresses of those two cells


'try making chains
For ii% = 1 To 9 'for each candidate
    'check if there are cells listed for the current candidate
    If NumberGridLinkCells(ii%) <> -1 Then
        'start with first chain
        NumberOfChains = 1 'set chain counter to 1
        'set down-counter for cells to chain
        UnchainedCells = NumberGridLinkCells(ii%)  'number of cells that can be chained
        'set first cell in list as type 1 (= ODD node in chain 1)
        GridLinkCellType(0, ii%) = 1
        'try to chain cells as long as there are unchained cells
        Do While UnchainedCells > 0
            'set flag that no cell is chained in current loop
            CellChained = False
            'loop through all listed cells, except the first cell
            For i = 1 To NumberGridLinkCells(ii%)
                'check if current listed cell is not chained
                If GridLinkCellType(i, ii%) = 0 Then
                    'current listed cell is not chained
                    'get adress of listed cell
                    j = GridLinkCell(i, ii%)
                    'TRY TO CHAIN WITHIN ROW
                    'Calculate row of this cell
                    CHRow = Int(j / 9)
                    'check if this row has a conjugating pair, if so than this cell is part of it
                    If RowLink(CHRow, ii%) Then
                        'is it cell 1 ?
                        If RowLinkCells(CHRow, ii%, 1) = j Then
                            'search in list for cell 2
                            For k = 0 To NumberGridLinkCells(ii%)
                                'check if current cell in list is cell 2, and check if cell 2 is chained
                                If (GridLinkCell(k, ii%) = RowLinkCells(CHRow, ii%, 2)) And (GridLinkCellType(k, ii%) > 0) Then
                                    'cell 2 is found and is allready chained
                                    'check cell 2 link type
                                    If (GridLinkCellType(k, ii%) Mod 2) = 1 Then
                                        'if cell 2 is set as type 1 (= ODD node) then set cell 1 as type 2 (= EVEN node)
                                        GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) + 1
                                    Else
                                        'if cell 2 is set as type 2 (= EVEN node) then set cell 1 as type 1 (= ODD node)
                                        GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) - 1
                                    End If
                                    'set flag that a cell was chained in current loop
                                    CellChained = True
                                    'Decrease number of cells to chain
                                    UnchainedCells = UnchainedCells - 1
                                    'stop searching
                                    Exit For
                                End If
                            Next k
                        Else 'it's not cell 1, must be cell 2
                            'search in list for cell 1 (similar as for cell 2
                            For k = 0 To NumberGridLinkCells(ii%)
                                If (GridLinkCell(k, ii%) = RowLinkCells(CHRow, ii%, 1)) And (GridLinkCellType(k, ii%) > 0) Then
                                    If (GridLinkCellType(k, ii%) Mod 2) = 1 Then
                                        GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) + 1
                                    Else
                                        GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) - 1
                                    End If
                                    CellChained = True
                                    UnchainedCells = UnchainedCells - 1
                                    Exit For
                                End If
                            Next k
                        End If
                    End If
                    'check if cell is still not chained
                    If GridLinkCellType(i, ii%) = 0 Then
                        'TRY TO CHAIN WITHIN COLUMN (similar as ROW)
                        CHCol = j Mod 9
                        If ColLink(CHCol, ii%) Then
                            If ColLinkCells(CHCol, ii%, 1) = j Then
                                For k = 0 To NumberGridLinkCells(ii%)
                                    If (GridLinkCell(k, ii%) = ColLinkCells(CHCol, ii%, 2)) And (GridLinkCellType(k, ii%) > 0) Then
                                        If (GridLinkCellType(k, ii%) Mod 2) = 1 Then
                                            GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) + 1
                                        Else
                                            GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) - 1
                                        End If
                                        CellChained = True
                                        UnchainedCells = UnchainedCells - 1
                                        Exit For
                                    End If
                                Next k
                            Else
                                For k = 0 To NumberGridLinkCells(ii%)
                                    If (GridLinkCell(k, ii%) = ColLinkCells(CHCol, ii%, 1)) And (GridLinkCellType(k, ii%) > 0) Then
                                        If (GridLinkCellType(k, ii%) Mod 2) = 1 Then
                                            GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) + 1
                                        Else
                                            GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) - 1
                                        End If
                                        CellChained = True
                                        UnchainedCells = UnchainedCells - 1
                                        Exit For
                                    End If
                                Next k
                            End If
                        End If
                    End If
                    'check if cell is still not chained
                    If GridLinkCellType(i, ii%) = 0 Then
                        'TRY TO CHAIN WITHIN BOX (similar as ROW/COLUMN)
                        CHBox = (Int(j / 27) * 3) + Int((j Mod 9) / 3)
                        If BoxLink(CHBox, ii%) Then
                            If BoxLinkCells(CHBox, ii%, 1) = j Then
                                For k = 0 To NumberGridLinkCells(ii%)
                                    If (GridLinkCell(k, ii%) = BoxLinkCells(CHBox, ii%, 2)) And (GridLinkCellType(k, ii%) > 0) Then
                                        If (GridLinkCellType(k, ii%) Mod 2) = 1 Then
                                            GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) + 1
                                        Else
                                            GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) - 1
                                        End If
                                        CellChained = True
                                        UnchainedCells = UnchainedCells - 1
                                        Exit For
                                    End If
                                Next k
                            Else
                                For k = 0 To NumberGridLinkCells(ii%)
                                    If (GridLinkCell(k, ii%) = BoxLinkCells(CHBox, ii%, 1)) And (GridLinkCellType(k, ii%) > 0) Then
                                        If (GridLinkCellType(k, ii%) Mod 2) = 1 Then
                                            GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) + 1
                                        Else
                                            GridLinkCellType(i, ii%) = GridLinkCellType(k, ii%) - 1
                                        End If
                                        CellChained = True
                                        UnchainedCells = UnchainedCells - 1
                                        Exit For
                                    End If
                                Next k
                            End If
                        End If
                    End If
                End If
            Next i
            'check if no cell was chained in current loop and there are still cells to chain
            If (Not CellChained) And (UnchainedCells > 0) Then
                'start new chain
                NumberOfChains = NumberOfChains + 1
                'decrease unchained cells
                UnchainedCells = UnchainedCells - 1
                'search through list
                For k = 0 To NumberGridLinkCells(ii%)
                    'check if current listed cell is not chained
                    If GridLinkCellType(k, ii%) = 0 Then
                        'set type as ODD node in current chain
                        GridLinkCellType(k, ii%) = (NumberOfChains * 2) - 1
                        'stop searching
                        Exit For
                    End If
                Next k
            End If
        Loop
        'AT THIS POINT ALL CELLS IN THE LIST ARE CHAINED IN ONE OR MORE CHAINS
        For i = 1 To NumberOfChains 'check all chains, one by one
            'check for any contradiction first
            'for each two cells in the list
            For k = 0 To (NumberGridLinkCells(ii%) - 1) 'first of those two cells
            For l = (k + 1) To NumberGridLinkCells(ii%) 'second of those two cells
                'check type of first of those two cells
                Select Case GridLinkCellType(k, ii%)
                    Case ((i * 2) - 1) 'ODD node in current chain
                        'check if second cell is the same type in same chain
                        If GridLinkCellType(l, ii%) = ((i * 2) - 1) Then 'ODD node in current chain
                            'check if both cells share the same row, column or box
                            If (Int(GridLinkCell(k, ii%) / 9) = Int(GridLinkCell(l, ii%) / 9)) _
                            Or ((GridLinkCell(k, ii%) Mod 9) = (GridLinkCell(l, ii%) Mod 9)) _
                            Or ((Int(GridLinkCell(k, ii%) / 27) * 3) + Int((GridLinkCell(k, ii%) Mod 9) / 3) = (Int(GridLinkCell(l, ii%) / 27) * 3) + Int((GridLinkCell(l, ii%) Mod 9) / 3)) Then
                                'two cells both ODD node in same chain = contradiction
                                'loose candidate ii% in all ODD node cells belonging to that same chain
                                For j = 0 To NumberGridLinkCells(ii%)
                                    If GridLinkCellType(j, ii%) = ((i * 2) - 1) Then
                                        '***************************************************
                                        'REMOVE CANDIDATE ii% FROM CELL GridLinkCell(j, ii%)
                                        '***************************************************
                                    End If
                                Next j
                                'set return value
                                SimpleColoring = True
                                'end function
                                Exit Function
                            End If
                        End If
                    Case (i * 2) 'EVEN node in current chain
                        'check if second cell is the same type in same chain
                        If GridLinkCellType(l, ii%) = (i * 2) Then 'EVEN node in current chain
                            'check if both cells share the same row, column or box
                            If (Int(GridLinkCell(k, ii%) / 9) = Int(GridLinkCell(l, ii%) / 9)) _
                            Or ((GridLinkCell(k, ii%) Mod 9) = (GridLinkCell(l, ii%) Mod 9)) _
                            Or ((Int(GridLinkCell(k, ii%) / 27) * 3) + Int((GridLinkCell(k, ii%) Mod 9) / 3) = (Int(GridLinkCell(l, ii%) / 27) * 3) + Int((GridLinkCell(l, ii%) Mod 9) / 3)) Then
                                'two cells both EVEN node in same chain = contradiction
                                'loose candidate ii% in all EVEN node cells belonging to that same chain
                                For j = 0 To NumberGridLinkCells(ii%)
                                    If GridLinkCellType(j, ii%) = (i * 2) Then
                                        '***************************************************
                                        'REMOVE CANDIDATE ii% FROM CELL GridLinkCell(j, ii%)
                                        '***************************************************
                                    End If
                                Next j
                                'set return value
                                SimpleColoring = True
                                'end function
                                Exit Function
                            End If
                        End If
                End Select
            Next l, k
            'no contradictions found
            'check for removable candidates seen by both an ODD and EVEN node from same chain
            'for each two cells in the list
            For k = 0 To (NumberGridLinkCells(ii%) - 1) 'first of those two cells
            For l = (k + 1) To NumberGridLinkCells(ii%) 'second of those two cells
                'check type of first of those two cells
                Select Case GridLinkCellType(k, ii%)
                    Case ((i * 2) - 1) 'ODD node in current chain
                        'check if second cell is different type in same chain
                        If GridLinkCellType(l, ii%) = (i * 2) Then 'EVEN node in current chain
                            'two different types of node (ODD and EVEN) within the same chain
                            'any cell seen by both these nodes holding candidate ii% will loose candidate ii%
                            'check for cells where candidate ii% can be removed, and remove candidate
                            If CandidateRemoved(GridLinkCell(k, ii%), GridLinkCell(l, ii%), ii%) Then
                                'candidate removal succesful, set return value
                                SimpleColoring = True
                                'end function
                                Exit Function
                            End If
                        End If
                    Case (i * 2) 'EVEN node in current chain
                        'check if second cell is different type in same chain
                        If GridLinkCellType(l, ii%) = ((i * 2) - 1) Then 'ODD node in current chain
                            'two different types of node (ODD and EVEN) within the same chain
                            'any cell seen by both these nodes holding candidate ii% will loose candidate ii%
                            'check for cells where candidate ii% can be removed
                            If CandidateRemoved(GridLinkCell(k, ii%), GridLinkCell(l, ii%), ii%) Then
                                'candidate removal succesful, set return value
                                SimpleColoring = True
                                'end function
                                Exit Function
                            End If
                        End If
                End Select
            Next l, k
        Next i
    End If
Next ii%

End Function


and...

Code:
Function CandidateRemoved(Cell1 As Integer, Cell2 As Integer, Candidate As Integer) As Boolean

Dim Row1 As Integer
Dim Row2 As Integer
Dim Col1 As Integer
Dim Col2 As Integer
Dim Box1 As Integer
Dim Box2 As Integer

Dim Cell As Integer
Dim CellStatus(0 To 80) As Integer
'CellStatus values:
' 0 = not seen by neither Cell1 or Cell2
' 1 = seen by either Cell1 or Cell2
' 2 = seen by both Cell1 and Cell2

'clear return value
CandidateRemoved = False

'clear cell status
For i = 0 To 80
    CellStatus(i) = 0
Next i

'calculate row, col and box from Cell1
Row1 = Int(Cell1 / 9)
Col1 = Cell1 Mod 9
Box1 = (Int(Cell1 / 27) * 27) + (Int((Cell1 Mod 9) / 3) * 3)

'increase status for all cells seen by Cell1
For i = 0 To 8
    'in same row
    Cell = (Row1 * 9) + i
    If CellStatus(Cell) = 0 Then CellStatus(Cell) = 1
    'in same col
    Cell = (i * 9) + Col1
    If CellStatus(Cell) = 0 Then CellStatus(Cell) = 1
Next i
For i = 0 To 2
For j = 0 To 2
    'in same box
    Cell = Box1 + (i * 9) + j
    If CellStatus(Cell) = 0 Then CellStatus(Cell) = 1
Next j, i

'calculate row, col and box from Cell2
Row2 = Int(Cell2 / 9)
Col2 = Cell2 Mod 9
Box2 = (Int(Cell2 / 27) * 27) + (Int((Cell2 Mod 9) / 3) * 3)

'increase status for all cells seen by Cell2
For i = 0 To 8
    'in same row
    Cell = (Row2 * 9) + i
    If CellStatus(Cell) = 1 Then CellStatus(Cell) = 2
    'in same col
    Cell = (i * 9) + Col2
    If CellStatus(Cell) = 1 Then CellStatus(Cell) = 2
Next i
For i = 0 To 2
For j = 0 To 2
    'in same box
    Cell = Box2 + (i * 9) + j
    If CellStatus(Cell) = 1 Then CellStatus(Cell) = 2
Next j, i

'check all cells
For i = 0 To 80
    'for any cell with status = 2 (except Cell1 and Cell2)
    If CellStatus(i) = 2 And i <> Cell1 And i <> Cell2 Then
        'check if candidate is present
        If CandidateAtCell(Candidate, i) Then
            '***************************************
            'REMOVE CANDIDATE Candidate FROM CELL i
            '***************************************
            'set return value
            CandidateRemoved = True
        End If
    End If
Next i

End Function


Succes.
_________________
Marc
~~~<><~~~<><~~~<><~~~<><~~~
Back to top
View user's profile Send private message Send e-mail Visit poster's website
Puzzler

Joined: 04 May 2009
Posts: 36
:

Items
PostPosted: Mon May 04, 2009 10:36 pm    Post subject: Thanks! Reply with quote

This will help me tremendously!

I'll review the code so can make the translations into my program.

Having at least some sense of how to tackle the problem is invaluable

Thank you very much!
Back to top
View user's profile Send private message
daj95376

Joined: 05 Feb 2006
Posts: 349
:

Items
PostPosted: Tue May 05, 2009 4:57 pm    Post subject: Reply with quote

1) Take a candidate grid and fill a Strong Links list from it.

Code:
 +-----------------------------------+
 |  .  .  7  |  .  .  .  |  7  .  .  |
 |  .  .  7  |  .  .  7  |  .  .  7  |
 |  .  .  .  |  .  7  .  |  7  .  .  |
 |-----------+-----------+-----------|
 |  .  .  .  |  .  7  7  |  7  .  .  |
 |  7  .  .  |  .  .  .  |  .  .  .  |
 |  .  .  .  |  .  7  .  |  .  7  7  |
 |-----------+-----------+-----------|
 |  .  .  .  |  7  .  .  |  .  7  .  |
 |  .  .  .  |  7  .  .  |  7  7  .  |
 |  .  7  .  |  .  .  .  |  .  .  .  |
 +-----------------------------------+

          Strong Links
 -------------------------------
         [r1c3] : [r1c7]
         [r1c3] : [r2c3]
         [r2c6] : [r3c5]
         [r2c6] : [r4c6]
         [r2c9] : [r6c9]
         [r3c5] : [r3c7]
         [r7c4] : [r7c8]
         [r7c4] : [r8c4]

2) Terminate checking this candidate when the Strong Links list is empty. Otherwise, clear a Colors list and move the first entry from the Strong Links list to it and initialize coloring.

Code:
          Strong Links                          Colors
 -------------------------------   -------------------------------
         [r1c3] : [r2c3]           Blue    [r1c3] : [r1c7]   Green
         [r2c6] : [r3c5]
         [r2c6] : [r4c6]
         [r2c9] : [r6c9]
         [r3c5] : [r3c7]
         [r7c4] : [r7c8]
         [r7c4] : [r8c4]

3) Repeatedly move entries from the Strong Links list to the Colors list until no cells in the Colors list appear in the Strong Links list.

Code:
          Strong Links                          Colors
 -------------------------------   -------------------------------
         [r2c6] : [r3c5]           Blue    [r1c3] : [r1c7]   Green
         [r2c6] : [r4c6]                   [r1c3] : [r2c3]
         [r2c9] : [r6c9]
         [r3c5] : [r3c7]
         [r7c4] : [r7c8]
         [r7c4] : [r8c4]

4) Iteratively color all cells in the Colors list based on coloring already assigned. Once a color is assigned to a cell, you're done with coloring that cell.

Code:
          Strong Links                          Colors
 -------------------------------   -------------------------------
         [r2c6] : [r3c5]           Blue    [r1c3] : [r1c7]   Green
         [r2c6] : [r4c6]           Blue    [r1c3] : [r2c3]   Green
         [r2c9] : [r6c9]
         [r3c5] : [r3c7]
         [r7c4] : [r7c8]
         [r7c4] : [r8c4]

5) Check to see if any two cells with the same color see each other. If so, then you have a contradiction and can eliminate the candidate from the cells with this color. Terminate checking this candidate after you perform eliminations.

6) Any uncolored cells that see a Blue cell and a Green cell can be eliminated. Terminate checking this candidate after you perform eliminations.

There is another check that can be performed for Colors, but it's not been used in any solutions that I've seen since Angus Johnson mentioned it a long time ago. I will include it for completeness.

7) If a house/unit has only uncolored candidate cells, check to see if these cells are seen by cells with the same color. If so, then the candidate can be eliminated in the cells with that color. Terminate checking this candidate after you perform eliminations.

Return to (2) if no eliminations performed.

=====

(2)+(3)+(4): Performed on Strong Links list remaining from above.

Code:
          Strong Links                          Colors
 -------------------------------   -------------------------------
         [r2c9] : [r6c9]           Blue    [r2c6] : [r3c5]   Green
         [r7c4] : [r7c8]           Blue    [r2c6] : [r4c6]   Green
         [r7c4] : [r8c4]           Green   [r3c5] : [r3c7]   Blue

(5): No contradiction detected.

(6): Uncolored candidate cell [r4c7] sees Green cell [r4c6] and Blue cell [r3c7]. Elimination [r4c7]<>7 is performed. No other uncolored candidate cells qualify. Terminate checking for Colors on this candidate (for now).


Last edited by daj95376 on Wed May 06, 2009 5:40 pm; edited 1 time in total
Back to top
View user's profile Send private message
hobiwan

Joined: 11 Feb 2008
Posts: 83
:

Items
PostPosted: Wed May 06, 2009 5:22 am    Post subject: Reply with quote

daj95376 wrote:
7) If a house/unit has any uncolored candidate cells, check to see if these cells are seen by cells with the same color. If so, then the candidate can be eliminated in the cells with that color.

Interesting! I never thought about that. I presume I have to read it as "If a house has only uncolored candidate cells"?
Back to top
View user's profile Send private message
Draco

Joined: 27 Jun 2008
Posts: 3
:

Items
PostPosted: Wed May 06, 2009 6:40 am    Post subject: Reply with quote

hobiwan wrote:
daj95376 wrote:
7) If a house/unit has any uncolored candidate cells, check to see if these cells are seen by cells with the same color. If so, then the candidate can be eliminated in the cells with that color.

Interesting! I never thought about that. I presume I have to read it as "If a house has only uncolored candidate cells"?

I am trying to grok this. For illustrative purposes (and brevity) let's pick a digit: 4. Let's also pick a house: b4, and say all of b4's 4's are all uncolored, does that mean:

(a) If any colored 4 intersects with a 4 in b4 then that color is invalid? OR
(b) If two cells with 4's of the same color intersect with a 4 in b4, that color is invalid?

... or something else entirely? If it helps, here's a grid with colored 4's in b2 and nowhere else. They intersect with 4's in b1 and b3:
Code:
1258 6    248  | 38  14  9    | 348 7   245
3    478  2478 | 78  5   6    | 489 289 1 
1578 1478 9    | 378 14  2    | 6   38  45
---------------+--------------+------------
4    5    1    | 9   368 38   | 78  28  267
68   2    3    | 4   7   5    | 89  1   69
678  9    78   | 2   68  1    | 5   4   3 
---------------+--------------+------------
178  1478 5    | 6   389 3478 | 2   39  479
9    47   6    | 1   2   347  | 347 5   8 
278  3    2478 | 5   89  478  | 1   6   479


Thx...

- drac
Back to top
View user's profile Send private message
hobiwan

Joined: 11 Feb 2008
Posts: 83
:

Items
PostPosted: Wed May 06, 2009 8:43 am    Post subject: Reply with quote

Draco,
I think I got that wrong in my post above. The principle behind coloring is of course that all candidates with color 1 or all candidates with color 2 have to be true. That said we get three cases:
    1. A house contains two candidates with opposite colors plus uncolored candidates: None of the uncolored candidates can be true (special variant of daj's case 6).
    2. A house contains one candidate with color 1 plus uncolored candidates, that all see candidates with color 2: All candidates with color 2 have to be false.
    3. A house contains uncolored candidates only that all see candidates with the same color: that color has to be false

My cases 2 and 3 correspond to daj's case (7) (with "any" and not with "only"), provided that my case 1 has already been checked.

Prove: One of the candidates in the house has to be true. If all are uncolored and see color 2 each, one instance of color 2 has to be false, thus all must be false. If one candidate with color 1 is in the house as well, either that candidate is true, then all candidates with color 2 are false, or it is false then we have the same case as above.

Your cases (a) and (b) are invalid IMO: All uncolored cells of a house have to see candidates with the same color.
Back to top
View user's profile Send private message
daj95376

Joined: 05 Feb 2006
Posts: 349
:

Items
PostPosted: Wed May 06, 2009 4:45 pm    Post subject: Reply with quote

hobiwan wrote:
daj95376 wrote:
7) If a house/unit has any uncolored candidate cells, check to see if these cells are seen by cells with the same color. If so, then the candidate can be eliminated in the cells with that color.

Interesting! I never thought about that. I presume I have to read it as "If a house has only uncolored candidate cells"?

Yes, I extended the concept too far by allowing colored cells in the house/unit.

Angus Johnson post
Back to top
View user's profile Send private message
Puzzler

Joined: 04 May 2009
Posts: 36
:

Items
PostPosted: Wed May 06, 2009 9:07 pm    Post subject: Almost there! Reply with quote

I have most of the coding done but I'm experiencing frustration with the coloring cycle.

It seems that the collision chains work sometimes but not others and I think it has to do with the starting color for broken chains.

I implemented the code as a linked list, and maybe that was my first mistake.

I've written about 6 billion lines of code, when I think a smarter programmer could do it in three lines of code, two of which are comments.

If anyone has the time to be a second pair of eyes for me, this is the code:

My object definition is:

Code:
 

Public Class clsCellChainLink
        Inherits clsCellAddress
        Public Color As Integer = -1
        Public Candidates As String
        Public ConjugateRowLink As clsCellChainLink
        Public ConjugateColLink As clsCellChainLink
        Public ConjugateBoxLink As clsCellChainLink
        Public Sub New(ByVal intRowNbr As Integer, ByVal inColNbr As Integer)
            MyBase.New(intRowNbr, inColNbr)
        End Sub
        Public Overloads Shared Operator <>(ByVal theCell As clsCellChainLink, ByVal theCompareCell As clsCellChainLink) As Boolean
            If theCell.RowNbr = theCompareCell.RowNbr And theCell.ColNbr = theCompareCell.ColNbr Then
                Return False
            Else
                Return True
            End If
        End Operator
        Public Overloads Shared Operator =(ByVal theCell As clsCellChainLink, ByVal theCompareCell As clsCellChainLink) As Boolean
            If theCell.RowNbr = theCompareCell.RowNbr And theCell.ColNbr = theCompareCell.ColNbr Then
                Return True
            Else
                Return False
            End If
        End Operator

    End Class



In my main routine I populate the cell chain and correctly assign the strong links to each object. So far, so good

Here's the main routine:

Code:

    Public Function SimpleColoring() As List(Of clsHintProfile)

        Dim HintProfiles As List(Of clsHintProfile)
        Dim ChainLinks As New List(Of clsCellChainLink)
        Dim ChainLink As clsCellChainLink
        Dim theCandidate As Integer

        InitializeSearchArrays()

        For intCandidate As Integer = 1 To 9

            ChainLinks = New List(Of clsCellChainLink)

            theCandidate = intCandidate

            'Get a list of all cells in the Grid that have 2 or 3 candidates and that contain the candidate
            Dim AllCells = From clsCell In MyGrid.Grid _
                           Select clsCell Where clsCell.CandidateList.contains(theCandidate) And _
                           (clsCell.CandidateList.Count = 2 Or clsCell.CandidateList.Count = 3)

            For Each Cell As clsCell In AllCells
                ChainLink = New clsCellChainLink(Cell.RowNbr, Cell.ColNbr)
                ChainLink.Candidates = Cell.CandidateList_ToString
                ChainLinks.Add(ChainLink)
            Next Cell

            'Set up the pointers between the strong links
            'Row conjugates
            For Each ChainLink In ChainLinks
                If ChainLink.ConjugateRowLink Is Nothing Then
                    'If there are two occurances of the candidate in the row, the cell is conjugating
                    If CountRowOccurances(ChainLink.RowNbr, intCandidate) = 2 Then
                        ChainLink.ConjugateRowLink = GetNextChainLink(ChainLinks, RANGE_ROW, ChainLink, intCandidate)
                        'Set the reciprocal pointer in the conjugating cell
                        If ChainLink.ConjugateRowLink IsNot Nothing Then
                            ChainLink.ConjugateRowLink.ConjugateRowLink = ChainLink
                        End If
                    End If
                End If

                'Column conjugates
                If ChainLink.ConjugateColLink Is Nothing Then
                    'If there are two occurances of the candidate in the col, the cell is conjugating
                    If CountColOccurances(ChainLink.ColNbr, intCandidate) = 2 Then
                        ChainLink.ConjugateColLink = GetNextChainLink(ChainLinks, RANGE_COL, ChainLink, intCandidate)
                        'Set the reciprocal pointer in the conjugating cell
                        If ChainLink.ConjugateColLink IsNot Nothing Then
                            ChainLink.ConjugateColLink.ConjugateColLink = ChainLink
                        End If
                    End If
                End If

                'Box conjugates
                If ChainLink.ConjugateBoxLink Is Nothing Then
                    'If there are two occurances of the candidate in the col, the cell is conjugating
                    ChainLink.ConjugateBoxLink = GetNextChainLink(ChainLinks, RANGE_BOX, ChainLink, intCandidate)
                    'Set the reciprocal pointer in the conjugating cell
                    If ChainLink.ConjugateBoxLink IsNot Nothing Then
                        ChainLink.ConjugateBoxLink.ConjugateBoxLink = ChainLink
                    End If
                End If

            Next ChainLink

            'remove the links that don't form part of any chain
            For i As Integer = ChainLinks.Count - 1 To 0 Step -1
                If ChainLinks(i).ConjugateRowLink Is Nothing And _
                   ChainLinks(i).ConjugateColLink Is Nothing Then
                    ChainLinks.RemoveAt(i)
                End If
            Next i

            ChainLinks = ColorChain(ChainLinks)

            'look for contradictions/collisions
            HintProfiles = GetCollidingCellsHintProfiles(ChainLinks, intCandidate)
            If HintProfiles IsNot Nothing Then
                Return HintProfiles
            End If

            'look for Trapped Cells
            HintProfiles = GetTrappedCellsHintProfiles(ChainLinks, intCandidate)
            If HintProfiles IsNot Nothing Then
                Return HintProfiles
            End If

         Next intCandidate

        Return Nothing

    End Function


The line that starts the coloring process is:

Code:

            ChainLinks = ColorChain(ChainLinks)


which looks like this:

Code:


Private Function ColorChain(ByVal theChain As List(Of clsCellChainLink)) As List(Of clsCellChainLink)

        'color the cells in the chain

        Dim LinksLeftToColor = From clsCellChainLink In theChain Select clsCellChainLink _
                          Where clsCellChainLink.Color = UNCOLORED

        Dim StartColor As Integer

        Do While LinksLeftToColor.Count > 0

            For Each Link As clsCellChainLink In theChain
                If Link.Color = UNCOLORED Then
                    StartColor = GetStartingCellColor(theChain, Link)
                    ColorCell(theChain, Link, StartColor)
                End If
            Next

        Loop

        Return theChain

    End Function


The routine "ColorCell" is a recursive routine that walks the list, flip-flopping it's way along until it comes to the end of a chain :

Code:

Private Function ColorCell(ByVal theChain As List(Of clsCellChainLink), ByVal theCell As clsCellChainLink, ByVal theCellColor As Integer) As clsCellChainLink

        'Recursively walk the cell chain
        Dim theReciprocalColor As Integer

        If theCellColor = GREEN Then
            theReciprocalColor = BLUE
        ElseIf theCellColor = BLUE Then
            theReciprocalColor = GREEN
        End If

        If theCell.Color = UNCOLORED Then
            theCell.Color = theCellColor
            'if the reciprocal row link is already colored, ignore it
            If theCell.ConjugateRowLink IsNot Nothing Then
                If theCell.ConjugateRowLink.Color = UNCOLORED Then
                    ColorCell(theChain, theCell.ConjugateRowLink, theReciprocalColor)
                End If
            End If

            If theCell.ConjugateColLink IsNot Nothing Then
                If theCell.ConjugateColLink.Color = UNCOLORED Then
                    ColorCell(theChain, theCell.ConjugateColLink, theReciprocalColor)
                End If
            End If

            If theCell.ConjugateBoxLink IsNot Nothing Then
                If theCell.ConjugateBoxLink.Color = UNCOLORED Then
                    If theChain.Contains(theCell.ConjugateBoxLink) Then
                        ColorCell(theChain, theCell.ConjugateBoxLink, theReciprocalColor)
                    End If
                End If
            End If
        Else
            If theCell.ConjugateBoxLink IsNot Nothing Then
                'if the ConjugateBoxLink cell is not in the chain, ignore it
                If theChain.Contains(theCell.ConjugateBoxLink) Then
                    If theCell.ConjugateBoxLink.Color = UNCOLORED Then
                        ColorCell(theChain, theCell.ConjugateBoxLink, theReciprocalColor)
                    End If
                End If
            End If
        End If
        Return theCell

    End Function


I try to find the starting color for each new chain through the "GetStartingColor" routine

Code:


    Private Function GetStartingCellColor(ByVal theChain As List(Of clsCellChainLink), ByVal theCell As clsCellChainLink) As Integer

        Dim RecipBox As Integer
        Dim StartingColor As Integer
        Dim RecipColor As Integer

        Dim BlueBoxCells = From clsCellChainLink In theChain Select clsCellChainLink _
                          Where clsCellChainLink.BoxNbr = theCell.BoxNbr And _
                          clsCellChainLink.Color = BLUE
        Dim GreenBoxCells = From clsCellChainLink In theChain Select clsCellChainLink _
                          Where clsCellChainLink.BoxNbr = theCell.BoxNbr And _
                          clsCellChainLink.Color = GREEN


        Dim RecipBlueBoxCells = From clsCellChainLink In theChain Select clsCellChainLink _
                        Where clsCellChainLink.BoxNbr = RecipBox And _
                        clsCellChainLink.Color = BLUE
        Dim RecipGreenBoxCells = From clsCellChainLink In theChain Select clsCellChainLink _
                          Where clsCellChainLink.BoxNbr = RecipBox And _
                          clsCellChainLink.Color = GREEN

        If BlueBoxCells.Count > 0 Then
            StartingColor = GREEN
        ElseIf GreenBoxCells.Count > 0 Then
            StartingColor = BLUE
        Else
            StartingColor = BLUE
        End If

        If theCell.ConjugateRowLink IsNot Nothing Then
            RecipBox = theCell.ConjugateRowLink.BoxNbr
        ElseIf theCell.ConjugateColLink IsNot Nothing Then
            RecipBox = theCell.ConjugateColLink.BoxNbr
        ElseIf theCell.ConjugateBoxLink IsNot Nothing Then
            RecipBox = theCell.ConjugateBoxLink.BoxNbr
        Else
            Return StartingColor
        End If

        If RecipBlueBoxCells.Count > 0 Then
            RecipColor = GREEN
        ElseIf RecipGreenBoxCells.Count > 0 Then
            RecipColor = BLUE
        Else
            RecipColor = BLUE
        End If

        'We've established the color of the cell, but we have to make sure that it's recipcrocal has not already been set
        'to a colliding color
        GetNewCellColors(StartingColor, RecipColor, StartingColor, RecipColor)

        Return StartingColor
    End Function



and

Code:


    Private Sub GetNewCellColors(ByVal theBoxColor As Integer, ByVal theRecipColor As Integer, _
                                 ByRef theNewCellColor As Integer, ByRef theNewRecipCellColor As Integer)

        'Establish the color of the cells we're inserting based on the following truth table
        'BoxColor   RecipColor   Box Result                   Recip Result
        'None       None       Blue                       Green
        'None       Blue       Blue                       Green
        'None       Green       Green                       Blue
        'None       Purple       Blue                       collision - make Green
        'Blue       None       Green                       Blue
        'Blue       Blue       Green                       collision - make blue
        'Blue       Green       Green                       Blue
        'Blue       Purple       Green                       collision - make blue
        'Green       None       Blue                       Green
        'Green       Blue       Blue                       Green
        'Green       Green       Blue                       collision - make Green
        'Green       Purple       Blue                       collision - make Green
        'Purple       None       collision - make Blue       Green
        'Purple       Blue       collision - make Blue       Green
        'Purple       Green       collision - make Green       Blue
        'Purple       Purple       collision - make Blue       collision - make Green


        'None       None       Blue                       Green
        If theBoxColor = UNCOLORED And theRecipColor = UNCOLORED Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
            'None       Blue       Blue                       Green
        ElseIf theBoxColor = UNCOLORED And theRecipColor = BLUE Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
            'None       Green       Green                       Blue
        ElseIf theBoxColor = UNCOLORED And theRecipColor = GREEN Then
            theNewCellColor = GREEN
            theNewRecipCellColor = BLUE
            'None       Purple       Blue                       collision - make Green
        ElseIf theBoxColor = UNCOLORED And theRecipColor = PURPLE Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
            'Blue       None       Green                       Blue
        ElseIf theBoxColor = BLUE And theRecipColor = UNCOLORED Then
            theNewCellColor = GREEN
            theNewRecipCellColor = BLUE
            'Blue       Blue       Green                       collision - make blue
        ElseIf theBoxColor = BLUE And theRecipColor = BLUE Then
            theNewCellColor = GREEN
            theNewRecipCellColor = BLUE
            'Blue       Green       Green                       Blue
        ElseIf theBoxColor = BLUE And theRecipColor = GREEN Then
            theNewCellColor = GREEN
            theNewRecipCellColor = BLUE
            'Blue       Purple       Green                       collision - make blue
        ElseIf theBoxColor = BLUE And theRecipColor = PURPLE Then
            theNewCellColor = GREEN
            theNewRecipCellColor = BLUE
            'Green       None       Blue                       Green
        ElseIf theBoxColor = GREEN And theRecipColor = UNCOLORED Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
            'Green       Blue       Blue                       Green
        ElseIf theBoxColor = GREEN And theRecipColor = BLUE Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
            'Green       Green       Blue                       collision - make Green
        ElseIf theBoxColor = GREEN And theRecipColor = GREEN Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
            'Green       Purple       Blue                       collision - make Green
        ElseIf theBoxColor = GREEN And theRecipColor = PURPLE Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
            'Purple       None       collision - make Blue       Green
        ElseIf theBoxColor = PURPLE And theRecipColor = UNCOLORED Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
            'Purple       Blue       collision - make Blue       Green
        ElseIf theBoxColor = PURPLE And theRecipColor = BLUE Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
            'Purple       Green       collision - make Green       Blue
        ElseIf theBoxColor = PURPLE And theRecipColor = GREEN Then
            theNewCellColor = GREEN
            theNewRecipCellColor = BLUE
            'Purple       Purple       collision - make Blue       collision - make Green
        ElseIf theBoxColor = PURPLE And theRecipColor = PURPLE Then
            theNewCellColor = BLUE
            theNewRecipCellColor = GREEN
        End If

    End Sub



This code works some of the time, but not all of the time, depending on the configuration of the cells to be colored.

Very frustrating! I think I've looked at the code too closely and aren't see in the problem anymore, or I just need to scrap it and start over. Grr!

Any help much appreciated!
Back to top
View user's profile Send private message
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