第4講 数独を解くソフトの開発(1)
第10話 数独を解くソフトVer.3

Ver.3のコード例
Dim n As Byte, m(8, 8) As Byte, cn As Integer, hnt As Byte, iz(80) As Byte, jz(80) As Byte, cm(8, 8) As Byte
'nは数独の一辺、x(15)は数独を収納する配列、cnは数独総数をカウント、hntはヒント数
'iz(80)はy座標を収納する配列、jz(80)はx座標を収納する配列
'cm(i, j)はm(i, j)のバックアップ配列
Dim ironuri(8, 8, 8) As Byte, rlst(8, 8, 8) As Byte, mx(8, 8) As Byte
'ironuri(i, j, k)は色塗り 0:は白 1:は色あり rlst(8, 8, 8)は候補数字を収納する配列、mx(8, 8)は候補数次数を収める配列
Private Sub CommandButton1_Click()
  CommandButton2_Click
  n = 9
  hj = Timer 'はじめの時間取得
'  Randomize (Timer) 'シード値を時間から取得
  dainyu 'シートのB4からJ12のセルからm(i, j)に代入することが任務
  f (0) '数独作成プロシージャ
  ow = Timer
  hyouji
'  hyoujirlst 'リスト構造解析の表示=各セルの候補数字の表示
'  hyouji1 '候補数字数の表示
  Cells(4, 12) = "問題を解くのにかかった時間は"
  Cells(5, 12) = ow - hj
  Cells(6, 12) = "秒です。"
  If cn = 1 And seigohantei = 1 Then Cells(7, 12) = "正しい解答です。" Else Cells(7, 12) = "誤った解答です。"
End Sub
Function seigohantei() '出来た数独が適正であるか調べるプロシージャ
  Dim i As Byte, j As Byte, a(8) As Byte
  For i = 0 To n - 1 '問題の数字と解答の同位置の数字が一致しているか調べている
    For j = 0 To n - 1
      If Cells(4 + i, 2 + j) > 0 Then
        If Cells(4 + i, 2 + j) <> Cells(14 + i, 2 + j) Then
          seigohantei = 0
          Exit Function
        End If
      End If
      If Cells(14 + i, 2 + j) = "" Then '解答に空欄がないかを調べている
        seigohantei = 0
        Exit Function
      End If
    Next
  Next
  For i = 0 To n - 1 '行に1から9までの数字がひとつずつ並んでいるかをチェック
    For j = 0 To n - 1
      a(j) = 0
    Next
    For j = 0 To n - 1
      a(Cells(14 + i, 2 + j) - 1) = 1
    Next
    For j = 0 To n - 1
      If a(j) = 0 Then
        seigohantei = 0
        Exit Function
      End If
    Next
  Next
  For i = 0 To n - 1 '列に1から9までの数字がひとつずつ並んでいるかをチェック
    For j = 0 To n - 1
      a(j) = 0
    Next
    For j = 0 To n - 1
      a(Cells(14 + j, 2 + i) - 1) = 1
    Next
    For j = 0 To n - 1
      If a(j) = 0 Then
        seigohantei = 0
        Exit Function
      End If
    Next
  Next
  Dim y As Byte, x As Byte
  For i = 0 To n - 1 'ブロックに1から9までの数字がひとつずつ並んでいるかをチェック
    For j = 0 To n - 1
      a(j) = 0
    Next
    For j = 0 To n - 1
      y = 3 * Int(i / 3) + Int(j / 3)
      x = 3 * (i Mod 3) + (j Mod 3)
      a(Cells(14 + y, 2 + x) - 1) = 1
    Next
    For j = 0 To n - 1
      If a(j) = 0 Then
        seigohantei = 0
        Exit Function
      End If
    Next
  Next
  seigohantei = 1
End Function
Sub dainyu()
  Dim i As Byte, j As Byte, k As Byte, w As Byte, y As Byte, x As Byte
  For i = 0 To n - 1 '初期化処理、m(i, j)とironuri(i, j, k)をすべて0に初期化
    For j = 0 To n - 1
      m(i, j) = 0
      For k = 0 To n - 1
        ironuri(i, j, k) = 0
      Next
    Next
  Next
  hnt = 0
  For i = 0 To n - 1
    For j = 0 To n - 1
      If Cells(4 + i, 2 + j) > 0 Then
        m(i, j) = Cells(4 + i, 2 + j)
        For k = 0 To n - 1 'セルリスト構造解析のための色塗り
          If m(i, k) = 0 Then
            ironuri(i, k, m(i, j) - 1) = 1 '行についての色塗り
          End If
          If m(k, j) = 0 Then
            ironuri(k, j, m(i, j) - 1) = 1 '列についての色塗り
          End If
          y = 3 * Int(i / 3) + Int(k / 3)
          x = 3 * Int(j / 3) + (k Mod 3)
          If y <> i And x <> j Then
            If m(y, x) = 0 Then
              ironuri(y, x, m(i, j) - 1) = 1 'ブロックについての色塗り
            End If
          End If
        Next
        hnt = hnt + 1
      Else
        m(i, j) = 0
      End If
    Next
  Next
  For i = 0 To n - 1 '全体構造解析=すべてのセルについてセルリスト構造解析をする
    For j = 0 To n - 1
      If m(i, j) = 0 Then
        kyokusyokaiseki i, j  '座標(i, j)について「セルリスト構造解析=局所解析」
      End If
    Next
  Next
  cn = 0
End Sub
Sub kyokusyokaiseki(y As Byte, x As Byte) 'セルリスト構造解析、解析場所を1つのセルに限定しているので局所解析と呼ぶ
  Dim i As Byte, w As Byte
  w = 0
  For i = 0 To n - 1
    If ironuri(y, x, i) = 0 Then
      rlst(y, x, w) = i + 1
      w = w + 1
    End If
  Next
  mx(y, x) = w
End Sub
Sub nyuryokujyun(g As Byte) '最も効率的に数独を作成させるための座標作り=数字候補数が最も少ないセルを座標にする
  Dim i As Byte, j As Byte, mn As Byte, ik As Byte, jk As Byte
  mn = 100
  For i = 0 To 8
    For j = 0 To 8
      If m(i, j) = 0 Then
        If mx(i, j) < mn Then
          mn = mx(i, j)
          ik = i
          jk = j
        End If
      End If
    Next
  Next
  iz(g) = ik
  jz(g) = jk

End Sub
Sub f(g As Byte)
  Dim i As Byte, j As Byte, k As Byte, h As Byte, w As Byte
  Dim y As Byte, x As Byte, yy As Byte, xx As Byte
  Dim hg(8) As Byte, hr(8) As Byte, hb(8) As Byte 'それぞれ行、列、ブロックについて色を塗った場所を記録するための配列
  
nyuryokujyun (g)
  y = iz(g)
  x = jz(g)
  kyokusyokaiseki y, x '局所解析
  If mx(y, x) = 0 Then Exit Sub '破綻処理、破綻した場合過去の入れ方が悪いので、過去に戻ってやり直し
  For i = 0 To mx(y, x) - 1
    m(y, x) = rlst(y, x, i) 'セルの候補数字のみを対象にする
    For j = 0 To n - 1
      hg(j) = 0
      hr(j) = 0
      hb(j) = 0
    Next
    For j = 0 To n - 1
      If m(y, j) = 0 Then
        If ironuri(y, j, m(y, x) - 1) = 0 Then
          ironuri(y, j, m(y, x) - 1) = 1 'm(y, x)の入力によって影響を受けた行のセルの色塗り
          hg(j) = 1 '色を塗った行位置を記録
        End If
      End If
      If m(j, x) = 0 Then
        If ironuri(j, x, m(y, x) - 1) = 0 Then
          ironuri(j, x, m(y, x) - 1) = 1 'm(y, x)の入力によって影響を受けた列のセルの色塗り
          hr(j) = 1 '色を塗った列位置を記録
        End If
      End If
      yy = 3 * Int(y / 3) + Int(j / 3)
      xx = 3 * Int(x / 3) + (j Mod 3)
      If yy <> y And xx <> x Then
        If m(yy, xx) = 0 Then
          If ironuri(yy, xx, m(y, x) - 1) = 0 Then
            ironuri(yy, xx, m(y, x) - 1) = 1 'm(y, x)の入力によって影響を受けたブロックのセルの色塗り
            hb(j) = 1 '色を塗ったブロック位置を記録
          End If
        End If
      End If
    Next
    If g + 1 < n * n - hnt Then
      f (g + 1) '行・列・ブロックの重複がなく、g + 1がn * n - hnt以下のときに、次のセル番号の世界に飛ぶ
      If cn = 2 Then Exit Sub 'cn = 2となっている理由は別解がないか探索させるため
    Else
      cn = cn + 1 '数独総数カウント
      If cn = 1 Then
        For j = 0 To n - 1 '別解がないか探索させている間にm(i ,j)は壊されてしまうためにバックアップをとっている。
          For k = 0 To n - 1
            cm(j, k) = m(j, k)
          Next
        Next
      End If
      If cn = 2 Then Exit Sub 'cn = 2となっている理由は別解がないか探索させるため
    End If
    For j = 0 To n - 1
      If hg(j) = 1 Then
        ironuri(y, j, m(y, x) - 1) = 0 'm(y, x)に値を入れ直すので、行で影響を受けたセルについて色を白に復元
      End If
      If hr(j) = 1 Then
        ironuri(j, x, m(y, x) - 1) = 0 'm(y, x)に値を入れ直すので、列で影響を受けたセルについて色を白に復元
      End If
      If hb(j) = 1 Then
        yy = 3 * Int(y / 3) + Int(j / 3)
        xx = 3 * Int(x / 3) + (j Mod 3)
        ironuri(yy, xx, m(y, x) - 1) = 0 'm(y, x)に値を入れ直すので、ブロックで影響を受けたセルについて色を白に復元
      End If
    Next
  Next
  m(y, x) = 0
End Sub
Sub hyouji() '解答表示プロシージャ
  Dim i As Byte, j As Byte
  For i = 0 To n - 1
    For j = 0 To n - 1
      If cm(i, j) > 0 Then Cells(14 + i, 2 + j) = cm(i, j)
    Next
  Next
End Sub
Sub hyoujirlst() '全セルの候補数字を表示するプロシージャ
  Dim i As Byte, j As Byte, k As Byte
  For i = 0 To n - 1
    For j = 0 To n - 1
      If m(i, j) = 0 Then
        If mx(i, j) > 0 Then
          For k = 0 To mx(i, j) - 1
            Cells(4 + i, 12 + 9 * j + k) = rlst(i, j, k)
          Next
        End If
      End If
    Next
  Next
End Sub
Sub hyouji1() '全セルの数字候補数を表示するプロシージャ
  Dim i As Byte, j As Byte
  For i = 0 To n - 1
    For j = 0 To n - 1
      If Cells(4 + i, 2 + j) > 0 Then Cells(14 + i, 2 + j) = "*" Else Cells(14 + i, 2 + j) = mx(i, j)
    Next
  Next
End Sub
Private Sub CommandButton2_Click()
  Rows("14:22").Select
  Selection.ClearContents
  Range("L4:L7").Select
  Selection.ClearContents
  Columns("L:cp").Select
  Selection.ClearContents
  Cells(1, 1).Select
End Sub
参考ダウンロード添付ファイル

Ver.3はVer.2と比較して解く速度は35倍加、Ver.1と比べて42倍加しています。

Ver.3を参考にして、
第2講と第3講で開発したヒント数0数独の解答自動生成ソフトも改良できます。
これは第6講辺りの課題になることを予告して、
第4講を終わりにします。
第5講では、問題をいかに作るかを考えます。
そして、数独を解くソフトVer.3で解かせます。
唯一解の問題であるかを確認させます。

第9話へ 第5講第1話へ


トップへ