Attribute VB_Name = "sudoku"

Option Explicit
Sub Notes()

'--------------------------------------------------------------------------------------------------
'    The code presented here performs the following sudoku tasks:
'       (Puzzles as assumed to be in the 81 character string format)
'
'              Checks that a puzzle is solvable (has at least one solution)
'                             see Function PuzzleIsSolvable() boolean
'              Checks that a puzzle has only one unique solution
'                            see Function PuzzleHasMultipleSolutions() boolean
'              Randomly creates a new solution (2 different algorithms)
'                             see Function CreateSolution()    returns 81 character string
'                             see Function CreateSolution2()   returns 81 character string
'              Randomly creates a new puzzle
'                             see function CreatePuzzleFromSolution()
'
'
'     Variables:
'
'            Row and Col, integers 1-9
'            Cell(row,col) Integer,  0 for unsolved cell, 1-9 for solved cells
'            Locked(row,col) Boolean   Indicates location of 'givens'
'            Poss(row,col)   9 digit string,  possible candidates for a cell "123456789"
'
'
'
'                     by John Musgrave
'                     jumpindoc@gmail.com
'
'              www.manifestmaster.com/jetsudoku
'                 Written in Visual Basic 6.0
'
'--------------------------------------------------------------------------------------------------

End Sub
Function PuzzleIsValid(puzzle As String, Solution As String) As Boolean
'PuzzleIsValid is true when puzzle is solvable and has one unique solution

Dim Solution2 As String  'not returned

'puzzle must be an 81 character string of numbers
If PuzzleHasMultipleSolutions(puzzle, Solution, Solution2) Then
      'puzzle is solvable but has multiple solutions
      'return false and return Solution (first solution)
    Else
      'not multisolution, possibly unsolvable so check Solution
      'if valid then solution will be an 81 character string of numbers (all non zero)
      If Len(Solution) = 81 Then
        'solvable and 1 solution
        PuzzleIsValid = True
       Else
        'puzzle not solvable - leave solution blank (tells calling subroutine that puzzle is insolvable)
      End If
End If

End Function

Function CreateNewPuzzle(PairsOnly As Boolean) As String

'can take anywhere from a few seconds to 30 seconds or more

'when PairsOnly is true, puzzle will be symmetrical, creating will be faster, puzzle will be less difficult

Dim puzzle As String

'create unique solution
puzzle = CreateSolution

'create puzzle
'Call CreatePuzzleFromSolution(puzzle)
Call CreatePuzzleFromSolutionByPairs(puzzle, PairsOnly)

CreateNewPuzzle = puzzle

End Function
Function CreateSolution2() As String

'--------------------------------------------------------------------------------------------------
' Create a new, randomly generated 81 digit string. (a solved puzzle)
'
'This algorithm is different than Function CreateSolution() in this way:
'
'   1).   The number 1 is placed randomly in each box, checking for conflicts
'   2).   This process is repeated for numbers 2 thru 9
'
' This algorithm will encounter a dead end > 99% of the time
' However, because it is more efficient than Function CreateSolution()
'   (ie. it doesn't search for naked/hidden singles) Function CreateSolution()
' it will return a new solution more quickly than
'
'--------------------------------------------------------------------------------------------------

Dim Cell(9, 9) As Integer     'stores the value (1-9) for each cell.  Cell(row,column) = 0 for unsolved cells
Dim poss(9, 9) As String      'stores a 9 digit string of all possible candidates for a cell. All cells start with poss() value "123456789"    Poss(row,col) = "" for solved cells
Dim locked(9, 9) As Boolean   'givens are locked (not applicable in this function)

Dim BoxRow() As Integer
Dim BoxCol() As Integer

Dim row As Integer
Dim col As Integer
Dim Digit  As Integer

Dim DeadEndCounter  As Integer
Dim DeadEnd  As Boolean
Dim box As Integer
Dim z As Integer

Dim counter As Integer

Dim r1 As Integer
Dim c1 As Integer

Do
    DeadEnd = False
    
    Call ClearCells(Cell(), locked(), poss())
    
    For Digit = 1 To 9
        For box = 1 To 9
                
            ReDim BoxRow(9)
            ReDim BoxCol(9)

            counter = 0
            Call GetBoxInit(box, r1, c1)
                'look at each cell in box.  Make sure cell() is zero (available) and has no conflicts in other rows/columns
                For row = r1 To r1 + 2
                    For col = c1 To c1 + 2
                        If RowHasNumber(row, col, Digit, Cell()) = False Then
                            If ColumnHasNumber(row, col, Digit, Cell()) = False Then
                                'make sure cell is available (could have other digit in it)
                                'increment counter if cell is ok and save cell in BoxRow() BoxCol() arrays
                                If Cell(row, col) = 0 Then
                                    counter = counter + 1
                                    BoxRow(counter) = row
                                    BoxCol(counter) = col
                                End If
                            End If
                        End If
                    Next col
                Next row
                       
                    If counter <> 0 Then
                        'counter = number available cells in box
                        'place digit randomly in available cell of box
                        'randomly pick from array
                        z = GetRandomNumber(counter)
                        
                        'assign digit to cell
                        Cell(BoxRow(z), BoxCol(z)) = Digit
                        
                       Else
                        DeadEnd = True
                        DeadEndCounter = DeadEndCounter + 1
                    End If
                    If DeadEnd Then Exit For
                If DeadEnd Then Exit For
        Next box
        If DeadEnd Then Exit For
    Next Digit
Loop While DeadEnd

CreateSolution2 = CreateStringFromCells(Cell())

'MsgBox DeadEndCounter, , Format(1 / DeadEndCounter, "percent")

End Function

Function CreateSolution() As String

'--------------------------------------------------------------------------------------------------
' Create a new, randomly generated 81 digit string. (a solved puzzle)
'
' Start with a blank grid and add random numbers until finding a valid solution
'
' The algorithm used here is as followes:
'
'      1). Place a random number in a random cell
'      2). Check for conflicts
'      3). If no conflicts, look for naked singles and hidden singles in the remaining cells
'      4). Check for dead end (one or more cells with no possible candidates.  Starts from scratch if encounters a dead end)
'      5). Continue until puzzle is finished
'
' This algorithm will encounter a dead end appox 60% of the time.  If one removes the
' search for singles (step #3), the dead end rate is > 99.9 %
'
'--------------------------------------------------------------------------------------------------

Dim Cell(9, 9) As Integer     'stores the value (1-9) for each cell.  Cell(row,column) = 0 for unsolved cells
Dim poss(9, 9) As String      'stores a 9 digit string of all possible candidates for a cell. All cells start with poss() value "123456789"    Poss(row,col) = "" for solved cells
Dim locked(9, 9) As Boolean   'givens are locked (not applicable in this function)

Dim row As Integer
Dim col As Integer
Dim MyNum As Integer

Dim MyPuzzle As String
Dim Success As Boolean
Dim Repeat As Boolean
Dim FoundCell As Boolean
Dim DeadEnd As Boolean

Do
  'start from scratch
  Call ClearCells(Cell(), locked(), poss())
    Do
        'pick a random cell and assign a random value to it (1-9)
        row = GetRandomNumber(9)
        col = GetRandomNumber(9)
    
        Do
            If Cell(row, col) = 0 Then
                    'cell is available
                    'randomly pick a number from the possible candidates for this cell  (this avoids conflict with other solved cells in row, column, and box)
                     MyNum = GetNumFromPoss(row, col, poss())
                    'assign value to cell
                     Cell(row, col) = MyNum
                    
                     FoundCell = True  'flag to exit loop
                    
                     'update the poss() array (remove MyNum from potential candidates in related cells)
                     Call UpdateRelatedCells(row, col, MyNum, Cell(), poss(), DeadEnd)  'here DeadEnd should never be true
                     
                   Else
                    'cell already used - move to next available cell (start search at cell(row,col))
                    Call GetFirstAvailableCell(Cell(), row, col)  'randomly selected cell was already used, so start with row 1 col 1 and search for next available cell
                    'loop back and check cell (should be available)
            End If
        
        Loop Until FoundCell
        
        FoundCell = False  'reset for next loop
        
           'now look for hidden and naked singles in Poss() array   (possible candidates in each unsolved cell)
            Do
                Repeat = False         'repeat allows search for naked singles when hidden singles are found
                'look for naked singles in all cells
                 Call PromoteNakedSingles(Cell(), poss(), Repeat, False)  'repeat is false then no naked singles found
                If Not Repeat Then
                       'naked single not found , look for hidden singles
                        Call PromoteHiddenSingles(Cell(), poss(), Repeat, False)
                End If
            Loop While Repeat  'found a single, recheck
        
        If PuzzleIsDone(Cell()) Then    'all cells have value <> 0   cell(row,col)
            Success = True      'flag to exit outer loop
            Exit Do
        End If
            
        'check for dead end - (unsolved cell with no possible candidates, happens just above 50% of the time)
        If FoundDeadEnd(Cell(), poss()) Then
            'Hit a dead end,  start over
            Success = False  'should already be false but just in case
            Call ClearCells(Cell(), locked(), poss()) 're-initiate all values
            Exit Do  'outer loop will return to top
        End If
    Loop
Loop Until Success = True

'Done!
'create 81 character string from cell(row,col) array
MyPuzzle = CreateStringFromCells(Cell())

'place in clipboard for pasting to other application (Ctrl+V)
Clipboard.Clear
Clipboard.SetText (MyPuzzle)

'return value to calling routine
CreateSolution = MyPuzzle

End Function
Sub GetFirstAvailableCell(Cell() As Integer, row As Integer, col As Integer)
'returns the row and column of the next available cell (where cell(row,col) = 0)
Dim counter As Integer

For row = 1 To 9
    For col = 1 To 9
        If Cell(row, col) = 0 Then
            Exit Sub  'returns row and col to calling routine
        End If
    Next col
Next row

End Sub
Function NumberGivensInCells(Cell() As Integer) As Integer

Dim row As Integer
Dim col As Integer
Dim counter As Integer

For row = 1 To 9
    For col = 1 To 9
        If Cell(row, col) <> 0 Then
            counter = counter + 1
        End If
    Next col
Next row

NumberGivensInCells = counter

End Function
Function NumberGivensInString(MyString As String) As Integer

Dim counter As Integer
Dim x As Integer
Dim MyChar As String

If Len(MyString) <> 81 Then
    MsgBox "string is invalid"
    Exit Function
End If

For x = 1 To 81
    MyChar = Mid(MyString, x, 1)
    If Val(MyChar) <> 0 Then
        counter = counter + 1
    End If
Next x

NumberGivensInString = counter

End Function


Sub GetNextAvailableCell(Cell() As Integer, row As Integer, col As Integer)

'returns the row and column of the next available cell (where cell(r,c) <> 0)
'starts in row, col
Dim counter As Integer

Do
    col = col + 1
    If col > 9 Then
        col = 1
        row = row + 1
            If row > 9 Then
                'return to top left cell
                row = 1
                col = 0
            End If
    End If

    If Cell(row, col) <> 0 Then
        Exit Do       'returns row and col to calling routine
    End If

       counter = counter + 1
Loop While counter < 81   'prevent endless loop (solved puzzle)


End Sub
Sub RemoveNumberFromPoss(row As Integer, col As Integer, MyNum As Integer, poss() As String)

'this sub removes a digit (myNum) from all poss() in cells related to cell in row & col

'example, removing a 4:    "123456789"  becomes  "123 56789"

'update the poss() array (possible candidates) for all the cells in the row, column, and box for this cell (row,col)
'remove MyNum from the possible candidates in those cells

Dim x As Integer
Dim y As Integer

Dim box As Integer
Dim r1 As Integer
Dim c1 As Integer

'remove mynum from all poss() in ROW
For x = 1 To 9
    Mid(poss(row, x), MyNum, 1) = " "
Next x

'remove mynum from all POSS() in COLUMN
For x = 1 To 9
    Mid(poss(x, col), MyNum, 1) = " "
Next x

'remove mynum from all poss() in BOX
box = GetBoxNumber(row, col)    'Box 1-9
Call GetBoxInit(box, r1, c1)    'r1 c1 is upper left cell in box

For x = r1 To r1 + 2
    For y = c1 To c1 + 2
        Mid(poss(x, y), MyNum, 1) = " "
    Next y
Next x

End Sub
Function GetNumFromPoss(row As Integer, col As Integer, poss() As String) As Integer

'look at all the possible candidates (poss() array) for this cell.  pick one candidate randomly to assign to this cell

Dim N(9) As String  '9 possible candidates in cell (but some may have been removed)
                    'poss() is 9 characters long.  eliminated candidates are spaces  (like Poss(row,col) = "123 56  9")

Dim x As Integer
Dim counter As Integer
Dim Digit As String
Dim zip As Integer

counter = 1  'don't use element zero in this array

If Trim(poss(row, col)) = "" Then
    'no possible values for this cell
    GetNumFromPoss = -1  'flag for bad cell, must have hit dead end (this may never happen)
   Else
    'create array of candidates for this cell (read poss(), return one at random
    For x = 1 To 9
        Digit = Mid(poss(row, col), x, 1)
        If Digit <> " " Then
            N(counter) = Val(Digit)
              counter = counter + 1
        End If
    Next x
    'pick from the array randomly
    zip = GetRandomNumber(counter - 1)   'ie.  if zip = 6 then pick 6th element in array
    GetNumFromPoss = N(zip)  'return value to calling subroutine
End If

End Function

Function CreateStringFromCells(Cell() As Integer) As String

'read cell(row,col) array and create an 81 character string

Dim row As Integer
Dim col As Integer
Dim MyPuzzle As String

For row = 1 To 9
    For col = 1 To 9
        MyPuzzle = MyPuzzle & Trim(Str(Cell(row, col)))   'need trim because str() function returns 2 digit string   (like " 3")
    Next col
Next row

CreateStringFromCells = MyPuzzle

End Function
Function NumCellsLeft(Cell() As Integer, req() As Boolean)

'used when creating a new puzzle
'count number of cells left that are not zero (blank) and not required (req(row,col))

'arrays
'    Cell(row,col)    value of cell  (zero if blank)
'    Req(row,col)     boolean  true if cell is required (removing it will cause multi solution situation)

Dim row As Integer
Dim col As Integer
Dim counter As Integer

For row = 1 To 9
    For col = 1 To 9
        If Cell(row, col) <> 0 Then
            If Not req(row, col) Then
                counter = counter + 1
            End If
        End If
    Next col
Next row

NumCellsLeft = counter

End Function
Sub CreatePuzzleFromSolutionByPairs(MyPuzzle As String, PairsOnly As Boolean)

'Using this method, a puzzle will always be solvable.  Puzzle validity mentioned
'here means that a puzzle has one solution only

'Remove cells in pairs
'
'to create a puzzle, start with a solved puzzle (MyPuzzle) and randomly remove pairs
'of cells.  Theses pairs are 'reflections' of each other to create puzzle symmetry
'(ie.  r9c9 is a reflection of r1c1)

'as each pair is removed, validity is checked (no multiple solutions)
'if a pair removal causes an invalid puzzle, the pair becomes locked via the locked(row,col) boolean

'once all remaining pairs are locked:
'       if PairsOnly is true, then the puzzle is finished  (works faster but puzzle is less difficult)
'       if PairsOnly is false, then each individual cell is tested
'       (see if removing it retains puzzle validity)

'When PairsOnly is true, puzzle will always be symmetrical

Dim Cell(9, 9) As Integer
Dim locked(9, 9) As Boolean     'cells become locked when removing them results in a multi solution problems (invalid puzzle)

Dim row As Integer
Dim col As Integer
Dim OldValue As Integer

Dim TempPuzzle As String

Dim r1, c1, r2, c2 As Integer   'pairs of cell

Dim OldValue1 As Integer
Dim OldValue2 As Integer

'fill the cell() array from the 81 character string
Call FillCells(MyPuzzle, Cell(), locked())

'now unlocked all cells
For row = 1 To 9
    For col = 1 To 9
        locked(row, col) = False
    Next col
Next row

'kill center cell
Cell(5, 5) = 0

Do
    'find a pair of cells  R1,C1  R2,C2 (reflections of each other)
    'remove from puzzle and test validity
    'get first cell
        If AllCellsLocked(Cell(), locked()) Then
            'can't remove any more pairs
            Exit Do
        End If
    
    Do
        'pick a random cell , make sure it is non zero and not locked()
        r1 = GetRandomNumber(9)
        c1 = GetRandomNumber(9)
    Loop Until Cell(r1, c1) <> 0 And locked(r1, c1) = False
    
    'get cell reflection - should already be non zero
    r2 = 10 - r1
    c2 = 10 - c1
    
    'save values for restore if needed
    OldValue1 = Cell(r1, c1)
    OldValue2 = Cell(r2, c2)
    
    'remove the cells from the puzzle
    Cell(r1, c1) = 0
    Cell(r2, c2) = 0
    
    'create 81 character string from cells
    TempPuzzle = CreateStringFromCells(Cell())
    
    If PuzzleHasMultipleSolutions(TempPuzzle, "", "") Then
        'restore last pair removed
        Cell(r1, c1) = OldValue1
        Cell(r2, c2) = OldValue2
        'lock the cells, they're needed
        locked(r1, c1) = True
        locked(r2, c2) = True
    End If
Loop

'at this point, all remaining cells are locked, no pairs can be removed
If Not PairsOnly Then
    'see if any single cell can be removed (takes more time but creates a more difficult puzzle)
    'this will cause the puzzle to be less symmetrical
    For row = 1 To 9
        For col = 1 To 9
            If Cell(row, col) <> 0 Then
                'see if number can be removed without causing a multisolution situation
                OldValue = Cell(row, col)
                Cell(row, col) = 0
                TempPuzzle = CreateStringFromCells(Cell())
                If PuzzleHasMultipleSolutions(TempPuzzle, "", "") Then
                    'need this cell
                    Cell(row, col) = OldValue
                End If
            End If
        Next col
    Next row
End If

'return the new puzzl to the calling subroutine
MyPuzzle = CreateStringFromCells(Cell())

End Sub
Function AllCellsLocked(Cell() As Integer, locked() As Boolean) As Boolean
'return true if all non zero cells are locked

Dim row As Integer
Dim col As Integer

For row = 1 To 9
    For col = 1 To 9
        If Cell(row, col) <> 0 Then
            If Not locked(row, col) Then
                Exit Function
            End If
        End If
    Next col
Next row

AllCellsLocked = True

End Function
Sub CreatePuzzleFromSolutionAlt(MySolution As String, MyPuzzle As String)
'send MySolution to this sub, MyPuzzle is returned

'this sub creates a puzzle by starting with a blank puzzle
'but knowing the solution (MyPuzzle)
'cells are picked randomly to create givens
'after 17 cells are set, validity is checked after each addition

Dim Cell(9, 9) As Integer
Dim poss(9, 9) As String
Dim req(9, 9) As Boolean        'required cell, removing it causes multi solution situation
Dim locked(9, 9) As Boolean     'givens (hints).  not required in this sub but needed for FillCell() routine

Dim CellCount As Integer
Dim TestPuzz As String

Dim row As Integer
Dim col As Integer

'fill the cell() array from the 81 character string
Call ClearCells(Cell(), locked(), poss())


'randomly add cells
Do
                
        'find a cell to add (Cell() = 0)
        
    '----------------------------------
        Do
            'inspect random cell.  need a cell where cell() = 0
            'if cell is blank, move to next available cell
             row = GetRandomNumber(9)
             col = GetRandomNumber(9)
            If Cell(row, col) = 0 Then
                    'found good cell, ok to blank this cell
                    Cell(row, col) = GetCellFromString(row, col, MySolution)
                Else
                   'can't use cell, get next available cell
                   Call GetNextAvailableCell(Cell(), row, col)
            End If
        Loop While Cell(row, col) = 0   '
    '----------------------------------
    
    CellCount = CellCount + 1
    
    'found a cell to remove  (cell(row,col)
    'check for validity (see if removing that cell causes a multi-solution puzzle)
    If CellCount > 17 Then
        TestPuzz = CreateStringFromCells(Cell())
        If PuzzleHasMultipleSolutions(TestPuzz, MyPuzzle, "") Then
           'need to add more cells
           Form2.Caption = CellCount
           Form2.Refresh
          Else
           MsgBox "done"
           MyPuzzle = TestPuzz
           Exit Sub  'return MyPuzzle to calling routine
        End If
    End If
Loop


End Sub
Sub CreatePuzzleFromSolution(MyPuzzle As String)

'MyPuzzle is an 81 character string, solved puzzle
'to create a puzzle to solve, randomly blank cells
'and check for validity after each removal (no multiple solutions)

'when finished, all givens are required (removing any of them causes multi-solution situation)
'this subroutine usually takes 1 to 10 seconds to complete

Dim Cell(9, 9) As Integer
Dim req(9, 9) As Boolean        'required cell, removing it causes multi solution situation
Dim locked(9, 9) As Boolean     'givens (hints).  not required in this sub but needed for FillCell() routine

Dim TestPuzz As String

Dim row As Integer
Dim col As Integer
Dim Cool As Boolean
Dim OldValue As Integer

Dim Xoffset As Integer      'for creating reflection of cells
Dim Yoffset As Integer
Dim OffsetCounter As Integer

Dim MyLoc As Integer     '1-4   1 =  NW   2 = NE   3 = SE    4 = SW     indicates reflections of found cell
Dim s1 As String
Dim DeadEnd As Boolean

'fill the cell() array from the 81 character string
Call FillCells(MyPuzzle, Cell(), locked())  'locked() array is ignored here but required by other subroutines

OffsetCounter = -1  'to start
Dim rr As Integer
Dim cc As Integer

'randomly delete cells
Do
        'see if any remaining cells can be removed
        If NumCellsLeft(Cell(), req()) = 0 Then
            'done - puzzle is valid (one solution only) and no more cells can be removed
            TestPuzz = CreateStringFromCells(Cell())
            MyPuzzle = TestPuzz
            Exit Sub
        End If
        
        OffsetCounter = OffsetCounter + 1
                
        'find a cell to remove (Cell() <> 0 and req() = false)
        If (OffsetCounter / 4) = Int(OffsetCounter / 4) Then   'generate random cell every 4th loop, the other 3 cells are reflections of 1st cell
            'find new random cell
            MyLoc = 1  'reset to 1st of 4 cells
            row = GetRandomNumber(9)
            col = GetRandomNumber(9)
            OldValue = 0 'reset
          Else
            'get reflection of cell
            MyLoc = MyLoc + 1
            
            Select Case MyLoc
                Case 2
                    'NE
                    rr = col
                    cc = 10 - row
                    row = rr
                    col = cc
                Case 3
                    'SE
                    rr = 10 - row
                    cc = 10 - col
                    row = rr
                    col = cc
                Case 4
                    'SW
                    rr = 10 - col
                    cc = row
                    row = rr
                    col = cc
            End Select
        End If
        
    Do
        'inspect random cell.  need a cell where cell() <> 0 and req() = false
        'if cell is blank, move to next available cell
        If Cell(row, col) <> 0 And Not req(row, col) Then
                'found good cell, ok to blank this cell
                OldValue = Cell(row, col) 'save for restore if needed
                Cell(row, col) = 0
            Else
               'can't use cell, get next available cell
               Call GetNextAvailableCell(Cell(), row, col)
        End If
            
    Loop While OldValue = 0   'found unsolved cell, loop to find different cell
    
    'found a cell to remove  (cell(row,col)
    'check for validity (see if removing that cell causes a multi-solution puzzle)
    TestPuzz = CreateStringFromCells(Cell())
        If PuzzleHasMultipleSolutions(TestPuzz, s1, "") Then
            'cell(row,col) is required
            'restore it
            Cell(row, col) = OldValue
            req(row, col) = True  'don't allow this cell to be removed
           Else
            'no multisolution situation, still make sure puzzle is valid (shouldn't happen, this is a safeguard)
            'look at s1
            If Len(s1) <> 81 Then
                MsgBox "puzzle is not solvable"
                Exit Sub
            End If
        End If
Loop

End Sub

Function PuzzleIsSolvable(puzzle As String, SolvedPuzzle As String, forward As Boolean) As Boolean

'forward true means 1-9   false means 9-1
'(see Function PuzzleHasMultipleSolutions to see how FORWARD is used)

'proves that puzzle is solvable (but could have multiple solutions)
'solve puzzle using brute force and naked/hidden singles - returns true when solvable and solution is returned (SolvedPuzzle 81 character string)
'enter puzzle, returns SolvedPuzzle  (both are 81 character strings)

Dim Cell(9, 9) As Integer        'single digit value for each cell (1-9, zero for empty cells)
Dim locked(9, 9) As Boolean      'locked cells are givens (hints)
Dim poss(9, 9) As String         'string array of possible candidates for each cell (starts as "123456789")

Dim row As Integer
Dim col As Integer
Dim DeadEnd As Boolean
Dim Digit As Integer

'initialize cell() and locked() arrays
Call ClearCells(Cell(), locked(), poss())

'enter all givens (hints) and lock those cells
Call FillCells(puzzle, Cell(), locked())

If HasConflicts(Cell(), locked()) Then     'a conflict occurs when a digit appears twice in a house
    SolvedPuzzle = ""    'tells calling routine that puzzle isn't solvable
    Exit Function
End If

'Puzzle is solved when all cells have a value
If PuzzleIsDone(Cell()) Then
    SolvedPuzzle = puzzle
    PuzzleIsSolvable = True
    Exit Function
End If

'not solved, compute the poss() array (possible candidates for each cell)
Call UpdatePossAllCells(Cell(), poss(), DeadEnd)

If DeadEnd Then          'one or more cells have no possible candidate
    SolvedPuzzle = ""    'tells calling routine that puzzle isn't solvable
    Exit Function
End If

row = 1
col = 1
'-----------------------------------------------------------------------
Do
    'find unsolved cell
    Call FindNextCell(row, col, Cell())
    
    If row = -1 Then
        'all cells are done
        SolvedPuzzle = CreateStringFromCells(Cell())
        Exit Do
    End If

    'get first possible value for this cell (get from Poss())
     Cell(row, col) = GetFirstPossibleValue(row, col, poss(), forward)
    'remove cell value from poss() in related cells
     Call UpdateRelatedCells(row, col, Cell(row, col), Cell(), poss(), DeadEnd)
   
    'first look for singles (naked and hidden)
    If Not DeadEnd Then
       ' Call SearchForSingles(Cell(), poss(), locked(), DeadEnd)
    End If
    
    Do While DeadEnd
        If row = -1 Then
            'puzzle is not solvable
            Exit Do
        End If
            'value in current row/col caused a dead end.  use another value or return to previous cell
            Call HandleDeadEnd(row, col, Cell(), poss(), locked(), DeadEnd, forward)
    Loop
    
Loop While DeadEnd = False
'-----------------------------------------------------------------------

If Len(SolvedPuzzle) = 81 Then
    PuzzleIsSolvable = True
End If

End Function
Sub HandleDeadEnd(row As Integer, col As Integer, Cell() As Integer, poss() As String, locked() As Boolean, DeadEnd As Boolean, forward As Boolean)

Dim x As Integer
Dim y As Integer
Dim Digit As Integer
 
'current value in this cell causes a dead end
'find a different value for this cell
'if unable, blank this cell and move to previous cell

Do
    'current cell's value causes a dead end
    'Get next value for this cell (digit)
        'save current cell value
        Digit = Cell(row, col)
        'blank this cell and all unlocked downstream cells, updating the poss() array
        Call RemoveAllUnlockedCells(row, col, Cell(), locked(), poss(), DeadEnd)
        'try to find new value for this cell (look at its poss())
        Digit = GetNextPossThisCell(row, col, Digit, poss(), forward)
    
    If Digit = 0 Then
        'no more possibles this cell
        'clear this cell and all unlocked cells downstream, then move to previous cell
        Do
            Call PrevCell(row, col)
            If row = -1 Then
                'puzzle not solvable
                DeadEnd = True
                Exit Sub
            End If
        Loop While locked(row, col)
        
        'have new cell - loop back to top
      Else
        'digit <> 0
        'assign digit to cell
        Cell(row, col) = Digit
        DeadEnd = False  'reset
        'update the poss() array for related cell(), check for deadend
        Call UpdateRelatedCells(row, col, Digit, Cell(), poss(), DeadEnd)
    End If
Loop While DeadEnd
            
    
End Sub

Sub RemoveAllUnlockedCells(row As Integer, col As Integer, Cell() As Integer, locked() As Boolean, poss() As String, DeadEnd As Boolean)

'current cell's just changed to zero
'some cell past this cell may have values created from hidden/naked singles
'these are no longer valid so all unlocked cell past this current cell must be changed to zero (and poss() array must be updated)

Dim r As Integer   'we don't want to change value of row or col to calling routine
Dim c As Integer
Dim Digit As Integer

r = row
c = col

Do
    If locked(r, c) = False Then
        Digit = Cell(r, c)
        If Digit <> 0 Then
            'unlocked cell, has value, change to zero and update poss()
            Cell(r, c) = 0
                'update the poss() array for related cells
                Call UpdateRelatedCells(r, c, Digit, Cell(), poss(), DeadEnd)
        End If
    End If

    c = c + 1
    If c > 9 Then
        c = 1
        r = r + 1
        If r > 9 Then Exit Do
    End If

Loop

End Sub

Function GetNextPossThisCell(row As Integer, col As Integer, MyNum As Integer, poss() As String, forward As Boolean) As Integer

'this cell has a value.  find it in poss() and return next number in poss

Dim x As Integer
Dim K As String

x = MyNum

'read poss() and get next possible candidate
If forward Then
        '1-9
        Do
            x = x + 1
            If x > 9 Then Exit Do
            K = Mid(poss(row, col), x, 1)
        Loop While Val(K) = 0
    Else
        'backwards
        '9-1
        Do
            x = x - 1
            If x < 1 Then Exit Do
            K = Mid(poss(row, col), x, 1)
        Loop While Val(K) = 0
End If

GetNextPossThisCell = Val(K)

End Function

Function GetFirstPossibleValue(row As Integer, col As Integer, poss() As String, forward As Boolean)

Dim x As Integer
Dim K As String

If forward Then
        x = 0
        Do
            x = x + 1
            If x > 9 Then Exit Do
            K = Mid(poss(row, col), x, 1)
        Loop While Val(K) = 0
    Else
        'backwards
        x = 10
        Do
            x = x - 1
            If x < 1 Then Exit Do
            K = Mid(poss(row, col), x, 1)
        Loop While Val(K) = 0
End If

GetFirstPossibleValue = Val(K)

End Function


Sub FindPrevCell(row As Integer, col As Integer, Cell() As Integer, locked() As Boolean, poss() As String)
'cell(row,col) is dead end poss() is blank
'move to previous unlocked cell and increment its value
'note:  all cells before this cell will have a value (no blank cells)

Do
    col = col - 1
        If col < 1 Then
            col = 9
            row = row - 1
            If row < 1 Then
                row = -1
                Exit Sub
            End If
        End If
Loop While locked(row, col)

End Sub

Sub FindNextCell(row As Integer, col As Integer, Cell() As Integer)
'find next blank cell, return row and column
'starts at supplied row and column

If row < 0 Then Exit Sub

Do Until Cell(row, col) = 0
    col = col + 1
    If col > 9 Then
        col = 1
        row = row + 1
        If row > 9 Then
            row = -1
            Exit Sub
        End If
    End If
Loop

End Sub
Sub UpdateRelatedCells2(row As Integer, col As Integer, Digit As Integer, Cell() As Integer, poss() As String, DeadEnd As Boolean)

'similar  to Sub UpdateRelatedCells() but this sub ADDS to poss() for digit removed from a cell
'digit was set for cell(row,col).  digit = previous value of cell(row,col).  need to restore digit in poss() for related cells
'update poss() for all visible cells, ADDING digit to poss()

'if cell(row, col) <> 0 then value is being added to cell.  need to remove digit from poss() in related cells
'but if cell(row, col) = 0 then value is being REMOVED from cell.  need to update poss() in related cells

Dim r As Integer
Dim c As Integer
Dim box As Integer
Dim r1 As Integer
Dim c1 As Integer

Dim ThisNumber As String

Dim a As Integer
Dim b As Integer

'replace digit in poss() in all related cells

'look in all poss() this row
'we want to add digit to poss for this cell(row,c)
'but need to make sure that digit isn't present in col c or box (were already checking row)

'check each cell in row (must check column

'check row
For c = 1 To 9
     'see if  is in column
    If CellCanSeeADigit(row, c, Digit, Cell()) = False Then
        Mid(poss(row, c), Digit, 1) = Trim(Str(Digit))
    End If
Next c

'check column
For r = 1 To 9
     'see if  is in column
    If CellCanSeeADigit(r, col, Digit, Cell()) = False Then
        Mid(poss(r, col), Digit, 1) = Trim(Str(Digit))
    End If
Next r

'box
box = GetBoxNumber(row, col)
Call GetBoxInit(box, r1, c1)

'look in all poss() this box
For r = r1 To r1 + 2
    For c = c1 To c1 + 2
        If CellCanSeeADigit(r, c, Digit, Cell()) = False Then
            Mid(poss(r, c), Digit, 1) = Trim(Str(Digit))
        End If
    Next c
Next r

End Sub
Function CellCanSeeADigit(row As Integer, col As Integer, Digit As Integer, Cell() As Integer) As Boolean

'look in row, column, and box for this cell
'look for digit in any of those houses

If RowHasNumber(row, col, Digit, Cell()) Then
    CellCanSeeADigit = True
    Exit Function
End If

If ColumnHasNumber(row, col, Digit, Cell()) Then
    CellCanSeeADigit = True
    Exit Function
End If

If BoxHasNumber(row, col, Digit, Cell()) Then
    CellCanSeeADigit = True
    Exit Function
End If

'must be false


End Function

Sub UpdateRelatedCells(row As Integer, col As Integer, Digit As Integer, Cell() As Integer, poss() As String, DeadEnd As Boolean)

'digit was set for cell(row,col)
'update poss() for all visible cells, removing digit, except in poss(row,col)

'if cell(row, col) <> 0 then value is being added to cell.  need to remove digit from poss() in related cells
'but if cell(row, col) = 0 then value is being REMOVED from cell.  need to update poss() in related cells

Dim r As Integer
Dim c As Integer
Dim box As Integer
Dim r1 As Integer
Dim c1 As Integer

If Cell(row, col) <> 0 Then
        'remove digit from poss() in all related cells
        'remove digit from poss() this row
        For c = 1 To 9
            If c <> col Then
                Mid(poss(row, c), Digit, 1) = " "
                If Trim(poss(row, c)) = "" Then
                    DeadEnd = True
                    'Exit Sub
                End If
            End If
        Next c
        
        'remove digit from  poss() this column
        For r = 1 To 9
            If r <> row Then
                Mid(poss(r, col), Digit, 1) = " "
                If Trim(poss(r, col)) = "" Then
                    DeadEnd = True
                    'Exit Sub
                End If
            End If
        Next r
        
        box = GetBoxNumber(row, col)
        Call GetBoxInit(box, r1, c1)
        
        'remove digit from poss() in box
        For r = r1 To r1 + 2
            For c = c1 To c1 + 2
                If r <> row Or c <> col Then
                    Mid(poss(r, c), Digit, 1) = " "
                    If Trim(poss(r, c)) = "" Then
                        DeadEnd = True
                        'Exit Sub
                    End If
                End If
            Next c
        Next r
    Else
       'cell(row,col) = 0   digit is its previous value
       'need to put digit back in poss() for related cells
       Call UpdateRelatedCells2(row, col, Digit, Cell(), poss(), DeadEnd)
End If

End Sub

Sub UpdatePossAllCells(Cell() As Integer, poss() As String, DeadEnd As Boolean)

'do this by looking at all non zero cells and affecting poss array

Dim row As Integer
Dim col As Integer
Dim box As Integer

Dim Digit As String

Dim r As Integer
Dim c As Integer

Dim x As Integer
Dim y As Integer

Call ClearPoss(poss())

For row = 1 To 9
    For col = 1 To 9
             If Cell(row, col) <> 0 Then
                Digit = Trim(Str(Cell(row, col)))
                'remove digit from poss() in all visible cells
                    'row
                    For c = 1 To 9
                        If c <> col Then
                            Mid(poss(row, c), Val(Digit), 1) = " "
                                If Trim(poss(row, c)) = "" Then
                                    DeadEnd = True
                                End If
                        End If
                    Next c
                    
                    'col
                    For r = 1 To 9
                        If r <> row Then
                            Mid(poss(r, col), Val(Digit), 1) = " "
                                If Trim(poss(r, col)) = "" Then
                                    DeadEnd = True
                                End If
                        End If
                    Next r
                    
                    'box
                    box = GetBoxNumber(row, col)
                    Call GetBoxInit(box, r, c)
                    
                    For x = r To r + 2
                        For y = c To c + 2
                            If x <> row Or y <> col Then
                                Mid(poss(x, y), Val(Digit), 1) = " "
                                    If Trim(poss(x, y)) = "" Then
                                        DeadEnd = True
                                    End If
                            End If
                        Next y
                    Next x
        End If
    Next col
Next row

End Sub


Function PuzzleHasMultipleSolutions(puzzle As String, s1 As String, s2 As String) As Boolean

'1).  solve by brute force - incrementing cell value 1-9
'2).  solve by brute force again - but cell value 9-1

'compare solutions.  If identical, has only 1 solution

'forward 1-9
If PuzzleIsSolvable(puzzle, s1, True) Then
    'backwards 9-1
    If PuzzleIsSolvable(puzzle, s2, False) Then
        If s1 <> s2 Then
            PuzzleHasMultipleSolutions = True
        End If
    End If
End If



End Function
Function FlipVert(puzzle As String) As String
Dim Cell(9, 9) As Integer

'flip vertically (not same as rotating 180)

Dim locked(9, 9) As Boolean
Dim x As Integer
Dim y As Integer
Dim temp As String

Call FillCells(puzzle, Cell(), locked())

For x = 9 To 1 Step -1
    For y = 1 To 9
        temp = temp & Trim(Str(Cell(x, y)))
    Next y
Next x

FlipVert = temp

End Function
Function Rotate90Right(puzzle As String) As String

'puzzle must be an 81 characters string of numbers
'returns modified 81 character string

Dim Cell(9, 9) As Integer

Dim locked(9, 9) As Boolean
Dim x As Integer
Dim y As Integer
Dim temp As String

Call FillCells(puzzle, Cell(), locked())
For y = 1 To 9
    For x = 9 To 1 Step -1
        temp = temp & Trim(Str(Cell(x, y)))
    Next x
Next y

Rotate90Right = temp

End Function
Function Rotate90Left(puzzle As String) As String

'puzzle must be an 81 characters string of numbers
'returns modified 81 character string


Dim Cell(9, 9) As Integer
Dim locked(9, 9) As Boolean
Dim x As Integer
Dim y As Integer
Dim temp As String

Call FillCells(puzzle, Cell(), locked())

For y = 9 To 1 Step -1
    For x = 1 To 9
        temp = temp & Trim(Str(Cell(x, y)))
    Next x
Next y

Rotate90Left = temp

End Function


Function FlipHorz(puzzle As String) As String

'puzzle must be an 81 characters string of numbers
'returns modified 81 character string

'flip horizontally

Dim Cell(9, 9) As Integer
Dim locked(9, 9) As Boolean
Dim x As Integer
Dim y As Integer
Dim temp As String

Call FillCells(puzzle, Cell(), locked())

For x = 1 To 9
    For y = 9 To 1 Step -1
        temp = temp & Trim(Str(Cell(x, y)))
    Next y
Next x

FlipHorz = temp

End Function

Function Rotate180(puzzle As String) As String

'puzzle must be an 81 characters string of numbers
'returns modified 81 character string

'rotate 180 (not the same as flipping vertically)

Dim Cell(9, 9) As Integer
Dim locked(9, 9) As Boolean
Dim x As Integer
Dim y As Integer
Dim temp As String

Call FillCells(puzzle, Cell(), locked())

For x = 9 To 1 Step -1
    For y = 9 To 1 Step -1
        temp = temp & Trim(Str(Cell(x, y)))
    Next y
Next x

Rotate180 = temp

End Function
Function GetCellFromString(row As Integer, col As Integer, MyString As String) As String
'mystring is 81 character string (solved puzzle)
'return the digit for row,col (return a 1 character string, not the value)

Dim x As Integer

x = (row - 1) * 9 + col

GetCellFromString = Mid(MyString, x, 1)


End Function

Function HasConflicts(Cell() As Integer, locked() As Boolean) As Boolean

'look for a row, column, or box with multiple instance of same number

Dim row As Integer
Dim col As Integer
Dim MyNum As Integer

Dim x As Integer
Dim y As Integer

Dim box As Integer
Dim r1 As Integer
Dim c1 As Integer

'check each solved cell for conflicts
For row = 1 To 9
    For col = 1 To 9
        If Cell(row, col) <> 0 Then
            MyNum = Cell(row, col)
            'check row
                For x = 1 To 9
                    If x <> col Then
                        If Cell(row, x) = MyNum Then
                            HasConflicts = True
                            Exit Function
                        End If
                    End If
                Next x
            'check column
                For x = 1 To 9
                    If x <> row Then
                        If Cell(x, col) = MyNum Then
                            HasConflicts = True
                            Exit Function
                        End If
                    End If
                Next x
            'check box
            box = GetBoxNumber(row, col)
            Call GetBoxInit(box, r1, c1)
                For x = r1 To r1 + 2
                    For y = c1 To c1 + 2
                        If x <> row Or y <> col Then
                            If Cell(x, y) = MyNum Then
                                HasConflicts = True
                                Exit Function
                            End If
                        End If
                    Next y
                Next x
        End If
    Next col
Next row

End Function
Sub SearchForSingles(Cell() As Integer, poss() As String, locked() As Boolean, DeadEnd As Boolean)

'look for hidden/naked single
Dim Repeat As Boolean
            
    Do
        Repeat = False         'repeat allows search for naked singles when hidden singles are found

        'look for naked singles
         Call PromoteNakedSingles(Cell(), poss(), Repeat, DeadEnd)  'repeat is false then no naked singles found
         If DeadEnd Then
            Exit Do
         End If
        'look for hidden singles
        If Not Repeat Then
           Call PromoteHiddenSingles(Cell(), poss(), Repeat, DeadEnd)
        End If
        
    Loop While Repeat  'found a single, recheck


End Sub

Sub NextCell(row As Integer, col As Integer)
        
col = col + 1

If col > 9 Then
    
    col = 1
    row = row + 1
    
    If row > 9 Then
        row = -1  'flag returned to calling subroutine
    End If
End If

End Sub
Sub PrevCell(row As Integer, col As Integer)
        
col = col - 1

If col < 1 Then
    
    col = 9
    row = row - 1
    
    If row < 1 Then
        row = -1     'flag returned to calling subroutine
    End If
End If

End Sub
Function RowHasNumber(row As Integer, col As Integer, Digit As Integer, Cell() As Integer) As Boolean
'return true is any cell in this row = digit

Dim c As Integer

For c = 1 To 9
    If Cell(row, c) = Digit Then
        RowHasNumber = True
        Exit For
    End If
Next c

End Function
Function ColumnHasNumber(row As Integer, col As Integer, Digit As Integer, Cell() As Integer) As Boolean
'return true is any cell in this column = digit

Dim r As Integer

For r = 1 To 9
    If Cell(r, col) = Digit Then
        ColumnHasNumber = True
        Exit For
    End If
Next r


End Function
Function BoxHasNumber(row As Integer, col As Integer, Digit As Integer, Cell() As Integer) As Boolean

'find the box where current cell(row,col) is located
'return true is any cell in this box = digit

Dim r As Integer
Dim c As Integer
Dim r1 As Integer
Dim c1 As Integer
Dim box As Integer

box = GetBoxNumber(row, col)

Call GetBoxInit(box, r1, c1) 'r1/c1 are coordinates for upper left cell in box

For r = r1 To r1 + 2
    For c = c1 To c1 + 2
        If Cell(r, c) = Digit Then
            BoxHasNumber = True
            Exit For
        End If
    Next c
Next r

End Function

Sub FillCells(MyPuzzle As String, Cell() As Integer, locked() As Boolean)

'mypuzzle must be an 81 character string of numbers 0 - 9
'this sub fills the two arrays,  cell(row,col) and locked(row,col)
'these array must diminsioned by the calling routine
'
'         Dim Cell(9,9) as Integer
'         Dim locked(9,9) as boolean
'
'non zero cells have locked() value = true, indicating that these cells are givens (hints)
On Error GoTo myerror

Dim row As Integer
Dim col As Integer

Dim x As Integer
Dim Digit As String

row = 1
For x = 1 To 81
    Digit = Mid(MyPuzzle, x, 1)
    col = col + 1
        If col > 9 Then
            col = 1
            row = row + 1
        End If
    Cell(row, col) = Val(Digit)
    locked(row, col) = (Val(Digit) <> 0)
Next x

Exit Sub
myerror:

MsgBox Error(Err), vbExclamation, "Error in Sub FillCells()"

End Sub

Sub PromoteHiddenSingles(Cell() As Integer, poss() As String, Repeat As Boolean, DeadEnd As Boolean)

'check puzzle for hidden singles in any house. Update cell() when found
'the boolean REPEAT tells the calling routine that a hidden single was found

Dim rowh(9) As Integer   'cell values for any particular house
Dim colH(9) As Integer

Dim row As Integer
Dim col As Integer
Dim box As Integer


'do all rows
For row = 1 To 9
    Call HouseArrayRow(rowh(), colH(), row)  'get cell locations for all cells in this row
    Call FindHiddenSingleInHouse(rowh(), colH(), Cell(), poss(), Repeat, DeadEnd)
    If Repeat Then Exit Sub
Next row

'columns
For col = 1 To 9
    Call HouseArrayCol(rowh(), colH(), col) 'get cell locations for all cells in this column
    Call FindHiddenSingleInHouse(rowh(), colH(), Cell(), poss(), Repeat, DeadEnd)
    If Repeat Then Exit Sub
Next col

'box
For box = 1 To 9
    Call HouseArrayBox(rowh(), colH(), box) 'get cell locations for all cells in this box
    Call FindHiddenSingleInHouse(rowh(), colH(), Cell(), poss(), Repeat, DeadEnd)
Next box


End Sub
Sub FindHiddenSingleInHouse(rowh() As Integer, colH() As Integer, Cell() As Integer, poss() As String, Repeat As Boolean, DeadEnd As Boolean)
'look for hidden single in this house

'cells for this house are in cells rowH(1-9) and colH(1-9)
'if hidden single is found, Cell(row,col) array and poss(row,col) array are updated and the REPEAT (boolean) returns TRUE

Dim Digit As Integer
Dim DS As String

Dim fr As Integer  'row of found cell
Dim fc As Integer  'col of found cell

Dim count As Integer
Dim ThisCell As Integer

'count how many times each digit (1-9) is present in house

For Digit = 1 To 9
    DS = Trim(Str(Digit))
    count = 0
    
    For ThisCell = 1 To 9
        'look at all the poss() for this house
        If InStr(poss(rowh(ThisCell), colH(ThisCell)), Digit) <> 0 Then
           'digit is present in poss()
           count = count + 1
           fr = rowh(ThisCell)
           fc = colH(ThisCell)
        End If
     Next ThisCell
         
    If count = 1 Then
        'hidden single was found in cell(fr,fc)
        If Cell(fr, fc) = 0 Then
            Cell(fr, fc) = Val(Digit) 'assign value to cell
             'now remove candidate (digit) from visible cells
             Call UpdateRelatedCells(fr, fc, Val(Digit), Cell(), poss(), DeadEnd)   'DeadEnd is true if any related cell has a poss() of "         " (no possible candidates)
                If DeadEnd Then Exit Sub
            Repeat = True
            Exit Sub
        End If
    End If
     
Next Digit

End Sub

Sub HouseArrayRow(rowh() As Integer, colH() As Integer, row As Integer)

'return set of cells for this row
'rowh() and colH() must be diminisioned by calling subroutine (Dim rowH(9) as integer)

Dim x As Integer

For x = 1 To 9
    rowh(x) = row
    colH(x) = x
Next x

End Sub
Sub HouseArrayCol(rowh() As Integer, colH() As Integer, col As Integer)

'return set of cells for this column
'rowh() and colH() must be diminisioned by calling subroutine (Dim rowH(9) as integer)

Dim x As Integer

For x = 1 To 9
    rowh(x) = x
    colH(x) = col
Next x

End Sub
Sub HouseArrayBox(rowh() As Integer, colH() As Integer, box As Integer)

'return set of cells for this box
'rowh() and colH() must be diminisioned by calling subroutine (Dim rowH(9) as integer)

Dim row As Integer
Dim col As Integer

Dim r As Integer
Dim c  As Integer

Dim counter As Integer

Call GetBoxInit(box, row, col)  'find upper left cell of box

For r = row To row + 2
    For c = col To col + 2
        counter = counter + 1
        rowh(counter) = r
        colH(counter) = c
    Next c
Next r

End Sub

Function FoundDeadEnd(Cell() As Integer, poss() As String) As Boolean

'look at each cell.  if any cell has Cell() = 0 (unsolved) and Poss() = "" ,  then dead end
'    ie.   Cell is unsolved but no possible candidates remain
'

Dim row As Integer
Dim col As Integer

For row = 1 To 9
    For col = 1 To 9
        If Cell(row, col) = 0 Then
            'unsolved cell -  should have candidates in poss(row,col) array
            If Trim(poss(row, col)) = "" Then
                'dead end
                FoundDeadEnd = True
                Exit Function
            End If
        End If
    Next col
Next row

FoundDeadEnd = False

End Function


Sub ClearCells(Cell() As Integer, locked() As Boolean, poss() As String)

Dim row As Integer
Dim col As Integer

'clear all cells

For row = 1 To 9
    For col = 1 To 9
        Cell(row, col) = 0
        poss(row, col) = "123456789"
        locked(row, col) = False
    Next col
Next row

End Sub

Sub ClearPoss(poss() As String)

Dim row As Integer
Dim col As Integer

'clear all poss values to "123456789"  (all possible candidates in each cell)
For row = 1 To 9
    For col = 1 To 9
        poss(row, col) = "123456789"
    Next col
Next row

End Sub

Function PuzzleIsDone(Cell() As Integer) As Boolean
' true when all cells are non zero
Dim row As Integer
Dim col As Integer

For row = 1 To 9
    For col = 1 To 9
        If Cell(row, col) = 0 Then
            Exit Function
        End If
    Next col
Next row

PuzzleIsDone = True

End Function
Sub PromoteNakedSingles(Cell() As Integer, poss() As String, Repeat As Boolean, DeadEnd As Boolean)

'look in all 81 cells for naked single.  promote if found (update cell() and poss() arrays)
'       ie.   if poss(row,col) value = " 2       "        then cell has naked single 2

Dim row As Integer
Dim col As Integer
Dim MyNum As Integer

For row = 1 To 9
    For col = 1 To 9
        If Cell(row, col) = 0 Then
            If Len(Trim(poss(row, col))) = 1 Then
                'found naked single
                'set the cell
                MyNum = Val(poss(row, col))
                Cell(row, col) = MyNum
                    'update related poss() array for related cells (remove mynum)
                     Call UpdateRelatedCells(row, col, MyNum, Cell(), poss(), DeadEnd)
                    If DeadEnd Then
                        Exit Sub
                    End If
                Repeat = True   'tell calling routine that at least 1 naked single was found
            End If
        End If
    Next col
Next row

End Sub


Function GetBoxInit(box As Integer, r1 As Integer, c1 As Integer)
'return r1 and c1 (top left cell of box)

'find row (r1)
Select Case box
    Case 1, 2, 3
        'band 1  top row is 1
        r1 = 1
    Case 4, 5, 6
        'band 2  top row is 4
        r1 = 4
    Case 7, 8, 9
        'band 3  top row is 7
        r1 = 7
End Select

'find col (c1)
Select Case box
    Case 1, 4, 7
        'stack 1 col = 1
        c1 = 1
    Case 2, 5, 8
        'stack 2 col = 4
        c1 = 4
    Case 3, 6, 9
        'stack 3 col = 7
        c1 = 7
End Select

End Function

Function GetBoxNumber(row As Integer, col As Integer) As Integer

Select Case row
    Case 1, 2, 3 'band 1
        Select Case col
            Case 1, 2, 3 'stack 1
                GetBoxNumber = 1
            Case 4, 5, 6 'stack 2
                GetBoxNumber = 2
            Case 7, 8, 9 'stack 3
                GetBoxNumber = 3
        End Select
    Case 4, 5, 6 'band 2
        Select Case col
            Case 1, 2, 3 'stack 1
                GetBoxNumber = 4
            Case 4, 5, 6 'stack 2
                GetBoxNumber = 5
            Case 7, 8, 9 'stack 3
                GetBoxNumber = 6
        End Select
    Case 7, 8, 9 'band 3
        Select Case col
            Case 1, 2, 3 'stack 1
                GetBoxNumber = 7
            Case 4, 5, 6 'stack 2
                GetBoxNumber = 8
            Case 7, 8, 9 'stack 3
                GetBoxNumber = 9
        End Select
End Select


End Function


Function GetRandomNumber(Max As Integer) As Integer
'return 1-max

Dim z As Integer

Do
    Randomize Timer
    z = Rnd(Timer) * Max
Loop While z < 1

GetRandomNumber = z

End Function
Function StringIsASolvedPuzzle(puzzle As String) As Boolean
'81 characters
'all 1-9
'valid

Dim x As Integer
Dim MyChar As String

If Len(puzzle) = 81 Then
    For x = 1 To Len(puzzle)
        MyChar = Mid(puzzle, x, 1)
        Select Case Asc(MyChar)
            '1-9 is ascii characters 49 - 58
            Case 49 To 57
                'cool
            Case Else
                Exit Function  'return false
        End Select
    Next x
   Else
    'not 81 characters
    Exit Function
End If

'81 characters, all numbers 1-9
'now check for validity

If PuzzleIsSolvable(puzzle, "", True) Then
    StringIsASolvedPuzzle = True
End If


End Function





Function PuzzleHasIllegalCharacters(puzzle As String) As Boolean
'check the character in the 81 digit string, look for illegal characters

Dim x As Integer
Dim MyChar As String

For x = 1 To Len(puzzle)
    MyChar = Mid(puzzle, x, 1)
    Select Case Asc(MyChar)
        '0-9 is ascii characters 48 - 58
        Case 48 To 57
            'cool
        Case Else
        PuzzleHasIllegalCharacters = True
    End Select
Next x

End Function


Function NumIsInRow(row As Integer, MyNum As Integer, Cell() As Integer) As Boolean

Dim col As Integer

For col = 1 To 9
    If Cell(row, col) = MyNum Then
        NumIsInRow = True
    End If
Next col


End Function
Function NumIsInCol(col As Integer, MyNum As Integer, Cell() As Integer) As Boolean

Dim row As Integer

For row = 1 To 9
    If Cell(row, col) = MyNum Then
        NumIsInCol = True
    End If
Next row


End Function

Function NumIsInBox(row As Integer, col As Integer, MyNum As Integer, Cell() As Integer) As Boolean

Dim box As Integer

Dim r1 As Integer
Dim c1 As Integer

Dim x As Integer
Dim y As Integer

box = GetBoxNumber(row, col)

'find top left of box
Call GetBoxInit(box, r1, c1)

For x = r1 To r1 + 2
    For y = c1 To c1 + 2
        If Cell(x, y) = MyNum Then
            NumIsInBox = True
        End If
    Next y
Next x

End Function