第４講 数独を解くソフトの開発（１）
第８話 数独を解くソフトVer.2
Ver.2のコード例
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)はｙ座標を収納する配列、jz(80)はｘ座標を収納する配列
'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 '行に１から９までの数字がひとつずつ並んでいるかをチェック
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 '列に１から９までの数字がひとつずつ並んでいるかをチェック
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 'ブロックに１から９までの数字がひとつずつ並んでいるかをチェック
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 '入力順を確定させるためのｙ座標作成
jz(w) = j '入力順を確定させるためのｘ座標作成
w = w + 1
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
Dim hg(8) As Byte, hr(8) As Byte, hb(8) As Byte 'それぞれ行、列、ブロックについて色を塗った場所を記録するための配列
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.1に比べて約１．２倍になりました。
これは
For i = 0 To n - 1
から
For i = 0 To mx(y, x) - 1
と探索範囲が限定されたからですが、
１．２倍とは情けない限りですね。
探索範囲をかなり絞ったのになぜ余り速くならなかったのでしょうか。
