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

yangyangzhifeng · 发表于 2013-10-20 13:34

本帖最后由 yangyangzhifeng 于 2013-10-24 12:55 编辑

Sub sudoku()
Dim ar, i&, j&, jg&(1 To 81), x&, t&, tt
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
ar = Sheet1.[a1:i9]
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
End If
Next
Next
x = 1: t = 1
Do
If x = 0 Then MsgBox "无解": Exit Sub
If x > 81 Then Exit Do
If ar(h(x), l(x)) = 0 Then
For i = jg(x) + 1 To 9
If f_g(g(x), i) + f_h(h(x), i) + f_l(l(x), i) = 0 Then
If jg(x) > 0 Then
f_g(g(x), jg(x)) = 0
f_h(h(x), jg(x)) = 0
f_l(l(x), jg(x)) = 0
End If
jg(x) = i: t = 1
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
Next
If i > 9 Then
t = -1
If jg(x) > 0 Then
f_g(g(x), jg(x)) = 0
f_h(h(x), jg(x)) = 0
f_l(l(x), jg(x)) = 0
jg(x) = 0
End If
End If
End If
x = x + t
Loop
For i = 1 To 81
ar(h(i), l(i)) = jg(i)
Next
Sheet2.[a1:i9] = ar
MsgBox Format(Timer - tt, "0.000s "): Sheet2.Activate
Sheet2.Cells.Font.Bold = False
Sheet2.Range(Sheet1.Range("a1:i9").SpecialCells(xlCellTypeConstants, 1).Address(0, 0)).Font.Bold = True
End Sub

复制代码

shudu.rar (13.62 KB, 下载次数: 155)
改良版

Sub sudoku2()
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
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
Else
t = -1
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&
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

复制代码

m_n_j001 · 发表于 2013-10-20 13:43

留印学习{:soso_e183:}

香川群子 · 发表于 2013-10-21 13:01

嗯，研究一下代码算法。

jiangdong110 · 发表于 2013-10-21 13:55

晕，太高深了！

yangyangzhifeng · 发表于 2013-10-21 14:25

jiangdong110 发表于 2013-10-21 13:55
晕，太高深了！

思路如下：
由于数独都是填1-9的数字，用3个数组 f_h&(1 To 9, 1 To 9), f_l&(1 To 9, 1 To 9)，f_g&(1 To 9, 1 To 9)可以记录行，列及宫格的数字
每尝试填上一个位置的数字，就更新这3个标记数组，当尝试到9后还不能满足条件则退回上一个位置，否则尝试下一个位置，直到填好最后一个
位置（有解）或退回第一个位置之前（无解）
g&(1 To 81), h&(1 To 81), l&(1 To 81)记录81个位置在3个标记数组中对应的第一维下标，可减少计算量

香川群子 · 发表于 2013-10-21 17:12

不错的思路，减少了很多重复计算无用功。

另外，长整形数组记录状态也确实可以提高速度。

我有空按照你的思路也来写一个……估计凭我的经验，速度也许还可以再提高些。

结论：思路其实最重要。

香川群子 · 发表于 2013-10-21 17:18

本帖最后由香川群子于 2013-10-22 00:59 编辑

按你的思路代码改写成功！

对于自由度较大(可能性较多的）计算尤其效果最佳。

速度比你的快，有时候可以快一倍。（一般大约10-50%）

shudu3.rar (24.12 KB, 下载次数: 140)

jiangdong110 · 发表于 2013-10-21 20:54

香川群子发表于 2013-10-21 17:18
不错的思路，减少了很多重复计算无用功。

另外，长整形数组记录状态也确实可以提高速度。

思路决定出路！

banjinjiu · 发表于 2013-10-21 22:10

很好，学习，下次不用再为数独冥思苦想了，值得研究，这个家中开了好头。

香川群子 · 发表于 2013-10-21 23:18

用了自定义类型解决了行、列、宫的坐标

Option Base 1
Type zb
h As Long
l As Long
g As Long
End Type
Sub shudu_kagawa2()
Dim jl(81), jl_h&(9, 9), jl_l&(9, 9), jl_g&(9, 9), sj(81) As zb
Dim sj0, sj1, i&, j&, k&, l&, tms#
tms = Timer
For i = 1 To 81
sj(i).h = (i - 1) \ 9 + 1
sj(i).l = (i - 1) Mod 9 + 1
sj(i).g = ((i - 1) \ 9 \ 3) * 3 + ((i - 1) Mod 9) \ 3 + 1
Next
sj0 = [b2].Resize(9, 9)
For i = 1 To 81
j = sj0(sj(i).h, sj(i).l)
If j Then
jl_h(sj(i).h, j) = 1
jl_l(sj(i).l, j) = 1
jl_g(sj(i).g, j) = 1
Else
k = k + 1
jl(k) = i
End If
Next
' MsgBox Format(Timer - tms, "0.000s")
ReDim js&(k)
For k = 1 To k
i = jl(k)
For j = js(k) + 1 To 9
If jl_h(sj(i).h, j) + jl_l(sj(i).l, j) + jl_g(sj(i).g, j) = 0 Then
jl_h(sj(i).h, j) = 1
jl_l(sj(i).l, j) = 1
jl_g(sj(i).g, j) = 1
js(k) = j
' sj1 = sj0
' For l = 1 To k
' i = jl(l)
' sj1(sj(jl(l)).h, sj(jl(l)).l) = js(l)
' Next
' [b12].Resize(9, 9) = sj1
Exit For
End If
Next
If j = 10 Then
js(k) = 0
i = jl(k - 1)
j = js(k - 1)
jl_h(sj(i).h, j) = 0
jl_l(sj(i).l, j) = 0
jl_g(sj(i).g, j) = 0
k = k - 2
End If
Next
' MsgBox Format(Timer - tms, "0.000s")
For k = 1 To k - 1
i = jl(k)
sj0(sj(i).h, sj(i).l) = js(k)
Next
[b12].Resize(9, 9) = sj0
MsgBox Format(Timer - tms, "0.0000s")
End Sub

复制代码

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

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

评分

评分

评分

评分