回溯法解数独，平均用时<0.2秒

香川群子 · 发表于 2013-10-23 14:34

暴力破解算法中，目前有两种类型：

剩余有效数检查法：
1. 空格处试填一个有效数，然后检查剩余所有空格的有效数s的状态：
a. 任一空格处有冲突时报错退出，退回上一个空格处 (即 s=""时)
  b. 唯一值时填入s
   (这以后是否立即重新检查前面状态，是算法分歧点)
  c. 有效数>1个 (如s="137")
2. 继续
3. 全部循环完成后，如果有唯一数发生则重新检查一遍，直至无唯一数时进入下一个空格的检查

由于检查繁琐，计算量较大，所以速度不是很好，但一般说算法比较稳定。

第二种算法，就是本楼楼主yangyangzhifeng提出的，
从头开始检查所有空格。
1 to 9 都无效时退回上一个空格

好处是计算过程极其简单，因而有时候效率也挺高，
但因为几乎没有利用到九宫格的唯一性特点，（即没有提前检查后面空格的唯一性）
所以也很有可能落入计算量超大的陷阱。

…………
所以，算法改进的关键是，如何及时检查唯一性，并很好地利用唯一性。

香川群子 · 发表于 2013-10-23 14:39

我正在思考，把算法1和算法2的特点结合起来，
并且在发现唯一数以后立即回溯之前同行、同列、同宫空格有效剩余s的算法。

这样大概可以减少计算量。

yangyangzhifeng · 发表于 2013-10-23 20:47

香川群子发表于 2013-10-23 14:39
我正在思考，把算法1和算法2的特点结合起来，
并且在发现唯一数以后立即回溯之前同行、同列、同宫空格有效 ...

按及时更新最少候选数位置的顺序来解答，好像比较好了

Sub sudoku3()
Dim br, ar&(1 To 9, 1 To 9), i&, j&, jg&(1 To 81), x&, t&, tt, jwz&(1 To 81), y&, k&
Dim f_g&(1 To 9, 1 To 9), f_h&(1 To 9, 1 To 9), f_l&(1 To 9, 1 To 9)
Dim g&(1 To 81), h&(1 To 81), l&(1 To 81)
tt = Timer
br = Sheet1.[b2].Resize(9, 9)
For i = 1 To 9
For j = 1 To 9
ar(i, j) = br(i, j)
Next
Next
For i = 1 To 9
For j = 1 To 9
x = x + 1
h(x) = i: l(x) = j
g(x) = ((i - 1) \ 3) * 3 + (j - 1) \ 3 + 1
jg(x) = ar(i, j)
If jg(x) > 0 Then
If f_g(g(x), jg(x)) + f_h(h(x), jg(x)) + f_l(l(x), jg(x)) > 0 Then MsgBox "无解": Exit Sub
f_g(g(x), jg(x)) = 1
f_h(h(x), jg(x)) = 1
f_l(l(x), jg(x)) = 1
Else
y = y + 1
jwz(y) = x
End If
Next
Next
j = 0: t = 1
Do
j = j + t
If j > y Then Exit Do
If t = 1 Then
jwz(j) = get_wz(ar)
End If
x = jwz(j)
If x <> 0 Then
For i = jg(x) + 1 To 9
If f_g(g(x), i) = 0 Then
If f_h(h(x), i) = 0 Then
If f_l(l(x), i) = 0 Then
jg(x) = i: t = 1: ar(h(x), l(x)) = i
f_g(g(x), jg(x)) = 1
f_h(h(x), jg(x)) = 1
f_l(l(x), jg(x)) = 1
Exit For
End If
End If
End If
Next
Else
t = -1
End If
If i > 9 Then
t = -1
jg(x) = 0: ar(h(x), l(x)) = 0
If j > 1 Then
x = jwz(j - 1)
f_g(g(x), jg(x)) = 0
f_h(h(x), jg(x)) = 0
f_l(l(x), jg(x)) = 0
Else
MsgBox "无解": Exit Sub
End If
End If
Loop
For i = 1 To 81
ar(h(i), l(i)) = jg(i)
Next
Sheet1.[b12].Resize(9, 9) = ar
MsgBox Format(Timer - tt, "0.000s ")
Sheet1.[b12].Resize(9, 9).Interior.ColorIndex = -4142
Sheet1.[b2].Resize(9, 9).SpecialCells(xlCellTypeConstants, 1).Offset(10).Interior.Color = vbRed
End Sub
Function get_wz(ar&()) As Long
Dim i&, j&, k, jg&(1 To 9), x&, r&, c&
For i = 1 To 9
For j = 1 To 9
If ar(i, j) = 0 Then
For k = 1 To 9
If ar(i, k) > 0 Then jg(ar(i, k)) = 1
If ar(k, j) > 0 Then jg(ar(k, j)) = 1
Next
For r = 1 + ((i - 1) \ 3) * 3 To 3 * ((i + 2) \ 3)
For c = 1 + ((j - 1) \ 3) * 3 To 3 * ((j + 2) \ 3)
If ar(r, c) > 0 Then jg(ar(r, c)) = 1
Next
Next
r = 0
For k = 1 To 9
r = r + jg(k)
Next
Erase jg
If r > x Then
x = r
get_wz = (i - 1) * 9 + j
If x = 8 Then Exit Function
End If
End If
Next
Next
End Function

复制代码

香川群子 · 发表于 2013-10-24 15:58

准备按以下思路写代码：

第一步：
从第一个位置开始的循环试算检查方法，
但检查值从 1 to 9 改进为有效数。（这样做本省节省的时间并不很多）

第二步：
接下来，要结合引进【对于新确定唯一数后，立即检查排除同行、同列、同宫中的有效数，
以便不用等待循环就能快速提前得出唯一数。

目前第二步的准备已经做好（快速检查同行、同列、同宫的方法）
但具体检查代码还未加入。

先把半成品代码贴上来。

Option Explicit
Option Base 1
Type zb
h As Long
l As Long
g As Long
hlg(1 To 20) As Long
n As Long
s As String
s1 As String
End Type
Sub shudu_kagawa3()
Dim jc&(3, 9, 9), sj(81) As zb
Dim sj0, xh&(81), yg&(81), gc(82, 3), jg$(81), jl&(81), jc1, jg1, jl1
Dim i&, j&, k&, l&, m&, n&, r&, s$, t&, u&, v&, tms#
tms = Timer
sj0 = [b2].Resize(9, 9)
For i = 1 To 9
For j = 1 To 9
k = ((i - 1) \ 3) * 3 + (j - 1) \ 3 + 1
m = m + 1
sj(m).h = i
sj(m).l = j
sj(m).g = k
n = sj0(i, j)
If n Then
jc(1, i, n) = 1
jc(2, j, n) = 1
jc(3, k, n) = 1
Else
l = l + 1
xh(l) = m
End If
Next
Next
u = 0
For n = 1 To l
m = xh(n)
i = sj(m).h
j = sj(m).l
k = sj(m).g
r = 0
For t = 1 To l
If t <> n Then
If sj(xh(t)).h = i Or sj(xh(t)).l = j Or sj(xh(t)).g = k Then
r = r + 1: sj(m).hlg(r) = xh(t)
End If
End If
Next
sj(m).n = r
s = ""
For t = 1 To 9
If jc(1, i, t) = 0 Then
If jc(2, j, t) = 0 Then
If jc(3, k, t) = 0 Then
s = s & t
End If
End If
End If
Next
sj(m).s = s
jg(n) = s
If Len(s) = 1 Then
u = u + 1
yg(u) = m
' jc(1, i, s) = 1
' jc(2, j, s) = 1
' jc(3, k, s) = 1
' Stop
End If
Next
' MsgBox Format(Timer - tms, "0.000s")
gc(1, 1) = jc 'Check
gc(1, 2) = jg 's
gc(2, 3) = jl 't
jc1 = jc
jg1 = jg
jl1 = jl
For n = 1 To l
m = xh(n)
i = sj(m).h
j = sj(m).l
k = sj(m).g
s = jg1(n)
' If Len(s) = 1 Then
' t = 0
' Else
For t = jl1(n) + 1 To Len(s)
v = Mid(s, t, 1)
If jc1(1, i, v) = 0 Then
If jc1(2, j, v) = 0 Then
If jc1(3, k, v) = 0 Then
jc1(1, i, v) = 1
jc1(2, j, v) = 1
jc1(3, k, v) = 1
jg1(n) = v
jl1(n) = t
Exit For
End If
End If
End If
Next
' End If
If t > Len(s) Then
m = xh(n - 1)
jc1 = gc(n - 1, 1)
jg1 = gc(n - 1, 2)
jl1 = gc(n - 1, 3)
v = Mid(jg1(n - 1), jl1(n - 1), 1)
jc1(1, sj(m).h, v) = 0
jc1(2, sj(m).l, v) = 0
jc1(3, sj(m).g, v) = 0
n = n - 2
Else
gc(n + 1, 1) = jc1 'Check
gc(n + 1, 2) = jg1 's
gc(n, 3) = jl1 't
End If
Next
' MsgBox Format(Timer - tms, "0.000s")
For n = 1 To l
m = xh(n)
sj0(sj(m).h, sj(m).l) = jg1(n)
Next
[b12].Resize(9, 9) = sj0
MsgBox Format(Timer - tms, "0.0000s")
End Sub

复制代码

香川群子 · 发表于 2013-10-24 16:53

反复检查唯一数的循环过程代码

Do Until u = 0
k = 0: yg2 = yg1: yg1 = yg
For i = 1 To u
n = yg2(i)
m = xh(n)
v = jg(n)
For j = 1 To sj(m).hlg(0)
t = sj(m).hlg(j)
s = Replace(jg(t), v, "")
jg(t) = s
If Len(s) = 1 Then
k = k + 1
yg1(k) = t
jc(1, sj(xh(t)).h, s) = 1
jc(2, sj(xh(t)).l, s) = 1
jc(3, sj(xh(t)).g, s) = 1
End If
Next
Next
u = k
Loop

复制代码

yangyangzhifeng · 发表于 2013-10-24 17:13

以下题目用用初始代码效果较好，用时1.094s

7*****4**
*1***3***
***2***5*
8***47***
*******62
*********
***1**7**
*6*******
*253*****
用你的半成品测试用时30s，我写的及时更新检查有效数字的代码用时3.719s，现在都不能通吃，不过现在还是及时更新检查有效数字的代码较好

lee1892 · 发表于 2013-10-24 17:14

香川群子发表于 2013-10-23 14:09
呵呵，我们现在的代码中就是使用sj(1 to 81)来记录和处理数据的。

比

嗯，显然我是说你们可以直接贴81个字符上来，完全没必要截图贴上来~

另外，这种暴力计算有探讨的必要吗？0.1秒和0.01秒的差别？

生成合法数独题的需求：
1、快速确定是否有解
2、快速确定是否解唯一

你们的代码都做不到吧？

至于计算数独的解，需要的是能提示玩家下一步能通过什么逻辑，判断哪一个格子可以填什么数或是去除某个可以填的数。

yangyangzhifeng · 发表于 2013-10-24 18:05

稍微修改就可以实现检查多解，唯一解，无解

Function get_wz(ar&()) As Long
Dim i&, j&, k, jg&(1 To 9), x&, r&, c&
x = -1
For i = 1 To 9
For j = 1 To 9
If ar(i, j) = 0 Then
For k = 1 To 9
If ar(i, k) > 0 Then jg(ar(i, k)) = 1
If ar(k, j) > 0 Then jg(ar(k, j)) = 1
Next
For r = 1 + ((i - 1) \ 3) * 3 To 3 * ((i + 2) \ 3)
For c = 1 + ((j - 1) \ 3) * 3 To 3 * ((j + 2) \ 3)
If ar(r, c) > 0 Then jg(ar(r, c)) = 1
Next
Next
r = 0
For k = 1 To 9
r = r + jg(k)
Next
Erase jg
If r > x Then
x = r
get_wz = (i - 1) * 9 + j
If x > 7 Then Exit Function
End If
End If
Next
Next
End Function
Sub sudoku4() '检查多解，唯一解，无解
Dim br, ar&(1 To 9, 1 To 9), i&, j&, jg&(1 To 81), x&, t&, tt, jwz&(1 To 81), y&, k&
Dim f_g&(1 To 9, 1 To 9), f_h&(1 To 9, 1 To 9), f_l&(1 To 9, 1 To 9), zzz&
Dim g&(1 To 81), h&(1 To 81), l&(1 To 81)
tt = Timer
br = Sheet1.[b2].Resize(9, 9)
For i = 1 To 9
For j = 1 To 9
ar(i, j) = br(i, j)
Next
Next
For i = 1 To 9
For j = 1 To 9
x = x + 1
h(x) = i: l(x) = j
g(x) = ((i - 1) \ 3) * 3 + (j - 1) \ 3 + 1
jg(x) = ar(i, j)
If jg(x) > 0 Then
If f_g(g(x), jg(x)) + f_h(h(x), jg(x)) + f_l(l(x), jg(x)) > 0 Then MsgBox "无解": Exit Sub
f_g(g(x), jg(x)) = 1
f_h(h(x), jg(x)) = 1
f_l(l(x), jg(x)) = 1
Else
y = y + 1
jwz(y) = x
End If
Next
Next
j = 0: t = 1
Do
j = j + t
If j > y Then
x = jwz(j - 1): t = -1
f_g(g(x), jg(x)) = 0
f_h(h(x), jg(x)) = 0
f_l(l(x), jg(x)) = 0
zzz = zzz + 1
If zzz > 2 Then MsgBox "2个以上解": Exit Sub
Else
If t = 1 Then
jwz(j) = get_wz(ar)
End If
x = jwz(j)
If x <> 0 Then
For i = jg(x) + 1 To 9
If f_g(g(x), i) = 0 Then
If f_h(h(x), i) = 0 Then
If f_l(l(x), i) = 0 Then
jg(x) = i: t = 1: ar(h(x), l(x)) = i
f_g(g(x), jg(x)) = 1
f_h(h(x), jg(x)) = 1
f_l(l(x), jg(x)) = 1
Exit For
End If
End If
End If
Next
If i > 9 Then
t = -1
jg(x) = 0: ar(h(x), l(x)) = 0
If j > 1 Then
x = jwz(j - 1)
f_g(g(x), jg(x)) = 0
f_h(h(x), jg(x)) = 0
f_l(l(x), jg(x)) = 0
Else
Exit Do
End If
End If
Else
t = -1
End If
End If
Loop
If zzz = 0 Then MsgBox "无解" Else MsgBox "唯一解"
End Sub

复制代码

香川群子 · 发表于 2016-3-5 14:30

本帖是VBA暴力解代码的精华帖。

7473v6575ba · 发表于 2016-3-5 21:41

{:soso__3409329614010722382_4:},先收了！

		自动登录	找回密码
密码			免费注册

[分享] 回溯法解数独，平均用时<0.2秒

评分