AI×エクセルVBAで数独を解く　上級編

以前に数独の初級編、中級編をエクセルVBAで解いてみた記事の続編です。
今回はAIを使って、前回の記事では解けなかった難易度の問題を解くコードを作成してみます。

数独のルールと基本的な解き方はこちら。（ニコリ公式チャンネルより）
数独はペンシルパズル雑誌「二コリ」から生まれたパズルです。

問題をAIに作ってもらう
AI×エクセルVBAで数独を解く　コーディング
テスト
AIで作成したVBAコード
まとめ

問題をAIに作ってもらう

こういう記事を書く際に難しいのが問題作りなのですが、今回はこれもAIにやってもらいます。
既存の問題サンプル問題として画像で読み込ませて、いったん解いてもらう。
そしてその問題の難易度と同じくらいの問題を作ってもらいました。

上記、一言だけ「先ほど読みこんだ画像の難易度と同じくらいの問題を作ってください」としていますが、具体的には解法のセオリーを指定し
「〇〇法と〇〇法を使って解くレベルの問題を作ってください」
だとより具体的なレベル設定ができると思います。

AI×エクセルVBAで数独を解く　コーディング

問題を作ってもらったら、次はコーディングです。
今回は下記で作ったコードを読み込ませて、それをベースにしてもらうことにしました。

具体的には
「この問題をエクセルVBAで解くためのコードを作ってください。
ただし下記のコードをベースに作り直してください
—————————-
（ここに前回のコードを貼り付け）」
としました。

テスト

実際にAI自身に問題を作らせ、作ってもらったコードで解き、エラーが発生したらその都度報告をして修正してもらいました。
その結果、なかなかの精度のものができたように思います。

AI自身に自信のほどを聞いてみました。

例外としては下記のような点が挙げられていました。
例外というかもっともな点です。

解が複数ある問題、または解なしの問題
計算時間が膨大になるものはフリーズしたように見えるかもしれない

AIで作成したVBAコード

Option Explicit

Private 候補値(1 To 9, 1 To 9, 1 To 9) As Integer
Private cnt As Integer

Public Sub main()
    Dim success As Boolean
    
    ' 画面更新停止（高速化）
    Application.ScreenUpdating = False
    
    ' 初期化と取り込み
    Call 候補値の初期化
    Call 盤面の初期値取り込み
    
    ' 1. 論理的な消去法で埋められるだけ埋める
    Do
        cnt = 0
        Call 論理的解析ルーチン
    Loop While cnt > 0
    
    ' 2. 残りを仮置き探索（バックトラッキング）で解く
    success = 仮置き探索(1, 1)
    
    Application.ScreenUpdating = True
    
    If success Then
        MsgBox "完了しました！"
    Else
        MsgBox "この問題には解がありません。入力ミスがないか確認してください。"
    End If
End Sub

' --- 論理的解析 ---
Private Sub 論理的解析ルーチン()
    Dim r As Integer, c As Integer
    For r = 1 To 9
        For c = 1 To 9
            If Cells(r, c).Value = "" Then
                If 候補値が唯一(r, c) Then
                    Call 候補値の確定処理(r, c, 確定した候補値(r, c))
                Else
                    Call 唯一の居場所チェック(r, c)
                End If
            End If
        Next c
    Next r
End Sub

Private Sub 唯一の居場所チェック(r As Integer, c As Integer)
    Dim v As Integer
    For v = 1 To 9
        If 候補値(r, c, v) = 1 Then
            ' そのマスに「その数字」しか入れない場合
            If ブロック内で唯一(r, c, v) Or 行内で唯一(r, c, v) Or 列内で唯一(r, c, v) Then
                Call 候補値の確定処理(r, c, v)
                Exit For
            End If
        End If
    Next v
End Sub

' --- 仮置き探索 ---
Private Function 仮置き探索(r As Integer, c As Integer) As Boolean
    Dim n As Integer, nextR As Integer, nextC As Integer
    
    If r > 9 Then
        仮置き探索 = True
        Exit Function
    End If
    
    ' 次のセル
    If c = 9 Then
        nextR = r + 1: nextC = 1
    Else
        nextR = r: nextC = c + 1
    End If
    
    If Cells(r, c).Value <> "" Then
        仮置き探索 = 仮置き探索(nextR, nextC)
        Exit Function
    End If
    
    For n = 1 To 9
        If 候補値(r, c, n) = 1 And ルール違反なし(r, c, n) Then
            Dim oldVal As Variant
            oldVal = Cells(r, c).Value
            Cells(r, c).Value = n
            Cells(r, c).Font.Color = RGB(0, 0, 255)
            
            ' 候補値を一時的に更新（再帰的に呼び出すため）
            If 仮置き探索(nextR, nextC) Then
                仮置き探索 = True
                Exit Function
            End If
            
            ' 失敗なら戻す
            Cells(r, c).Value = oldVal
        End If
    Next n
    仮置き探索 = False
End Function

Private Function ルール違反なし(r As Integer, c As Integer, val As Integer) As Boolean
    Dim i As Integer, j As Integer, br As Integer, bc As Integer
    
    ' 行・列チェック
    For i = 1 To 9
        If i <> c And Cells(r, i).Value = val Then Exit Function
        If i <> r And Cells(i, c).Value = val Then Exit Function
    Next i
    
    ' ブロックチェック
    br = ((r - 1) \ 3) * 3 + 1
    bc = ((c - 1) \ 3) * 3 + 1
    For i = br To br + 2
        For j = bc To bc + 2
            If (i <> r Or j <> c) And Cells(i, j).Value = val Then Exit Function
        Next j
    Next i
    ルール違反なし = True
End Function

' --- 基礎処理 ---
Private Sub 候補値の初期化()
    Dim r As Integer, c As Integer, n As Integer
    For r = 1 To 9: For c = 1 To 9: For n = 1 To 9
        候補値(r, c, n) = 1
    Next n: Next c: Next r
End Sub

Private Sub 盤面の初期値取り込み()
    Dim r As Integer, c As Integer
    For r = 1 To 9: For c = 1 To 9
        If Cells(r, c).Value <> "" Then Call 候補値の確定処理(r, c, CInt(Cells(r, c).Value))
    Next c: Next r
End Sub

Private Sub 候補値の確定処理(r As Integer, c As Integer, v As Integer)
    Dim i As Integer, j As Integer, br As Integer, bc As Integer
    If Cells(r, c).Value = "" Then
        Cells(r, c).Value = v
        Cells(r, c).Font.Color = RGB(255, 0, 0)
        cnt = cnt + 1
    End If
    For i = 1 To 9: 候補値(r, c, i) = 0: Next i
    候補値(r, c, v) = 1
    For i = 1 To 9
        If i <> r Then 候補値(i, c, v) = 0
        If i <> c Then 候補値(r, i, v) = 0
    Next i
    br = ((r - 1) \ 3) * 3 + 1: bc = ((c - 1) \ 3) * 3 + 1
    For i = br To br + 2: For j = bc To bc + 2
        If i <> r Or j <> c Then 候補値(i, j, v) = 0
    Next j: Next i
End Sub

Private Function 候補値が唯一(r As Integer, c As Integer) As Boolean
    Dim n As Integer, s As Integer
    For n = 1 To 9: s = s + 候補値(r, c, n): Next n
    候補値が唯一 = (s = 1)
End Function

Private Function 確定した候補値(r As Integer, c As Integer) As Integer
    Dim n As Integer
    For n = 1 To 9: If 候補値(r, c, n) = 1 Then 確定した候補値 = n: Exit Function
    Next n
End Function

Private Function ブロック内で唯一(r As Integer, c As Integer, v As Integer) As Boolean
    Dim i As Integer, j As Integer, br As Integer, bc As Integer
    br = ((r - 1) \ 3) * 3 + 1: bc = ((c - 1) \ 3) * 3 + 1
    For i = br To br + 2: For j = bc To bc + 2
        If (i <> r Or j <> c) And 候補値(i, j, v) = 1 Then Exit Function
    Next j: Next i
    ブロック内で唯一 = True
End Function

Private Function 行内で唯一(r As Integer, c As Integer, v As Integer) As Boolean
    Dim i As Integer
    For i = 1 To 9: If i <> c And 候補値(r, i, v) = 1 Then Exit Function
    Next i
    行内で唯一 = True
End Function

Private Function 列内で唯一(r As Integer, c As Integer, v As Integer) As Boolean
    Dim i As Integer
    For i = 1 To 9: If i <> r And 候補値(i, c, v) = 1 Then Exit Function
    Next i
    列内で唯一 = True
End Function

まとめ

一昔前なら、ちょっとした疑問に対して仮説を立て、検証をする手段としてプログラムを作れることが有効な手段でした。
自然言語で仮説を立ててもらうことはもちろん、検証するプログラムのコーディングもAIで作れるようになったことを実感しました。

数独はペンシルパズル雑誌「二コリ」から生まれたパズルです。

リンク

問題をAIに作ってもらう

AI×エクセルVBAで数独を解く コーディング

テスト

AIで作成したVBAコード

まとめ

コメント

AI×エクセルVBAで数独を解く　コーディング