Macrosudoku v1.2 bêta eng
Description
La MacroSudoku v1.2 ENG permet de:
_ résoudre TOUS les Sudokus (y compris les plus difficiles)
_ Aider à la résolution (ajout d'un chiffre supplémentaire, identification des erreurs etc.)
_ Générer un nombre infini de Sudoku nouveau, selon la difficulté choisie (de très facile à très difficile).
Contrairement aux autres sources trouvées sur le net, cette macro est TRES facile d'utilisation, complète (résolution logique puis par essais successifs), rapide (résolution en 100ms), et enfin elle permet d'aussi générer de nouvelles grilles.
La macro contient aussi une page d'option, qui permet de paramétrer la macro (couleur utilisée, recherche ou non de toutes les solutions, utilisation ou non d'un log, temps limite de solution/génération, difficulté de la grille générée).
Je recherche des partenaires pour continuer le développement de cette application, que je souhaiterais rendre open-source. Si intéressé:
_ me contacter à macrosudoku@gmail.com
_ visiter http://macrosudoku.blogspot.com/
Amusez vous bien !
_ résoudre TOUS les Sudokus (y compris les plus difficiles)
_ Aider à la résolution (ajout d'un chiffre supplémentaire, identification des erreurs etc.)
_ Générer un nombre infini de Sudoku nouveau, selon la difficulté choisie (de très facile à très difficile).
Contrairement aux autres sources trouvées sur le net, cette macro est TRES facile d'utilisation, complète (résolution logique puis par essais successifs), rapide (résolution en 100ms), et enfin elle permet d'aussi générer de nouvelles grilles.
La macro contient aussi une page d'option, qui permet de paramétrer la macro (couleur utilisée, recherche ou non de toutes les solutions, utilisation ou non d'un log, temps limite de solution/génération, difficulté de la grille générée).
Je recherche des partenaires pour continuer le développement de cette application, que je souhaiterais rendre open-source. Si intéressé:
_ me contacter à macrosudoku@gmail.com
_ visiter http://macrosudoku.blogspot.com/
Amusez vous bien !
Source / Exemple :
'================================================================
'= MacroSudoku v1.2 =
'= Macro started the 19/10/2008 by Bastien YVERNEAU =
'================================================================
' Ideas for later:
' _ Implement a timer, counting how long does the user need to solve the grid (with a pause/resume function, when paused hide the grid)
' _ Give the opportunity to make a printable sheet of x sudokus
' _ Create a "High-Scores" sheet, and make it work
' _ Correct the bug that makes the rating change if AllSolution is 'On' or 'Off'
' _ Give the options to generate a new Sudoku OR to take it from the database
' Done:
' _ Solve the issue of fake grid from the beginning...
' _ Optimiser les boucles de résolution et utiliser des booleens pour les contrôler
' _ Add a "Log" excel sheet
' _ Check if all cases in the grid contain only figure (and no letter, no symbol etc)
' _ Count the number of potential solution
' _ Implement the Sudoku Creator
' _ Create an "options" sheet, and make it work
' _ Create a function to estimate the difficulty
' Declaration of private constants
Private Const WSSudoku As String = "MacroSudoku"
Private Const WSOptions As String = "Options"
Private Const WSHighScores As String = "High Scores"
Private Const WSLog As String = "Log"
Private Const WSSamples As String = "Sudoku Samples"
Private Const WSDocuments As String = "Documents"
Private Const Password As String = "#########################"
Private Const Col1 As Integer = 2
Private Const Row1 As Integer = 3
Private Const NbInitValue As Integer = 5
' Declaration of private variable
Private ColorInit As Integer
Private ColorMistake As Integer
Private ColorHint As Integer
Private Difficulty, OptionsDifficulty As String
Private NbLevel, NbCheckU, NbCheckSB, LineLog, ColLog, NbSolution, LineR, TimeLimitSolution, TimeLimitGeneration As Integer
Private Solution(8, 8, 9) As Integer
Private TimeSolution, TimeGeneration As Double
Private bool, UpdateUsual, UpdateSubGroup, BoolAllSolutions, BoolLog, Terminate As Boolean
Private Sub AnalyseTheSudokuGrid_Click()
' Solve the Sudoku and fill Solution()
Dim i, j, k, Test, MyArray(8, 8, 9) As Integer
Dim str2 As String
' Set the MacroSudoku sheet zoom ability and scroll area
' !!!! move this to 'This workbook', in the macro "Private Sub Workbook_open()"
' doesn't work....Worksheets(WSSudoku).PageSetup.Zoom = False
Worksheets(WSSudoku).ScrollArea = "$A$1:$V$15"
' Check if all values written on the Sudoku grid are integer
If CheckIfAllInteger() = False Then Exit Sub
' Init the log if it's turned on (i.e. if BoolLog is True)
If BoolLog Then bool = InitLog()
If BoolLog Then bool = PrintLog("AnalyseTheSudokuGrid", "Started")
' NbLevel/NbCheckU/NbCheckSB count the number of time each main function is called ; LineLog is used to print the log;
NbLevel = 0
NbCheckU = 0
NbCheckSB = 0
LineLog = 2
ColLog = 1
' NbSolution count the number of total solution
NbSolution = 0
Terminate = False
' TimeSolution count the time needed to find a solution
TimeSolution = Timer
' Set the options
bool = SetOptions()
' Take the initial value of the grid
bool = InitArray(MyArray())
bool = InitValue(MyArray())
' If the BoolAllSolutions is true, then check if a minimum number of values are entered to avoid very long resolution time
If BoolAllSolutions Then If VeryLongComputingTime(MyArray()) Then Exit Sub
' Solve the Sudoku grid
Test = Solve(MyArray())
' Check the solution (needed as Solve() might return a false value if BoolAllSolutions is true
Test = TestGrid(Solution())
' Update the status: if grid is not feasible, exit the function. Else, show how much time was needed
If Test <> 1 Then
bool = ResetStatus()
bool = PrintStatus("This grid is not feasible!")
bool = PrintWarning()
Exit Sub
Else
' Estimate the difficulty of the grid
bool = EstimateDifficulty(Int(100000 * (Timer - TimeSolution)) / 100)
bool = ResetStatus()
If BoolAllSolutions Then
If NbSolution = 1 Then
bool = PrintStatus("Sudoku solved in " + CStr(Int(100000 * (Timer - TimeSolution)) / 100) + " milliseconds. Sudoku rated as '" + Difficulty + "'. There is only " + CStr(NbSolution) + " solution.")
Else
bool = PrintStatus("Sudoku solved in " + CStr(Int(100000 * (Timer - TimeSolution)) / 100) + " milliseconds. Sudoku rated as '" + Difficulty + "'. There are " + CStr(NbSolution) + " solutions.")
End If
Else
bool = PrintStatus("Sudoku solved in " + CStr(Int(100000 * (Timer - TimeSolution)) / 100) + " milliseconds. Sudoku rated as '" + Difficulty + "'.")
End If
' Protect all the initial values
bool = ProtectInitValue()
End If
' Update the buttons
FindMyMistakes.Enabled = True
GiveMe1NumberMore.Enabled = True
ShowTheFullSolution.Enabled = True
EmptyTheSudokuGrid.Enabled = True
AnalyseTheSudokuGrid.Enabled = False
CreateANewSudokuGrid.Enabled = False
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog Then bool = PrintLog("AnalyseTheSudokuGrid", "Ended")
End Sub
Private Sub BossComing_Click()
' Show a 'professional' excel sheet, and hide the other sheets
' Hide the MacroSudoku Excel sheets
Worksheets(WSSudoku).Visible = xlSheetHidden
Worksheets(WSOptions).Visible = xlSheetHidden
Worksheets(WSHighScores).Visible = xlSheetHidden
Worksheets(WSLog).Visible = xlSheetHidden
Worksheets(WSSamples).Visible = xlSheetHidden
' Activate the 'Documents' excel sheet
Worksheets(WSDocuments).Activate
End Sub
Private Sub EmptyTheSudokuGrid_Click()
' Empty the grid, so as to prepare a new one
Dim i, j As Integer
' Unprotect the Excel sheet
Worksheets(WSSudoku).Unprotect Password
' Update the buttons
FindMyMistakes.Enabled = False
GiveMe1NumberMore.Enabled = False
ShowTheFullSolution.Enabled = False
AnalyseTheSudokuGrid.Enabled = True
CreateANewSudokuGrid.Enabled = True
EmptyTheSudokuGrid.Enabled = False
' Delete any formatting and put value to 0
For i = 0 To 8
For j = 0 To 8
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Interior.ColorIndex = xlNone
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).ClearContents
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Locked = False
Next
Next
' Reset Solution()
bool = InitArray(Solution())
' Reset the status cell, and print an informative message
bool = ResetStatus()
bool = PrintStatus("The Sudoku grid is now ready for a new Sudoku!")
End Sub
Private Sub FindMyMistakes_Click()
' Compare the grid with the solution and mark the wrong number
Dim i, j, k As Integer
' Unprotect the Excel sheet
Worksheets(WSSudoku).Unprotect Password
' Clear the format of each cell (paint the background as white)
For i = 0 To 8
For j = 0 To 8
If Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Locked = False Then Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Interior.ColorIndex = xlNone
Next
Next
' Compare each cell with the solution, if values are different then paint it in orange
' k count the number of mistake occured
k = 0
For i = 0 To 8
For j = 0 To 8
If (Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value <> 0 And Solution(i, j, 0) <> Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value) Then
' Change the color of the mistaken case(i,j)
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Interior.ColorIndex = ColorMistake
' Wait half a second
bool = Wait(0.5)
' Put back the initial color of the mistaken case(i,j)
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Interior.ColorIndex = xlNone
k = k + 1
End If
Next
Next
bool = ResetStatus()
bool = PrintStatus("The Sudoku has " + CStr(k) + " mistakes.")
' Protect the Excel sheet
Worksheets(WSSudoku).Protect Password
End Sub
Private Sub GiveMe1NumberMore_Click()
' Write a new number (hint) on the Excel sheet
Dim i, j, k, NbEmptyCase As Integer
' Unprotect the Excel sheet
Worksheets(WSSudoku).Unprotect Password
NbEmptyCase = 0
' Count the number of empty cell
For i = 0 To 8
For j = 0 To 8
If Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value = 0 Then NbEmptyCase = NbEmptyCase + 1
Next
Next
' If the Sudoku is already full, then launch ShowTheFullSolution_Click and exit the function
If NbEmptyCase = 0 Then
Call ShowTheFullSolution_Click
Exit Sub
End If
' Choose randomly a number to add
k = Int(NbEmptyCase * Rnd()) + 1
NbEmptyCase = 0
For i = 0 To 8
For j = 0 To 8
If Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value = 0 Then NbEmptyCase = NbEmptyCase + 1
' If the number counted (l) is equal to the number guessed (k)
If NbEmptyCase = k Then
' Print the value Solution(i, j, 0) on the Sudoku grid at the case(i,j),
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value = Solution(i, j, 0)
' Change the color of case(i,j), Wait half a second, Put back the initial color of the case(i,j)
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Interior.ColorIndex = ColorHint
bool = Wait(0.5)
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Interior.ColorIndex = xlNone
' Update the status cell
bool = ResetStatus()
bool = PrintStatus("The number " + CStr(Solution(i, j, 0)) + " was added to the case(" + CStr(i + 1) + "," + CStr(j + 1) + ").")
' To exit the loop quicker...
i = 8
j = 8
End If
Next
Next
' Protect the Excel sheet
Worksheets(WSSudoku).Protect Password
End Sub
Private Sub ShowTheFullSolution_Click()
' Write the full grid in the Excel sheet
Dim i, j, k As Integer
' Unprotect the Excel sheet
Worksheets(WSSudoku).Unprotect Password
' Test the result of the grid Solution()
k = TestGrid(Solution())
' Result of Testgrid:
If k <> 1 Then
bool = ResetStatus()
If k = -1 Then bool = PrintStatus("The grid is not feasible.")
If k = -2 Then bool = PrintStatus("The grid is not feasible and was thus not completed.")
If k = 2 Then bool = PrintStatus("The grid is not completed.")
' If the grid is solved, write the full solution
Else
bool = PrintStatus("Soduko completed.")
For i = 0 To 8
For j = 0 To 8
If (Solution(i, j, 0) <> 0 And Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Locked = False) Then Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value = Solution(i, j, 0)
Next
Next
End If
' Update the buttons
FindMyMistakes.Enabled = False
GiveMe1NumberMore.Enabled = False
ShowTheFullSolution.Enabled = False
' Protect the Excel sheet
Worksheets(WSSudoku).Protect Password
End Sub
Private Function Solve(MyArray() As Integer) As Integer
' Resolve a given grid MyArray. Can be recursive!
Dim i, j, min, k, l, M, N, Test As Integer
Dim MyArray2(8, 8, 9) As Integer
Solve = 0
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog = True Then bool = PrintLog("Solve", "Started")
' Check if the solution time is still under the limit set in the 'Options' sheet
If Not CheckTimeSolution() Then
i = MsgBox("MacroSudoku is taking too much time to solve the Sudoku. Do you want to continue anyway (be careful, this will remove the time limitation)?", vbInformation + vbOKCancel, "Solution Time Limit")
If i = vbOK Then TimeLimitSolution = 0
If i = vbCancel Then
Terminate = True
Exit Function
End If
End If
' Increase the depth of the NbLevel
NbLevel = NbLevel + 1
' Main Loop where Solve try the Sudoku rules to solve the grid
Do
Do
UpdateUsual = CheckGridUsual(MyArray())
Loop While UpdateUsual
' Solve the grid by applying the Subgroup rule
UpdateSubGroup = CheckGridSubGroup(MyArray())
Loop While UpdateSubGroup
' Check if the grid is completed
Test = TestGrid(MyArray())
If Test = 1 Then
bool = CopyArray1toArray2(MyArray(), Solution())
NbSolution = NbSolution + 1
Solve = Test
If Not BoolAllSolutions Then Exit Function
End If
If Test < 0 Then
Solve = Test
Exit Function
End If
' *********************************************************************************
' * As the grid is still unsolved by applying the Sudoku rules, Solve() will have *
' * to make a guess and to call itself with a new MyArray() *
' *********************************************************************************
If Test = 2 Then
' Copy MyArray to MyArray2 in order to keep it safe
bool = CopyArray1toArray2(MyArray(), MyArray2())
' Search the case(i,j) with the less potential-values remaining min
min = 9
For i = 0 To 8
For j = 0 To 8
' For each unknown case(i,j)
If MyArray(i, j, 0) = 0 Then
If SumVal(MyArray(), i, j) < min Then
min = SumVal(MyArray(), i, j)
k = i
l = j
End If
End If
Next
Next
' Try to solve the grid for each potential-value of the case(k,l)
For i = 1 To min
' First, copy back MyArray2(), which is a saved copy, to MyArray()
bool = CopyArray1toArray2(MyArray2(), MyArray())
' Identify the m-th value within the potential values for the case(k,l) which is still valid
M = 0
For j = 1 To 9
If MyArray(k, l, j) = 1 Then
M = M + 1
If M = i Then
N = j
j = 10
End If
End If
Next
' Add the guessed value n to the case (k,l)
bool = UpdateAll(MyArray(), k, l, N)
' And try to solve the new MyArray() with the guessed value n (Solve() is a recursive function)
Solve = Solve(MyArray())
' If Solve return a '1' (i.e. grid solved) and the function is not looking for all solutions, then exit the function
If Not BoolAllSolutions Then
If Solve = 1 Then Exit Function
End If
If Terminate Then Exit Function
Next
End If
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog = True Then bool = PrintLog("Solve", "Ended")
End Function
Private Function CheckGridUsual(MyArray() As Integer) As Boolean
' Check the grid with the 'usual' rules to remove possible value
Dim i, j, k As Integer
CheckGridUsual = False
' NbCheckU count how many times the function CheckGridUsual has been called
NbCheckU = NbCheckU + 1
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog = True Then bool = PrintLog("CheckGridUsual", "Started")
' Run each row/column and each value to see what potential-value can be deducted (only one left)
For i = 0 To 8
For k = 1 To 9
' Each row
If SumArrayRow(MyArray(), i, k) = 1 Then
For j = 0 To 8
If MyArray(i, j, k) = 1 Then
bool = UpdateAll(MyArray(), i, j, k)
CheckGridUsual = True
End If
Next
End If
' Each column
If SumArrayCol(MyArray(), i, k) = 1 Then
For j = 0 To 8
If MyArray(j, i, k) = 1 Then
bool = UpdateAll(MyArray(), j, i, k)
CheckGridUsual = True
End If
Next
End If
Next
Next
' Run each case to see what potential-value can be deducted (only one left)
For i = 0 To 8
For j = 0 To 8
If SumVal(MyArray(), i, j) = 1 Then
For k = 1 To 9
If MyArray(i, j, k) = 1 Then
bool = UpdateAll(MyArray(), i, j, k)
CheckGridUsual = True
End If
Next
End If
Next
Next
' Run each square to see what potential-value can be deducted (only one left)
For i = 0 To 2
For j = 0 To 2
For k = 1 To 9
If SumArraySqu(MyArray(), 3 * i, 3 * j, k) = 1 Then
bool = UpdateSquare(MyArray(), i, j, k)
CheckGridUsual = True
End If
Next
Next
Next
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog = True Then bool = PrintLog("CheckGridUsual", "Ended")
End Function
Private Function UpdateSquare(MyArray() As Integer, ByVal i As Integer, ByVal j As Integer, ByVal k As Integer) As Boolean
' Update the square number (i,j) for the value k, which is found
Dim l, M As Integer
FindInSquare = True
For l = 0 To 2
For M = 0 To 2
If MyArray(3 * i + l, 3 * j + M, k) = 1 Then
bool = UpdateAll(MyArray(), 3 * i + l, 3 * j + M, k)
End If
Next
Next
End Function
Private Function CheckGridSubGroup(MyArray() As Integer) As Boolean
' Check the grid with the SubGroup rule (which work with a square + a colum or a row) to remove possible value
Dim i, j, k As Integer
CheckGridSubGroup = False
' NbChecksb count how many times the function CheckGridSubGroup has been called
NbCheckSB = NbCheckSB + 1
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog = True Then bool = PrintLog("CheckGridSubGroup", "Started")
' Apply the subgroup rule for each row/column i and value k
For i = 0 To 8
For k = 1 To 9
bool = False
' For each row
j = SubGroup(MyArray(), i, k, "row")
If j <> -1 Then bool = CleanSquare(MyArray(), i, j, k, "row")
' If CleanSquare is true (the square was cleaned), then CheckGridSubGroup is true
If bool Then CheckGridSubGroup = True
' Same code than above, but for each column
j = SubGroup(MyArray(), i, k, "col")
If j <> -1 Then bool = CleanSquare(MyArray(), j, i, k, "col")
If bool Then CheckGridSubGroup = True
Next
Next
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog = True Then bool = PrintLog("CheckGridSubGroup", "Ended")
End Function
Private Function SubGroup(MyArray() As Integer, ByVal i As Integer, ByVal k As Integer, ByVal str2 As String) As Integer
' Check if the subgroup rule apply for a given value k and a given row/column i
' str2: either "col" or "row" depending on the case
' i: row/column number, depending on the case
' k: value checked for the subgroup rule
Dim j, l, M As Integer
SubGroup = -1
M = -1
' Check if the subgroup rule apply, for the i row and the k value
If str2 = "row" Then
' If there is less than 1 potential-values k in the row i, then no need to check the rule
If SumArrayRow(MyArray(), i, k) > 1 Then
For j = 0 To 8
' If the case(i,j) has a potential-value k, then l save the square number
If MyArray(i, j, k) = 1 Then
l = Pwr3(j)
SubGroup = j
' If it's the 1st case(i,j) found with a potential-value k, then m save the 1st square number
If M = -1 Then M = Pwr3(j)
' If l and m are different (= different squares), then SubGroup will be '-1', else it will give the column number of the case(i,j)
If l <> M Then
SubGroup = -1
Exit Function
End If
End If
Next
End If
' Same code than above, but i and j are now reversed (rows become columns)
Else
If SumArrayCol(MyArray(), i, k) > 1 Then
For j = 0 To 8
If MyArray(j, i, k) = 1 Then
l = Pwr3(j)
SubGroup = j
If M = -1 Then M = Pwr3(j)
If l <> M Then
SubGroup = -1
Exit Function
End If
End If
Next
End If
End If
End Function
Private Function CleanSquare(MyArray() As Integer, ByVal i As Integer, ByVal j As Integer, ByVal k As Integer, ByVal str2 As String) As Boolean
' Clean the square where the subgroup apply for the value k
' str2: either "col" or "row", depending on the case
' i: row number
' j: column number
' k: value removed in the same square than the case(i,j), expect for the i/j column/row
' CleanSquare is true if a k potential value have been removed, false if their is no value to remove
Dim l, M As Integer
CleanSquare = False
For l = 0 To 2
For M = 0 To 2
' Code for the column case
If str2 = "col" Then
' Check if the column (3 * Pwr3(j) + m) is not equal to the j column
If (3 * Pwr3(j) + M) <> j Then
' Check if the k potential value is still potential, i.e. equal to 1
If MyArray(3 * Pwr3(i) + l, 3 * Pwr3(j) + M, k) = 1 Then
MyArray(3 * Pwr3(i) + l, 3 * Pwr3(j) + M, k) = 0
CleanSquare = True
End If
End If
End If
'Same code than above but for the row case
If str2 = "row" Then
If (3 * Pwr3(i) + l) <> i Then
If MyArray(3 * Pwr3(i) + l, 3 * Pwr3(j) + M, k) = 1 Then
MyArray(3 * Pwr3(i) + l, 3 * Pwr3(j) + M, k) = 0
CleanSquare = True
End If
End If
End If
Next
Next
End Function
Private Function InitArray(MyArray() As Integer) As Boolean
' Set values of MyArray() to '0' or '1'
Dim i, j, k As Integer
InitArray = True
For i = 0 To 8
For j = 0 To 8
MyArray(i, j, 0) = 0
For k = 1 To 9
MyArray(i, j, k) = 1
Next
Next
Next
End Function
Private Function InitValue(MyArray() As Integer) As Boolean
' Copy the values of the grid from the Excel sheet, and update MyArray()
Dim i, j As Integer
ValeurInit = True
' For each cell(i,j), if the value (copied on k) is not equal to 0 then it updates MyArray()
For i = 0 To 8
For j = 0 To 8
If Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value <> 0 Then bool = UpdateAll(MyArray(), i, j, Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value)
Next
Next
End Function
Private Function ProtectInitValue() As Boolean
' Protect the initial values of the Soduko Grid and change their color
Dim i, j As Integer
ProtectInitValue = True
' Unprotect the Excel sheet
Worksheets(WSSudoku).Unprotect Password
' Unprotect all cells of the Sudoku grid
For i = 0 To 8
For j = 0 To 8
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Locked = False
Next
Next
' Re-protect only cells with an initial value
For i = 0 To 8
For j = 0 To 8
If Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value <> 0 Then
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Interior.ColorIndex = ColorInit
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Locked = True
End If
Next
Next
' Protect the Excel sheet
Worksheets(WSSudoku).Protect Password
End Function
Private Function UpdateAll(MyArray() As Integer, ByVal i As Integer, ByVal j As Integer, ByVal k As Integer) As Boolean
' Update MyArray() with the new value k in the case(i,j)
Dim l, M As Integer
UpdateAll = True
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog = True Then bool = PrintLog("UpdateAll", "Started")
' Remove the k potential-value for the whole i row and j column
For l = 0 To 8
MyArray(i, l, k) = 0
MyArray(l, j, k) = 0
Next
' Remove the k potential-value for the whole square where the case(i,j) is located
For l = 0 To 2
For M = 0 To 2
MyArray(3 * Pwr3(i) + l, 3 * Pwr3(j) + M, k) = 0
Next
Next
' Remove all potential-values for the case(i,j)
For l = 1 To 9
MyArray(i, j, l) = 0
Next
' Update MyArray: enter the k value for the grid (i,j,0) and rewrite the k value as potential
MyArray(i, j, 0) = k
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog = True Then bool = PrintLog("UpdateAll", "Ended")
End Function
Private Function Pwr3(ByVal i As Integer) As Integer
' Give the int part of (i/3)
Pwr3 = Int(i / 3)
End Function
Private Function SumVal(MyArray() As Integer, ByVal i As Integer, ByVal j As Integer) As Integer
' Count the number of remaining possible value for a given case(i,j)
Dim k As Integer
SumVal = 0
For k = 1 To 9
If MyArray(i, j, k) = 1 Then SumVal = SumVal + 1
Next
End Function
Private Function SumArrayCol(MyArray() As Integer, ByVal j As Integer, ByVal k As Integer) As Integer
' Count the number of 1 in the column j of the array MyArray(), for the value k
Dim i As Integer
SumArrayCol = 0
For i = 0 To 8
SumArrayCol = SumArrayCol + MyArray(i, j, k)
Next
End Function
Private Function SumArrayRow(MyArray() As Integer, ByVal i As Integer, ByVal k As Integer) As Integer
' Count the number of 1 in the row i of the array MyArray(), for the value k
Dim j As Integer
SumArrayRow = 0
For j = 0 To 8
SumArrayRow = SumArrayRow + MyArray(i, j, k)
Next
End Function
Private Function SumArraySqu(MyArray() As Integer, ByVal i As Integer, ByVal j As Integer, ByVal k As Integer) As Integer
' Count the number of 1 within the same square than the case (i, j) of the array MyArray(), for the value k
Dim l, M As Integer
SumArraySqu = 0
For l = 0 To 2
For M = 0 To 2
SumArraySqu = SumArraySqu + MyArray(3 * Pwr3(i) + l, 3 * Pwr3(j) + M, k)
Next
Next
End Function
Private Function PrintLog(ByVal str2 As String, ByVal str3 As String) As Boolean
' Write the log of the macro
PrintLog = True
' The function stops if Collog is above 20
If ColLog > 24 Then
Exit Function
Else
' Print the value on the log: str2 and str3, the time, LineLog and NbLevel
Worksheets(WSLog).Cells(LineLog, ColLog + 0).Value = str2
Worksheets(WSLog).Cells(LineLog, ColLog + 1).Value = str3
Worksheets(WSLog).Cells(LineLog, ColLog + 2).Value = Timer - Time
Worksheets(WSLog).Cells(LineLog, ColLog + 3).Value = LineLog
Worksheets(WSLog).Cells(LineLog, ColLog + 4).Value = NbLevel
' Increase the LineLog to prepare the new print
LineLog = LineLog + 1
' If linelog reach 65536, the macro will make an error (Excel limitation). To avoid this, Linelog is put back to 2 and ColLog is increased by 6
If LineLog = 65536 Then
LineLog = 2
ColLog = ColLog + 6
End If
End If
End Function
Private Function InitLog() As Boolean
' Init/Clear the log sheet
' Clear contents of the 28 first columns
Worksheets(WSLog).Range("A:AB").ClearContents
' Write the titles
Worksheets(WSLog).Cells(1, 1).Value = "Processus"
Worksheets(WSLog).Cells(1, 2).Value = "Start/End"
Worksheets(WSLog).Cells(1, 3).Value = "Time"
Worksheets(WSLog).Cells(1, 4).Value = "Line"
Worksheets(WSLog).Cells(1, 5).Value = "NbLevel"
End Function
Private Function TestGrid(MyArray() As Integer) As Integer
' Test the grid to see if it's completed (or not) or feasible (or not)
' -2 if the grid is false and not completed
' -1 if the grid is false and completed
' 1 if the grid is not false and completed
' 2 if the grid is not false and not completed
Dim bF, bC As Boolean
Dim aTestCol(9) As Integer
Dim aTestRow(9) As Integer
Dim i, j, k, l As Integer
bF = True
bC = True
For i = 0 To 8
For j = 0 To 8
If MyArray(i, j, 0) = 0 Then bC = False
Next
Next
' Test each column and each row to see if each value is there only once
For i = 0 To 8
bool = ResetaTest(aTestCol())
bool = ResetaTest(aTestRow())
For j = 0 To 8
aTestCol(MyArray(i, j, 0)) = aTestCol(MyArray(i, j, 0)) + 1
aTestRow(MyArray(j, i, 0)) = aTestRow(MyArray(j, i, 0)) + 1
Next
If TestaTest(aTestCol()) = False Then bF = False
If TestaTest(aTestRow()) = False Then bF = False
Next
' Test each square to see if each value is here only once
For i = 0 To 2
For j = 0 To 2
' Testing each square
bool = ResetaTest(aTestCol())
For k = 0 To 2
For l = 0 To 2
aTestCol(MyArray(3 * i + k, 3 * j + l, 0)) = aTestCol(MyArray(3 * i + k, 3 * j + l, 0)) + 1
Next
Next
If TestaTest(aTestCol()) = False Then bF = False
Next
Next
' Test if all potential-values are forbidden (=0)
l = 0
For i = 0 To 8
For j = 0 To 8
For k = 1 To 9
l = l + MyArray(i, j, k)
' Created to exit the loop quicker as soon as a potential value have been found
If l > 1 Then
i = 9
j = 9
k = 10
End If
Next
Next
Next
' If no potential-values is still valid then the grid if false
If l = 0 Then
If bC = False Then
bF = False
End If
End If
If bC Then
TestGrid = 1
Else
TestGrid = 2
End If
If bF = False Then TestGrid = -TestGrid
End Function
Private Function ResetaTest(aTest() As Integer) As Boolean
' Reset aTest by setting all values to '0'
Dim i As Integer
ResetTest = True
For i = 1 To 9
aTest(i) = 0
Next
End Function
Private Function TestaTest(aTest() As Integer) As Boolean
' See if any value between 1 and 9 was counted more than once
' ATest() is an array of Integer(9), counting for each value i how many times they were counted in aTest(i)
Dim i As Integer
TestaTest = True
For i = 1 To 9
If aTest(i) > 1 Then TestaTest = False
Next
End Function
Private Function CopyArray1toArray2(MyArray1() As Integer, MyArray2() As Integer) As Boolean
' Copy all values from MyArray1(8,8,9) to MyArray2(8,8,9)
' Was created because it was not possible to use a ByVal Array() as a parameter in a function (no idea why!!)
Dim i, j, k As Integer
CopyArray1toArray2 = True
For i = 0 To 8
For j = 0 To 8
For k = 0 To 9
MyArray2(i, j, k) = MyArray1(i, j, k)
Next
Next
Next
End Function
Private Function PrintStatus(str2 As String) As Boolean
' Print the string str2 in the status cell
Dim str As String
' Unprotect the Excel sheet and the Status cell
Worksheets(WSSudoku).Unprotect Password
' Check if the cell Status is empty are already containing a string str
str = Worksheets(WSSudoku).Cells(14, 2).Value
If str <> "" Then
Worksheets(WSSudoku).Cells(14, 2).Value = str + " " + str2
Else
Worksheets(WSSudoku).Cells(14, 2).Value = str2
End If
' Protect the Excel sheet and the Status cell
Worksheets(WSSudoku).Protect Password
PrintStatus = True
End Function
Private Function ResetStatus() As Boolean
' Reset the status cell
' Unprotect the Excel sheet and the Status cell
Worksheets(WSSudoku).Unprotect Password
Worksheets(WSSudoku).Cells(14, 2).Value = ""
' Protect the Excel sheet and the Status cell
Worksheets(WSSudoku).Protect Password
ResetStatus = True
End Function
Private Function CheckIfAllInteger() As Boolean
' Check if all initial values are integers and below 10
Dim i, j As Integer
Dim k As Double
Dim str2 As String
CheckIfAllInteger = True
' For each case(i,j) of the sudoku grid
For i = 0 To 8
For j = 0 To 8
' str2 is a string showing the value type
str2 = TypeName(Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value)
' Values can be Integer or Empty, or else they will need to be checked
If str2 <> "Integer" And str2 <> "Empty" Then
' But if they are Long, Single, or Double, it can be a format mistake (for example, 1 entered as a double)
If str2 = "Long" Or str2 = "Single" Or str2 = "Double" Then
k = Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value
If k <> Int(k) Then
k = MsgBox("Please enter only integer numbers on the Sudoku.", vbOKOnly + vbExclamation, "Error")
CheckIfAllInteger = False
Exit Function
End If
Else
k = MsgBox("Please enter only integer numbers on the Sudoku.", vbOKOnly + vbExclamation, "Error")
CheckIfAllInteger = False
Exit Function
End If
End If
' Check if the number is below 9
If str2 = "Integer" Or str2 = "Long" Or str2 = "Single" Or str2 = "Double" Then
k = Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value
If k > 9 Or k < 0 Then
k = MsgBox("Please enter only integer numbers between 1 and 9 on the Sudoku.", vbOKOnly + vbExclamation, "Error")
CheckIfAllInteger = False
Exit Function
End If
End If
Next
Next
End Function
Private Function PrintWarning() As Boolean
' Make the status cell changing color
Dim Time2 As Double
PrintWarning = True
' Unprotect the Excel sheet and the Status cell
Worksheets(WSSudoku).Unprotect Password
Time2 = Timer
Do
Worksheets(WSSudoku).Cells(14, 2).Interior.ColorIndex = ColorMistake
bool = Wait(0.2)
Worksheets(WSSudoku).Cells(14, 2).Interior.ColorIndex = xlNone
bool = Wait(0.2)
Loop While (Timer - Time2) < 2
' Protect the Excel sheet and the Status cell
Worksheets(WSSudoku).Protect Password
End Function
Private Function Wait(ByVal Dbl As Double) As Boolean
' Wait a given time, given by dbl
Dim Time2 As Double
Wait = True
Time2 = Timer
Do
Loop While (Timer - Time2) < Dbl
End Function
Private Sub CreateANewSudokuGrid_Click()
' Init the process of creation of a valid Sudoku grid
Dim i, j, k, l, Nbr, NbMiniValue, NbrGridGenerated As Integer
Dim Grid(8, 8) As Integer
Dim Soluce(8, 8) As Integer
Dim MyArray(8, 8, 9) As Integer
Randomize
' Set the MacroSudoku sheet zoom ability and scroll area
' !!!! move this to 'This workbook', in the macro "Private Sub Workbook_open()"
' doesn't work....Worksheets(WSSudoku).PageSetup.Zoom = False
Worksheets(WSSudoku).ScrollArea = "$A$1:$V$15"
' Init the log if it's turned on (i.e. if BoolLog is True)
If BoolLog Then bool = InitLog()
If BoolLog Then bool = PrintLog("CreateANewSudokuGrid", "Started")
LineLog = 2
ColLog = 1
' Set the options
bool = SetOptions()
' TimeGeneration count the time needed to generate a grid
TimeGeneration = Timer
NbrGridGenerated = 0
' Main loop: create Sudoku until it reaches the level of difficulty set in Options, or when TimeGeneration is expired
Do
' Init MyArray()
bool = InitArray(MyArray())
NbrGridGenerated = NbrGridGenerated + 1
' Launch the recursive function CreateValidGrid with BoolAllSolutions as False, then put it back as True
BoolAllSolutions = False
bool = CreateValidGrid(0, MyArray())
BoolAllSolutions = True
' Init the array Grid()
' Grid can have 3 possible values for each case(i,j)
' 1: not tested, not empty (x is the value of the Solution)
' 0: tested, empty
' -1: tested, not empty (because it leads to a more-than-1-solution grid)
For i = 0 To 8
For j = 0 To 8
Grid(i, j) = 1
Soluce(i, j) = Solution(i, j, 0)
Next
Next
' Set NbMiniValue depending on the difficulty set in options
If OptionsDifficulty = "Very Easy" Then
NbMiniValue = 10
Else
If OptionsDifficulty = "Easy" Then
NbMiniValue = 5
Else
NbMiniValue = 0
End If
End If
' Remove all not-needed value (i.e. as long as there is still only 1 solution)
Do
' Choose a random case which is NOT empty and NOT tested
Do
k = Int(Rnd() * 9)
l = Int(Rnd() * 9)
Loop While Grid(k, l) < 1
' Remove the number of the case(k,l)
Grid(k, l) = 0
NbSolution = 0
' Init MyArray()
bool = InitArray(MyArray())
' Copy the Soluce(i,j) values to MyArray() for each value not empty (Grid(i,j) <> 0)
For i = 0 To 8
For j = 0 To 8
If Grid(i, j) <> 0 Then
bool = UpdateAll(MyArray(), i, j, Soluce(i, j))
End If
Next
Next
' Solve the incomplete solution
TimeSolution = Timer
Test = Solve(MyArray())
' Count the number of solution
If NbSolution > 1 Then
Grid(k, l) = -1
End If
' Count how many numbers can still be removed
Nbr = 0
For i = 0 To 8
For j = 0 To 8
If Grid(i, j) = 1 Then Nbr = Nbr + 1
Next
Next
' Check if the generation time is still under the limit set in the 'Options' sheet
If Not CheckTimeGeneration() Then
i = MsgBox("MacroSudoku is taking too much time to generate a Sudoku at the difficulty set in 'Options'. Do you want to continue anyway (be careful, this will remove the time limitation)?", vbInformation + vbOKCancel, "Generation Time Limit")
If i = vbOK Then TimeLimitGeneration = 0
If i = vbCancel Then Exit Sub
End If
Loop While Nbr > NbMiniValue
' NbLevel/NbCheckU/NbCheckSB count the number of time each main function is called.
NbLevel = 0
NbCheckU = 0
NbCheckSB = 0
NbSolution = 0
' to remove!! prevent the MacroSudoku to generate very hard BoolAllSolutions = False
' Init MyArray()
bool = InitArray(MyArray())
' Copy the Soluce(i,j) values to MyArray() for each value not empty (Grid(i,j) <> 0)
For i = 0 To 8
For j = 0 To 8
If Grid(i, j) <> 0 Then bool = UpdateAll(MyArray(), i, j, Soluce(i, j))
Next
Next
' Solve the Sudoku grid
TimeSolution = Timer
Test = Solve(MyArray())
' Estimate the difficulty of the grid
bool = EstimateDifficulty(Int(100000 * (Timer - TimeSolution)) / 100)
' Check if the generation time is still under the limit set in the 'Options' sheet
If Not CheckTimeGeneration() Then
i = MsgBox("MacroSudoku is taking too much time to generate a Sudoku at the difficulty set in 'Options'. Do you want to continue anyway (be careful, this will remove the time limitation)?", vbInformation + vbOKCancel, "Generation Time Limit")
If i = vbOK Then TimeLimitGeneration = 0
If i = vbCancel Then Exit Sub
End If
' to remove!!
bool = PrintStatus(CStr(NbrGridGenerated))
Loop While Difficulty <> OptionsDifficulty
' Print the Sudoku generated
For i = 0 To 8
For j = 0 To 8
If Grid(i, j) <> 0 Then
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value = Soluce(i, j)
Else
Worksheets(WSSudoku).Cells(Row1 + i, Col1 + j).Value = ""
End If
Next
Next
' Update the status bar
bool = ResetStatus()
bool = PrintStatus(CStr(NbrGridGenerated) + " Sudoku(s) generated in " + CStr(Int(100000 * (Timer - TimeGeneration)) / 100) + " milliseconds. ")
bool = PrintStatus("Sudoku solved in " + CStr(Int(100000 * (Timer - TimeSolution)) / 100) + " milliseconds. Sudoku rated as '" + Difficulty + "'. There is only " + CStr(NbSolution) + " solution.")
' Protect all the initial values
bool = ProtectInitValue()
' Update the buttons
FindMyMistakes.Enabled = True
GiveMe1NumberMore.Enabled = True
ShowTheFullSolution.Enabled = True
EmptyTheSudokuGrid.Enabled = True
AnalyseTheSudokuGrid.Enabled = False
CreateANewSudokuGrid.Enabled = False
' Update the log if it's turned on (i.e. if BoolLog is True)
If BoolLog Then bool = PrintLog("CreateANewSudokuGrid", "Ended")
End Sub
Private Function CreateValidGrid(NbrValue As Integer, MyArray() As Integer) As Boolean
' Create a valid Sudoku grid. Also recursive, like Solution. Call itself until the number of set figure is equal to NbInitValue
Dim i, j, k, Test As Integer
Dim MyArray2(8, 8, 9) As Integer
CreateValidGrid = True
Randomize
' Copy MyArray to MyArray2 for safety (possibilty to go back)
bool = CopyArray1toArray2(MyArray(), MyArray2())
' Choose a random case which is empty
Do
i = Int(Rnd() * 9)
j = Int(Rnd() * 9)
Loop While MyArray(i, j, 0) <> 0
' Choose a random value k to add to the case(i,j)
k = Int(Rnd() * 9) + 1
' Add the value k to the case(i,j)
bool = UpdateAll(MyArray(), i, j, k)
' Test the result of the grid
TimeSolution = Timer
Test = Solve(MyArray())
' MyArray2 is used to change MyArray to its previous state
bool = CopyArray1toArray2(MyArray2(), MyArray())
' If the grid is still valid, then the value k is added to the case(i,j) and the number of value is increased
If Test > 0 Then
NbrValue = NbrValue + 1
bool = UpdateAll(MyArray(), i, j, k)
End If
' Check if the grid has the number of set-numbers required = NbInitValue. If yes, then it stops. if not, then it calls itself.
If NbrValue = NbInitValue Then
Exit Function
Else
bool = CreateValidGrid(NbrValue, MyArray())
End If
End Function
Private Function SetOptions() As Boolean
' Set the Options values from the Option sheet
SetOptions = True
' Get if the macro should look for all solutions and if it should use the log
BoolAllSolutions = Worksheets(WSOptions).AllSolutionTrue.Value
BoolLog = Worksheets(WSOptions).LogTrue.Value
' Get the color of each kind of cell (
ColorInit = Worksheets(WSOptions).Cells(6, 3).Interior.ColorIndex
ColorHint = Worksheets(WSOptions).Cells(8, 3).Interior.ColorIndex
ColorMistake = Worksheets(WSOptions).Cells(10, 3).Interior.ColorIndex
' Get the time limitation for Solution and Generation
TimeLimitSolution = Worksheets(WSOptions).Cells(6, 13).Value
TimeLimitGeneration = Worksheets(WSOptions).Cells(8, 13).Value
' Get the Difficulty set in the Options sheet, set OptionsDifficulty
If Worksheets(WSOptions).SudokuDifficultyVE.Value Then OptionsDifficulty = "Very Easy"
If Worksheets(WSOptions).SudokuDifficultyE.Value Then OptionsDifficulty = "Easy"
If Worksheets(WSOptions).SudokuDifficultyM.Value Then OptionsDifficulty = "Medium"
If Worksheets(WSOptions).SudokuDifficultyD.Value Then OptionsDifficulty = "Difficult"
If Worksheets(WSOptions).SudokuDifficultyVD.Value Then OptionsDifficulty = "Very Difficult"
End Function
Private Function EstimateDifficulty(ByVal Dbl As Double) As Boolean
' Estimate the difficulty based on a calculation from: NbLevel, NbCheckSB, NbCheckU and Time
EstimateDifficulty = True
' 5: Very difficult. If the macro had to make at least 5 guess
If NbLevel > 5 Then
Difficulty = "Very difficult"
Exit Function
End If
' 4: Difficult. If the macro had to make at least 2 guess.
If NbLevel > 2 Then
Difficulty = "Difficult"
Exit Function
End If
' 3: Medium. If the macro had to use the SubGroup rule and resolution time>30
If NbCheckSB > 0 And ((Dbl > 60 And BoolAllSolutions) Or (Dbl > 30 And Not BoolAllSolutions)) Then
Difficulty = "Medium"
Exit Function
End If
' 2: Easy. If the macro did not have to make guess AND to use SubGroup rule.
If Dbl > 15 Then
Difficulty = "Easy"
Exit Function
End If
' 1: Very Easy. Used in all other cases
Difficulty = "Very Easy"
End Function
Private Function VeryLongComputingTime(MyArray() As Integer) As Boolean
' Check if the user want to continue when there is not enough initial values
Dim i, j, k As Integer
VeryLongComputingTime = False
k = 0
For i = 0 To 8
For j = 0 To 8
If MyArray(i, j, 0) <> 0 Then k = k + 1
Next
Next
If k < 10 Then i = MsgBox("You have launched the resolution of the Sudoku with only " + CStr(k) + " initial values." + Chr(10) + "Since the macro also has to search for all solutions, the MacroSudoku" + Chr(10) + "might take a very long time to end. Do you want to continue?", vbOKCancel + vbExclamation, "Very long processing time")
If i = vbCancel Then VeryLongComputingTime = True
End Function
Private Function CheckTimeSolution() As Boolean
' Check if the the time of solution is still under the limit set in 'Options'
CheckTimeSolution = True
If TimeLimitSolution = 0 Then Exit Function
If (Timer - TimeSolution) > TimeLimitSolution * 60 Then CheckTimeSolution = False
End Function
Private Function CheckTimeGeneration() As Boolean
' Check if the the time of solution is still under the limit set in 'Options'
CheckTimeGeneration = True
If TimeLimitGeneration = 0 Then Exit Function
If (Timer - TimeGeneration) > TimeLimitGeneration * 60 Then CheckTimeGeneration = False
End Function
Codes Sources
A voir également
- Macrosudoku v1.2 bêta eng
- Europnet beta - Forum IRC
- Arbre alpha-beta - Forum C
- Avis au créateur de chat (surtout IRc) - Forum Visual Basic
- Bannir du tchat - Forum IRC
- Durée de gline - Forum IRC
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.