主题:五个球游戏
mqfcu7
[专家分:0] 发布于 2007-11-27 17:38:00
本人对五个球游戏里的一个算法很感兴趣,一直想到网上找到这个代码,我将问题抽象出来,哪们高手能帮帮我
如数组
0 0 0 0 0 0
0 0 [color=FF0000]1[/color] 1 0 0
0 1 0 0 1 0
0 0 1 1 [color=FF0000]0[/color] 0
0 0 0 0 0 0
0 0 0 0 0 0
我现在想将1与0交换,但计算机必须判断从1到0有路可走才能交换,不通则不能交换!
0为可走,1为不可走!
回复列表 (共18个回复)
11 楼
华夏天使 [专家分:0] 发布于 2007-12-29 21:11:00
Private Sub Run1(ByVal Array(,) As Integer, ByVal Track(,) As Integer, ByVal X As Integer, ByVal Y As Integer)
Dim I As Integer '循环用
Dim J As Integer '循环用
Dim EndLoop as Integer=1 '循环用
Dim Height1 As Integer '详细见后面
Dim Height2 As Integer '详细见后面
Dim TempArray(n, n + 1) As Integer
Dim TempTrack(n, n + 1) As Integer
Array(X, Y) = 0 '所在点赋为0
Do While Array(X - 1, Y) = 0
X = X - 1
Loop
Height1 = X - 1 'Height1赋值
Do While Array(X + 1, Y) = 0
X = X + 1
Loop
Height2 = X + 1 'Height2赋值
X = Height1 + 1 '给X赋新值,这个点与原来的点对其他任意一点的连通性是一样的
For I = 0 To n '给TempArray赋值
For J = 0 To Y
TempArray(I, J) = Array(I, J)
Next
Next
For I = 0 To n
For J = Y + 2 To n + 1
TempArray(I, J) = Array(I, J - 1)
Next
Next
For I = 0 To Height1 '这是TempArray比原来的Array多的一列
TempArray(I, Y + 1) = 1
Next
For I = Height2 To n
TempArray(I, Y + 1) = 1
Next
For I = X To Height2 - 1
TempArray(I, Y + 1) = 0
Next
Run2(TempArray, TempTrack, X, Y, 1) '在TempArray搜寻需要的路径
Do While EndLoop <> 0
EndLoop = 0
For I = 1 To n - 1
If I < Height1 Or I > Height2 Then '由于TempArray被多加的一列分为两部分,现在要拼接
If TempArray(I, Y) = 0 And TempArray(I, Y + 2) = 0 Then
If TempTrack(I, Y) = 1 And TempTrack(I, Y + 2) = 0 Then
Run2(TempArray, TempTrack, I, Y + 2, 2)
EndLoop = EndLoop + 1
Else
If TempTrack(I, Y) = 0 And TempTrack(I, Y + 2) = 1 Then
Run2(TempArray, TempTrack, I, Y, 4)
EndLoop = EndLoop + 1
End If
End If
End If
End If
Next
Loop
For I = 1 To n - 1 '最终拼接到Track
For J = 0 To Y
Track(I, J) = TempTrack(I, J)
Next
Next
For I = 1 To n - 1
For J = Y + 2 To n + 1
Track(I, J - 1) = TempTrack(I, J)
Next
Next
End Sub
未完
12 楼
华夏天使 [专家分:0] 发布于 2007-12-29 21:12:00
Private Sub Run2(ByRef Array(,) As Integer, ByRef Track(,) As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal Direction As Integer) '搜寻包围圈的方法
Dim EndLoop As Integer = 0 '循环参数,0时循环
Dim Directions(n, n + 1) As Integer '记录曾到过的地方,只记录搜寻方向为1时即可
Do While EndLoop = 0
Select Case Direction
Case 1
If Directions(X, Y) = 1 Then '如果再一次以相同状态到达同一点,认为已经搜索完毕
EndLoop = 1
Else
Directions(X, Y) = 1 '如果未曾在搜索方向为1时到达过(X,Y),则现在记录
End If
If Array(X - 1, Y) = 0 Then '优先往上搜索,如果有空档,转为Direction=4
Track(X, Y) = 1
X = X - 1
Direction = 4
Else
If Array(X, Y - 1) = 0 Then '否则往左搜索
Track(X, Y) = 1
Y = Y - 1
Else '如果左边也不通,往下,转为Direction=2
Direction = 2
End If
End If
Case 2
If Array(X, Y - 1) = 0 Then '优先往左搜索,如果有空档,转为Direction=1
Track(X, Y) = 1
Y = Y - 1
Direction = 1
Else
If Array(X + 1, Y) = 0 Then '否则往下搜索
Track(X, Y) = 1
X = X + 1
Else '如果下边也不通,往右,转为Direction=3
Direction = 3
End If
End If
未完
13 楼
华夏天使 [专家分:0] 发布于 2007-12-29 21:12:00
Case 3 '优先往下搜索,如果有空档,转为Direction=2
If Array(X + 1, Y) = 0 Then
Track(X, Y) = 1
X = X + 1
Direction = 2
Else
If Array(X, Y + 1) = 0 Then '否则往右搜索
Track(X, Y) = 1
Y = Y + 1
Else '如果右边也不通,往上,转为Direction=4
Direction = 4
End If
End If
Case 4 '优先往右搜索,如果有空档,转为Direction=3
If Array(X, Y + 1) = 0 Then
Track(X, Y) = 1
Y = Y + 1
Direction = 3
Else '否则往上搜索
If Array(X - 1, Y) = 0 Then
Track(X, Y) = 1
X = X - 1
Else '如果上方也不通,往左,转Direction=1
Direction = 1
End If
End If
End Select
Loop
End Sub
End Class
完毕
14 楼
华夏天使 [专家分:0] 发布于 2007-12-29 21:24:00
本算法关键是Run1中的加一列,使搜寻路径时确实是沿着边界。
15 楼
华夏天使 [专家分:0] 发布于 2007-12-29 21:34:00
本算法虽然简单,但感觉计算量多了些,希望高人们可以不吝赐教。
16 楼
华夏天使 [专家分:0] 发布于 2007-12-29 22:04:00
可以尝试一下,应该不会有问题。
但如果有错误,还请指正,我对类似数学问题也比较感兴趣。
17 楼
华夏天使 [专家分:0] 发布于 2007-12-29 22:32:00
注释中的"寻找逆时针方向包围点1的最大圈所用到的数组"其实是"逆时针方向寻找包围点1的最大圈所用到的数组",因为算法是顺着逆时针方向搜寻,其实如果是顺着顺时针方向搜寻,应该是同样结果。
而且有时点1正好在搜索到的圈上。
第一次回复这么多,呵呵。
最近对VB比较感兴趣,正好就拿这个问题练习练习,呵呵。
18 楼
mqfcu7 [专家分:0] 发布于 2008-01-15 19:16:00
楼上的,谢谢。其实就是连连看游戏的核心算法。如果你用栈(VB好像有吧,很久没用了),那会优化很多。但我想得到最短路径。穷举不能做,因为10*矩阵就不行了!
我来回复