G版和HIGHFLYBIRD及高人请进!如何能求出所有的路径呢？

yjr111 · 发表于 2012-2-22 17:31:38

Gu_xl 发表于 2012-2-22 16:58
先发个演示图和编译的程序，程序仅对Line有效！

G版，简直爱死你了，太棒了！

yjr111 · 发表于 2012-2-22 23:32:55

安静等待G版的核心代码！

haiyunzhou · 发表于 2012-2-23 10:47:39

学习了非常感谢

Gu_xl · 发表于 2012-2-23 19:51:23

思路和核心代码在二楼公布！

flytoday · 发表于 2012-2-23 20:56:07

G版
(GXL-BREAK_SSFuzz ss Fuzz)子程序没有发上来，出错

yjr111 · 发表于 2012-2-23 23:20:09

Gu_xl 发表于 2012-2-23 19:51
思路和核心代码在二楼公布！

现在才能轻松打开网页，对G版感激涕零，老泪纵横啊

chlh_jd · 发表于 2012-2-25 01:26:58

本帖最后由 chlh_jd 于 2012-2-25 01:32 编辑

之前有见过求2点间的最短距离，效率非常高，也用了穷举法了，稍微修改下应该能满足楼主的要求。

;;;来自网络，谁写的，我回头查下补上
(defun c:2pt-min-dis (/ show getss@ getconnect main getconnect pt1 pt2 ss1 ss2 complete zhf_time_dot)
;;;相关函数
(defun show (lst stop)
(mapcar (function(lambda (x) (redraw (vlax-vla-object->ename x) 3)))
lst
)
(if stop
(progn (getpoint)
(mapcar (function (lambda (x) (redraw (vlax-vla-object->ename x) 4)))
lst
)
)
)
)
(defun getss@ (p)
(ssget "c"
p
(polar p (/ pi 4) (/ (getvar "viewsize") 5000))
(list (cons 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 getconnect (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
(function(lambda (x)
(if (member x sse)
(setq
complete (append complete (list (list x (get:len x))))
)
)
))
ss
)
(if complete
(setq complete (vl-sort complete
(function (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) (quote 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
(function (lambda (a b) (< (cadr a) (cadr b))))
)
shortest (cadar complete)
dist-ss (mapcar (function (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 (function (lambda (x) (list x (car now)))) ss)
)
dist-ss (append
dist-ss
(mapcar
(function (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
(function (lambda (a b) (< (cadr a) (cadr b))))
)
)
)
)
)
;;;_____________________________
;;;_____________________________
;;;_____________________________
(if show
(progn
(mapcar (function (lambda (x) (vlax-put x (quote color) 0))) passed-ss)
(mapcar (function (lambda (x) (vla-update x))) passed-ss)
)
)
;;;_____________________________
;;;_____________________________
;;;_____________________________
(if complete
(progn
(setq
complete (vl-sort complete
(function(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
)
)
;;;___________________________________________
(redraw)
(setq pt1 (getpoint "\n起点:")
pt2 (getpoint "\n终点:")
)
(mapcar
(function(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 ss1 (main pt1 pt2 t))
(if ss1
(progn
(setq ss2 (ssadd))
(mapcar (function(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)
)
;;;两点最短路径结束
;;;---------------------------------------------------------------------;;;

;;;来自网络，谁写的，我回头查下补上 
(defun c:2pt-min-dis (/ show getss@ getconnect main getconnect pt1 pt2 ss1 ss2 complete zhf_time_dot) 
  ;;;相关函数 
(defun show (lst stop) 
  (mapcar (function(lambda (x) (redraw (vlax-vla-object->ename x) 3))) 
   lst 
  ) 
  (if stop 
    (progn (getpoint) 
    (mapcar (function (lambda (x) (redraw (vlax-vla-object->ename x) 4))) 
     lst 
    ) 
    ) 
  ) 
) 
(defun getss@ (p) 
  (ssget "c" 
  p 
  (polar p (/ pi 4) (/ (getvar "viewsize") 5000)) 
  (list (cons 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 getconnect (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 
 (function(lambda (x) 
    (if (member x sse) 
      (setq 
        complete (append complete (list (list x (get:len x)))) 
      ) 
    ) 
  )) 
 ss 
      ) 
      (if complete 
 (setq complete (vl-sort complete 
    (function (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) (quote 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 
     (function (lambda (a b) (< (cadr a) (cadr b)))) 
          ) 
        shortest (cadar complete) 
        dist-ss  (mapcar (function (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 (function (lambda (x) (list x (car now)))) ss) 
    ) 
        dist-ss (append 
      dist-ss 
      (mapcar 
        (function (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 
      (function (lambda (a b) (< (cadr a) (cadr b)))) 
    ) 
  ) 
       ) 
     ) 
   ) 
;;;_____________________________ 
;;;_____________________________ 
;;;_____________________________ 
   (if show 
     (progn 
       (mapcar (function (lambda (x) (vlax-put x (quote color) 0))) passed-ss) 
       (mapcar (function (lambda (x) (vla-update x))) passed-ss) 
     ) 
   ) 
;;;_____________________________ 
;;;_____________________________ 
;;;_____________________________ 
   (if complete 
     (progn 
       (setq 
  complete (vl-sort complete 
      (function(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 
  ) 
) 
;;;___________________________________________ 
  (redraw) 
  (setq pt1 (getpoint "\n起点:") 
 pt2 (getpoint "\n终点:") 
  ) 
  (mapcar 
    (function(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 ss1 (main pt1 pt2 t)) 
  (if ss1 
    (progn 
      (setq ss2 (ssadd)) 
      (mapcar (function(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) 
) 
;;;两点最短路径结束 
;;;---------------------------------------------------------------------;;;

liuyj · 发表于 2012-2-25 15:42:07

chlh_jd的程序好像缺了两个函数，get:len和z_timer，先找个替代一下，z_timer就直接删了吧。
(defun get:len (en / len)
  (if (vl-catch-all-error-p
(setq len (vl-catch-all-apply
      'vlax-curve-getdistatparam
      (list en
   (vl-catch-all-apply
      'vlax-curve-getendparam
      (list en)
   )
      )
   )
)
   )
nil
len
  )
)

zdqwy19 · 发表于 2012-2-25 20:15:21

干啥用的

xiaxiang · 发表于 2012-2-26 13:42:25

这样子啊，回复只为看贴，神奇的代码

账号		自动登录	找回密码
密码			注册

G版和HIGHFLYBIRD及高人请进!如何能求出所有的路径呢？

评分

点评

点评

评分

评分

点评

浏览过的版块