求A点到B点之间最短的一条路线(看谁速度最快)

彭希仁

以下是有点像灌水原理解题代码
Sub xi()
    Dim i As Long
    Dim j As Long
    Dim jj As Long
    Dim x As Long
    Dim y As Long
    t = Timer
    arr = Range("A1:AE" & [b65536].End(xlUp).Row)
    ReDim arr1(1 To 1000, 1 To 4) As Long
   
    y = 1: yy = 3: x = 1
    arr1(1, 1) = 2
    arr1(1, 2) = 2
    For z = 1 To 999999999          '灌水
        xx = x
        x = 0
        For i = 1 To xx
            For j = -1 To 1
                For jj = -1 To 1
                    If j * jj = 0 Then
                        If arr(arr1(i, y) - j, arr1(i, y + 1) - jj) = -1 Then
                            arr(arr1(i, y) - j, arr1(i, y + 1) - jj) = z
                            x = x + 1
                            arr1(x, yy) = arr1(i, y) - j    '记录位置
                            arr1(x, yy + 1) = arr1(i, y + 1) - jj
                        End If
                    End If
                Next
            Next
        Next i
        If y = 1 Then  '交换位置
            y = 3: yy = 1
        Else
            y = 1: yy = 3
        End If
        If x = 0 Then Exit For
    Next z
    x = UBound(arr) - 1
    y = 2
    For i = arr(x, y) To 1 Step -1          '找到回家的路
        For j = -1 To 1                   '
            For jj = -1 To 1
                If j * jj = 0 Then
                    If arr(x - j, y - jj) = i Then
                        arr(x, y) = 1
                        x = x - j
                        y = y - jj
                        GoTo ren:
                    End If
                End If
            Next
        Next
ren:
    Next i
    Range("A1:AD" & [b65536].End(xlUp).Row) = arr
    MsgBox ("耗时" & Timer - t & "秒")
End Sub

[ 本帖最后由 彭希仁 于 2008-11-9 20:47 编辑 ]

彭希仁

原帖由 winland 于 2008-11-8 16:02 发表
原来彭兄弟的灌水法和我的方法是一样的。把递归去掉，改了一下代码。找最短路径挺快，就是画上最短路径比较慢了。
425816

这个方法的速度对这种两三个分支路线的寻找来说还没什么，假如设置障碍比较少的话，效率 ...

的确方法一样．不过速度上要想再提高还真有难度，因为画上最短路径没法提速．

zlf2008

好像楼主出的题目是走迷宫或推箱子吧

彭希仁

原帖由 zlf2008 于 2008-11-9 11:03 发表
好像楼主出的题目是走迷宫或推箱子吧

没有,就是走迷宫,不过是超大的迷宫.

HHAAMM

If y = 1 Then  '交换位置
            y = 3: yy = 1
        Else
            y = 1: yy = 3
        End If
呵呵，两边换着用，再用For i = 1 To xx加以限定范围，有意思！！
不知这样跟用两个数组的差别大不大

HHAAMM

............
if a then
arr1(x, 1) = arr2(i, 1) - j    '记录位置
arr1(x, 2) = arr2(i, 2) - jj
else
arr2(x, 1) = arr1(i, 1) - j
arr2(x, 2) = arr1(i, 2) - jj
end if
............
if a then a=false

[ 本帖最后由 HHAAMM 于 2009-6-23 18:23 编辑 ]

HHAAMM

加个判断，如果已经有水灌到B的门口了，就终止循环
这样，在道路复杂的情况下，可以少很多循环，但每次都要if，是不是又得不偿失！！

彭希仁

原帖由 HHAAMM 于 2009-6-23 18:18 发表
If y = 1 Then  '交换位置
            y = 3: yy = 1
        Else
            y = 1: yy = 3
        End If
呵呵，两边换着用，再用For i = 1 To xx加以限定范围，有意思！！
不知这样跟用两个数组的差别大 ...

其实就是两个数组。没有别的意思，换成数组也可以，但数组不好切换

HHAAMM

彭版，俺的意思是，水可以不灌到这些圈起来的地方（57的意思）

彭希仁

是的,可以加一个if