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
Private Sub CommandButton1_Click()
CommandButton2_Click
n = 9
Randomize (Timer) 'シード値を時間から取得
hj = Timer 'はじめの時間取得
' dainyu
syokika
f (0) 'ｎ次数独作成プロシージャ
ow = Timer '終わりの時間取得
hyouji '解答表示
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 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 '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
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) '数独作成Subプロシージャ
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
nyuryokujyun (g) '入力順の作成＝座標作成
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 g + 1 < n * n Then
f (g + 1) '行・列・ブロックの重複がなく、g + 1がn * n以下のときに、次のセル番号の世界に飛ぶ
If cn = 1 Then Exit Sub 'cn = 1となっている理由は解答が1つ出来ればよいから。
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 = 1 Then Exit Sub 'cn = 1となっている理由は解答が1つ出来ればよいから。
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 n * n - hnt - 1
Cells(4 + iz(i), 2 + jz(i)) = i
Next
End Sub
Private Sub CommandButton2_Click()
Rows("4:12").Select
Selection.ClearContents
Rows("14:22").Select
Selection.ClearContents
Range("L4:L7").Select
Selection.ClearContents
Cells(1, 1).Select
End Sub
参考ダウンロード添付ファイル
解答を作成してしまいましたが、
ちょっと工夫をしますと問題を生成できます。
もちろん、第５講で作った問題配置のための座標作成添付ファイルと合体させる必要があります。
ⅱ．解が存在する
ⅲ．別解が存在しない
の検証は次の課題として、ⅰⅱの条件を満たしていなくても問題を表示させてください。
