第4講 数独を解くソフトの開発(1)
第7話 セルリスト構造解析結果の表示
101
052
102
を実現するプログラム例
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
  Randomize (Timer) 'シード値を時間から取得
  hj = Timer 'はじめの時間取得
  Randomize (Timer) 'シード値を時間から取得
  dainyu 'シートのB4からJ12のセルからm(i, j)に代入することが任務
'  f (0) '数独作成プロシージャ
  ow = Timer
 
 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
  w = 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
        iz(w) = i '入力順を確定させるためのy座標作成
        jz(w) = j '入力順を確定させるためのx座標作成
      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 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
  y = iz(g)
  x = jz(g)
  For i = 0 To n - 1
    m(y, x) = i + 1
    h = 1
    For j = 0 To n - 1
      If j <> x Then
        If m(y, x) = m(y, j) Then
          h = 0
          Exit For
        End If
      End If
    Next
    If h = 1 Then
      For j = 0 To n - 1
        If j <> y Then
          If m(y, x) = m(j, x) Then
            h = 0
            Exit For
          End If
        End If
      Next
    End If
    If h = 1 Then
      For j = 0 To n - 1
        xx = 3 * Int(x / 3) + (j Mod 3)
        yy = 3 * Int(y / 3) + Int(j / 3)
        If x <> xx Or y <> yy Then
          If m(y, x) = m(yy, xx) Then
            h = 0
            Exit For
          End If
        End If
      Next
    End If
    If h = 1 Then
      If g + 1 < n * n - hnt Then
        f (g + 1)
        If cn = 2 Then Exit Sub
      Else
        cn = cn + 1
        If cn = 1 Then
          For j = 0 To n - 1
            For k = 0 To n - 1
              cm(j, k) = m(j, k)
            Next
          Next
        End If
        If cn = 2 Then Exit Sub
      End If
    End If
  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.2の開発をしてください。

第6話へ 第8話へ


トップへ