九连环VBA解法

banjinjiu

香川群子 发表于 2013-6-14 15:24
递归部分代码做了优化，去掉了一些不必要的重复过程。

感谢香川老师，技术越来越精湛，理解也更深刻，或者有后来人对九连环设想做些改进，或做其他用途，这是我发现许多论坛没有的，值得我学习，辛苦了。

banjinjiu

香川群子 发表于 2013-6-14 15:24
递归部分代码做了优化，去掉了一些不必要的重复过程。

香川老师，是否再回到一楼看看，改进代码，让1，2，3，4，5，6，7，8，9上下跳舞呢？

香川群子

代码加了必要的注释：

1. 
   
2. Sub RndTest()
   
3.     l = Len([a1]) '获取数位长度
   
4.     [a1] = f(l) 'A1中写入起始状态 (随机生成)
   
5.     [b1] = f(l) 'B1中写入结果状态 (随机生成)
   
6.     kagawa '调用计算主过程
   
7. End Sub
   
8. Sub kagawa()
   
9.     tms = Timer
   
10. '    s = "111111111": t = "000000000" '=2^8=256
    
11. '    s = "000000000": t = "111111111" '=2^8=256
    
12. '    s = "000000001": t = "000000000" '=2^7-1+2^8=383
    
13.    
    
14.     s = [a1]: l = Len(s): ReDim jg$(2 ^ l + 2): jg(0) = s
    
15.     '以下为对s进行预处理到达 "00xxxxxxx" 的理想初始状态
    
16.     If Left(s, 2) = "00" Then k = 1
    
17.     If Left(s, 1) = "1" Then Mid(s, 1, 2) = "00": jg(1) = s: k = 2
    
18.     If Left(s, 2) = "01" Then Mid(s, 1, 2) = "11": jg(1) = s: Mid(s, 1, 2) = "00": jg(2) = s: k = 3
    
19.    
    
20.     t = [b1]: If Left(t, 2) = "10" Then Mid(t, 1, 2) = "00" '对结果t进行预处理，排除讨厌的"10xxxxxxx"
    
21.    
    
22. '    [d8].CurrentRegion.Offset(1) = "": [d9] = 9: [e9] = "'" & s
    
23.     For i = l To 3 Step -1 '倒序检查s和t对应每个位置是否状态相同
    
24.         Do Until Mid(s, i, 1) = Mid(t, i, 1) 'Do循环直到状态相同 (0对0 或 1对1)
    
25.             Call dg(i) '如果状态不同则进行 递归【反位】(0-1互换)
    
26. '            [d65536].End(3).Offset(1) = i
    
27. '            [e65536].End(3).Offset(1) = "'" & s
    
28.         Loop
    
29.     Next
    
30.     '以上循环结束时，从第3位开始的状态已经递归反位处理结束达到s和t的相同状态。
    
31.    
    
32.     '以下为对最先2位进行标准化处理 并找到准确的结果位置k 解释略
    
33.     If Left([b1], 2) = "10" Then
    
34.         For k = IIf(k > 6, k - 6, 0) To k - 1
    
35.             If jg(k) = t Then Exit For
    
36.         Next
    
37.         s = jg(k): k = k + 1: Mid(s, 1, 2) = "10": jg(k) = s
    
38.     Else
    
39.         If Left(s, 2) = "11" Then Mid(s, 1, 2) = "00": jg(k) = s: k = k + 1
    
40.         Mid(s, 1, 2) = "11": jg(k) = s: k = k + 1
    
41.         Mid(s, 1, 2) = "01": jg(k) = s: k = k + 1
    
42.         For k = IIf(k > 8, k - 8, 0) To k - 1
    
43.             If jg(k) = t Then Exit For
    
44.         Next
    
45.     End If
    
46.    
    
47.     '输出结果到工作表
    
48.     [a2:a65536].Clear: [a2].Resize(k).NumberFormat = "@"
    
49.     [a1].Resize(k + 1) = Application.Transpose(jg)
    
50.    
    
51.     '以下为排除起始状态的可能的重复
    
52.     For i = 1 To 2
    
53.         If jg(i) = jg(0) Then
    
54.             [a1].Resize(k + 1).Value = [a1].Offset(i).Resize(k + 1).Value
    
55.             k = k - i
    
56.         End If
    
57.     Next
    
58.    
    
59.     '到达结果位置
    
60.     [a1].Offset(k).Activate
    
61.     Erase jg
    
62.     MsgBox Format(Timer - tms, "0.000s ") & k
    
63. End Sub
    
64. Sub dg(n) '对第n个位置进行【0-1互换】 的递归过程 也即对第n位状态进行【反位】处理
    
65. 
    
66.     If n = 3 Then '递归到只剩前3位时就可以按照规律进行：上12下1、3【反位】、上1下12、最先一个"1"之后【反位】
    
67.         Mid(s, 1, 2) = "11": jg(k) = s: k = k + 1 '上12
    
68.         Mid(s, 1, 2) = "01": jg(k) = s: k = k + 1 '下1
    
69.         Mid(s, 3, 1) = IIf(Mid(s, 3, 1) = "1", "0", "1"): jg(k) = s: k = k + 1 '3【反位】(0-1互换)
    
70.         Mid(s, 1, 2) = "11": jg(k) = s: k = k + 1 '上1
    
71.         Mid(s, 1, 2) = "00": jg(k) = s: k = k + 1 '下12
    
72.         For i = 3 To l - 1 '查找第1个出现"1"的位置 即 00001x*** 类型
    
73.             If Mid(s, i, 1) = "1" Then '"0"之后第1个"1"的下一个x进行【反位】(0-1互换)
    
74.                 Mid(s, i + 1, 1) = IIf(Mid(s, i + 1, 1) = "1", "0", "1"): jg(k) = s: k = k + 1
    
75.                 Exit For '退出
    
76.             End If
    
77.         Next
    
78.     Else
    
79.         If Mid(s, n - 1, 1) = "1" Then '检查n-1位置必须是"1" 即 xxxx1**** 类型
    
80.             For i = n - 2 To 3 Step -1 '继续检查n-2位置(必须是"0")
    
81.                 If Mid(s, i, 1) = "1" Then Call dg(i) '如果是"1"则递归【反位】
    
82.             Next
    
83.             
    
84.             If k > 1 Then '因为要检查k-1以及k-2的s状态到n-1位置是否不同所以必须k>1
    
85.                 If Left(s, n - 2) = String(n - 2, "0") Then '首先检查到n-2位置是否都是"0" 即 00001x*** 类型
    
86.                     If Left(jg(k - 1), n - 1) <> Left(jg(k - 2), n - 1) Then
    
87.                      '再检查k-1以及k-2的s状态到第n-1位置是否相同 如不同则可以【反位】(0-1互换)
    
88.                         Mid(s, n, 1) = IIf(Mid(s, n, 1) = "1", "0", "1"): jg(k) = s: k = k + 1
    
89.                     Else '如相同则不需要【反位】(将退回前一状态)
    
90. '                         Stop
    
91.                     End If
    
92.                 End If
    
93.             Else 'k=1 时可直接对第n位置进行【反位】(0-1互换)
    
94.                 Mid(s, n, 1) = IIf(Mid(s, n, 1) = "1", "0", "1"): jg(k) = s: k = k + 1
    
95.             End If
    
96.         Else '如果检查n-1位置不是"1"而是"0",则需要递归【反位】即把"0"转换为"1"
    
97.             Call dg(n - 1)
    
98.         End If
    
99.     End If
    
100. '    [f65536].End(3).Offset(1) = n
     
101. '    [g65536].End(3).Offset(1) = "'" & s
     
102. End Sub
     
103. Function f(n) '按指定位数生成随机0、1状态
     
104. '    Application.Volatile
     
105.     Randomize
     
106.     For i = 1 To n
     
107.         f = f & IIf(Rnd < 0.5, 0, 1)
     
108.     Next
     
109. End Function

复制代码

香川群子

附件中代码做了注释，并增加了可以监控的输出（语句被注释了）

香川群子

banjinjiu 发表于 2013-6-14 19:27
香川老师，是否再回到一楼看看，改进代码，让1，2，3，4，5，6，7，8，9上下跳舞呢？

做成动画效果？

速度慢一点、再慢一点？

香川群子

增加了一个直接数组For……Next循环版


但是目前没有进行最少步数的鉴别运算，所以只能是闭着眼睛一路走下去……直到终点。
然后，根据结果倒查最接近结果的起点在哪里。

感觉比较愚笨，但电脑计算则速度飞快……因为完全不用动脑筋，而且直接循环显然比递归绕来绕去要快。


呵呵。

9 Ring.zip (35.91 KB, 下载次数: 59)

2013-6-17 16:14 上传

点击文件名下载附件

香川群子

循环部分代码很简单的。

1. Sub kagawa()
   
2.     tms = Timer
   
3.    
   
4.     s = [a1]: l = Len(s): ReDim jg$(2 ^ (l + 1)): jg(0) = s: Mid(s, 1, 2) = "00": k = 1
   
5.     t = [b1]: Mid(t, 1, 2) = "00"
   
6.    
   
7.     For i = 1 To UBound(jg)
   
8.         Mid(s, 1, 2) = "11": jg(k) = s: k = k + 1
   
9.         Mid(s, 1, 2) = "01": jg(k) = s: k = k + 1
   
10.         Mid(s, 3, 1) = IIf(Mid(s, 3, 1) = "1", "0", "1"): jg(k) = s: k = k + 1
    
11.         Mid(s, 1, 2) = "11": jg(k) = s: k = k + 1
    
12.         Mid(s, 1, 2) = "00": jg(k) = s: k = k + 1
    
13.         If s = t Then
    
14.             t = [b1]
    
15.             If Mid(t, 1, 2) = "10" Then jg(k) = t: k = k + 1
    
16.             Exit For
    
17.         End If
    
18.         For j = 4 To l
    
19.             If Mid(s, j - 1, 1) = "1" Then Mid(s, j, 1) = IIf(Mid(s, j, 1) = "1", "0", "1"): jg(k) = s: k = k + 1: Exit For
    
20.         Next
    
21.         If s = t Then
    
22.             t = [b1]
    
23.             If Mid(t, 1, 2) = "10" Then
    
24.                 jg(k) = t: k = k + 1
    
25.             Else
    
26.                 Mid(s, 1, 2) = "11": jg(k) = s: k = k + 1
    
27.                 Mid(s, 1, 2) = "01": jg(k) = s: k = k + 1
    
28.             End If
    
29.             Exit For
    
30.         End If
    
31.     Next
    
32.     [c2] = k - 1
    
33.    
    
34.     For j = k - 1 To k - 3 Step -1
    
35.         If jg(j) = t Then Exit For
    
36.     Next
    
37.    
    
38.     s = [a1]
    
39.     If Mid(s, 1, 2) = "10" Then
    
40.         Mid(s, 1, 2) = "00": jg(0) = s
    
41.         For i = j To 0 Step -1
    
42.             If jg(i) = s Then Exit For
    
43.         Next
    
44.         If i = 0 Then
    
45.             For k = j + 1 To 1 Step -1
    
46.                 jg(k) = jg(k - 1)
    
47.             Next
    
48.         End If
    
49.     Else
    
50.         For i = j To 1 Step -1
    
51.             If jg(i) = s Then Exit For
    
52.         Next
    
53.         i = i + 1
    
54.     End If
    
55.    
    
56.     For k = 1 To j - i + 1
    
57.         jg(k) = jg(k + i - 1)
    
58.     Next
    
59.     ReDim Preserve jg(k - 1)
    
60.    
    
61.     [a2:a65536].Clear: [a2].Resize(k - 1).NumberFormat = "@"
    
62.     [a1].Resize(k) = Application.Transpose(jg)
    
63.     [a1].Offset(k - 1).Activate
    
64.     Erase jg
    
65.     [c5] = k - 1
    
66.     [c6] = Format(Timer - tms, "0.000s")
    
67. '    MsgBox Format(Timer - tms, "0.000s ") & k - 1
    
68. End Sub

复制代码

banjinjiu

香川群子 发表于 2013-6-17 15:59
循环部分代码很简单的。

香川老师，太神速了，赶不上你的节奏，等等再研究，让我们多学习先，你泉思如涌啊。
原来我以为讨论帖一定很热闹，果不其然，前两天我发了一个讨论帖却无人应和，是有关一笔画的贴子，和其他的一笔画不同，详见“四条线连接九个点”：http://club.excelhome.net/thread-1027161-1-1.html，晚上加班做材料到现在，明天上级来检查，害得我才看到你的回帖，很感谢。请你继续帮忙，看来再难的问题也难不住你啊！

香川群子

递归和数组都有一个小bug ……当 s 和 t 相等时 其实不用计算了。

banjinjiu

香川群子 发表于 2013-6-7 05:11
你还需要多演示几步，至少演示到第4环，最好演示到第5环。

否则不知道接下来该如何做。

香川群子老师，你好，现在开学了，教师也忙了，我有个课表，今天就上课了，很急，缺教师课表，有个总表，麻烦你帮忙，最好运用VBA，把教师表和打印的搞出来，教师表里主要填写任教课程和任教班级，感谢。如果觉得有不合理的地方，请尽情修改，谢谢。
地址如下：http://club.excelhome.net/thread-1052238-1-1.html