第４話 数独自動生成と適切性の判定
数独の適切性の判定を組み込んだプログラム例
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
Dim ironuri(8, 8, 8) As Byte, rlst(8, 8, 8) As Byte, mx(8, 8) As Byte, onoff As Byte
Private Sub CommandButton1_Click()
CommandButton2_Click
n = 9
hnt = Cells(4, 15) 'ヒント数
Dim ty As Byte
ty = Cells(5, 15) 'タイプの取得 0:非対称 1:上下対称 2:左右対称 3:点対称
Select Case ty 'シートのO5で指定しているタイプを選択
Case 0
hitaisyou '非対称座標作成
Case 1
retutaisyou '上下対称に生成させるための座標作成
Case 2
gyoutaisyou '左右対称に生成させるための座標作成
Case 3
tentaisyou '点対称に生成させるための座標作成
End Select
syokika 'm(i, j),rlst(i, j, k),cnを0に初期化、cnは生成した数独をカウントする変数
onoff = 0 '以下２行は問題作成
f (0)
hyouji1 '問題の表示
onoff = 1 '以下３行は問題を解いている。
cn = 0
f (hnt)
If cn = 1 Then '適切性の判定
hyouji '解答の表示
Cells(8, 12) = "適切な数独です。"
Else
Cells(8, 12) = "不適切な数独です。"
End If
End Sub
Sub tm() '正しく配置しているかを確かめるためのプロシージャだが、実際には使っていない。削っても可。
Dim i As Byte
For i = 0 To hnt - 1
m(iz(i), jz(i)) = i + 1
Next
For i = 0 To hnt - 1
Cells(4 + iz(i), 2 + jz(i)) = m(iz(i), jz(i))
Next
Dim j As Byte, w As Byte, h As Byte
w = 0
h = 1
For i = 0 To 8
For j = 0 To 8
If Cells(4 + i, 2 + j) > 0 Then w = w + 1
If Cells(4 + i, 2 + j) > 0 Then
If Cells(12 - i, 2 + j) = 0 Then h = 0
End If
Next
Next
Cells(6, 15) = w
If h = 1 Then Cells(7, 15) = "○" Else Cells(7, 15) = "×"
End Sub
Sub hitaisyou() '非対称に生成するための座標作成
Dim i As Integer, a As Integer, w As Integer, tb As Integer, h As Byte, tane As Byte
w = Int(81 * Rnd) 'はじめの位置
tane = Int(10 * Rnd) '飛びを選択するための変数
Select Case tane '飛びの選択 tbは飛びを表す変数
Case 0
tb = 5
Case 1
tb = 7
Case 2
tb = 11
Case 3
tb = 13
Case 4
tb = 17
Case 5
tb = 19
Case 6
tb = 23
Case 7
tb = 29
Case 8
tb = 31
Case 9
tb = 37
End Select
For i = 0 To hnt - 1 '座標作成
a = (w + tb * i) Mod 81
iz(i) = Int(a / 9)
jz(i) = a Mod 9
Next
End Sub
Sub retutaisyou() '上下に生成させるための対称座標作成
Dim i As Integer, a As Integer, w As Integer, tb As Integer, h As Byte, ch As Integer, gz As Byte, j As Byte, tane As Byte
w = Int(36 * Rnd) 'はじめの位置
tane = Int(10 * Rnd) '飛びを選択するための変数
Select Case tane '飛びの選択 tbは飛びを表す変数
Case 0
tb = 5
Case 1
tb = 7
Case 2
tb = 11
Case 3
tb = 13
Case 4
tb = 17
Case 5
tb = 19
Case 6
tb = 23
Case 7
tb = 29
Case 8
tb = 31
Case 9
tb = 41
End Select
If hnt Mod 2 = 0 Then 'ヒント数が偶数の場合の座標作成
gz = Int(2 * Rnd) '中央の行に配置する「ヒント数÷9行」からの揺らぎを＋にするか－にするかの選択をする変数
If gz = 0 Then
Do While 1
ch = Int(hnt / 9) + Int(4 * Rnd) '中央の行の配置数 Int(hnt / 9)は「ヒント数÷9列」 + Int(4 * Rnd)は＋の揺らぎ
If ch Mod 2 = 0 And ch < 9 Then Exit Do '中央の行への配置数を偶数として８個以下としている
Loop
End If
If gz = 1 Then
Do While 1
ch = Int(hnt / 9) - Int(3 * Rnd) '中央の行の配置数 Int(hnt / 9)は「ヒント数÷9行」 + Int(3 * Rnd)は－の揺らぎ
If ch >= 0 Then '中央行への配置数を０個以上で偶数としている
If ch Mod 2 = 0 Then
Exit Do
End If
End If
Loop
End If
For i = 0 To ch - 1 '中央行への配置
iz(i) = 4 '中央行だからｙ座標は4
If i = 0 Then
jz(i) = Int(9 * Rnd) 'ｘ座標を0以上8以下にしている
End If
If i > 0 Then 'ｘ座標が重複しないようにしている
Do While 1
jz(i) = Int(9 * Rnd) 'ｘ座標を0以上8以下にしている
h = 1
For j = 0 To i - 1
If jz(j) = jz(i) Then
h = 0 '重複がある限りDo文を継続させる
Exit For
End If
Next
If h = 1 Then Exit Do '重複がなかったのでDo文を強制的に抜ける
Loop
End If
Next
For i = 0 To Int((hnt - ch) / 2) - 1 '中央行以外を上下対称に配置
a = (w + tb * i) Mod 36 'セル番号を35以下に限定
iz(i + ch) = Int(a / 9) '中央行より上の行のｙ座標
jz(i + ch) = a Mod 9 '中央行より上の行のｘ座標
iz(i + ch + Int((hnt - ch) / 2)) = 8 - Int(a / 9) '中央行より下の行のｙ座標
jz(i + ch + Int((hnt - ch) / 2)) = a Mod 9 '中央行より下の行のｘ座標
Next
End If
If hnt Mod 2 = 1 Then 'ヒント数が奇数の場合の座標作成
gz = Int(2 * Rnd) '中央の行に配置する「ヒント数÷9行」からの揺らぎを＋にするか－にするかの選択をする変数
If gz = 0 Then
Do While 1
ch = Int(hnt / 9) + Int(4 * Rnd) '中央の行の配置数 Int(hnt / 9)は「ヒント数÷9行」 + Int(4 * Rnd)は＋の揺らぎ
If ch Mod 2 = 1 And ch < 9 Then Exit Do '中央の行への配置数を奇数として８個以下としている
Loop
End If
If gz = 1 Then
Do While 1
ch = Int(hnt / 9) - Int(3 * Rnd) '中央の行の配置数 Int(hnt / 9)は「ヒント数÷9行」 + Int(3 * Rnd)は－の揺らぎ
If ch >= 0 Then '中央の行への配置数を０個以上で奇数としている
If ch Mod 2 = 1 Then
Exit Do
End If
End If
Loop
End If
For i = 0 To ch - 1 '中央行への配置
iz(i) = 4 '中央行だからｙ座標は4
If i = 0 Then
jz(i) = Int(9 * Rnd) 'ｘ座標を0以上8以下にしている
End If
If i > 0 Then 'ｘ座標が重複しないようにしている
Do While 1
jz(i) = Int(9 * Rnd) 'ｘ座標を0以上8以下にしている
h = 1
For j = 0 To i - 1
If jz(j) = jz(i) Then
h = 0 '重複がある限りDo文を継続させる
Exit For
End If
Next
If h = 1 Then Exit Do '重複がなかったのでDo文を強制的に抜ける
Loop
End If
Next
For i = 0 To Int((hnt - ch) / 2) - 1 '中央行以外を上下対称に配置
a = (w + tb * i) Mod 36 'セル番号を35以下に限定
iz(i + ch) = Int(a / 9) '中央行より上の行のｙ座標
jz(i + ch) = a Mod 9 '中央行より上の行のｘ座標
iz(i + ch + Int((hnt - ch) / 2)) = 8 - Int(a / 9) '中央行より下の行のｙ座標
jz(i + ch + Int((hnt - ch) / 2)) = a Mod 9 '中央行より下の行のｘ座標
Next
End If
End Sub
Sub gyoutaisyou() '左右に生成させるための対称座標作成
Dim i As Integer, a As Integer, w As Integer, tb As Integer, h As Byte, ch As Integer, gz As Byte, j As Byte, tane As Byte
w = Int(36 * Rnd) 'はじめの位置
tane = Int(10 * Rnd) '飛びを選択するための変数
Select Case tane '飛びの選択 tbは飛びを表す変数
Case 0
tb = 5
Case 1
tb = 7
Case 2
tb = 11
Case 3
tb = 13
Case 4
tb = 17
Case 5
tb = 19
Case 6
tb = 23
Case 7
tb = 29
Case 8
tb = 31
Case 9
tb = 41
End Select
If hnt Mod 2 = 0 Then 'ヒント数が偶数の場合の座標作成
gz = Int(2 * Rnd) '中央の列に配置する「ヒント数÷9列」からの揺らぎを＋にするか－にするかの選択をする変数
If gz = 0 Then
Do While 1
ch = Int(hnt / 9) + Int(4 * Rnd) '中央の列の配置数 Int(hnt / 9)は「ヒント数÷9列」 + Int(4 * Rnd)は＋の揺らぎ
If ch Mod 2 = 0 And ch < 9 Then Exit Do '中央の列への配置数を偶数として８個以下としている
Loop
End If
If gz = 1 Then
Do While 1
ch = Int(hnt / 9) - Int(3 * Rnd) '中央の列の配置数 Int(hnt / 9)は「ヒント数÷9列」 + Int(3 * Rnd)は－の揺らぎ
If ch >= 0 Then '中央列への配置数を０個以上で偶数としている
If ch Mod 2 = 0 Then
Exit Do
End If
End If
Loop
End If
For i = 0 To ch - 1 '中央列への配置
jz(i) = 4 '中央列だからｙ座標は4
If i = 0 Then
iz(i) = Int(9 * Rnd) 'ｘ座標を0以上8以下にしている
End If
If i > 0 Then 'ｘ座標が重複しないようにしている
Do While 1
iz(i) = Int(9 * Rnd) 'ｘ座標を0以上8以下にしている
h = 1
For j = 0 To i - 1
If iz(j) = iz(i) Then
h = 0 '重複がある限りDo文を継続させる
Exit For
End If
Next
If h = 1 Then Exit Do '重複がなかったのでDo文を強制的に抜ける
Loop
End If
Next
For i = 0 To Int((hnt - ch) / 2) - 1 '中央列以外を左右対称に配置
a = (w + tb * i) Mod 36 'セル番号を35以下に限定
iz(i + ch) = a Mod 9 '中央列より左の列のｙ座標
jz(i + ch) = Int(a / 9) '中央列より左の列のｘ座標
iz(i + ch + Int((hnt - ch) / 2)) = a Mod 9 '中央列より右の列のｙ座標
jz(i + ch + Int((hnt - ch) / 2)) = 8 - Int(a / 9) '中央列より右の列のｘ座標
Next
End If
If hnt Mod 2 = 1 Then 'ヒント数が奇数の場合の座標作成
gz = Int(2 * Rnd) '中央の列に配置する「ヒント数÷9列」からの揺らぎを＋にするか－にするかの選択をする変数
If gz = 0 Then
Do While 1
ch = Int(hnt / 9) + Int(4 * Rnd) '中央の列の配置数 Int(hnt / 9)は「ヒント数÷9列」 + Int(4 * Rnd)は＋の揺らぎ
If ch Mod 2 = 1 And ch < 9 Then Exit Do '中央の列への配置数を奇数として８個以下としている
Loop
End If
If gz = 1 Then
Do While 1
ch = Int(hnt / 9) - Int(3 * Rnd) '中央の列の配置数 Int(hnt / 9)は「ヒント数÷9列」 + Int(3 * Rnd)は－の揺らぎ
If ch >= 0 Then '中央の列への配置数を０個以左で奇数としている
If ch Mod 2 = 1 Then
Exit Do
End If
End If
Loop
End If
For i = 0 To ch - 1 '中央列への配置
jz(i) = 4 '中央列だからｙ座標は4
If i = 0 Then
iz(i) = Int(9 * Rnd) 'ｘ座標を0以上8以下にしている
End If
If i > 0 Then 'ｘ座標が重複しないようにしている
Do While 1
iz(i) = Int(9 * Rnd) 'ｘ座標を0以上8以下にしている
h = 1
For j = 0 To i - 1
If iz(j) = iz(i) Then
h = 0 '重複がある限りDo文を継続させる
Exit For
End If
Next
If h = 1 Then Exit Do '重複がなかったのでDo文を強制的に抜ける
Loop
End If
Next
For i = 0 To Int((hnt - ch) / 2) - 1 '中央列以外を左右対称に配置
a = (w + tb * i) Mod 36 'セル番号を35以下に限定
iz(i + ch) = a Mod 9 '中央列より左の列のｙ座標
jz(i + ch) = Int(a / 9) '中央列より左の列のｘ座標
iz(i + ch + Int((hnt - ch) / 2)) = a Mod 9 '中央列より右の列のｙ座標
jz(i + ch + Int((hnt - ch) / 2)) = 8 - Int(a / 9) '中央列より右の列のｘ座標
Next
End If
End Sub
Sub tentaisyou() '点対称に生成させるための座標作成
Dim i As Integer, a As Integer, w As Integer, tb As Integer, h As Byte, tane As Byte
w = Int(40 * Rnd) 'はじめの位置
tane = Int(10 * Rnd) '飛びを選択するための変数
Select Case tane '飛びの選択 tbは飛びを表す変数
Case 0
tb = 7
Case 1
tb = 11
Case 2
tb = 13
Case 3
tb = 17
Case 4
tb = 19
Case 5
tb = 23
Case 6
tb = 29
Case 7
tb = 47
Case 8
tb = 59
Case 9
tb = 61
End Select
If hnt Mod 2 = 0 Then 'ヒント数が偶数の場合の座標作成
For i = 0 To Int(hnt / 2) - 1
a = (w + tb * i) Mod 40 'セル番号を39以下に限定
iz(i) = Int(a / 9) 'セル番号が39以下のｙ座標
jz(i) = a Mod 9 'セル番号が39以下のｘ座標
iz(i + Int(hnt / 2)) = 8 - Int(a / 9) 'セル番号が39以上のｙ座標
jz(i + Int(hnt / 2)) = 8 - (a Mod 9) 'セル番号が39以上のｘ座標
Next
End If
If hnt Mod 2 = 1 Then 'ヒント数が偶数の場合の座標作成
iz(0) = 4
jz(0) = 4
For i = 0 To Int(hnt / 2) - 1
a = (w + tb * i) Mod 40 'セル番号を39以下に限定
iz(i + 1) = Int(a / 9) 'セル番号が39以下のｙ座標
jz(i + 1) = a Mod 9 'セル番号が39以下のｘ座標
iz(i + 1 + Int(hnt / 2)) = 8 - Int(a / 9) 'セル番号が39以上のｙ座標
jz(i + 1 + Int(hnt / 2)) = 8 - (a Mod 9) 'セル番号が39以上のｘ座標
Next
End If
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 syokika() '初期化
Dim i As Byte, j As Byte, k As Byte
For i = 0 To n - 1
For j = 0 To n - 1
m(i, j) = 0
mx(i, j) = 9
For k = 0 To n - 1
ironuri(i, j, k) = 0
Next
Next
Next
cn = 0
End Sub
Sub dainyu() '代入と全体リスト構造解析
Dim i As Byte, j As Byte, k As Byte, y As Byte, x As Byte
For i = 0 To n - 1
For j = 0 To n - 1
m(i, j) = 0
For k = 0 To n - 1
ironuri(i, j, k) = 0
Next
Next
Next
For i = 0 To hnt - 1
m(iz(i), jz(i)) = cm(iz(i), jz(i))
For j = 0 To n - 1
If m(iz(i), j) = 0 Then
ironuri(iz(i), j, m(iz(i), jz(i)) - 1) = 1
End If
If m(j, jz(i)) = 0 Then
ironuri(j, jz(i), m(iz(i), jz(i)) - 1) = 1
End If
y = 3 * Int(iz(i) / 3) + Int(j / 3)
x = 3 * Int(jz(i) / 3) + (j Mod 3)
If y <> iz(i) And x <> jz(i) Then
If m(y, x) = 0 Then
ironuri(y, x, m(iz(i), jz(i)) - 1) = 1
End If
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
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, ii As Byte, iii As Byte
Dim hg(8) As Byte, hr(8) As Byte, hb(8) As Byte
If onoff = 1 Then nyuryokujyun (g) 'onoffが1のときに入力順＝新たな座標作成をしているために既存の座標が壊される。onoffが0ときは既存の座標を壊さない
y = iz(g)
x = jz(g)
kyokusyokaiseki y, x '現在のセルのリスト構造解析
If mx(y, x) = 0 Then Exit Sub '破綻した場合の処理、破綻した場合過去の入れ方が悪いので過去に戻ってやり直す。
ii = Int(mx(y, x) * Rnd)
For i = 0 To mx(y, x) - 1 'セルの候補数字のみを対象にする
iii = (i + ii) Mod mx(y, x)
m(y, x) = rlst(y, x, iii) '順番に入れるのではなくランダムに入れることによって、規則的でなくする。
For j = 0 To n - 1
hg(j) = 0
hr(j) = 0
hb(j) = 0
Next
For j = 0 To n - 1 '以下色塗り。mx(y, x)の行と列とブロックにmx(y, x)に入力された数字を入れることを不可とする。
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 onoff = 0 Then '問題作成
If g + 1 < hnt Then
f (g + 1) '行・列・ブロックの重複がなく、g + 1がhnt以下のときに、次のセル番号の世界に飛ぶ
If cn = 1 Then Exit Sub 'cn = 1となっている理由は問題が1つ出来ればよいから
Else
cn = cn + 1
If cn = 1 Then Exit Sub 'cn = 1となっている理由は問題が1つ出来ればよいから
End If
End If
If onoff = 1 Then '問題を解く
If g + 1 < n * n Then
f (g + 1) '行・列・ブロックの重複がなく、g + 1がn * n以下のときに、次のセル番号の世界に飛ぶ
If cn = 2 Then Exit Sub 'cn = 2となっている理由は別解がないか探索させるため
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 'cn = 2となっている理由は別解がないか探索させるため
End If
End If
For j = 0 To n - 1
If hg(j) = 1 Then
ironuri(y, j, m(y, x) - 1) = 0 'mx(y, x)に数字を入れ直すので、行の該当箇所を色なしに復元
End If
If hr(j) = 1 Then
ironuri(j, x, m(y, x) - 1) = 0 'mx(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 'mx(y, x)に数字を入れ直すので、ブロックの該当箇所を色なしに復元
End If
Next
Next
m(y, x) = 0 'すべての場合を尽くしてやり直して過去に戻るので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 hyouji1()
Dim i As Byte
For i = 0 To hnt - 1
Cells(4 + iz(i), 2 + jz(i)) = m(iz(i), jz(i))
Next
End Sub
Private Sub CommandButton2_Click()
Range("B4:J12").Select
Selection.ClearContents
Range("B14:J22").Select
Selection.ClearContents
Range("L4:L8").Select
Selection.ClearContents
Cells(1, 1).Select
End Sub
参考ダウンロード添付ファイル
次の課題は、判定をして適切である場合にだけ数独と解答を表示させることです。
わざと無限ループのDo While文にして、
適切なときだけDo While文を強制的に抜けるようにするとよいと思います。
皆さん考えてください。
うっかり生成時間を入れ忘れましたので、
以降は入れてください。
また、試行錯誤回数もカウントして表示してください。
