第７話 セルリスト構造解析結果の表示
を実現するプログラム例
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
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 '行に１から９までの数字がひとつずつ並んでいるかをチェック
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 '入力順を確定させるためのｘ座標作成
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の開発をしてください。
