规求vba解数独游戏的源码

丸子77 · 发表于 2013-10-14 15:04

需求:
1.用excel自带的vba窗体的方式展现游戏界面
2.将1到9这9个数字按一定秩序填入每行（从左至右）、每列（从上至下）、每个小九宫格（内有9个小方格），每个数字在每行、每列、每个小九宫格中只能出现一次。

谢谢啦！！！

丸子77 · 发表于 2013-10-14 15:07

亲们、最好能提供代码注释、因为是初学者、没有注释看不懂。非常感谢！

lee1892 · 发表于 2013-10-14 15:41

坛子里只有人贴过暴力计算的，没有AI可言。估计你看了也是白看~

自己搜索一下~

liucqa · 发表于 2013-10-15 11:05

你这是做作业吧，找枪手？

香川群子 · 发表于 2013-10-15 11:31

lee1892 发表于 2013-10-14 15:41
坛子里只有人贴过暴力计算的，没有AI可言。估计你看了也是白看~

自己搜索一下~

估计不可能按照 9 x 9 = 81 的全排列进行暴力计算……

一共有Fact(81)=5.79712602074737E+120 种排列组合方式。

即：
5797126020747367985879734231578109105412357244731625958745865049716390179693892056256184534249745940480000000000000000000

所以不可能是暴力破解算法。

…………
应该是循环试算+剪枝的算法。
虽然不会是智能解法，但也很有些技术含量了。

香川群子 · 发表于 2013-10-15 11:45

其实，我倒是研究过按照数独规则的智能算法。

但有2个缺点：
1. 有时候会无解。
  a. 当某些位置成对可以互换时，可以选一个继续，但也容易造成试算错误无解
  b. 某些高级智能太复杂难以写成代码
  c. 真的解不出(必须从多个可能性中试一试)

2. 计算速度比【自动试算+剪枝】的【伪暴力算法】更慢。

呵呵。

香川群子 · 发表于 2013-10-15 11:52

以下是我的智能算法代码：

九宫格数据填写在B2:J10的区域里。

Sub Answer()
Dim A%, p%, t1, t2, Sj0, Sj1
t1 = Timer
Sj = [datas]
Sj0 = Sj
Do
A = AllCross(Sj)
If A = 81 Then
[datas] = Sj
t2 = Timer
[p11] = t2 - t1
'MsgBox Format(t2 - t1, "0.000 S")
Exit Sub
ElseIf A = -1 Then
Sj = Sj0
p = p + 1
GoTo ValidTest
Else
Sj1 = Sj
p = 1
ValidTest:
If GetValid(Sj, p) = 0 Then
Sj = Sj0
p = p + 1
GoTo ValidTest
Else
Sj0 = Sj1
End If
End If
Loop
End Sub
Function AllCross(ByRef Sj As Variant) As Integer
Dim i%, j%, K%, kk%, Sj1, GetSome As Boolean
'Sj = [datas]
Do
GetSome = False
For kk = 1 To 9
Sj1 = Sj
For i = 1 To 9
For j = 1 To 9
If Sj(i, j) = kk Then
For K = 1 To 9
Sj1(i, K) = 1
Sj1(K, j) = 1
Sj1(((i - 1) \ 3) * 3 + 1 + (K - 1) \ 3, ((j - 1) \ 3) * 3 + 1 + (K - 1) Mod 3) = 1
Next K
ElseIf Sj(i, j) >= 1 And Sj(i, j) <= 9 Then
Sj1(i, j) = 1
End If
Next j
Next i
For i = 1 To 9
For j = 1 To 9
If Sj1(i, j) = "" Then
R = 0
C = 0
D = 0
For K = 1 To 9
R = R + Val(Sj1(i, K))
C = C + Val(Sj1(K, j))
D = D + Val(Sj1(((i - 1) \ 3) * 3 + 1 + (K - 1) \ 3, ((j - 1) \ 3) * 3 + 1 + (K - 1) Mod 3))
Next K
If R = 8 Or C = 8 Or D = 8 Then
Sj(i, j) = kk
GetSome = True
End If
End If
Next j
Next i
Next kk
Loop While GetSome
For i = 1 To 9
R = 0
For j = 1 To 9
If Len(Sj(i, j)) <> 1 Then
GoTo RNext
Else
R = R + Sj(i, j)
End If
Next j
If R <> 45 Then GoTo Ext
RNext:
Next i
For i = 1 To 9
C = 0
For j = 1 To 9
If Len(Sj(j, i)) <> 1 Then
GoTo CNext
Else
C = C + Sj(j, i)
End If
Next j
If C <> 45 Then GoTo Ext
CNext:
Next i
For K = 0 To 8
D = 0
For i = 0 To 2
For j = 0 To 2
If Len(Sj(i + (K \ 3) * 3 + 1, j + (K Mod 3) * 3 + 1)) <> 1 Then
GoTo DNext
Else
D = D + Sj(i + (K \ 3) * 3 + 1, j + (K Mod 3) * 3 + 1)
End If
Next j
Next i
If D <> 45 Then GoTo Ext
DNext:
Next K
AllCross = 0
For i = 1 To 9
For j = 1 To 9
If Len(Sj(i, j)) = 1 Then AllCross = AllCross + 1
Next j
Next i
Exit Function
Ext:
AllCross = -1
End Function
Function GetValid(ByRef Sj As Variant, ByRef p As Integer) As Integer
Dim i%, j%, K%, l&, S$, Sj1
Sj1 = Sj
l = 9
For i = 1 To 9
For j = 1 To 9
If Sj(i, j) = "" Then
S = "123456789"
For K = 1 To 9
S = Replace(S, Sj(i, K), "")
S = Replace(S, Sj(K, j), "")
S = Replace(S, Sj(((i - 1) \ 3) * 3 + 1 + (K - 1) \ 3, ((j - 1) \ 3) * 3 + 1 + (K - 1) Mod 3), "")
Next K
Sj1(i, j) = S
If Len(S) = 0 Then Exit Function
If Len(S) < l Then
If Len(S) = 1 Then
Sj(i, j) = S
GetValid = 1
Exit Function
Else
l = Len(S)
End If
End If
End If
Next j
Next i
For i = 1 To 9
For j = 1 To 9
If Len(Sj1(i, j)) = l Then
Sj(i, j) = Mid(Sj1(i, j), p, 1)
GetValid = p
Exit Function
End If
Next j
Next i
GetValid = 0
End Function

复制代码

代码注释就不给了。

lee1892 · 发表于 2013-10-15 12:00

香川群子发表于 2013-10-15 11:31
估计不可能按照 9 x 9 = 81 的全排列进行暴力计算……

一共有Fact(81)=5.79712602074737E+120 种排列组 ...

循环试算不是暴力是啥？

其实，我倒是研究过按照数独规则的智能算法。

但有2个缺点：
1. 有时候会无解。
  a. 当某些位置成对可以互换时，可以选一个继续，但也容易造成试算错误无解
  b. 某些高级智能太复杂难以写成代码
  c. 真的解不出(必须从多个可能性中试一试)

2. 计算速度比【自动试算+剪枝】的【伪暴力算法】更慢。

估计：
1、你对数独的高级技巧掌握的不够丰富
2、到目前我做过的数以千的高难度数独中，只碰到过一个必须反复多次使用暴力试算的办法的，其它最多一两个格子需要这么干的。所以还是回到1，呵呵
3、暴力计算当然快，模拟人脑按游戏的内在逻辑推理计算才是有意思的地方
4、神经网络算法应该可以应用，不知道速度上比暴力计算如何~

香川群子 · 发表于 2013-10-15 12:04

我的智能算法只引入了两种基本算法：

1. 交叉确认唯一性。
反复循环1-9，按行、列、宫检查排除后确定得到唯一性值，代入后继续循环，
直至循环不能产生新的解为止

2. 行、列、宫检查计算本位置可能出现的值，如果是具有唯一性的值就填入

3. 对于无法由上述1、2计算得到正确的唯一解的空单元格，采取填入第一个可能值进行测试。

…………
毫无疑问，以上算法经常会有错误无解的情况，但大部分也可以轻松地计算出结果来。呵呵。

香川群子 · 发表于 2013-10-16 19:00

写了个递归计算的暴力破解代码：

Dim m&, cnt1&, cnt2&
Sub shudu_kagawa() '主程序
Dim i&, j&, n&, t&
tms = Timer
sj0 = [data]
' [b12].Resize(9, 9) = sj0
ReDim sj(80)
For i = 0 To 8
For j = 0 To 8
t = sj0(i + 1, j + 1): If t Then sj(i * 9 + j) = t: n = n + 1
Next
Next
'以上为原始数据转为一维数组数据
m = 0: cnt1 = 0: cnt2 = 0
Call sim(sj, n) '调用递归计算过程
[b24] = Format(Timer - tms, "0.000s ") & cnt1 & "/" & cnt2
MsgBox Format(Timer - tms, "0.000s ") & cnt1 & "/" & cnt2
End Sub
Sub sim(ByVal sj, ByVal n&) '递归计算过程代码
Dim i&, k&, k1&, t1$
If m = 81 Then Exit Sub
Do
m = 0
For k = 0 To 80
If sj(k) = 0 Then
t1 = sim1(sj, k)
If t1 = "" Then Exit Sub Else If Len(t1) = 1 Then sj(k) = t1: m = m + 1
End If
Next
If m Then n = m + n Else Exit Do
Loop
If n = 81 Then Call Output(sj): m = 81: Exit Sub
'以上为Do……Loop循环按唯一性原则填入有效数，直至81个数全部填满时退出
For k = 0 To 80
If sj(k) = 0 Then k1 = k: t1 = sim1(sj, k): Exit For
Next
'以上为检查第一个可以有多个数待选的空位置
For i = 1 To Len(t1)
cnt1 = cnt1 + 1
sj1 = sj
sj1(k1) = Mid(t1, i, 1) '此位置从候选数中循环取1个进行赋值
Call sim(sj1, n + 1) '然后递归进行深度计算
Next
If m = 81 Then Exit Sub
End Sub
Function sim1$(ByVal sj1, ByVal k1) '检查某个位置候选数的函数代码
Dim i&, j&, k&, i1&, j1&, s$
cnt2 = cnt2 + 1
s$ = "123456789"
i1 = k1 \ 9
For j = 0 To 8
s = Replace(s, sj1(i1 * 9 + j), "") '检查同一行
Next
j1 = k1 Mod 9
For i = 0 To 8
s = Replace(s, sj1(i * 9 + j1), "") '检查同一列
Next
i1 = i1 \ 3: j1 = j1 \ 3
For k = 0 To 80
If (k \ 9) \ 3 = i1 And (k Mod 9) \ 3 = j1 Then s = Replace(s, sj1(k), "")
'检查同一宫内
Next
sim1 = s
End Function
Sub Output(sj1) '把计算完成的一维数组结果转换为九宫格后输出
Dim sj2(8, 8), k&
For k = 0 To 80
sj2(k \ 9, k Mod 9) = sj1(k)
Next
[b12].Resize(9, 9) = sj2
End Sub

复制代码

使用一维数组是为了让代码看上去简单一些。

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

[求助] 规求vba解数独游戏的源码

点评

点评

最新热点 /1