第４話 魔方陣末項法＋リスト法
コード全文
Dim ls(100) As Byte, mx As Byte
Private Sub CommandButton1_Click()
Dim n As Byte, cn As Integer, x(10, 10) As Byte
Dim iz(100) As Byte, jz(100) As Byte
Dim hajime As Variant, owari As Variant
Rows("5").Select
Selection.ClearContents
Range("A1").Select
hajime = Timer
n = Cells(3, 11)
cn = 0
Call zahyousakusei(n, iz(), jz())
Call syokika(n)
' hyouji (n) '番号付けが上手くいっているかの確認 上手くいっていることが確認できたら'をつけて注釈文に変更する。
Call f(0, cn, n, x(), iz(), jz())
Cells(5, 14) = n
Cells(5, 15) = "次魔方陣は"
Cells(5, 20) = cn
Cells(5, 23) = "個存在しました。"
owari = Timer
Cells(5, 29) = "全解の生成にかかった時間は"
Cells(5, 40) = owari - hajime
Cells(5, 44) = "秒です。"
End Sub
'Sub hyouji(n As Byte)
' Dim i As Byte, j As Byte, a(10, 10) As Byte
' For i = 0 To n * n - 1
' a(iz(i), jz(i)) = i
' Next
' For i = 0 To n - 1
' For j = 0 To n - 1
' Cells(6 + i, 2 + j) = a(i, j)
' Next
' Next
'End Sub
Sub syokika(n As Byte)
Dim i As Byte
mx = n * n
For i = 1 To mx
ls(i) = i
Next
End Sub
Sub zahyousakusei(n As Byte, iz() As Byte, jz() As Byte)
Dim i As Byte, j As Byte, a(10, 10) As Byte, c As Byte
For i = 0 To n - 1
For j = 0 To n - 1
a(i, j) = 128
Next
Next
For i = 0 To n - 1
a(i, i) = i
Next
c = n
For i = 0 To n - 1
If a(i, n - 1 - i) = 128 Then
a(i, n - 1 - i) = c
c = c + 1
End If
Next
For i = 0 To n - 1
For j = i To n - 1
If a(i, j) = 128 Then
a(i, j) = c
c = c + 1
End If
Next
For j = i To n - 1
If a(j, i) = 128 Then
a(j, i) = c
c = c + 1
End If
Next
Next
For i = 0 To n - 1
For j = 0 To n - 1
iz(a(i, j)) = i
jz(a(i, j)) = j
Next
Next
End Sub
Sub f(g As Byte, cn As Integer, n As Byte, x() As Byte, iz() As Byte, jz() As Byte)
Dim h As Byte, i As Byte, j As Byte, k As Byte, a As Byte, s As Integer, gi As Byte, gj As Byte
Dim ji As Byte, jj As Byte, hh As Byte, w As Byte, ik As Byte
Dim ii As Byte, iii As Byte
a = cn Mod 10
s = Int(cn / 10)
gi = iz(g)
gj = jz(g)
ii = Int(n * n * Rnd)
If gi = 0 And gj = n - 2 Then
w = 0
For i = 0 To n - 3
w = w + x(0, i)
Next
w = w + x(0, n - 1)
w1 = Int(n * (n * n + 1) / 2) - w
If w1 < 1 Then Exit Sub
If w1 > n * n Then Exit Sub
h = 0
For i = 1 To mx
If ls(i) = w1 Then
ik = i
h = 1
Exit For
End If
Next
If h = 0 Then Exit Sub
w = ls(mx)
ls(mx) = ls(ik)
ls(ik) = w
mx = mx - 1
x(gi, gj) = w1
Call f(g + 1, cn, n, x(), iz(), jz())
'If cn = 50 Then Exit Sub
mx = mx + 1
w = ls(mx)
ls(mx) = ls(ik)
ls(ik) = w
Exit Sub
End If
If gi = n - 2 And gj = 0 Then
w = 0
For i = 0 To n - 3
w = w + x(i, 0)
Next
w = w + x(n - 1, 0)
w1 = Int(n * (n * n + 1) / 2) - w
If w1 < 1 Then Exit Sub
If w1 > n * n Then Exit Sub
h = 0
For i = 1 To mx
If ls(i) = w1 Then
ik = i
h = 1
Exit For
End If
Next
If h = 0 Then Exit Sub
w = ls(mx)
ls(mx) = ls(ik)
ls(ik) = w
mx = mx - 1
x(gi, gj) = w1
Call f(g + 1, cn, n, x(), iz(), jz())
'If cn = 50 Then Exit Sub
mx = mx + 1
w = ls(mx)
ls(mx) = ls(ik)
ls(ik) = w
Exit Sub
End If
If (gi > 0 And gi < n - 1) And gj = n - 1 Then
w = 0
For i = 0 To n - 2
w = w + x(gi, i)
Next
w1 = Int(n * (n * n + 1) / 2) - w
If w1 < 1 Then Exit Sub
If w1 > n * n Then Exit Sub
h = 0
For i = 1 To mx
If ls(i) = w1 Then
ik = i
h = 1
Exit For
End If
Next
If h = 0 Then Exit Sub
w = ls(mx)
ls(mx) = ls(ik)
ls(ik) = w
mx = mx - 1
x(gi, gj) = w1
Call f(g + 1, cn, n, x(), iz(), jz())
'If cn = 50 Then Exit Sub
mx = mx + 1
w = ls(mx)
ls(mx) = ls(ik)
ls(ik) = w
Exit Sub
End If
If (gj > 0 And gj < n - 1) And gi = n - 1 Then
w = 0
For i = 0 To n - 2
w = w + x(i, gj)
Next
w1 = Int(n * (n * n + 1) / 2) - w
If w1 < 1 Then Exit Sub
If w1 > n * n Then Exit Sub
h = 0
For i = 1 To mx
If ls(i) = w1 Then
ik = i
h = 1
Exit For
End If
Next
If h = 0 Then Exit Sub
w = ls(mx)
ls(mx) = ls(ik)
ls(ik) = w
mx = mx - 1
x(gi, gj) = w1
If g + 1 < n * n Then
Call f(g + 1, cn, n, x(), iz(), jz())
'If cn = 50 Then Exit Sub
'If cn = 100 Then Exit Sub
Else
For j = 0 To n - 1
For k = 0 To n - 1
Cells(7 + j + (n + 1) * s, 2 + k + (n + 1) * a) = x(j, k)
Next
Next
cn = cn + 1
'If cn = 50 Then Exit Sub
'If cn = 100 Then Exit Sub
End If
mx = mx + 1
w = ls(mx)
ls(mx) = ls(ik)
ls(ik) = w
Exit Sub
End If
' If n = 4 Then kk = 1
' If n = 5 Then kk = 3
' If n = 6 Then kk = 5
' If n = 3 Then kk = 1
For i = 1 To mx
' iii = ((ii + kk * i) Mod mx) + 1
x(gi, gj) = ls(i)
w = ls(mx)
ls(mx) = ls(i)
ls(i) = w
mx = mx - 1
h = 1
If h = 1 Then
If gj = n - 2 And gi = 0 Then
w = 0
For j = 0 To n - 1
w = w + x(gi, j)
Next
If w <> Int(n * (n * n + 1) / 2) Then h = 0
End If
End If
If h = 1 Then
If gj = n - 1 And gi > 0 And g > n Then
w = 0
For j = 0 To n - 1
w = w + x(gi, j)
Next
If w <> Int(n * (n * n + 1) / 2) Then h = 0
End If
End If
If h = 1 Then
If gi = n - 2 And gj = 0 Then
w = 0
For j = 0 To n - 1
w = w + x(j, gj)
Next
If w <> Int(n * (n * n + 1) / 2) Then h = 0
End If
End If
If h = 1 Then
If gi = n - 1 And gj > 0 And g > 2 * n Then
w = 0
For j = 0 To n - 1
w = w + x(j, gj)
Next
If w <> Int(n * (n * n + 1) / 2) Then h = 0
End If
End If
If h = 1 Then
If gi = n - 1 And gj = 0 Then
w = 0
For j = 0 To n - 1
w = w + x(j, n - 1 - j)
Next
If w <> Int(n * (n * n + 1) / 2) Then h = 0
End If
End If
If h = 1 Then
If gi = n - 1 And gj = n - 1 Then
w = 0
For j = 0 To n - 1
w = w + x(j, j)
Next
If w <> Int(n * (n * n + 1) / 2) Then h = 0
End If
End If
If h = 1 Then
If g + 1 < n * n Then
Call f(g + 1, cn, n, x(), iz(), jz())
'If cn = 50 Then Exit Sub
End If
End If
mx = mx + 1
w = ls(i)
ls(i) = ls(mx)
ls(mx) = w
Next
End Sub
Private Sub CommandButton2_Click()
Rows("5:20000").Select
Selection.ClearContents
Range("A1").Select
End Sub
実行画面
参考ファイル
４次魔方陣の全解生成では、
予想に反して１５１／１０１≒１．５倍加したのみでした。
研究の結果今回のファイルや末項確定法自動生成ソフトには、
改善の余地があることがわかりました。
第16講は特殊種法を扱う予定でしたが、
４次と５次に限定した末項確定法自動生成ソフトの改良に取り組みます。
先にファイルを示しておきます。
４次魔方陣全解高速版
５次魔方陣高速版
今まで合同もすべて生成させていました。
線対称・点対称・回転を考慮に入れると、
合同な魔方陣が８つできます。
今回のファイルで４次魔方陣を作らせると、
７０４０個できますが、本質的に異なる魔方陣は
７０４０÷８＝８８０個です。
全解版を考えるときは、合同を排除して
本質的に異なる魔方陣のみを生成しなければなりません。
合同なものも生成していた理由は、
はずかしながら合同を排除する簡単な方法が思いつかなかったからです。
ですが、合同な魔方陣の排除は大変簡単な方法でできることがわかりました。
近々合同を排除するにはどうしたらよいかもテーマとして扱います。
第16講では、全体リスト構造解析＝全セルリスト構造解析を数独版で実現し、
数独を素早く解かせるソフトに挑戦します。
さらに、第17講では部分リスト構造解析を導入して、
ソフトの高速化を図ります。
