Author Topic: Help Finding Block Route  (Read 12300 times)

0 Members and 1 Guest are viewing this topic.

ymg

  • Swamp Rat
  • Posts: 725
Re: Help Finding Block Route
« Reply #30 on: August 20, 2013, 12:35:55 PM »
Quote
I feel I should thank to ymg for brilliant Dijikstra algorithm

Marko,

Hope everybody understand that the brilliance is with Dijkstra not with me.

What tou are achieving with your SHORTTINPATH function is actually a subset of the Euclidian Minimum Spanning Tree.
The whole tree should encompass all the points.

For this there is Prim's algorithm, or even Djiktra's but Problem 1 from his 1959 paper.

You are right in the fact that the EMST will always lie along the edges of a Delaunay triangulation.

ymg

qdzung

  • Guest
Re: Help Finding Block Route
« Reply #31 on: August 22, 2013, 03:55:55 AM »
Great!!!
I have try to dev. my tool to automatic cable route and mto with VBA, but ... :ugly:

Finally chang to lisp and I found this topic  :mrgreen:

Thanks for all!

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Help Finding Block Route
« Reply #32 on: August 22, 2013, 08:41:58 AM »
Not so great!!!

I've found some wrong calculations in Dijkstra... See my attached *.dwg and *.jpg...

So long from being correct... :( :( :(
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Help Finding Block Route
« Reply #33 on: August 22, 2013, 03:20:26 PM »
I've changed my codes posted at the end of page #2... The problem was in (minpath) subfunction; also had to add (AssocOn) to make it work correctly... Also now it's slower, but that is the fact if wanted to be OK...

Cheers, M.R.
 :-) :-) :-)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ymg

  • Swamp Rat
  • Posts: 725
Re: Help Finding Block Route
« Reply #34 on: August 22, 2013, 03:48:19 PM »
Quote
I've found some wrong calculations in Dijkstra...

Marko,

I doubt that you can extend minpath to the sphere just like that.
That why they invented geodetic calculations.

Your distance on a sphere have to be great circle.
You will have also to take care of pole effect.

So Dijkstra's stands if you apply it to the plan.

ymg

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Help Finding Block Route
« Reply #35 on: August 22, 2013, 04:33:05 PM »
I don't quite know... It gave me correct results after my modifications first time, after that checked once more and it was wrong, then rotated view (3dorbit) and picked points from 3D but now last point as first and first as last and it was OK...

I just don't understand it seems you're right ymg... But now codes are better as it may give correct result in bigger probability...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Help Finding Block Route
« Reply #36 on: August 22, 2013, 06:13:38 PM »
So, I've changed codes again... Now it creates 4 different 3d polylines if it's something like geodesic-sphere... One of these should be correct one, I guess...

M.R.
For planar TINs it works fine - all 4 3d polylines overlap each other - all are correct...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Help Finding Block Route
« Reply #37 on: August 23, 2013, 06:01:24 AM »
Here they are... FINAL VERSIONS ...  So slooooooooooooow, but finally correct result even for geodesic spheres...

Code - Auto/Visual Lisp: [Select]
  1. (defun unique ( linlst )
  2.   (if (car linlst) (cons (car linlst) (unique (_vl-remove (car linlst) (_vl-remove (list (cadar linlst) (caar linlst)) (cdr linlst) 1e-6) 1e-6))))
  3. )
  4.  
  5. (defun _vl-remove ( el lst fuzz )
  6.   (vl-remove-if '(lambda ( x ) (and (equal (car x) (car el) fuzz) (equal (cadr x) (cadr el) fuzz))) lst)
  7. )
  8.  
  9. (defun eraseduplin ( ss / i lin p1 p2 linlst linlstn )
  10.   (setq i -1)
  11.   (while (setq lin (ssname ss (setq i (1+ i))))
  12.     (setq p1 (cdr (assoc 10 (entget lin)))
  13.           p2 (cdr (assoc 11 (entget lin)))
  14.     )
  15.     (setq linlst (cons (list p1 p2) linlst))
  16.     (entdel lin)
  17.   )
  18.   (setq linlstn (unique linlst))
  19.   (foreach lin linlstn
  20.     (entmake (list '(0 . "LINE") (cons 10 (car lin)) (cons 11 (cadr lin))))
  21.   )
  22. )
  23.  
  24. ; Find the path of minimum total length between two given nodes g and f.      ;
  25. ; Using Dijkstra Algorithm                                                    ;
  26. ;                                                                             ;
  27. ; See http://tech-algorithm.com/articles/dijkstra-algorithm/                  ;
  28. ;                                                                             ;
  29. ; Written by ymg   August 2013                                                ;
  30.  
  31. (defun minpath ( g f nodes edges / brname clnodes closedl dst1 dst2 m minpath minpathn mp new nodname old oldpos openl totdist )
  32.   (setq nodes   (vl-remove g nodes)
  33.         openl   (list (list g 0 nil))
  34.         closedl nil
  35.   )
  36.   (foreach n nodes
  37.     (setq nodes (subst (list n 0 nil) n nodes))
  38.   )
  39.   (while (not (equal (caar closedl) f 1e-6))
  40.     (setq nodname (caar openl)
  41.           totdist (cadar openl)
  42.           closedl (cons (car openl) closedl)
  43.           openl   (cdr openl)
  44.           clnodes (mapcar 'car closedl)
  45.  
  46.     )
  47.     (foreach e edges
  48.       (setq brname nil)
  49.       (if (equal (car e) nodname 1e-6)
  50.         (setq brname (cadr e))
  51.       )
  52.       (if (equal (cadr e) nodname 1e-6)
  53.         (setq brname (car e))
  54.       )
  55.  
  56.       (if brname
  57.         (progn
  58.           (setq new (list brname (+ (caddr e) totdist) nodname))
  59.           (cond
  60.             ((member brname clnodes))
  61.             ((setq oldpos (vl-position brname (mapcar 'car openl)))
  62.              (setq old (nth oldpos openl))
  63.              (if (< (cadr new) (cadr old))
  64.                (setq openl (subst new old openl))
  65.              )
  66.             )
  67.             (t (setq openl (cons new openl)))
  68.           )
  69.           (setq edges (vl-remove e edges))
  70.         )
  71.       )
  72.     )
  73.     (setq
  74.       openl (vl-sort openl
  75.                      (function (lambda (a b) (< (cadr a) (cadr b))))
  76.             )
  77.     )
  78.   )
  79.   (setq minpath (list (list (car closedl))))
  80.   (setq dst1 (cadr (car closedl)))
  81.   (setq m 1)
  82.   (foreach k closedl
  83.     (setq dst2 (cadr k))
  84.     (if (not (equal dst1 dst2 1e-6)) (setq m (1+ m) dst1 dst2))
  85.   )
  86.   (repeat m
  87.     (foreach n closedl
  88.       (if (= (length minpath) 1)
  89.         (if (equal (car n) (caddr (caar minpath)) 1e-6) (setq mp (cons n mp)))
  90.         (mapcar '(lambda (x) (if (equal (car n) (caddr (car x)) 1e-6) (setq mp (cons n mp)))) minpath)
  91.       )
  92.     )
  93.     (setq mp (vl-sort mp '(lambda (a b) (not (equal (car b) (car a) 1e-6)))))
  94.     (if (= (length minpath) 1)
  95.       (setq minpath (mapcar '(lambda (x) (cons x (car minpath))) mp))
  96.       (setq minpath (mapcar '(lambda (x) (mapcar '(lambda (y) (if (equal (car x) (caddr (car y)) 1e-6) (cons x y))) minpath)) mp))
  97.     )
  98.     (setq minpath (mapcar '(lambda (x) (vl-remove nil x)) minpath))
  99.     (if (listp (caaaar minpath)) (setq minpath (apply 'append minpath)))
  100.     (mapcar '(lambda (x) (if (eq (caddr (car x)) nil) (setq minpathn (cons x minpathn)))) minpath)
  101.     (setq mp nil)
  102.   )
  103.   (setq minpathn (acet-list-remove-duplicates minpathn nil))
  104.   (setq minpathn (vl-remove nil minpathn))
  105. )
  106.  
  107. (defun make3dpl ( ptlst )
  108.   (entmake
  109.     (list
  110.       '(0 . "POLYLINE")
  111.       '(100 . "AcDbEntity")
  112.       '(100 . "AcDb3dPolyline")
  113.       '(66 . 1)
  114.       '(62 . 3)
  115.       '(10 0.0 0.0 0.0)
  116.       '(70 . 8)
  117.       '(210 0.0 0.0 1.0)
  118.     )
  119.   )
  120.   (foreach pt ptlst
  121.     (entmake
  122.       (list
  123.         '(0 . "VERTEX")
  124.         '(100 . "AcDbEntity")
  125.         '(100 . "AcDbVertex")
  126.         '(100 . "AcDb3dPolylineVertex")
  127.         (cons 10 pt)
  128.         '(70 . 32)
  129.       )
  130.     )
  131.   )
  132.     (list
  133.       '(0 . "SEQEND")
  134.       '(100 . "AcDbEntity")
  135.     )
  136.   )
  137. )
  138.  
  139. (defun c:shorttinpath ( / osm ss i 3df lin p1 p2 p3 linlst ptlst g f dijkstra ptlstpths pl )
  140.   (setq osm (getvar 'osmode))
  141.   (setq ss (ssget "_:L" '((0 . "3DFACE") (8 . "*TIN"))))
  142.   (setq i -1)
  143.   (while (setq 3df (ssname ss (setq i (1+ i))))
  144.     (setq p1 (cdr (assoc 11 (entget 3df)))
  145.           p2 (cdr (assoc 12 (entget 3df)))
  146.           p3 (cdr (assoc 13 (entget 3df)))
  147.     )
  148.     (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
  149.     (entmake (list '(0 . "LINE") (cons 10 p2) (cons 11 p3)))
  150.     (entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 p1)))
  151.   )
  152.   (setq ss (ssget "_X" (list '(0 . "LINE") (cons 8 (getvar 'clayer)))))
  153.   (eraseduplin ss)
  154.   (setq ss (ssget "_X" (list '(0 . "LINE") (cons 8 (getvar 'clayer)))))
  155.   (setq i -1)
  156.   (while (setq lin (ssname ss (setq i (1+ i))))
  157.     (setq p1 (cdr (assoc 10 (entget lin)))
  158.           p2 (cdr (assoc 11 (entget lin)))
  159.     )
  160.     (setq linlst (cons (list p1 p2 (distance p1 p2)) linlst))
  161.     (setq ptlst (cons p1 ptlst) ptlst (cons p2 ptlst))
  162.     (entdel lin)
  163.   )
  164.   (setq ptlst (acet-list-remove-duplicates ptlst 1e-6))
  165.   (setvar 'osmode 1)
  166.   (setq g (getpoint "\nPick starting point on TIN : ")
  167.         f (getpoint "\nPick ending point on TIN : ")
  168.   )
  169.   (setq dijkstra (minpath g f ptlst linlst))
  170.   (setq ptlstpths (mapcar '(lambda (x) (mapcar 'car x)) dijkstra))
  171.   (mapcar '(lambda (x) (make3dpl x)) ptlstpths)
  172.   (prompt "\nShortest path length is : ") (princ (rtos (setq len (cadr (last (car dijkstra)))))) (prompt " - you should check length to match data")
  173.   (setq ss (ssget "_X" (list '(0 . "POLYLINE") '(70 . 8) (cons 8 (getvar 'clayer)))))
  174.   (setq i -1)
  175.   (while (setq pl (ssname ss (setq i (1+ i))))
  176.     (if (not (equal (vla-get-length (vlax-ename->vla-object pl)) len 1e-6)) (entdel pl))
  177.   )
  178.   (setvar 'osmode osm)
  179.   (textscr)
  180.   (princ)
  181. )
  182.  

Code - Auto/Visual Lisp: [Select]
  1. ; Find the path of minimum total length between two given nodes g and f.      ;
  2. ; Using Dijkstra Algorithm                                                    ;
  3. ;                                                                             ;
  4. ; See http://tech-algorithm.com/articles/dijkstra-algorithm/                  ;
  5. ;                                                                             ;
  6. ; Written by ymg   August 2013                                                ;
  7.  
  8. (defun minpath ( g f nodes edges / brname clnodes closedl dst1 dst2 m minpath minpathn mp new nodname old oldpos openl totdist )
  9.   (setq nodes   (vl-remove g nodes)
  10.         openl   (list (list g 0 nil))
  11.         closedl nil
  12.   )
  13.   (foreach n nodes
  14.     (setq nodes (subst (list n 0 nil) n nodes))
  15.   )
  16.   (while (not (equal (caar closedl) f 1e-6))
  17.     (setq nodname (caar openl)
  18.           totdist (cadar openl)
  19.           closedl (cons (car openl) closedl)
  20.           openl   (cdr openl)
  21.           clnodes (mapcar 'car closedl)
  22.  
  23.     )
  24.     (foreach e edges
  25.       (setq brname nil)
  26.       (if (equal (car e) nodname 1e-6)
  27.         (setq brname (cadr e))
  28.       )
  29.       (if (equal (cadr e) nodname 1e-6)
  30.         (setq brname (car e))
  31.       )
  32.  
  33.       (if brname
  34.         (progn
  35.           (setq new (list brname (+ (caddr e) totdist) nodname))
  36.           (cond
  37.             ((member brname clnodes))
  38.             ((setq oldpos (vl-position brname (mapcar 'car openl)))
  39.              (setq old (nth oldpos openl))
  40.              (if (< (cadr new) (cadr old))
  41.                (setq openl (subst new old openl))
  42.              )
  43.             )
  44.             (t (setq openl (cons new openl)))
  45.           )
  46.           (setq edges (vl-remove e edges))
  47.         )
  48.       )
  49.     )
  50.     (setq
  51.       openl (vl-sort openl
  52.                      (function (lambda (a b) (< (cadr a) (cadr b))))
  53.             )
  54.     )
  55.   )
  56.   (setq minpath (list (list (car closedl))))
  57.   (setq dst1 (cadr (car closedl)))
  58.   (setq m 1)
  59.   (foreach k closedl
  60.     (setq dst2 (cadr k))
  61.     (if (not (equal dst1 dst2 1e-6)) (setq m (1+ m) dst1 dst2))
  62.   )
  63.   (repeat m
  64.     (foreach n closedl
  65.       (if (= (length minpath) 1)
  66.         (if (equal (car n) (caddr (caar minpath)) 1e-6) (setq mp (cons n mp)))
  67.         (mapcar '(lambda (x) (if (equal (car n) (caddr (car x)) 1e-6) (setq mp (cons n mp)))) minpath)
  68.       )
  69.     )
  70.     (setq mp (vl-sort mp '(lambda (a b) (not (equal (car b) (car a) 1e-6)))))
  71.     (if (= (length minpath) 1)
  72.       (setq minpath (mapcar '(lambda (x) (cons x (car minpath))) mp))
  73.       (setq minpath (mapcar '(lambda (x) (mapcar '(lambda (y) (if (equal (car x) (caddr (car y)) 1e-6) (cons x y))) minpath)) mp))
  74.     )
  75.     (setq minpath (mapcar '(lambda (x) (vl-remove nil x)) minpath))
  76.     (if (listp (caaaar minpath)) (setq minpath (apply 'append minpath)))
  77.     (mapcar '(lambda (x) (if (eq (caddr (car x)) nil) (setq minpathn (cons x minpathn)))) minpath)
  78.     (setq mp nil)
  79.   )
  80.   (setq minpathn (acet-list-remove-duplicates minpathn nil))
  81.   (setq minpathn (vl-remove nil minpathn))
  82. )
  83.  
  84. (defun make3dpl ( ptlst )
  85.   (entmake
  86.     (list
  87.       '(0 . "POLYLINE")
  88.       '(100 . "AcDbEntity")
  89.       '(100 . "AcDb3dPolyline")
  90.       '(66 . 1)
  91.       '(62 . 3)
  92.       '(10 0.0 0.0 0.0)
  93.       '(70 . 8)
  94.       '(210 0.0 0.0 1.0)
  95.     )
  96.   )
  97.   (foreach pt ptlst
  98.     (entmake
  99.       (list
  100.         '(0 . "VERTEX")
  101.         '(100 . "AcDbEntity")
  102.         '(100 . "AcDbVertex")
  103.         '(100 . "AcDb3dPolylineVertex")
  104.         (cons 10 pt)
  105.         '(70 . 32)
  106.       )
  107.     )
  108.   )
  109.     (list
  110.       '(0 . "SEQEND")
  111.       '(100 . "AcDbEntity")
  112.     )
  113.   )
  114. )
  115.  
  116. (defun c:shortlinespath ( / osm ss i lin p1 p2 linlst ptlst g f dijkstra ptlstpths pl )
  117.   (setq osm (getvar 'osmode))
  118.   (setq ss (ssget "_:L" '((0 . "LINE"))))
  119.   (setq i -1)
  120.   (while (setq lin (ssname ss (setq i (1+ i))))
  121.     (setq p1 (cdr (assoc 10 (entget lin)))
  122.           p2 (cdr (assoc 11 (entget lin)))
  123.     )
  124.     (setq linlst (cons (list p1 p2 (distance p1 p2)) linlst))
  125.     (setq ptlst (cons p1 ptlst) ptlst (cons p2 ptlst))
  126.   )
  127.   (setq ptlst (acet-list-remove-duplicates ptlst 1e-6))
  128.   (setvar 'osmode 1)
  129.   (setq g (getpoint "\nPick starting point on LINES NETWORK : ")
  130.         f (getpoint "\nPick ending point on LINES NETWORK : ")
  131.   )
  132.   (setq dijkstra (minpath g f ptlst linlst))
  133.   (setq ptlstpths (mapcar '(lambda (x) (mapcar 'car x)) dijkstra))
  134.   (mapcar '(lambda (x) (make3dpl x)) ptlstpths)
  135.   (prompt "\nShortest path length is : ") (princ (rtos (setq len (cadr (last (car dijkstra)))))) (prompt " - you should check length to match data")
  136.   (setq ss (ssget "_X" (list '(0 . "POLYLINE") '(70 . 8) (cons 8 (getvar 'clayer)))))
  137.   (setq i -1)
  138.   (while (setq pl (ssname ss (setq i (1+ i))))
  139.     (if (not (equal (vla-get-length (vlax-ename->vla-object pl)) len 1e-6)) (entdel pl))
  140.   )
  141.   (setvar 'osmode osm)
  142.   (textscr)
  143.   (princ)
  144. )
  145.  

I think it can't be faster...
M.R.
 8-) 8-) 8-)
« Last Edit: August 23, 2013, 06:48:46 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ronjonp

  • Needs a day job
  • Posts: 7148
Re: Help Finding Block Route
« Reply #38 on: August 26, 2013, 11:23:49 AM »
First off I want to thank YMG for converting the algorithm to lisp and Marko for his many examples :).


Here is my contribution (for 2d) which works on a network of polylines and block locations on (or close) to those polylines.
I did a little bit of cleanup to add routes between block locations as well as for points of polylines that reside within a fuzz value of another polyline within the network.


There is still some work to be done to the code for creating the network more correctly, but it seems to be working fairly well for my uses.


Have fun.  ;D

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

ribarm

  • Water Moccasin
  • Posts: 2369
  • Marko Ribar, architect
Re: Help Finding Block Route
« Reply #39 on: August 26, 2013, 12:25:29 PM »
Well done, Ron...

I didn't follow you what do you initially wanted to achieve, but now I see it... I've picked some other home node, and it returned correct results... What is the problem with fuzz factor? I don't see where it should be different? Fuzz factor - X scale factor of nodes is 10.0 - I've changed it to 1.0 and still it did correctly calculations...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ronjonp

  • Needs a day job
  • Posts: 7148
Re: Help Finding Block Route
« Reply #40 on: August 26, 2013, 01:02:47 PM »
Marko,


For the example I posted, the fuzz value will be fine. The line is just there to alert other people using the code that it may need to be adjusted for different scenarios.


 :)

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

ymg

  • Swamp Rat
  • Posts: 725
Re: Help Finding Block Route
« Reply #41 on: August 26, 2013, 07:10:56 PM »
RonJomp,

Glad I could help a bit.  :-)

This being said, I still don't understand what it is you are doing ?

The network of polylines, what does it represents ?

Here,  yet another link to a paper that probably could help qdzung:

A Heuristic Technique For The Generation Of A Network Geometry For Rural Natural Gas Distribution Systems

Good thing they invented Cut&Paste with such long titles.

ymg

ronjonp

  • Needs a day job
  • Posts: 7148
Re: Help Finding Block Route
« Reply #42 on: August 26, 2013, 07:59:41 PM »
YMG,


The existing route is a pipe network. The blocks are valves connected to the pipe network. These valves have to be wired to a controller and generally follow the path of the pipes back to the controller. Dijkstra's algorithm finds the shortest route along the pipes from each of these valves back to the controller. Clear as mud ?  ;D


Ron

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

jvillarreal

  • Bull Frog
  • Posts: 319
Re: Help Finding Block Route
« Reply #43 on: June 25, 2015, 09:42:58 AM »
This is pure brilliance. Should be in the show my stuff section imo.

FYI - The _createedges function errored out for me here:

(>= (distance (setq p2 (vlax-curve-getpointatparam e (1+ (fix pa)))) p) fuzz)

changing it to:
          (setq p2 (vlax-curve-getpointatparam e (1+ (fix pa))))
          (>= (distance p2 p) fuzz)

worked for me.

ronjonp

  • Needs a day job
  • Posts: 7148
Re: Help Finding Block Route
« Reply #44 on: June 25, 2015, 10:24:14 AM »
This is pure brilliance. Should be in the show my stuff section imo.

FYI - The _createedges function errored out for me here:

(>= (distance (setq p2 (vlax-curve-getpointatparam e (1+ (fix pa)))) p) fuzz)

changing it to:
          (setq p2 (vlax-curve-getpointatparam e (1+ (fix pa))))
          (>= (distance p2 p) fuzz)

worked for me.
Thanks for reporting the error .. Here's the updated function that checks if there is a point before passing it to the distance command.

Code - Auto/Visual Lisp: [Select]
  1.   ;; If the endpoint is within the fuzz factor distance of another polyline
  2.   ;; and not already at an endpoint, create 'edges' from that point
  3.   ;; to the adjacent vertices
  4.   (defun _createedges (p l fuzz / cp out p p1 p2 pa)
  5.     (foreach e l
  6.       (if (and (setq cp (vlax-curve-getclosestpointto e p))
  7.                (<= (distance p cp) fuzz)
  8.                (setq pa (vlax-curve-getparamatpoint e cp))
  9.                (setq p1 (vlax-curve-getpointatparam e (fix pa)))
  10.                (>= (distance p1 p) fuzz)
  11.                (setq p2 (vlax-curve-getpointatparam e (1+ (fix pa))))
  12.                (>= (distance p2 p) fuzz)
  13.           )
  14.         (setq out (cons (list (list p p1 (distance p p1)) (list p p2 (distance p p2))) out))
  15.       )
  16.     )
  17.     (apply 'append out)
  18.   )
« Last Edit: June 25, 2015, 10:28:30 AM by ronjonp »

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC