出个算法题，大家练练手【3个和尚和3个妖怪过河】

香川群子

yipzx 发表于 2018-9-6 09:53
没错，再加个优化条件，记录最短步数，超过了直接剪枝就可以了。

我的想法是，到了倒数第2步时，循环检查一遍，如果能够一步结束的，就输出结果，剪枝终止递归探索。

这样计算之后，m=3，n=2时，实际不同的最短路径只有12条。
或者说，用广度搜索算法比较容易实现。
过程中，需要使用字典排除重复结果。（状态相同时，只保留路径最短的过程）

如果用深度搜索，加了字典之后也是一样的效果。

yipzx

香川群子 发表于 2018-9-6 10:17
我的想法是，到了倒数第2步时，循环检查一遍，如果能够一步结束的，就输出结果，剪枝终止递归探索。

...

广度优先的话，vba没有现成的列表或链表数据类型，写起来麻烦一点。这题是否还有其他思路，不用递归。有点像求一个矩阵的逆。

yipzx

吃完饭顺着矩阵的思路想了一下，果然是有联系，简化如下，大家先看看，3monks 3monsters 和5 monks 3monsters 的构成如下。有空写下代码

就是将可能性设置成路径规划，求最短路径，只输出最短路径（输出的是路径，不是步骤），和题目有点偏差了，不过大家自己改改，也能得出所有解。

wuliaolang

每一状态有（一岸的和尚数，妖怪数，船位置）3个要素，记录这个状态，下一步有5种方法，一个方法满足题目设置要求并且不与之前记录冲突，即可进入下一轮。
我这个想法有两个问题，一个是最先记录的状态不一定是最优的，可以多记录一个，变成（一岸的和尚数，妖怪数，船位置，步数）4个要素，查到步数更小的替换掉，不过有多个解法，我估计写不出来代码。另一个问题是，有一些状态是一定无解的，如何避免重复计算。

wuliaolang

试着做了一下，把自己做晕了，估计漏洞百出
一开始想起来前几年考一建时学的网络计划，和关键线路计算很类似，后面才反应过来，要求的好像不是最短路线，那么只要过程不重复就可以咯

1. Public arr(100), brr(100), LR, ans, wr, ifwr 'arr记录过程，brr收集死点，LR方向，ans路线数，wr死点数
   
2. Sub 和尚和妖怪()
   
3. Cells.Clear
   
4. t = Timer
   
5. ans = 0: wr = 0: LR = 1
   
6. m = 3: n = 3
   
7. arr(1) = m & ";" & n & ";" & 0 & ";" & 0 & ";" & 1
   
8. e = s(m, n, 0, 0, 1)
   
9. Erase arr, brr
   
10. MsgBox Format(Timer - t, "0.0000")
    
11. End Sub
    
12. Function s(m, n, i, j, x)
    
13. If m = 0 And n = 0 Then
    
14. ans = ans + 1
    
15. Range("a" & 2 * ans - 1) = x
    
16. Range("a" & 2 * ans) = Join(arr, "&")
    
17. s = x
    
18. arr(x) = ""
    
19. LR = 1
    
20. Exit Function
    
21. Else
    
22. ifans = ans
    
23. ifwr = 1
    
24. s = f(m - LR * 2, n, i + LR * 2, j, x + 1)
    
25. s = f(m - LR * 1, n, i + LR * 1, j, x + 1)
    
26. s = f(m - LR * 1, n - LR * 1, i + LR * 1, j + LR * 1, x + 1)
    
27. s = f(m, n - LR * 2, i, j + LR * 2, x + 1)
    
28. s = f(m, n - LR * 1, i, j + LR * 1, x + 1)
    
29. If ifans = ans And ifwr = 1 Then
    
30. wr = wr + 1
    
31. brr(wr) = m & ";" & n & ";" & i & ";" & j & ";" & LR
    
32. End If
    
33. LR = LR * -1
    
34. arr(x) = ""
    
35. End If
    
36. End Function
    
37. 
    
38. Function f(m, n, i, j, x)
    
39. If m < 0 Or n < 0 Or i < 0 Or j < 0 Then Exit Function
    
40. If m < n And m * n > 0 Then Exit Function
    
41. If i < j And i * j > 0 Then Exit Function
    
42. If InStr(Join(arr, "&"), m & ";" & n & ";" & i & ";" & j & ";" & -LR) > 1 Then ifwr = -1: Exit Function
    
43. If InStr(Join(brr, "&"), m & ";" & n & ";" & i & ";" & j & ";" & -LR) > 1 Then Exit Function
    
44. LR = LR * -1
    
45. arr(x) = m & ";" & n & ";" & i & ";" & j & ";" & LR
    
46. f = s(m, n, i, j, x)
    
47. End Function
    
48. 
    

复制代码

yipzx

wuliaolang 发表于 2018-9-6 21:32
试着做了一下，把自己做晕了，估计漏洞百出
一开始想起来前几年考一建时学的网络计划，和关键线路计算很类 ...

我的第二个代码既是求关键最短路径，可以参考一下。这个题绕了一点，一来一回才算一步，这样想才能用路径规划。

香川群子

yipzx 发表于 2018-9-6 10:46
广度优先的话，vba没有现成的列表或链表数据类型，写起来麻烦一点。这题是否还有其他思路，不用递归。有 ...

深度搜索、和 广度搜索 的递归代码，我都写成功了。计算结果一致。

计算过程不同，但是剪枝方式基本相同。

1. 深度搜索时，检查倒数一步（起始就是当前状态遍历一次渡河方式，如果直接到终点了就可结束、退出递归）
2. 过程中，用字典检查 渡河状态（去=1还是回=0）以及两边状态的合并字符串，记录为当前步数。
   如果新的结果字典重复，那么只有步数相同或更少的可以保留，继续检查下去，步数较大的就被剪枝了。

这样遍历得到所有可能的最短路径结果。
【所谓最短路径结果，是指过程中每一步、都是最短路径】


…………
广度搜索，使用了数组记录每一步（层级）的中间结果，
同时用字典检查新的结果的步数是最少的（最短路径），如果不是最少步数（即当前得到的状态，已经在之前的层级被实现过了）那就剪枝废弃不保存。

这样，到无法更新层级时（每有新的层级步数结果出现）就检查结束了。
过程中，得到终点状态结果时就输出一种解法。

…………
其它的，我想大概就是过程处理和状态判断的技巧了。基本上不影响整体算法思路了。

香川群子

yipzx 发表于 2018-9-6 23:33
我的第二个代码既是求关键最短路径，可以参考一下。这个题绕了一点，一来一回才算一步，这样想才能用路径 ...

过程中可以是一来一回算一步，但最终状态肯定是奇数的。
即，最后一步是只去就完成，不用回了。

zopey

1楼 指出过河有4条最简路径，按限定规则 写代码生成 邻接矩阵图，
在图上 4条路径 可以清晰目测。



渡河.zip (16.39 KB, 下载次数: 15)

2018-9-7 10:42 上传

点击文件名下载附件

zopey

Sub 按钮2_Click()
Cells.ClearContents
m = 4 'm>=n
n = 4
k0 = (m + 1) * (n + 1)

Dim arr()
ReDim arr(1 To k0, 1 To 2)
For i = 0 To m
For j = 0 To n
If (i - j >= 0 And i - j <= m - n) Or i Mod m = 0 Then '和尚大于等于妖怪
    k = k + 1
    arr(k, 1) = i
    arr(k, 2) = j
    Cells(1 + k, 1) = "'" & i & j
    Cells(1, 1 + k) = "'" & i & j
End If
Next
Next

Dim brr()
ReDim brr(1 To k, 1 To k)
For i = 1 To k - 1
For j = i + 1 To k
    x1 = arr(j, 1) - arr(i, 1)
    x2 = arr(j, 2) - arr(i, 2)
    If x2 >= 0 And x1 <= 2 - x2 Then '乘船规则
       'brr(i, j) = 1
       brr(j, i) = 1
    End If
Next
Next

[b2].Resize(k, k) = brr
End Sub