数独解析VBコード
[ VBA ]コード
サンプルコード
'VB(2017)用コード '■数独を解析し結果を表示する関数 坂江保 '構文 Sudoku_Kaiseki_Main(ByRef lngRangeS(,) As Integer, ByRef s As String, Optional SmallLarge As Boolean = True) As Integer ' '戻り値 Integer型。解析の成功は「0」、それ以外はなんらかのエラー。エラー番号に対応する定数でエラー内容を表示 ' lngRangeS(,) 9×9の2次元配列に格納された数値を解析する。解析結果はこの引数 lngRangeS(,) に格納される。 ' s 解析時にエラー起きた場合、エラー内容がこの引数 s に格納される。 ' SmallLarge 仮定法を使用し解析する場合、小さな数字・大きな数字のどちらから仮定するかを設定 ' 小さい数字から設定する場合は「True」。省略した場合はTrue。 '【使用例】・・・セル範囲[A1:I9]の数字を基に解析を行い、結果をセル範囲[A1:I9]に表示 'Sub Sample_DLL()'VBAコード ' Dim clsSudoku As New Sudoku_Kaiseki.analysis_sudoku 'クラスをインスタンス化 ' Dim i As Long, j As Long ' Dim lngRangeS(9, 9) As Long, s As String, v As Variant ' v = Range("A1:I9").Value ' For i = 1 To 9 ' For j = 1 To 9 ' lngRangeS(i, j) = v(i, j) ' Next ' Next ' If 0 < clsSudoku.Sudoku_Kaiseki_Main(lngRangeS, s, True) Then ' MsgBox s ' Exit Sub ' End If ' For i = 1 To 9 ' For j = 1 To 9 ' v(i, j) = lngRangeS(i, j) ' Next ' Next ' Range("A11:I19").Value = v 'End Sub
Imports System Imports System.Runtime.InteropServices Namespace MyAnalysis <ComVisible(True)> Public Interface IAnalysis_sudoku Function Sudoku_Kaiseki_Main(ByRef lngRangeS(,) As Integer, ByRef s As String, Optional SmallLarge As Boolean = True) As Integer End Interface <ClassInterface(ClassInterfaceType.None)> Public Class analysis_sudoku Implements IAnalysis_sudoku Private lngS(,) As Integer Private bolKNum(,,) As Boolean 'エラーナンバー Private Const ERR_0 As Byte = 0 Private Const ERR_1 As Byte = 1 Private Const ERR_2 As Byte = 2 Private Const ERR_3 As Byte = 3 Private Const ERR_4 As Byte = 4 'エラー内容 Private Const ERROR1 As String = "数値以外は入力しないで下さい。" Private Const ERROR2 As String = "既に全てのマスが埋まっています。" Private Const ERROR3 As String = "この問題は解析不可能です。" Private Const ERROR4 As String = "解析に失敗しました。" Private lngKI As Integer Private lngKP As Integer Private lngKRow As Integer Private lngKCol As Integer Private lngKMin As Integer Private lngKMinY As Integer Private lngKMinX As Integer Private lngKBlank As Integer Private lngExStage As Integer Private bolKExRe As Boolean Private bolContradiction As Boolean Private bolConcatenation As Boolean Structure Separation Dim Value(,) As Integer Dim Count(,) As Integer End Structure Private typSep(52) As Separation Private typEmp As Separation
Public Function Sudoku_Kaiseki_Main(ByRef lngRangeS(,) As Integer, ByRef s As String, Optional SmallLarge As Boolean = True) As Integer Implements IAnalysis_sudoku.Sudoku_Kaiseki_Main Dim i As Integer, j As Integer Dim lngKCheck As Integer, lngKCheck2 As Integer On Error GoTo FIN Call Initialize_K() Sudoku_Kaiseki_Main = Eqipment_K(lngRangeS) If 0 < Sudoku_Kaiseki_Main Then GoTo FIN If Check_Overlap() Then ' Sudoku_Kaiseki_Main = ERR_3 : GoTo FIN End If Do lngKCheck = lngKBlank If lngKBlank < 41 Then Call First_Check_1() Else First_Check_2() If bolContradiction Then GoTo BOLR If lngKCheck = lngKBlank Then Do lngKCheck2 = lngKBlank Call Second_Check() Loop Until lngKCheck2 = lngKBlank If lngKCheck = lngKBlank Then If Examine() Then GoTo BOLR Call Blank_Cells_Count() If bolConcatenation Then bolContradiction = Check_Overlap() If bolContradiction Then GoTo BOLR If lngKCheck = lngKBlank Then bolContradiction = Check_bolKNum() BOLR: Do If bolContradiction Then bolContradiction = False If lngExStage < 2 Then Sudoku_Kaiseki_Main = ERR_3 : GoTo FIN If bolKExRe Then bolKExRe = False Else Call Set_Again() Else Call Examine(True) lngExStage = lngExStage + 1 Call typRedim(lngExStage) With typSep(lngExStage) For i = 1 To 9 For j = 1 To 9 typSep(lngExStage).Value(i, j) = lngS(i, j) Next Next End With End If Call Katei_Check(SmallLarge) Loop Until bolKExRe = False End If End If End If Loop Until lngKBlank < 1 On Error GoTo 0 For i = 1 To 9 For j = 1 To 9 lngRangeS(i, j) = lngS(i, j) Next Next Return Sudoku_Kaiseki_Main Exit Function FIN: Select Case Sudoku_Kaiseki_Main Case ERR_0 s = ERROR4 : Sudoku_Kaiseki_Main = ERR_4 Case ERR_1 s = ERROR1 Case ERR_2 s = ERROR2 Case ERR_3 s = ERROR3 End Select Return Sudoku_Kaiseki_Main End Function
Private Sub Initialize_K() lngKBlank = 0 lngExStage = 1 bolKExRe = False bolContradiction = False ReDim lngS(9, 9) ReDim bolKNum(9, 9, 9) End Sub
Private Function Eqipment_K(ByVal lngRangeSudoku(,) As Integer) As Integer Dim i As Integer, j As Integer, k As Integer Call typRedim(1) With typSep(1) For i = 1 To 9 For j = 1 To 9 k = lngRangeSudoku(i, j) Select Case k Case 1 To 9 lngS(i, j) = k .Value(i, j) = k bolKNum(i, j, k) = True Case Else For k = 1 To 9 bolKNum(i, j, k) = True Next lngKBlank = lngKBlank + 1 End Select Next Next End With If lngKBlank = 0 Then Eqipment_K = ERR_2 Return Eqipment_K End Function
Private Sub typRedim(ByVal i As Integer) With typSep(i) ReDim .Value(9, 9) ReDim .Count(9, 9) End With End Sub
Private Function Check_Overlap() As Boolean Dim i As Integer, j As Integer, k As Integer, l As Integer, n As Integer For i = 1 To 9 For j = 1 To 9 If 0 < lngS(i, j) Then n = lngS(i, j) For k = i + 1 To 9 If n = lngS(k, j) Then GoTo OVERLAP Next For k = j + 1 To 9 If n = lngS(i, k) Then GoTo OVERLAP Next If Not (i Mod 3 = 0) Then Call Row_Col_Value(i, j) For k = lngKRow To lngKRow + 2 For l = lngKCol To lngKCol + 2 If i = k Or j = l Then Else If n = lngS(k, l) Then GoTo OVERLAP Next Next End If End If Next Next Return False Exit Function OVERLAP: Return True End Function
Private Sub Row_Col_Value(ByVal y As Integer, ByVal x As Integer) lngKRow = ((y - 1) \ 3) * 3 + 1 lngKCol = ((x - 1) \ 3) * 3 + 1 End Sub
Private Sub First_Check_1() Dim i As Integer, j As Integer For i = 1 To 9 For j = 1 To 9 If lngS(i, j) = 0 Then Call Tate_Yoko(i, j) Call Masu(i, j) If Kakunin(i, j) Then Exit Sub End If Next Next End Sub
Private Sub First_Check_2() Dim i As Integer, j As Integer For i = 1 To 9 For j = 1 To 9 If 0 < lngS(i, j) Then If bolKNum(i, j, lngS(i, j)) Then Else bolContradiction = True : Exit Sub Call Row_Col_Value(i, j) Call Number_Determination(lngKRow, lngKCol, i, j, lngS(i, j)) End If Next Next End Sub
Private Sub Second_Check() Dim i As Integer, j As Integer For i = 1 To 9 For j = 1 To 9 If lngS(i, j) = 0 Then Call Check_Other_Areas(i, j) Next Next End Sub
Private Sub Tate_Yoko(ByVal y As Integer, ByVal x As Integer) Dim i As Integer For i = 1 To 9 If lngS(i, x) = 0 Then Else bolKNum(y, x, lngS(i, x)) = False If lngS(y, i) = 0 Then Else bolKNum(y, x, lngS(y, i)) = False Next End Sub
Private Sub Masu(ByVal y As Integer, ByVal x As Integer) Dim i As Integer, j As Integer Call Row_Col_Value(y, x) For i = lngKRow To lngKRow + 2 For j = lngKCol To lngKCol + 2 If lngS(i, j) = 0 Then Else bolKNum(y, x, lngS(i, j)) = False Next Next End Sub
Private Function Kakunin(ByVal y As Integer, ByVal x As Integer) As Boolean Dim i As Integer, v As Integer, c As Integer For i = 1 To 9 If bolKNum(y, x, i) Then c = c + 1 : v = i Next If c = 1 Then lngS(y, x) = v lngKBlank = lngKBlank - 1 ElseIf c = 0 Then bolContradiction = True Kakunin = True End If Return Kakunin End Function
Private Sub Check_Other_Areas(ByVal y As Integer, ByVal x As Integer) Dim i As Integer, j As Integer, k As Integer Call Row_Col_Value(y, x) For i = 1 To 9 If bolKNum(y, x, i) Then Do For j = 1 To 9 If y = j Then Else If bolKNum(j, x, i) Then Exit Do Next GoTo DEC Loop Do For j = 1 To 9 If x = j Then Else If bolKNum(y, j, i) Then Exit Do Next GoTo DEC Loop Do For j = lngKRow To lngKRow + 2 For k = lngKCol To lngKCol + 2 If y = j And x = k Then Else If bolKNum(j, k, i) Then Exit Do Next Next GoTo DEC Loop End If Next Exit Sub DEC: lngS(y, x) = i Call Number_Determination(lngKRow, lngKCol, y, x, i) lngKBlank = lngKBlank - 1 End Sub
Private Sub Number_Determination(ByVal LR As Integer, ByVal LC As Integer, ByVal LY As Integer, ByVal LX As Integer, ByVal LV As Integer) Dim i As Integer, j As Integer For i = 1 To 9 bolKNum(LY, LX, i) = False bolKNum(i, LX, LV) = False bolKNum(LY, i, LV) = False Next For i = LR To LR + 2 For j = LC To LC + 2 bolKNum(i, j, LV) = False Next Next bolKNum(LY, LX, LV) = True End Sub
Private Function Examine(Optional f As Boolean = False) As Boolean Dim i As Integer, j As Integer lngKMin = 0 For i = 1 To 9 For j = 1 To 9 If lngS(i, j) = 0 Then If Concatenation(i, j) Then Return True Exit Function End If End If Next Next If f Then Return False Exit Function Else bolConcatenation = False End If For i = 1 To 9 For j = 1 To 9 Call Check_Alliance(i, j) Next Next Return False End Function
Private Function Concatenation(ByVal y As Integer, ByVal x As Integer) As Boolean Dim r As Integer r = Join_Main(y, x) If r = 0 Then bolContradiction = True Concatenation = True Return True Exit Function End If lngS(y, x) = r Call MinY_MinX(y, x, r) Return False End Function
Private Sub MinY_MinX(ByVal y As Integer, ByVal x As Integer, ByVal TNum As Integer) If 9 < TNum Then Else Exit Sub If lngKMin = 0 Or TNum < lngKMin Then lngKMin = TNum : lngKMinY = y : lngKMinX = x End If End Sub
Private Sub Check_Alliance(ByVal y As Integer, ByVal x As Integer) Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, n As Integer, o As Integer, p As Integer, q As Integer, r As Integer, v As Integer Dim lngLen As Integer, lngSV As Integer, lngValue As Integer If lngS(y, x) < 10 Then Exit Sub v = lngS(y, x) lngLen = Len(CStr(v)) If 5 < lngLen Then Exit Sub For i = 1 To 9 If v = lngS(i, x) Then m = m + 1 If lngS(i, x) < 10 Then n = n + 1 If v = lngS(y, i) Then o = o + 1 If lngS(y, i) < 10 Then p = p + 1 Next If m = lngLen And Not (lngLen = 9 - n) Then lngValue = v For i = 1 To lngLen lngSV = lngValue Mod 10 For j = 1 To 9 Call Join_Number(j, x, lngSV, v) Next lngValue = Int(lngValue / 10) Next End If If o = lngLen And Not (lngLen = 9 - p) Then lngValue = v For i = 1 To lngLen lngSV = lngValue Mod 10 For j = 1 To 9 Call Join_Number(y, j, lngSV, v) Next lngValue = Int(lngValue / 10) Next End If Call Row_Col_Value(y, x) For i = lngKRow To lngKRow + 2 For j = lngKCol To lngKCol + 2 If v = lngS(i, j) Then q = q + 1 If lngS(i, j) < 10 Then r = r + 1 Next Next If q = lngLen And Not (lngLen = 9 - r) Then lngValue = v For i = 1 To lngLen lngSV = lngValue Mod 10 For j = lngKRow To lngKRow + 2 For k = lngKCol To lngKCol + 2 Call Join_Number(j, k, lngSV, v) Next Next lngValue = Int(lngValue / 10) Next End If End Sub
Private Sub Join_Number(ByVal N1 As Integer, ByVal N2 As Integer, ByVal N3 As Integer, p As Integer) If 9 < lngS(N1, N2) Then If p = lngS(N1, N2) Then Exit Sub If bolKNum(N1, N2, N3) Then bolConcatenation = True bolKNum(N1, N2, N3) = False lngS(N1, N2) = Join_Main(N1, N2) End If End If End Sub
Private Function Join_Main(ByVal y As Integer, ByVal x As Integer) As Integer Dim i As Integer For i = 1 To 9 If bolKNum(y, x, i) Then If Join_Main = 0 Then Join_Main = i Else Join_Main = Join_Main * 10 + i End If End If Next Return Join_Main End Function
Private Function Check_bolKNum() As Boolean Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer For i = 1 To 9 For j = 1 To 9 Do For k = 1 To 9 If bolKNum(j, k, i) Then Exit Do Next GoTo OUT Loop Do For k = 1 To 9 If bolKNum(k, j, i) Then Exit Do Next GoTo OUT Loop Next For j = 1 To 7 Step 3 For k = 1 To 7 Step 3 Do For l = j To j + 2 For m = k To k + 2 If bolKNum(l, m, i) Then Exit Do Next Next GoTo OUT Loop Next Next Next Return False Exit Function OUT: Check_bolKNum = True Return True End Function
Private Sub Katei_Check(ByVal f As Boolean) With typSep(lngExStage) lngKP = .Value(lngKMinY, lngKMinX) lngKI = .Count(lngKMinY, lngKMinX) + 1 If Len(CStr(lngKP)) < lngKI Then Call Back_Stage() Else .Count(lngKMinY, lngKMinX) = lngKI Call Run_Katei(f) End If End With End Sub
Private Sub Back_Stage() lngExStage = lngExStage - 1 bolContradiction = True bolKExRe = True Call Set_Again() Call typRedim(lngExStage + 1) End Sub
Private Sub Run_Katei(ByVal f As Boolean) Dim i As Integer, lngKateiNum As Integer If f Then lngKateiNum = CLng(Mid$(CStr(lngKP), lngKI, 1)) Else lngKateiNum = CLng(Mid$(CStr(lngKP), Len(CStr(lngKP)) - lngKI + 1, 1)) End If lngS(lngKMinY, lngKMinX) = lngKateiNum For i = 1 To 9 bolKNum(lngKMinY, lngKMinX, i) = False Next bolKNum(lngKMinY, lngKMinX, lngKateiNum) = True Call Blank_Cells_Count() End Sub
Private Sub Set_Again() Dim i As Integer, j As Integer, k As Integer, l As Integer, r As Integer, lngLen As Integer lngKMin = 0 lngKBlank = 0 ReDim bolKNum(9, 9, 9) With typSep(lngExStage) For i = 1 To 9 For j = 1 To 9 lngS(i, j) = .Value(i, j) r = lngS(i, j) If r = 0 Then lngKBlank = lngKBlank + 1 ElseIf r < 10 Then bolKNum(i, j, r) = True Else lngKBlank = lngKBlank + 1 Call MinY_MinX(i, j, r) lngLen = Len(CStr(r)) For l = 1 To lngLen k = r Mod 10 bolKNum(i, j, k) = True r = Int(r / 10) Next End If Next Next End With End Sub
Private Sub Blank_Cells_Count() Dim i As Integer, j As Integer lngKBlank = 0 For i = 1 To 9 For j = 1 To 9 If lngS(i, j) = 0 Then lngKBlank = lngKBlank + 1 ElseIf 9 < lngS(i, j) Then lngKBlank = lngKBlank + 1 lngS(i, j) = 0 End If Next Next End Sub
End Class End Namespace
