第８講 数独（ナンプレ）作成アプリVer.3に３on３確定と排除を組み込む
第12話 数独（ナンプレ）作成ソフトVer.4の完成！
Dim m As Integer, n As Integer, h As Integer
Dim p(8, 8) As Byte, mx(8, 8) As Byte, rlst(8, 8, 8) As Byte
'pは数独を収納する配列
'mxは各セルの候補数字の個数を収納する配列
'rlstは候補数字を収納する配列
Dim cp(8, 8) As Byte '数独収納配列のコピー
Dim y(80) As Byte, x(80) As Byte
Dim cy(80) As Byte, cx(80) As Byte '座標のコピー
Dim sy(80, 20) As Byte, sx(80, 20) As Byte
'相補確定を行ったセルの座標sy(i, j)のiはgを表し、j + 1 は時間gにおける該当セル個数を表す
Dim a(8, 8) As Integer
Dim hintosu As Byte, rn As Byte
Dim cn As Integer
Dim cmx(80, 8, 8) As Byte
Dim crlst(80, 8, 8, 8) As Byte
Dim hth(80, 8, 8) As Byte
Dim kh(8, 8, 8) As Byte, ckh(80, 8, 8, 8) As Byte
Dim hj1 As Single
Dim n2 As Integer, n2_1 As Integer, n_1 As Byte 'n*n等の計算を何回もさせないために導入
Dim sc(80) As Byte '相補確定の起きた個数を数えるカウンタ
Dim rh(80) As Byte 'ライン排除確定したかどうかを示す配列
Dim sh(80) As Byte '相補確定とそれによる排除をしたかどうかを示す配列
Dim cnt As Integer
Private Sub CommandButton1_Click()
Rnd (-1)
Dim hj As Single
hj = Timer
Randomize hj
CommandButton2_Click
n = Cells(2, 2)
rn = Int(Sqr(n))
n2 = n * n
n_1 = n - 1
n2_1 = n2 - 1
hintosu = Cells(3, 7)
kz = 0
cnt = 0
gzy '偶然要素を付け加えるプロシージャ＝毎回異なる配置にるするためのプロシージャ
zys '座標作成プロシージャ
Do While 1
hj1 = Timer
zlk '全体リスト構造解析プロシージャ
y(0) = 0
x(0) = 0
Call sds(0, 0) '数独作成プロシージャ
sdc '数独のコピー
zlk '全体リスト構造解析プロシージャ
mds '問題作成プロシージャ
Call nck(hintosu, 1)
Call sds(hintosu, 1) '数独作成プロシージャ
zlk '全体リスト構造解析プロシージャ
mds '問題作成プロシージャ
Call nck(hintosu, 2)
Call sds(hintosu, 2) '数独作成プロシージャ
If cn = 1 Then Exit Do
Loop
hyouji '問題表示プロシージャ
Cells(6, 12) = "数独作成にかかった平均の時間は"
Cells(7, 12) = Timer - hj
Cells(8, 12) = "秒です。"
Range("A1").Select
End Sub
Sub gzy()
Dim s As Byte
s = Int(Rnd * 10)
If s = 0 Then m = 47
If s = 1 Then m = 29
If s = 2 Then m = 52
If s = 3 Then m = 11
If s = 4 Then m = 31
If s = 5 Then m = 43
If s = 6 Then m = 23
If s = 7 Then m = 7
If s = 8 Then m = 13
If s = 9 Then m = 19
h = Int(Rnd * 81)
End Sub
Sub mds()
Dim i As Byte, u As Byte
For i = 0 To hintosu - 1
y(i) = cy(i)
x(i) = cx(i)
Next
For i = 0 To hintosu - 1
p(cy(i), cx(i)) = cp(cy(i), cx(i))
u = klk(i)
Next
End Sub
Sub sdc()
Dim i As Integer
For i = 0 To n2_1
cp(cy(i), cx(i)) = p(cy(i), cx(i))
Next
End Sub
Sub zlk() '全体リスト構造解析プロシージャ
Dim i As Integer, j As Integer, k As Integer, l As Integer
cn = 0
For i = 0 To n_1
For j = 0 To n_1
mx(i, j) = n_1
p(i, j) = 0
For k = 0 To n_1
rlst(i, j, k) = k + 1
kh(i, j, k) = 1 '1は白、0は色あり、すなわち1であればセルにk+1が入力可で、0であれば不可
Next
Next
Next
For i = 0 To n2_1
For j = 0 To n_1
For k = 0 To n_1
hth(i, j, k) = 0
Next
Next
Next
End Sub
Sub zys() '座標作成プロシージャ
Dim i As Byte
Dim s As Byte, t As Byte
For i = 0 To n2_1
s = Int(i / n)
t = i Mod n
a(s, t) = (h + i * m) Mod (n2)
y(a(s, t)) = s
x(a(s, t)) = t
cy(a(s, t)) = s
cx(a(s, t)) = t
Next
End Sub
Sub sds(g As Byte, mok As Byte) '数独作成プロシージャ
If mok = 1 Then If mx(y(g), x(g)) > 0 Then Exit Sub
'確定法で問題を解かせるための命令文
'リストは１個しかない場合のみに以降を続ける。
'リストが２個以上ある場合には強制的に前に戻させる。
'試行錯誤はさせないので、g = hintosu まで戻り、
'更に、CommandButton1_ClickのDo文に戻り、
'次の問題を作るようになっている。
'以下同じことを繰り返せば、確定法で解ける問題が必然的に出来る！
'確定法で解く＝試行錯誤をしないので、復元に関する規定は一切不要になるために、
'復元に関する命令文はすべて注釈文にしてある。
If mok = 0 Then If cn = 1 Then Exit Sub
If mok = 2 Then If cn = 2 Then Exit Sub
Dim i As Byte, ii As Byte, iii As Byte, u As Byte
ii = Int(Rnd * mx(y(g), x(g)))
For i = 0 To mx(y(g), x(g))
iii = (i + ii) Mod (mx(y(g), x(g)) + 1)
p(y(g), x(g)) = rlst(y(g), x(g), iii)
u = klk(g) '局所リスト解析プロシージャ
If u = 1 Then
If g + 1 < n2 Then
u = nck(g + 1, mok)
If u = 1 Then
Call sds(g + 1, mok)
End If
' If rh(g + 1) = 1 Then
' mx(y(g + 1), x(g + 1)) = cmx(g + 1, y(g + 1), x(g + 1))
' For j = 0 To n_1
' rlst(y(g + 1), x(g + 1), j) = crlst(g + 1, y(g + 1), x(g + 1), j)
' Next
' For j = 0 To n_1
' kh(y(g + 1), x(g + 1), j) = ckh(g + 1, y(g + 1), x(g + 1), j)
' Next
' End If
' If mok = 1 Then
' If sh(g + 1) = 1 Then
' For j = 0 To sc(g + 1) - 1
' If hth(g + 1, sy(g + 1, j), sx(g + 1, j)) = 1 Then
' mx(sy(g + 1, j), sx(g + 1, j)) = cmx(g + 1, sy(g + 1, j), sx(g + 1, j))
' For k = 0 To n_1
' rlst(sy(g + 1, j), sx(g + 1, j), k) = crlst(g + 1, sy(g + 1, j), sx(g + 1, j), k)
' Next
' For k = 0 To n_1
' kh(sy(g + 1, j), sx(g + 1, j), k) = ckh(g + 1, sy(g + 1, j), sx(g + 1, j), k)
' Next
' End If
' Next
' End If
' End If
If mok = 0 Then If cn = 1 Then Exit Sub
If mok = 2 Then If cn = 2 Then Exit Sub
Else
cn = cn + 1
If mok = 0 Then If cn = 1 Then Exit Sub
If mok = 2 Then If cn = 2 Then Exit Sub
End If
End If
hukugen (g)
If mok = 0 Then If cn = 1 Then Exit Sub
If mok = 2 Then If cn = 2 Then Exit Sub
Next
p(y(g), x(g)) = 0
End Sub
Function rhk(g As Byte) 'ライン排除確定解析＋相補確定解析プロシージャ
Dim i As Byte, j As Byte, k As Byte, l As Byte, w As Byte 'wは行･列・ブロックにおける白の個数を数えるカウンタ
Dim m As Byte, o As Byte, q As Byte
Dim ys(8) As Byte 'y座標を記録する変数
Dim xs(8) As Byte 'x座標を記録する変数
Dim ys1(8) As Byte 'y座標を記録する変数
Dim xs1(8) As Byte 'x座標を記録する変数
Dim hs As Byte
Dim ybs As Byte, xbs As Byte
Dim ks As Byte, ka As Byte
Dim ls As Byte, la As Byte
rhk = 1
hs = hintosu
sc(g) = 0
' For i = 0 To n_1
' For j = 0 To n_1
' hth(g, i, j) = 0
' Next
' Next
' rh(g) = 0
' sh(g) = 0
'以下各数字に対応する行におけるライン排除確定があるかを調べるための手順
For i = 0 To n_1 'i + 1 は入力する数字を示す。
For j = 0 To n_1 'jはy座標（縦座標）
w = 0
For k = 0 To n_1 'kはx座標（横座標）
If p(j, k) = 0 Then
If kh(j, k, i) = 1 Then
xs(w) = k
w = w + 1
End If
End If
Next
If w = 1 Then '以下ライン排除確定解析
For k = 0 To mx(j, xs(0))
If rlst(j, xs(0), k) = i + 1 Then
For l = 0 To n_1 '以下ライン排除確定による破綻解析
If l <> xs(0) And p(j, l) = 0 Then
If mx(j, l) = 0 And rlst(j, l, 0) = i + 1 Then
' rh(g) = 0
rhk = 0
Exit Function
End If
End If
Next
For l = 0 To n_1
If l <> j And p(l, xs(0)) = 0 Then
If mx(l, xs(0)) = 0 And rlst(l, xs(0), 0) = i + 1 Then
' rh(g) = 0
rhk = 0
Exit Function
End If
End If
Next
ybs = rn * Int(j / rn)
xbs = rn * Int(xs(0) / rn)
For l = 0 To n_1
ls = Int(l / rn)
la = l Mod rn
If ybs + ls <> j And xbs + la <> xs(0) And p(ybs + ls, xbs + la) = 0 Then
If mx(ybs + ls, xbs + la) = 0 And rlst(ybs + ls, xbs + la, 0) = i + 1 Then
' rh(g) = 0
rhk = 0
Exit Function
End If
End If
Next '以上ライン排除確定による破綻解析
y(g) = j
x(g) = xs(0)
' cmx(g, y(g), x(g)) = mx(y(g), x(g))
' For l = 0 To n_1
' crlst(g, y(g), x(g), l) = rlst(y(g), x(g), l)
' Next
' For l = 0 To n_1
' ckh(g, y(g), x(g), l) = kh(y(g), x(g), l)
' Next
rlst(y(g), x(g), 0) = i + 1
rlst(y(g), x(g), 1) = k + 1
mx(y(g), x(g)) = 0
kh(y(g), x(g), i) = 0
' rh(g) = 1
rhk = 1
Exit Function
End If
Next
End If '以上ライン排除確定解析
If w = 2 Then '以下相補確定解析ための手続き
For k = i + 1 To n_1
w = 0
For l = 0 To n_1
If p(j, l) = 0 Then
If kh(j, l, k) = 1 Then
xs1(w) = l
w = w + 1
End If
End If
Next
If w = 2 And xs(0) = xs1(0) And xs(1) = xs1(1) Then
For l = 0 To n_1
If l <> xs(0) And l <> xs(1) Then '以下相補確定による破綻解析
If p(j, l) = 0 Then
If mx(j, l) = 1 Then
If (rlst(j, l, 0) = i + 1 Or rlst(j, l, 1) = i + 1) And (rlst(j, l, 0) = k + 1 Or rlst(j, l, 1) = k + 1) Then
rhk = 0
rh(g) = 0
Exit Function
End If
End If
If mx(j, l) = 0 Then
If (rlst(j, l, 0) = i + 1 Or rlst(j, l, 1) = i + 1) Or (rlst(j, l, 0) = k + 1 Or rlst(j, l, 1) = k + 1) Then
rhk = 0
rh(g) = 0
Exit Function
End If
End If
End If
End If
Next '以上相補確定による破綻解析
For l = 0 To n_1 '以下相補確定による排除解析
If l <> xs(0) And l <> xs(1) Then
If p(j, l) = 0 Then
For m = 0 To mx(j, l)
If rlst(j, l, m) = i + 1 Then
sy(g, sc(g)) = j
sx(g, sc(g)) = l
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For o = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
' For o = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g))))
rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = i + 1
mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1
kh(sy(g, sc(g)), sx(g, sc(g)), i) = 0
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
Exit For
End If
If rlst(j, l, m) = k + 1 Then
sy(g, sc(g)) = j
sx(g, sc(g)) = l
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For o = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
' For o = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g))))
rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = k + 1
mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1
kh(sy(g, sc(g)), sx(g, sc(g)), k) = 0
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
Exit For
End If
Next
End If
End If
Next '以上相補確定による解除解析
If hth(g, j, xs(0)) = 0 Then '以下相補確定
sx(g, sc(g)) = xs(0)
sy(g, sc(g)) = j
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For l = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
' For l = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
mx(sy(g, sc(g)), sx(g, sc(g))) = 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
End If
If hth(g, j, xs(1)) = 0 Then
sx(g, sc(g)) = xs(1)
sy(g, sc(g)) = j
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For l = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
' For l = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
mx(sy(g, sc(g)), sx(g, sc(g))) = 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
End If '以上相補確定
' sh(g) = 1
Exit Function
End If
Next
End If '以上相補確定解析のための手続き
'以下3on3確定解析は大変複雑なため独立プロシージャに仕事を依頼
'本来は、相補確定解析から独立プロシージャに仕事を依頼すべきであった。
'理由は二つ。
'すでにライン排除確定解析プロシージャが大きくなりすぎている！
'仕事を他のプロシージャに依頼すると、コードがすっきりして仕組みがわかりやすくなること！
If w = 3 Then
rhk = tontx(g, xs, j, i)
'tontxは行についての3on3解析を行うプロシージャ
'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であったことをお忘れなきように！
Exit Function
End If
'以上行における白いセルのカウント
Next
Next
'以下各数字に対応する列におけるライン排除確定があるかを調べるための手順
For i = 0 To n_1 'i + 1 は入力する数字を示す。
For j = 0 To n_1 'jはy座標（縦座標）
w = 0
For k = 0 To n_1 'kはx座標（横座標）
If p(k, j) = 0 Then
If kh(k, j, i) = 1 Then
ys(w) = k
w = w + 1
End If
End If
Next
If w = 1 Then
For k = 0 To mx(ys(0), j)
If rlst(ys(0), j, k) = i + 1 Then
For l = 0 To n_1 '以下ライン排除確定による破綻解析
If l <> j And p(ys(0), l) = 0 Then
If mx(ys(0), l) = 0 And rlst(ys(0), l, 0) = i + 1 Then
rh(g) = 0
rhk = 0
Exit Function
End If
End If
Next
For l = 0 To n_1
If l <> ys(0) And p(l, j) = 0 Then
If mx(l, j) = 0 And rlst(l, j, 0) = i + 1 Then
rh(g) = 0
rhk = 0
Exit Function
End If
End If
Next
ybs = rn * Int(ys(0) / rn)
xbs = rn * Int(j / rn)
For l = 0 To n_1
ls = Int(l / rn)
la = l Mod rn
If ybs + ls <> ys(0) And xbs + la <> j And p(ybs + ls, xbs + la) = 0 Then
If mx(ybs + ls, xbs + la) = 0 And rlst(ybs + ls, xbs + la, 0) = i + 1 Then
rh(g) = 0
rhk = 0
Exit Function
End If
End If
Next '以下ライン排除確定による破綻解析
y(g) = ys(0)
x(g) = j
' cmx(g, y(g), x(g)) = mx(y(g), x(g))
' For l = 0 To n_1
' crlst(g, y(g), x(g), l) = rlst(y(g), x(g), l)
' Next
' For l = 0 To n_1
' ckh(g, y(g), x(g), l) = kh(y(g), x(g), l)
' Next
rlst(y(g), x(g), k) = rlst(y(g), x(g), 0)
rlst(y(g), x(g), 0) = i + 1
mx(y(g), x(g)) = 0
kh(y(g), x(g), i) = 0
' rh(g) = 1
Exit Function
End If
Next
End If
If w = 2 Then '以下相補確定解析のための手続き
For k = i + 1 To n_1
w = 0
For l = 0 To n_1
If p(l, j) = 0 Then
If kh(l, j, k) = 1 Then
ys1(w) = l
w = w + 1
End If
End If
Next
If w = 2 And ys(0) = ys1(0) And ys(1) = ys1(1) Then
For l = 0 To n_1 '以下相補確定破綻解析
If l <> ys(0) And l <> ys(1) Then
If p(l, j) = 0 Then
If mx(l, j) = 1 Then
If (rlst(l, j, 0) = i + 1 Or rlst(l, j, 1) = i + 1) And (rlst(l, j, 0) = k + 1 Or rlst(l, j, 1) = k + 1) Then
rhk = 0
rh(g) = 0
Exit Function
End If
End If
If mx(l, j) = 0 Then
If (rlst(l, j, 0) = i + 1 Or rlst(l, j, 1) = i + 1) Or (rlst(l, j, 0) = k + 1 Or rlst(l, j, 1) = k + 1) Then
rhk = 0
rh(g) = 0
Exit Function
End If
End If
End If
End If
Next '以上相補確定破綻解析
For l = 0 To n_1 '以下相補確定による排除解析
If l <> ys(0) And l <> ys(1) Then
If p(l, j) = 0 Then
For m = 0 To mx(l, j)
If rlst(l, j, m) = i + 1 Then
sy(g, sc(g)) = l
sx(g, sc(g)) = j
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For o = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
' For o = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g))))
rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = i + 1
mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1
kh(sy(g, sc(g)), sx(g, sc(g)), i) = 0
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
Exit For
End If
If rlst(l, j, m) = k + 1 Then
sy(g, sc(g)) = l
sx(g, sc(g)) = j
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For o = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
' For o = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g))))
rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = k + 1
mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1
kh(sy(g, sc(g)), sx(g, sc(g)), k) = 0
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
Exit For
End If
Next
End If
End If
Next '以上相補確定による排除解析
If hth(g, j, ys(0)) = 0 Then '以下相補確定解析
sx(g, sc(g)) = j
sy(g, sc(g)) = ys(0)
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For l = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
' For l = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
mx(sy(g, sc(g)), sx(g, sc(g))) = 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
End If
If hth(g, j, ys(1)) = 0 Then
sx(g, sc(g)) = j
sy(g, sc(g)) = ys(1)
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For l = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
' For l = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
mx(sy(g, sc(g)), sx(g, sc(g))) = 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
End If '以上相補確定
' sh(g) = 1
Exit Function
End If
Next
End If '以上相補確定解析のための手続き
'以下3on3確定解析は大変複雑なため独立プロシージャに仕事を依頼
'本来は、相補確定解析から独立プロシージャに仕事を依頼すべきであった。
'理由は二つ。
'すでにライン排除確定解析プロシージャが大きくなりすぎている！
'仕事を他のプロシージャに依頼すると、コードがすっきりして仕組みがわかりやすくなること！
If w = 3 Then
rhk = tonty(g, ys, j, i)
'tontyは列についての3on3解析を行うプロシージャ
'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であったことをお忘れなきように！
Exit Function
End If
'以上行における白いセルのカウント
Next
Next
'以下各数字に対応するブロックにおけるライン排除確定があるかを調べるための手順
For i = 0 To n_1 'i + 1 は入力する数字を示す。
For j = 0 To n_1 'jはy座標（縦座標）
ybs = rn * Int(j / rn)
xbs = rn * (j Mod rn)
w = 0
For k = 0 To n_1 'kはx座標（横座標）
ks = Int(k / rn)
ka = k Mod rn
If p(ybs + ks, xbs + ka) = 0 Then
If kh(ybs + ks, xbs + ka, i) = 1 Then
ys(w) = ybs + ks
xs(w) = xbs + ka
w = w + 1
End If
End If
Next
If w = 1 Then
For k = 0 To mx(ys(0), xs(0))
If rlst(ys(0), xs(0), k) = i + 1 Then
For l = 0 To n_1 '以下ライン排除確定による破綻解析
If l <> xs(0) And p(ys(0), l) = 0 Then
If mx(ys(0), l) = 0 And rlst(ys(0), l, 0) = i + 1 Then
rh(g) = 0
rhk = 0
Exit Function
End If
End If
Next
For l = 0 To n_1
If l <> ys(0) And p(l, xs(0)) = 0 Then
If mx(l, xs(0)) = 0 And rlst(l, xs(0), 0) = i + 1 Then
rh(g) = 0
rhk = 0
Exit Function
End If
End If
Next
ybs = rn * Int(ys(0) / rn)
xbs = rn * Int(xs(0) / rn)
For l = 0 To n_1
ls = Int(l / rn)
la = l Mod rn
If ybs + ls <> ys(0) And xbs + la <> xs(0) And p(ybs + ls, xbs + la) = 0 Then
If mx(ybs + ls, xbs + la) = 0 And rlst(ybs + ls, xbs + la, 0) = i + 1 Then
rh(g) = 0
rhk = 0
Exit Function
End If
End If
Next '以上ライン排除確定による破綻解析
y(g) = ys(0)
x(g) = xs(0)
' cmx(g, y(g), x(g)) = mx(y(g), x(g))
' For l = 0 To n_1
' crlst(g, y(g), x(g), l) = rlst(y(g), x(g), l)
' Next
' For l = 0 To n_1
' ckh(g, y(g), x(g), l) = kh(y(g), x(g), l)
' Next
rlst(y(g), x(g), k) = rlst(y(g), x(g), 0)
rlst(y(g), x(g), 0) = i + 1
mx(y(g), x(g)) = 0
kh(y(g), x(g), i) = 0
' rh(g) = 1
Exit Function
End If
Next
End If
If w = 2 Then '以下相補確定解析のための手続き
For k = i + 1 To n_1
w = 0
For l = 0 To n_1
ls = Int(l / rn)
la = l Mod rn
If p(ybs + ls, xbs + la) = 0 Then
If kh(ybs + ls, xbs + la, k) = 1 Then
xs1(w) = xbs + la
ys1(w) = ybs + ls
w = w + 1
End If
End If
Next
If w = 2 And (xs(0) = xs1(0) And ys(0) = ys1(0)) And (xs(1) = xs1(1) And ys(1) = ys1(1)) Then
For l = 0 To n_1 '以下相補確定破綻解析
ls = Int(l / rn)
la = l Mod rn
If (xbs + la <> xs(0) Or ybs + ls <> ys(0)) And (xbs + la <> xs(1) Or ybs + ls <> ys(1)) Then
If p(ybs + ls, xbs + la) = 0 Then
If mx(ybs + ls, xbs + la) = 1 Then
If (rlst(ybs + ls, xbs + la, 0) = i + 1 Or rlst(ybs + ls, xbs + la, 1) = i + 1) And (rlst(ybs + ls, xbs + la, 0) = k + 1 Or rlst(ybs + ls, xbs + la, 1) = k + 1) Then
rhk = 0
rh(g) = 0
Exit Function
End If
End If
If mx(ybs + ls, xbs + la) = 0 Then
If (rlst(ybs + ls, xbs + la, 0) = i + 1 Or rlst(ybs + ls, xbs + la, 1) = i + 1) Or (rlst(ybs + ls, xbs + la, 0) = k + 1 Or rlst(ybs + ls, xbs + la, 1) = k + 1) Then
rhk = 0
rh(g) = 0
Exit Function
End If
End If
End If
End If
Next '以上相補確定による破綻解析
For l = 0 To n_1 '以下相補確定による排除解析
ls = Int(l / rn)
la = l Mod rn
If (xbs + la <> xs(0) Or ybs + ls <> ys(0)) And (xbs + la <> xs(1) Or ybs + ls <> ys(1)) Then
If p(ybs + ls, xbs + la) = 0 Then
For m = 0 To mx(ybs + ls, xbs + la)
If rlst(ybs + ls, xbs + la, m) = i + 1 Then
sy(g, sc(g)) = ybs + ls
sx(g, sc(g)) = xbs + la
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For o = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
' For o = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g))))
rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = i + 1
mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1
kh(sy(g, sc(g)), sx(g, sc(g)), i) = 0
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
Exit For
End If
If rlst(ybs + ls, xbs + la, m) = k + 1 Then
sy(g, sc(g)) = ybs + ls
sx(g, sc(g)) = xbs + la
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For o = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
' For o = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o)
' Next
rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g))))
rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = k + 1
mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1
kh(sy(g, sc(g)), sx(g, sc(g)), k) = 0
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
Exit For
End If
Next
End If
End If
Next '以上相補確定による排除解析
If hth(g, ys(0), xs(0)) = 0 Then '以下相補確定
sx(g, sc(g)) = xs(0)
sy(g, sc(g)) = ys(0)
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For l = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
' For l = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
mx(sy(g, sc(g)), sx(g, sc(g))) = 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
End If
If hth(g, ys(1), xs(1)) = 0 Then
sx(g, sc(g)) = xs(1)
sy(g, sc(g)) = ys(1)
' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g)))
' For l = 0 To n_1
' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
' For l = 0 To n_1
' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l)
' Next
mx(sy(g, sc(g)), sx(g, sc(g))) = 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1
rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1
' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1
sc(g) = sc(g) + 1
End If '以上相補確定
sh(g) = 1
Exit Function
End If
Next
End If '以上相補確定解析のための手続き
'以下3on3確定解析は大変複雑なため独立プロシージャに仕事を依頼
'本来は、相補確定解析から独立プロシージャに仕事を依頼すべきであった。
'理由は二つ。
'すでにライン排除確定解析プロシージャが大きくなりすぎている！
'仕事を他のプロシージャに依頼すると、コードがすっきりして仕組みがわかりやすくなること！
If w = 3 Then
rhk = tontb(g, ys, xs, i)
'tontyは列についての3on3解析を行うプロシージャ
'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であったことをお忘れなきように！
Exit Function
End If
'以上行における白いセルのカウント
Next
Next
End Function
Function tontx(g As Byte, xs() As Byte, s As Byte, ny As Byte) '行についての3on3解析を行うFunctionプロシージャ
'引数のnyは、内容（naiyou）の略、呼び出し側のライン排除確定プロシージャのiに当たる。
'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であった。
'確定法で解く＝仮定法を使わないので復元規定は最初から記述しない。
Dim i As Byte, j As Byte, k As Byte, l As Byte, m As Byte, o As Byte, w As Byte
Dim xs1(8) As Byte 'x座標を記録する変数
Dim xs2(8) As Byte 'x座標を記録する変数
tontx = 1
For i = ny + 1 To n_1
'i + 1 は数独配列p(○, ○)に入れる２番目の内容（１から９の値）
'もっと正確に説明すると、3on3のセルにおけるリストの２番目となる可能性のある値である。
'可能性という言い方をしたのは、以下の条件を満たしてはじめて２番目のリストになるから。
w = 0
For j = 0 To n_1 'jはx座標(横座標）
If p(s, j) = 0 Then 's = ys(0)
If kh(s, j, i) = 1 Then
xs1(w) = j
w = w + 1
End If
End If
Next
If w = 3 Then
If xs(0) = xs1(0) And xs(1) = xs1(1) And xs(2) = xs1(2) Then
For j = 0 To n_1 'j + 1 は3on3セルの３番目のリスト候補
If j <> ny And j <> i Then
w = 0
For k = 0 To n_1 'kはx座標(横座標）
If p(s, k) = 0 Then 's = ys(0)
If kh(s, k, j) = 1 Then
xs2(w) = k
w = w + 1
End If
End If
Next
If w = 2 Or w = 3 Then
If (xs2(0) = xs(0) And xs2(1) = xs(1)) Or (xs2(0) = xs(0) And xs2(2) = xs(2)) Or (xs2(1) = xs(1) And xs2(2) = xs(2)) Then
'以降3on3確定による破綻処理
For k = 0 To n_1
If k <> xs(0) And k <> xs(1) And k <> xs(2) Then
If p(s, k) = 0 Then
If mx(s, k) = 2 Then
w = 0
For l = 0 To 2
If rlst(s, k, l) = ny + 1 Or rlst(s, k, l) = i + 1 Or rlst(s, k, l) = j + 1 Then
w = w + 1
End If
Next
If w = 3 Then
tontx = 0
Exit Function
End If
End If
If mx(s, k) = 1 Then
w = 0
For l = 0 To 1
If rlst(s, k, l) = ny + 1 Or rlst(s, k, l) = i + 1 Or rlst(s, k, l) = j + 1 Then
w = w + 1
End If
Next
If w = 2 Then
tontx = 0
Exit Function
End If
End If
If mx(s, k) = 0 Then
If rlst(s, k, 0) = ny + 1 Or rlst(s, k, 0) = i + 1 Or rlst(s, k, 0) = j + 1 Then
tontx = 0
Exit Function
End If
End If
End If
End If
Next
'3on3確定による破綻処理終了
' Cells(4 + Int(cnt / 50), 1 + (cnt Mod 50)) = "X"
' cnt = cnt + 1
'以降3on3確定による排除解析
For k = 0 To n_1
If k <> xs(0) And k <> xs(1) And k <> xs(2) Then
If p(s, k) = 0 Then
For l = 0 To mx(s, k)
If ny + 1 = rlst(s, k, l) Then
rlst(s, k, l) = rlst(s, k, mx(s, k))
rlst(s, k, mx(s, k)) = ny + 1
kh(s, k, ny) = 0
mx(s, k) = mx(s, k) - 1
Exit For
End If
Next
For l = 0 To mx(s, k)
If i + 1 = rlst(s, k, l) Then
rlst(s, k, l) = rlst(s, k, mx(s, k))
rlst(s, k, mx(s, k)) = i + 1
kh(s, k, i) = 0
mx(s, k) = mx(s, k) - 1
Exit For
End If
Next
For l = 0 To mx(s, k)
If j + 1 = rlst(s, k, l) Then
rlst(s, k, l) = rlst(s, k, mx(s, k))
rlst(s, k, mx(s, k)) = j + 1
kh(s, k, j) = 0
mx(s, k) = mx(s, k) - 1
Exit For
End If
Next
End If
End If
Next
'3on3確定による排除解析終了
'以降3on3確定解析
Dim kr(2) As Byte
For k = 0 To 2
kr(k) = 0
Next
w = 0
For k = 0 To mx(s, xs(0))
If ny + 1 = rlst(s, xs(0), k) Then
kr(0) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(s, xs(0))
If i + 1 = rlst(s, xs(0), k) Then
kr(1) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(s, xs(0))
If j + 1 = rlst(s, xs(0), k) Then
kr(2) = 1
w = w + 1
Exit For
End If
Next
If w = 3 Then
rlst(s, xs(0), 0) = ny + 1
rlst(s, xs(0), 1) = i + 1
rlst(s, xs(0), 2) = j + 1
mx(s, xs(0)) = 2
End If
If w = 2 Then
w = 0
If kr(0) = 1 Then
rlst(s, xs(0), w) = ny + 1
w = w + 1
End If
If kr(1) = 1 Then
rlst(s, xs(0), w) = i + 1
w = w + 1
End If
If kr(2) = 1 Then
rlst(s, xs(0), w) = j + 1
w = w + 1
End If
mx(s, xs(0)) = 1
End If
For k = 0 To 2
kr(k) = 0
Next
w = 0
For k = 0 To mx(s, xs(1))
If ny + 1 = rlst(s, xs(1), k) Then
kr(0) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(s, xs(1))
If i + 1 = rlst(s, xs(1), k) Then
kr(1) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(s, xs(1))
If j + 1 = rlst(s, xs(1), k) Then
kr(2) = 1
w = w + 1
Exit For
End If
Next
If w = 3 Then
rlst(s, xs(1), 0) = ny + 1
rlst(s, xs(1), 1) = i + 1
rlst(s, xs(1), 2) = j + 1
mx(s, xs(1)) = 2
End If
If w = 2 Then
w = 0
If kr(0) = 1 Then
rlst(s, xs(1), w) = ny + 1
w = w + 1
End If
If kr(1) = 1 Then
rlst(s, xs(1), w) = i + 1
w = w + 1
End If
If kr(2) = 1 Then
rlst(s, xs(1), w) = j + 1
w = w + 1
End If
mx(s, xs(1)) = 1
End If
For k = 0 To 2
kr(k) = 0
Next
w = 0
For k = 0 To mx(s, xs(2))
If ny + 1 = rlst(s, xs(2), k) Then
kr(0) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(s, xs(2))
If i + 1 = rlst(s, xs(2), k) Then
kr(1) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(s, xs(2))
If j + 1 = rlst(s, xs(2), k) Then
kr(2) = 1
w = w + 1
Exit For
End If
Next
If w = 3 Then
rlst(s, xs(2), 0) = ny + 1
rlst(s, xs(2), 1) = i + 1
rlst(s, xs(2), 2) = j + 1
mx(s, xs(2)) = 2
End If
If w = 2 Then
w = 0
If kr(0) = 1 Then
rlst(s, xs(2), w) = ny + 1
w = w + 1
End If
If kr(1) = 1 Then
rlst(s, xs(2), w) = i + 1
w = w + 1
End If
If kr(2) = 1 Then
rlst(s, xs(2), w) = j + 1
w = w + 1
End If
mx(s, xs(2)) = 1
End If
'3on3確定解析終了
Exit For
End If
End If
End If
Next
End If
End If
Next
End Function
Function tonty(g As Byte, ys() As Byte, t As Byte, ny As Byte) '列についての3on3解析を行うFunctionプロシージャ
'引数のnyは、内容（naiyou）の略、呼び出し側のライン排除確定プロシージャのiに当たる。
'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であった。
'確定法で解く＝仮定法を使わないので復元規定は最初から記述しない。
Dim i As Byte, j As Byte, k As Byte, l As Byte, m As Byte, o As Byte, w As Byte
Dim ys1(8) As Byte 'y座標を記録する変数
Dim ys2(8) As Byte 'y座標を記録する変数
tonty = 1
Dim xs1(8) As Byte 'x座標を記録する変数
Dim xs2(8) As Byte 'x座標を記録する変数
tonty = 1
For i = ny + 1 To n_1
'i + 1 は数独配列p(○, ○)に入れる２番目の内容（１から９の値）
'もっと正確に説明すると、3on3のセルにおけるリストの２番目となる可能性のある値である。
'可能性という言い方をしたのは、以下の条件を満たしてはじめて２番目のリストになるから。
w = 0
For j = 0 To n_1 'jはx座標(横座標）
If p(j, t) = 0 Then 's = ys(0)
If kh(j, t, i) = 1 Then
ys1(w) = j
w = w + 1
End If
End If
Next
If w = 3 Then
If ys(0) = ys1(0) And ys(1) = ys1(1) And ys(2) = ys1(2) Then
For j = 0 To n_1 'j + 1 は3on3セルの３番目のリスト候補
If j <> ny And j <> i Then
w = 0
For k = 0 To n_1 'kはx座標(横座標）
If p(k, t) = 0 Then 's = ys(0)
If kh(k, t, j) = 1 Then
ys2(w) = k
w = w + 1
End If
End If
Next
If w = 2 Or w = 3 Then
If (ys2(0) = ys(0) And ys2(1) = ys(1)) Or (ys2(0) = ys(0) And ys2(2) = ys(2)) Or (ys2(1) = ys(1) And ys2(2) = ys(2)) Then
'以降3on3確定による破綻処理
For k = 0 To n_1
If k <> ys(0) And k <> ys(1) And k <> ys(2) Then
If p(k, t) = 0 Then
If mx(k, t) = 2 Then
w = 0
For l = 0 To 2
If rlst(k, t, l) = ny + 1 Or rlst(k, t, l) = i + 1 Or rlst(k, t, l) = j + 1 Then
w = w + 1
End If
Next
If w = 3 Then
tonty = 0
Exit Function
End If
End If
If mx(k, t) = 1 Then
w = 0
For l = 0 To 1
If rlst(k, t, l) = ny + 1 Or rlst(k, t, l) = i + 1 Or rlst(k, t, l) = j + 1 Then
w = w + 1
End If
Next
If w = 2 Then
tonty = 0
Exit Function
End If
End If
If mx(k, t) = 0 Then
If rlst(k, t, 0) = ny + 1 Or rlst(k, t, 0) = i + 1 Or rlst(k, t, 0) = j + 1 Then
tonty = 0
Exit Function
End If
End If
End If
End If
Next
'3on3確定による破綻処理終了
' Cells(4 + Int(cnt / 50), 1 + (cnt Mod 50)) = "X"
' cnt = cnt + 1
'以降3on3確定による排除解析
For k = 0 To n_1
If k <> ys(0) And k <> ys(1) And k <> ys(2) Then
If p(k, t) = 0 Then
For l = 0 To mx(k, t)
If ny + 1 = rlst(k, t, l) Then
rlst(k, t, l) = rlst(k, t, mx(k, t))
rlst(k, t, mx(k, t)) = ny + 1
kh(k, t, ny) = 0
mx(k, t) = mx(k, t) - 1
Exit For
End If
Next
For l = 0 To mx(k, t)
If i + 1 = rlst(k, t, l) Then
rlst(k, t, l) = rlst(k, t, mx(k, t))
rlst(k, t, mx(k, t)) = i + 1
kh(k, t, i) = 0
mx(k, t) = mx(k, t) - 1
Exit For
End If
Next
For l = 0 To mx(k, t)
If j + 1 = rlst(k, t, l) Then
rlst(k, t, l) = rlst(k, t, mx(k, t))
rlst(k, t, mx(k, t)) = j + 1
kh(k, t, j) = 0
mx(k, t) = mx(k, t) - 1
Exit For
End If
Next
End If
End If
Next
'3on3確定による排除解析終了
'以降3on3確定解析
Dim kr(2) As Byte
For k = 0 To 2
kr(k) = 0
Next
w = 0
For k = 0 To mx(ys(0), t)
If ny + 1 = rlst(ys(0), t, k) Then
kr(0) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(0), t)
If i + 1 = rlst(ys(0), t, k) Then
kr(1) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(0), t)
If j + 1 = rlst(ys(0), t, k) Then
kr(2) = 1
w = w + 1
Exit For
End If
Next
If w = 3 Then
rlst(ys(0), t, 0) = ny + 1
rlst(ys(0), t, 1) = i + 1
rlst(ys(0), t, 2) = j + 1
mx(ys(0), t) = 2
End If
If w = 2 Then
w = 0
If kr(0) = 1 Then
rlst(ys(0), t, w) = ny + 1
w = w + 1
End If
If kr(1) = 1 Then
rlst(ys(0), t, w) = i + 1
w = w + 1
End If
If kr(2) = 1 Then
rlst(ys(0), t, w) = j + 1
w = w + 1
End If
mx(ys(0), t) = 1
End If
For k = 0 To 2
kr(k) = 0
Next
w = 0
For k = 0 To mx(ys(1), t)
If ny + 1 = rlst(ys(1), t, k) Then
kr(0) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(1), t)
If i + 1 = rlst(ys(1), t, k) Then
kr(1) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(1), t)
If j + 1 = rlst(ys(1), t, k) Then
kr(2) = 1
w = w + 1
Exit For
End If
Next
If w = 3 Then
rlst(ys(1), t, 0) = ny + 1
rlst(ys(1), t, 1) = i + 1
rlst(ys(1), t, 2) = j + 1
mx(ys(1), t) = 2
End If
If w = 2 Then
w = 0
If kr(0) = 1 Then
rlst(ys(1), t, w) = ny + 1
w = w + 1
End If
If kr(1) = 1 Then
rlst(ys(1), t, w) = i + 1
w = w + 1
End If
If kr(2) = 1 Then
rlst(ys(1), t, w) = j + 1
w = w + 1
End If
mx(ys(1), t) = 1
End If
For k = 0 To 2
kr(k) = 0
Next
w = 0
For k = 0 To mx(ys(2), t)
If ny + 1 = rlst(ys(2), t, k) Then
kr(0) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(2), t)
If i + 1 = rlst(ys(2), t, k) Then
kr(1) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(2), t)
If j + 1 = rlst(ys(2), t, k) Then
kr(2) = 1
w = w + 1
Exit For
End If
Next
If w = 3 Then
rlst(ys(2), t, 0) = ny + 1
rlst(ys(2), t, 1) = i + 1
rlst(ys(2), t, 2) = j + 1
mx(ys(2), t) = 2
End If
If w = 2 Then
w = 0
If kr(0) = 1 Then
rlst(ys(2), t, w) = ny + 1
w = w + 1
End If
If kr(1) = 1 Then
rlst(ys(2), t, w) = i + 1
w = w + 1
End If
If kr(2) = 1 Then
rlst(ys(2), t, w) = j + 1
w = w + 1
End If
mx(ys(2), t) = 1
End If
'3on3確定解析終了
Exit For
End If
End If
End If
Next
End If
End If
Next
End Function
Function tontb(g As Byte, ys() As Byte, xs() As Byte, ny As Byte) '行についての3on3解析を行うFunctionプロシージャ
'引数のnyは、内容（naiyou）の略、呼び出し側のライン排除確定プロシージャのiに当たる。
'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であった。
'確定法で解く＝仮定法を使わないので復元規定は最初から記述しない。
Dim i As Byte, j As Byte, k As Byte, l As Byte, m As Byte, o As Byte, w As Byte
Dim xs1(8) As Byte 'x座標を記録する変数
Dim xs2(8) As Byte 'x座標を記録する変数
Dim ys1(8) As Byte 'x座標を記録する変数
Dim ys2(8) As Byte 'x座標を記録する変数
tontb = 1
Dim ybs As Byte, xbs As Byte
ybs = rn * Int(ys(0) / rn)
xbs = rn * Int(xs(0) / rn)
Dim js As Byte, ja As Byte
Dim ks As Byte, ka As Byte
For i = ny + 1 To n_1
'i + 1 は数独配列p(○, ○)に入れる２番目の内容（１から９の値）
'もっと正確に説明すると、3on3のセルにおけるリストの２番目となる可能性のある値である。
'可能性という言い方をしたのは、以下の条件を満たしてはじめて２番目のリストになるから。
w = 0
For j = 0 To n_1 'jはブロック番号
js = Int(j / rn)
ja = j Mod rn
If p(ybs + js, xbs + ja) = 0 Then 's = ys(0)
If kh(ybs + js, xbs + ja, i) = 1 Then
ys1(w) = ybs + js
xs1(w) = xbs + ja
w = w + 1
End If
End If
Next
If w = 3 Then
If (ys(0) = ys1(0) Or xs(0) = xs1(0)) And (ys(1) = ys1(1) Or xs(1) = xs1(1)) And (ys(2) = ys1(2) Or xs(2) = xs1(2)) Then
For j = 0 To n_1 'j + 1 は3on3セルの３番目のリスト候補
If j <> ny And j <> i Then
w = 0
For k = 0 To n_1 'kはブロック内番号
ks = Int(k / rn)
ka = k Mod rn
If p(ybs + ks, xbs + ka) = 0 Then 's = ys(0)
If kh(ybs + ks, xbs + ka, j) = 1 Then
ys2(w) = ybs + ks
xs2(w) = xbs + ka
w = w + 1
End If
End If
Next
If w = 2 Or w = 3 Then
If (((ys2(0) = ys(0)) And (xs2(0) = xs(0))) And (((ys2(1) = ys(1)) And xs2(1) = xs(1)))) Or (((ys2(0) = ys(0)) And (xs2(0) = xs(0))) And (((ys2(2) = ys(2)) And xs2(2) = xs(2)))) Or (((ys2(1) = ys(1)) And (xs2(1) = xs(1))) And (((ys2(2) = ys(2)) And xs2(2) = xs(2)))) Then
'以降3on3確定による破綻処理
For k = 0 To n_1
ks = Int(k / rn)
ka = k Mod rn
If (ybs + ks <> ys(0) Or xbs <> xs(0)) And (ybs + ks <> ys(1) Or xbs <> xs(1)) And (ybs + ks <> ys(2) Or xbs <> xs(2)) Then
If p(ybs + ks, xbs + ka) = 0 Then
If mx(ybs + ks, xbs + ka) = 2 Then
w = 0
For l = 0 To 2
If rlst(ybs + ks, xbs + ka, l) = ny + 1 Or rlst(ybs + ks, xbs + ka, l) = i + 1 Or rlst(ybs + ks, xbs + ka, l) = j + 1 Then
w = w + 1
End If
Next
If w = 3 Then
tontb = 0
Exit Function
End If
End If
If mx(ybs + ks, xbs + ka) = 1 Then
w = 0
For l = 0 To 1
If rlst(ybs + ks, xbs + ka, l) = ny + 1 Or rlst(ybs + ks, xbs + ka, l) = i + 1 Or rlst(ybs + ks, xbs + ka, l) = j + 1 Then
w = w + 1
End If
Next
If w = 2 Then
tontb = 0
Exit Function
End If
End If
If mx(ybs + ks, xbs + ka) = 0 Then
If rlst(ybs + ks, xbs + ka, 0) = ny + 1 Or rlst(ybs + ks, xbs + ka, 0) = i + 1 Or rlst(ybs + ks, xbs + ka, 0) = j + 1 Then
tontb = 0
Exit Function
End If
End If
End If
End If
Next
'3on3確定による破綻処理終了
' Cells(4 + Int(cnt / 50), 1 + (cnt Mod 50)) = "X"
' cnt = cnt + 1
'以降3on3確定による排除解析
For k = 0 To n_1
ks = Int(k / rn)
ka = k Mod rn
If (ybs + ks <> ys(0) Or xbs <> xs(0)) And (ybs + ks <> ys(1) Or xbs <> xs(1)) And (ybs + ks <> ys(2) Or xbs <> xs(2)) Then
If p(ybs + ks, xbs + ka) = 0 Then
For l = 0 To mx(ybs + ks, xbs + ka)
If ny + 1 = rlst(ybs + ks, xbs + ka, l) Then
rlst(ybs + ks, xbs + ka, l) = rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka))
rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka)) = ny + 1
kh(ybs + ks, xbs + ka, ny) = 0
mx(ybs + ks, xbs + ka) = mx(ybs + ks, xbs + ka) - 1
Exit For
End If
Next
For l = 0 To mx(ybs + ks, xbs + ka)
If i + 1 = rlst(ybs + ks, xbs + ka, l) Then
rlst(ybs + ks, xbs + ka, l) = rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka))
rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka)) = i + 1
kh(ybs + ks, xbs + ka, i) = 0
mx(ybs + ks, xbs + ka) = mx(ybs + ks, xbs + ka) - 1
Exit For
End If
Next
For l = 0 To mx(ybs + ks, xbs + ka)
If j + 1 = rlst(ybs + ks, xbs + ka, l) Then
rlst(ybs + ks, xbs + ka, l) = rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka))
rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka)) = j + 1
kh(ybs + ks, xbs + ka, j) = 0
mx(ybs + ks, xbs + ka) = mx(ybs + ks, xbs + ka) - 1
Exit For
End If
Next
End If
End If
Next
'3on3確定による排除解析終了
'以降3on3確定解析
Dim kr(2) As Byte
For k = 0 To 2
kr(k) = 0
Next
w = 0
For k = 0 To mx(ys(0), xs(0))
If ny + 1 = rlst(ys(0), xs(0), k) Then
kr(0) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(0), xs(0))
If i + 1 = rlst(ys(0), xs(0), k) Then
kr(1) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(0), xs(0))
If j + 1 = rlst(ys(0), xs(0), k) Then
kr(2) = 1
w = w + 1
Exit For
End If
Next
If w = 3 Then
rlst(ys(0), xs(0), 0) = ny + 1
rlst(ys(0), xs(0), 1) = i + 1
rlst(ys(0), xs(0), 2) = j + 1
mx(ys(0), xs(0)) = 2
End If
If w = 2 Then
w = 0
If kr(0) = 1 Then
rlst(ys(0), xs(0), w) = ny + 1
w = w + 1
End If
If kr(1) = 1 Then
rlst(ys(0), xs(0), w) = i + 1
w = w + 1
End If
If kr(2) = 1 Then
rlst(ys(0), xs(0), w) = j + 1
w = w + 1
End If
mx(ys(0), xs(0)) = 1
End If
For k = 0 To 2
kr(k) = 0
Next
w = 0
For k = 0 To mx(ys(1), xs(1))
If ny + 1 = rlst(ys(1), xs(1), k) Then
kr(0) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(1), xs(1))
If i + 1 = rlst(ys(1), xs(1), k) Then
kr(1) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(1), xs(1))
If j + 1 = rlst(ys(1), xs(1), k) Then
kr(2) = 1
w = w + 1
Exit For
End If
Next
If w = 3 Then
rlst(ys(1), xs(1), 0) = ny + 1
rlst(ys(1), xs(1), 1) = i + 1
rlst(ys(1), xs(1), 2) = j + 1
mx(ys(1), xs(1)) = 2
End If
If w = 2 Then
w = 0
If kr(0) = 1 Then
rlst(ys(1), xs(1), w) = ny + 1
w = w + 1
End If
If kr(1) = 1 Then
rlst(ys(1), xs(1), w) = i + 1
w = w + 1
End If
If kr(2) = 1 Then
rlst(ys(1), xs(1), w) = j + 1
w = w + 1
End If
mx(ys(1), xs(1)) = 1
End If
For k = 0 To 2
kr(k) = 0
Next
w = 0
For k = 0 To mx(ys(2), xs(2))
If ny + 1 = rlst(ys(2), xs(2), k) Then
kr(0) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(2), xs(2))
If i + 1 = rlst(ys(2), xs(2), k) Then
kr(1) = 1
w = w + 1
Exit For
End If
Next
For k = 0 To mx(ys(2), xs(2))
If j + 1 = rlst(ys(2), xs(2), k) Then
kr(2) = 1
w = w + 1
Exit For
End If
Next
If w = 3 Then
rlst(ys(2), xs(2), 0) = ny + 1
rlst(ys(2), xs(2), 1) = i + 1
rlst(ys(2), xs(2), 2) = j + 1
mx(ys(2), xs(2)) = 2
End If
If w = 2 Then
w = 0
If kr(0) = 1 Then
rlst(ys(2), xs(2), w) = ny + 1
w = w + 1
End If
If kr(1) = 1 Then
rlst(ys(2), xs(2), w) = i + 1
w = w + 1
End If
If kr(2) = 1 Then
rlst(ys(2), xs(2), w) = j + 1
w = w + 1
End If
mx(ys(2), xs(2)) = 1
End If
'3on3確定解析終了
Exit For
End If
End If
End If
Next
End If
End If
Next
End Function
Function nck(g As Byte, mok As Byte)
nck = 1
Dim i As Byte, j As Byte, mn As Byte, ik As Byte, jk As Byte
mn = 100
For i = 0 To n_1
For j = 0 To n_1
If p(i, j) = 0 Then
If mn > mx(i, j) Then
mn = mx(i, j)
ik = i
jk = j
If mn = 0 Then
y(g) = ik
x(g) = jk
Exit Function
End If
End If
End If
Next
Next
y(g) = ik
x(g) = jk
If mok = 1 Then
nck = rhk(g)
End If
End Function
Function klk(g As Byte) '局所リスト解析プロシージャ
Dim i As Byte, j As Byte, k As Byte, w As Byte
For i = 0 To n_1
For j = 0 To n_1
hth(g, i, j) = 0
Next
Next
For i = 0 To n_1
If p(y(g), i) = 0 Then
For j = 0 To mx(y(g), i)
If p(y(g), x(g)) = rlst(y(g), i, j) Then
If mx(y(g), i) = 0 Then
klk = 0
Exit Function
End If
hth(g, y(g), i) = 1
For k = 0 To n_1
crlst(g, y(g), i, k) = rlst(y(g), i, k)
Next
For k = 0 To n_1
ckh(g, y(g), i, k) = kh(y(g), i, k)
Next
cmx(g, y(g), i) = mx(y(g), i)
w = rlst(y(g), i, j)
rlst(y(g), i, j) = rlst(y(g), i, mx(y(g), i))
rlst(y(g), i, mx(y(g), i)) = w
kh(y(g), i, p(y(g), x(g)) - 1) = 0
mx(y(g), i) = mx(y(g), i) - 1
Exit For
End If
Next
End If
Next
For i = 0 To n_1
If p(i, x(g)) = 0 Then
For j = 0 To mx(i, x(g))
If p(y(g), x(g)) = rlst(i, x(g), j) Then
If mx(i, x(g)) = 0 Then
klk = 0
Exit Function
End If
hth(g, i, x(g)) = 1
For k = 0 To n_1
crlst(g, i, x(g), k) = rlst(i, x(g), k)
Next
For k = 0 To n_1
ckh(g, i, x(g), k) = kh(i, x(g), k)
Next
cmx(g, i, x(g)) = mx(i, x(g))
w = rlst(i, x(g), j)
rlst(i, x(g), j) = rlst(i, x(g), mx(i, x(g)))
rlst(i, x(g), mx(i, x(g))) = w
kh(i, x(g), p(y(g), x(g)) - 1) = 0
mx(i, x(g)) = mx(i, x(g)) - 1
Exit For
End If
Next
End If
Next
Dim ybs As Byte, xbs As Byte
Dim isy As Byte, ia As Byte
ybs = rn * Int(y(g) / rn)
xbs = rn * Int(x(g) / rn)
For i = 0 To n_1
isy = Int(i / rn)
ia = i Mod rn
If ybs + isy <> y(g) And xbs + ia <> x(g) And p(ybs + isy, xbs + ia) = 0 Then
For j = 0 To mx(ybs + isy, xbs + ia)
If p(y(g), x(g)) = rlst(ybs + isy, xbs + ia, j) Then
If mx(ybs + isy, xbs + ia) = 0 Then
klk = 0
Exit Function
End If
hth(g, ybs + isy, xbs + ia) = 1
For k = 0 To n_1
crlst(g, ybs + isy, xbs + ia, k) = rlst(ybs + isy, xbs + ia, k)
Next
For k = 0 To n_1
ckh(g, ybs + isy, xbs + ia, k) = kh(ybs + isy, xbs + ia, k)
Next
cmx(g, ybs + isy, xbs + ia) = mx(ybs + isy, xbs + ia)
w = rlst(ybs + isy, xbs + ia, j)
rlst(ybs + isy, xbs + ia, j) = rlst(ybs + isy, xbs + ia, mx(ybs + isy, xbs + ia))
rlst(ybs + isy, xbs + ia, mx(ybs + isy, xbs + ia)) = w
kh(ybs + isy, xbs + ia, p(y(g), x(g)) - 1) = 0
mx(ybs + isy, xbs + ia) = mx(ybs + isy, xbs + ia) - 1
Exit For
End If
Next
End If
Next
klk = 1
End Function
Sub hukugen(g As Integer)
Dim i As Byte, j As Byte, ybs As Byte, xbs As Byte, isy As Byte, ia As Byte
For i = 0 To n_1
If i <> x(g) And p(y(g), i) = 0 Then
If hth(g, y(g), i) = 1 Then
For j = 0 To n_1
rlst(y(g), i, j) = crlst(g, y(g), i, j)
Next
For j = 0 To n_1
kh(y(g), i, j) = ckh(g, y(g), i, j)
Next
mx(y(g), i) = cmx(g, y(g), i)
End If
End If
Next
For i = 0 To n_1
If i <> y(g) And p(i, x(g)) = 0 Then
If hth(g, i, x(g)) = 1 Then
For j = 0 To n_1
rlst(i, x(g), j) = crlst(g, i, x(g), j)
Next
For j = 0 To n_1
kh(i, x(g), j) = ckh(g, i, x(g), j)
Next
mx(i, x(g)) = cmx(g, i, x(g))
End If
End If
Next
ybs = rn * Int(y(g) / rn)
xbs = rn * Int(x(g) / rn)
For i = 0 To n_1
isy = Int(i / rn)
ia = i Mod rn
If ybs + isy <> y(g) And xbs + ia <> x(g) And p(ybs + isy, xbs + ia) = 0 Then
If hth(g, ybs + isy, xbs + ia) = 1 Then
For j = 0 To n_1
rlst(ybs + isy, xbs + ia, j) = crlst(g, ybs + isy, xbs + ia, j)
Next
For j = 0 To n_1
kh(ybs + isy, xbs + ia, j) = ckh(g, ybs + isy, xbs + ia, j)
Next
mx(ybs + isy, xbs + ia) = cmx(g, ybs + isy, xbs + ia)
End If
End If
Next
End Sub
Sub hyouji() '問題表示プロシージャ
Dim i As Integer
For i = 0 To hintosu - 1
Cells(5 + cy(i), 2 + cx(i)) = cp(cy(i), cx(i))
Next
End Sub
Sub hyouji2() '問題表示プロシージャ
Dim i As Integer
For i = 0 To n2_1
Cells(15 + cy(i), 2 + cx(i)) = cp(cy(i), cx(i))
Next
End Sub
'以下全体リスト構造解析表示プロシージャ 正しいことが確認できた際にもプロシージャ自体は残しておく
'この後のプログラムの進展の際に何回も利用するするから
Sub hyouji1()
Dim i As Integer, j As Integer
For i = 0 To n_1
For j = 0 To n_1
If p(i, j) = 0 Then
For k = 0 To n_1
Cells(15 + i, 2 + 10 * j + k) = rlst(i, j, k)
Next
For k = 0 To mx(i, j)
'以下は、マクロの記録から学んだもの
Cells(15 + i, 2 + 10 * j + k).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'以上は、マクロの記録から学んだもの
Next
For k = mx(i, j) + 1 To n_1
'以下は、マクロの記録から学んだもの
Cells(15 + i, 2 + 10 * j + k).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.388845066682843
.PatternTintAndShade = 0
End With
'以上は、マクロの記録から学んだもの
Next
Else
For k = 0 To n_1
Cells(15 + i, 2 + 10 * j + k) = "＊"
Next
End If
Next
Next
End Sub
Function kensyou(a() As Integer, n As Integer)
Dim b(80) As Byte, i As Integer, j As Integer
For i = 0 To n2_1
b(i) = 0
Next
For i = 0 To n_1
For j = 0 To n_1
b(a(i, j)) = 1
Next
Next
For i = 0 To n_1
If b(i) = 0 Then
kensyou = 0
Exit Function
End If
Next
kensyou = 1
End Function
Private Sub CommandButton2_Click()
Rows("5:13").Select
Selection.ClearContents
Rows("15:23").Select
Selection.ClearContents
' Rows("15:35").Select
' Selection.Delete
Range("A1").Select
End Sub
Private Sub CommandButton3_Click()
hyouji2
End Sub
数独（ナンプレ）作成ソフトVer.4
３on３は大分苦戦しましたが、
ようやく完成の運びとなりました。
第９講の課題は、Ver.4にライン反照排除を組み込むことです。
第1１話へ 第９講第１話へ
eclipse c++ 入門
魔方陣 数独（ナンプレ）で学ぶ VBA 入門
数独（ナンプレ）のシンプルな解き方・簡単な解法の研究
vc++講義へ
excel 2013 2010 2007 vba入門へ
ＶＢ講義基礎へ
初心者のための世界で一番わかりやすいVisual C++入門基礎講座へ
初心者のための世界で一番わかりやすいVisual Basic入門基礎講座へ
専門用語なしの C言語 C++ 入門（Visual C++ 2010で学ぶ C言語 C++ 入門）
専門用語なしの excel vba マクロ 入門 2013 2010 2007 対応講義 第1部
eclipse java 入門へ
excel 2016 vba 入門へ
小学生からエンジニアまでのRuby入門へ
本サイトトップへ
