[源码]：搜索两点间最短路线的lisp程序

wkai

前几天见到 舟自横 坛友的帖子，对这个问题很感兴趣，今天有空写出来一段程序，请大家测试。

目的 寻找连接两点的最近路线
前提 所有路线只在交点处交叉,起点和终点选择路线的端点.
核心函数 (main 起点 终点 是否显示搜索过程)
返回值   (最短路线长度  最短路线途径实体表)
测试命令:tt

也欢迎大家就算法问题进行探讨交流。


应 nicoster 和各位网友的要求，贴出代码，供大家参考。
[php]
(defun z_timer (/ stime h m s)
  (if (not zhf_time_dot)
    (setq zhf_time_dot (getvar "date") h nil)
    (progn
      (setq stime (getvar "date"))
      (setq stime (- stime zhf_time_dot))
      (setq stime (* 86400.0 (- stime (fix stime))))
      (setq h (fix (/ stime 3600)))
      (setq m (fix (/ (- stime (* h 3600)) 60)))
      (setq s (fix (- stime (* m 60) (* h 3600))))
      (setq zhf_time_dot nil)
      
      (strcat (if (> h 0)
                (strcat (rtos h 2 0) "小时")""
              )
              (if (> m 0)
                (strcat (rtos m 2 0) "分钟")""
              )
              (rtos s 2 0)
              "秒"
      )
      )
    )
  )
(defun show (lst stop)
  (mapcar '(lambda (x) (redraw (vlax-vla-object->ename x) 3))
          lst
  )
  (if stop (progn(getpoint)
  (mapcar '(lambda (x) (redraw (vlax-vla-object->ename x) 4))
          lst
  )))
)
(defun ss2lst (ss vla / re e)
  (if ss
    (repeat (setq n (sslength ss))
      (if vla
        (setq e (vlax-ename->vla-object (ssname ss (setq n (1- n)))))
        (setq e (ssname ss (setq n (1- n))))
      )
      (setq re (append re (list e)))
    )
  )
  re
)
(defun getss@ (p)
  (ssget "c"
         p
         (polar p (/ pi 4) (/ (getvar "viewsize") 5000))
         '((0 . "arc,ellipse,*line"))
  )
)
(defun getconnect (e)
  (vl-remove e
             (append (ss2lst (getss@ (vlax-curve-getStartpoint e)) t)
                     (ss2lst (getss@ (vlax-curve-getEndpoint e)) t)
             )
  )
)
(defun remove:same (lst / re)
  (foreach n lst
    (if        (member n re)
      ()
      (setq re (append re (list re)))
    )
  )
  re
)
(defun get:len (e)
  (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
)
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
(defun main (pt1 pt2 show / ss sse line path paths shortlen shortlst ss1 shortest)
  (setq count 0)
  (setq        ss  (ss2lst (getss@ pt1) t)
        sse (ss2lst (getss@ pt2) t)
  )
  (if (and ss sse)
    (progn      
      (setq passed-ss ss
            path-ss   (mapcar '(lambda (x) (list x)) ss)
            dist-ss   (mapcar '(lambda (x) (list x (get:len x))) ss)
            dist-ss   (vl-sort dist-ss '(lambda (a b) (< (cadr a) (cadr b))))
            complete  nil
             
      )
      (mapcar '(lambda (x)
                 (if (member x sse)
                   (setq complete (append complete (list(list x (get:len x)))))
                 )
               )
              ss
      )
      (if complete
        (setq complete (vl-sort        complete
                                '(lambda (a b) (< (cadr a) (cadr b)))
                       )
              shortest (cadar complete)
        )
      )
      
      (if (and shortest (= shortest (distance pt1 pt2)))
        (progn
        (list (cadar complete) (list(caar complete)))
        )
        (progn
      (while (and dist-ss (> (length sse) (length complete)))
        (setq now     (car dist-ss)
              dist-ss (cdr dist-ss)
        )
        ;;;_____________________________
        ;;;_____________________________
        ;;;_____________________________
        (if show
          (progn
            (vlax-put (car now) 'color (+ 21 (* 10 (rem count 20))))
            (vla-update (car now))
          )
        )
        ;;;_____________________________
        ;;;_____________________________
        ;;;_____________________________
          (if (member (car now) sse)
            (progn
              (setq complete (append complete (list now)))
              ;;;__________________________________________________
              ;;;到达终点后剔出所有距离已经超出最小路由长度的未完成方向
              (setq complete
                     (vl-sort complete
                              '(lambda (a b) (< (cadr a) (cadr b)))
                     )
                    shortest (cadar complete)
                    dist-ss (mapcar '(lambda(x)(if (< (cadr x) shortest) x nil)) dist-ss)
                    dist-ss (vl-remove nil dist-ss)
              )
              ;;;__________________________________________________
              ;;;__________________________________________________
            )
            (progn
              (setq count (1+ count))
              (setq ss (getconnect (car now)))
              (mapcar '(lambda (x) (setq ss (vl-remove x ss)))
                      passed-ss
              )
              (setq passed-ss (append passed-ss ss)
                    path-ss   (append
                                path-ss
                                (mapcar '(lambda (x) (list x (car now))) ss)
                              )
                    dist-ss   (append
                                dist-ss
                                (mapcar
                                  '(lambda (x)
                                     (if (or (not shortest) (< (get:len x) shortest))(list x (+ (cadr now) (get:len x))))
                                   )
                                  ss
                                )
                              )
                    dist-ss (vl-remove nil dist-ss)
                    dist-ss   (vl-sort dist-ss
                                       '(lambda (a b) (< (cadr a) (cadr b)))
                              )
              )
          )
        )
        )
      ;;;_____________________________
      ;;;_____________________________
      ;;;_____________________________
        (if show
          (progn
            (mapcar '(lambda (x) (vlax-put x 'color 0)) passed-ss)
            (mapcar '(lambda (x) (vla-update x)) passed-ss)
          )
        )
      ;;;_____________________________
      ;;;_____________________________
      ;;;_____________________________
      (if complete
        (progn
          (setq
            complete (vl-sort complete
                              '(lambda (a b) (< (cadr a) (cadr b)))
                     )
            n (car complete)
            
          )          
          (setq        len (cadr n)
                n   (car n)
          )
          (while n
            (setq ss1 (append ss1 (list n)))
            (setq n (cadr (assoc n path-ss)))
          )          
          (list len (reverse ss1 ))
        )
        nil
      )
    )))
    nil
  )  
)
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
(defun c:tt (/ pt1 pt2 ss1 ss2 complete)
  (redraw)
  (setq        pt1 (getpoint "\n起点:")
        pt2 (getpoint "\n终点:")
  )
  (mapcar
    '(lambda (pt)
       (grdraw (polar pt (* pi 0.25) (/ (getvar "viewsize") 40))
               (polar pt (* pi -0.75) (/ (getvar "viewsize") 40))
               1
       )
       (grdraw (polar pt (* pi 0.75) (/ (getvar "viewsize") 40))
               (polar pt (* pi -0.25) (/ (getvar "viewsize") 40))
               1
       )
     )
    (list pt1 pt2)
  )
  (setq zhf_time_dot nil)
  (z_timer)
  (setq ss1 (main pt1 pt2 t))  
  (if ss1
    (progn
      (setq ss2 (ssadd))
      (mapcar '(lambda (x)
                 (setq ss2 (ssadd (vlax-vla-object->ename x) ss2))
               )
              (cadr ss1)
      )
      (princ (strcat "\n虚线显示最短路线, 共需" (itoa (sslength ss2)) "步,总长度为:"
                     (rtos (car ss1))
                     "  历时:"
                     (z_timer)
             )
      )
      (show (cadr ss1) nil)
      
    )
    (princ (strcat "\n两点间没有可连通路径,历时:" (z_timer)))
  )  
  (princ)
)
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
;;;________________________________________________
(princ "\n寻找连接两点的最近路线,by wkai @ xdcad ")
(princ "\n前提 所有路线只在交点处交叉,起点和终点选择路线的端点.")
(princ "\n核心函数 (main 起点 终点 是否显示搜索过程) ")
(princ "\n返回值   (最短路线长度  最短路线途径实体表)")
(princ "\n测试命令:tt\n")
(princ)
[/php]

wkai

程序和测试文件

舟自横

能不能发一个到我邮箱..
研究一下...
99849930449@SINA.COM
我下不了
其实这个函数用拓扑方式比较好!
但是我还在研究当中.先看一下WKAI]
兄的高作...

ljpnb

wkai  版主厉害，佩服佩服！而且整个查询过程相对爽，最好有机会能见识一下源程序。

舟自横

我已经收到邮件
可否借原程序一观?谢...
测试完了再研究一下/..

eachy

Autodesk Map 3D 2005 中的拓扑分析有此功能，还可以设定约束条件来搜索。

wkai

我认为交流源码不如交流方法。
最开始我是用递归求解的，对于复杂的图形会很慢很慢，现在的搜索过程可以称之为 漫延 法， 总是从距离起点最近的节点向外延伸，这样能够有效的搜索整个网络.

lihb

我下不了,能不能发一份.lihongbo@changhen.cn

wkai

在我的 网U 中可以下载 第二版
http://free.ys168.com/?wkai

spshchen

真是厉害  让我看到了好程序,建议增加交点也作为路由的交点,还有对象的选择,如哪层的线,因为实际用的时候不仅仅只有路由线路.
还有能交流一下方法吗?

wkai

只打开 路由线路 所在图层就可以了。

spshchen

是用Dijkstra 算法吗?  可以交流一下 思路吗?我也想写个,因为我还有更多的需求,如:其中一段的距离是用自定义的,不是线的实际长度,还有就是我是用交点也作为路由点的(这个有办法的,我打段后处理,在UNDO一下).
是先建立点和点的关系表,再查表实现的吗?

wkai

Dijkstra 算法我不太清楚是什么， 我是按照自己的思路做的。

我没有建立 点和点的关系表， 也不是以坐标点作为程序设计的主要内容，而是把实体作为节点来操作，从起点连接到的实体开始搜索， 过程中逐步建立 实体链接表，通过搜索连接到与 目标点 相接的实体时，表示已经形成了从起点到终点的一条通路，之后倒查 实体链接表， 将 路由实体 提取出来。

而搜索的过程 是按照我说的 蔓延的 方式进行的。

aeo

1. 
   
2. Dijkstra教授
   
3. Edsger Wybe Dijkstr :1930-2002
   
4. Dijkstra教授，著名的计算机科学和工业先锋，在长时间与癌症的斗争之后，于2002年8月6日，死于Netherlands Nuennen的家中。
   
5. ......1930年生于Netherlands Rotterdam，老爸是个化学家，老妈是个数学家。获得数学和物理双学位，和计算机博士。
   
6. 1952-1962，程序员，Mathematisch Centrum, Amsterdam
   
7. 1962-1984，数学教授，Eindhoven大学
   
8. 1973-1984，研究员，Burroughs Corporation
   
9. 1984-1999，Schlumberger Centennial Chair，某大学
   
10. 1999，退休
    
11. 他有3个孩子，两个孙子。
    
12. 1972年获得图灵奖，..................，1974年 AFIPS Harry Goode Award,
    
13. 1982 IEEE计算机先锋奖,1989 ACM， 因对计算机教育的非凡成就，
    
14. SIGCSE奖；
    
15. 他提出将操作系统作为同步序列方式处理；
    
16. 写了第一个Algol 60编译器；
    
17. 最短路算法；
    
18. 极力倡导在程序中放弃使用GOTO的领导人物；
    
19. 写过很多东西！大约有1300个著作，可以在 [url]http://www.cs.utexas.edu/user/EWD找到它们的电子版。他与许多朋
    
20. 友和同事一直保持联系--不是用电子邮件，而是用传统的书信:[/url])
    
21. 他的智慧、雄辩、以及他说的话都很有名如"计算机是否能思考的
    
22. 问题等同于潜水艇是否能游泳"..................
    
23. 他提出了许多概念丰富了计算机语言，例如"结构化程序设计""同步""向量""栈"
    

复制代码

1. 
   
2. Dijkstra最短路径（一点到各顶点最短路径）
   
3. 
   
4. 
   
5. 阳明
   
6. 
   
7. 
   
8. 
   
9. 
   
10. {本程序解决6个顶点之间的最短路径问题,各顶点间关系的数据文件在sj.txt中}
    
11. {如果顶点I到顶点J不能直达就设置距离为30000}
    
12. program dijkstra;
    
13. type
    
14.    jihe=set of 0..5;
    
15. var
    
16.    a:array[0..5,0..5] of integer;
    
17.    dist:array[0..5] of integer;
    
18.    i,j,k,m,n:integer;
    
19.    fv:text;
    
20.    s:jihe;
    
21. begin
    
22.    s:=[0];
    
23.    assign(fv,'sj.txt');
    
24.    reset(fv);
    
25.    for i:=0 to 5 do  {从文件中读数据,其中a[i,j]代表从顶点i到顶点j的直达距离,如果不通用30000代替}
    
26.      begin
    
27.         for j:=0 to 5 do read(fv,a[i,j]);
    
28.         readln(fv)
    
29.      end;
    
30.    for i:=1 to 5 do  {设置DIST数组的初始值,即为顶点0到各顶点的直达距离(算法的第一步)}
    
31.       dist[i]:=a[0,i];
    
32.    for i:=1 to 5 do
    
33.    begin
    
34.         m:=0;
    
35.         dist[m]:=30000;    {设置DIST[M]的目的是为下面的一步做准备,即在DIST数组中一个最小的值}
    
36. 
    
37.         for j:=1 to 5 do    {算法的第二步,找最小的DIST值}
    
38.         if (not (j in s)) and (dist[m]>dist[j])  
    
39.          then m:=j ;    {用M来记录到底是哪个顶点}
    
40.         s:=s+[m];    {把顶点加入S中}
    
41. 
    
42.         for k:=1 to 5 do     {算法的第三步,修改后面的DIST值}
    
43.            if (not (k in s)) and  (dist[k]>dist[m]+a[m,k])
    
44.              then
    
45.                dist[k]:=dist[m]+a[m,k]
    
46.    end;
    
47.    writeln('原各顶点间的路径关系是：（30000代表不通）');
    
48.    for i:=0 to 5 do
    
49.       begin
    
50.         for j:=0 to 5 do  write(a[i,j]:6);
    
51.         writeln
    
52.       end;
    
53.    writeln; writeln;
    

复制代码

1. 
   
2. Dijkstra 算法：
   
3. 类似标号法，本质为贪心算法。
   
4. var
   
5. a:array[1..maxn,1..maxn] of integer;
   
6. b,pre:array[1..maxn] of integer; {pre[i]指最短路径上I的前驱结点}
   
7. mark:array[1..maxn] of boolean;
   
8. procedure dijkstra(v0:integer);
   
9. begin
   
10. fillchar(mark,sizeof(mark),false);
    
11. for i:=1 to n do begin
    
12. d[i]:=a[v0,i];
    
13. if d[i]< >0 then pre[i]:=v0 else pre[i]:=0;
    
14. end;
    
15. mark[v0]:=true;
    
16. repeat {每循环一次加入一个离1集合最近的结点并调整其他结点的参数}
    
17. min:=maxint; u:=0; {u记录离1集合最近的结点}
    
18. for i:=1 to n do
    
19. if (not mark[i]) and (d[i]< min) then begin
    
20. u:=i; min:=d[i];
    
21. end;
    
22. if u< >0 then begin
    
23. mark[u]:=true;
    
24. for i:=1 to n do
    
25. if (not mark[i]) and (a[u,i]+d[u]< d[i]) then begin
    
26. d[i]:=a[u,i]+d[u];
    
27. pre[i]:=u;
    
28. end;
    
29. end;
    
30. until u=0;
    
31. end;
    

复制代码

aeo

最初由 aeo 发布
[B][code]
Dijkstra教授
Edsger Wybe Dijkstr :1930-2002
[/B]

[iframe h=900 w=800]http://student.zjzk.cn/course_ware/data_structure/web/tu/tu7.5.2.htm[/iframe]