Yep, looks like the solution. ::)
This reeks of Dijkstra's algorithm (http://en.wikipedia.org/wiki/Dijkstra%27s_algorithm)...
Could someone help out or at least get me started on the thought process?
Yep, looks like the solution. ::)
I don't understand, this:
Just saying that the pseudo code Lee suggested looks like the solution to the problem.
Yea, I paid no attention to the "Rolling Eyes" but it looks up to Lee's post above mine. At least it does on my browser & settings.Just saying that the pseudo code Lee suggested looks like the solution to the problem.
Guess I just don't understand how you guys use rolling eyes anymore, seemed like the antithesis of a "Nice find Lee" sentiment.
Yep, looks like the solution. ::)
I don't understand, this:This reeks of Dijkstra's algorithm (http://en.wikipedia.org/wiki/Dijkstra%27s_algorithm)...
Seems like a perfectly good response to the question:Could someone help out or at least get me started on the thought process?
Amongst the other responses in the thread. It identifies the problem, a way to solve it and antes up pseudo code to boot.
What's the problem?
Thanks guys .. will take a look at it on Monday. Have a nice weekend.
Whoops! I thought they were already created. ;D
I will go back to my cracks now. Yes I am drawing more crack.
Unfortunately the routes do not exist. I need to automate a way to figure these out .
However, Garey and Johnson [3] prove that the RSMT problem is NP-complete, indicating that a polynomial-time algorithm to compute an optimal RSMT is unlikely to exist.
(defun unique ( linlst )
(if (car linlst) (cons (car linlst) (unique (_vl-remove (car linlst) (_vl-remove (list (cadar linlst) (caar linlst)) (cdr linlst) 1e-6) 1e-6))))
)
(defun _vl-remove ( el lst fuzz )
(vl-remove-if '(lambda ( x ) (and (equal (car x) (car el) fuzz) (equal (cadr x) (cadr el) fuzz))) lst)
)
(defun eraseduplin ( ss / i lin p1 p2 lay linlst linlstn )
(setq i -1)
(while (setq lin (ssname ss (setq i (1+ i))))
(setq p1 (cdr (assoc 10 (entget lin)))
p2 (cdr (assoc 11 (entget lin)))
lay (cdr (assoc 8 (entget lin)))
)
(setq linlst (cons (list p1 p2) linlst))
(entdel lin)
)
(setq linlstn (unique linlst))
(foreach lin linlstn
(entmake (list '(0 . "LINE") (cons 8 lay) (cons 10 (car lin)) (cons 11 (cadr lin))))
)
)
(defun c:eraseduplines-0lines ( / ss s i lin )
(setq ss (ssget "_:L" '((0 . "LINE"))))
(setq s (ssadd))
(setq i -1)
(while (setq lin (ssname ss (setq i (1+ i))))
(if (equal (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget lin))) 1e-6) (entdel lin) (ssadd lin s))
)
(eraseduplin s)
(princ)
)
(defun c:ed0l nil (c:eraseduplines-0lines))
I feel I should thank to ymg for brilliant Dijikstra algorithm
I've found some wrong calculations in Dijkstra...
This is pure brilliance. Should be in the show my stuff section imo.Thanks for reporting the error .. Here's the updated function that checks if there is a point before passing it to the distance command.
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.
Gotta thank you again for this excellent routine Ron and YMG..This routine has saved me dozens of hours as well as clicks. I'm using it today to record distances for 1200 runs..Thank you immensely!Glad it has helped you out so much! :)
(defun C:MinLength (/ ID1 ID2 IDEND IDSTART LISTPOINT LTSID LTSIDFIL LTSIDPNT
LTSID_EDGE LTSLINE LTSPATH LTSPNT LTSPNTALL OLMODE P1 P2
PNTEND PNTSTART SSLINE X
)
(vl-load-com)
(setvar "CMDECHO" 0)
(defun *error* (msg)
(if Olmode
(setvar 'osmode Olmode)
)
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar 'osmode))
(Alert
"Qu\U+00E9t ch\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng l\U+00E0 LINE: "
)
(setq ssLine (ssget "_:L" (list (cons 0 "LINE"))))
(if ssLine
(Progn
(setvar 'osmode 1)
(setq PntStart
(getpoint
"\nCh\U+1ECDn \U+0111i\U+1EC3m xu\U+1EA5t ph\U+00E1t: "
)
)
(setq
PntEnd (getpoint
"\nCh\U+1ECDn \U+0111i\U+1EC3m \U+0111\U+1EBFn: "
)
)
(setq LtsLine (LM:ss->ent ssLine))
(setq LtsPntAll (list))
(foreach eLine LtsLine
(setq
LtsPntAll (append LtsPntAll
(list (cdr (assoc 10 (entget eLine)))
(cdr (assoc 11 (entget eLine)))
)
)
)
)
(setq LtsPnt (SortAB (LM:UniqueFuzz LtsPntAll 1e-6)))
(setq LtsIDPnt
(mapcar '(lambda (x) (list (vl-position x LtsPnt) x))
LtsPnt
)
)
(setq LtsID
(mapcar '(lambda (x) (vl-position x LtsPnt))
LtsPnt
)
)
(setq IDStart
(caar (vl-remove-if-not
(function
(lambda (x) (equal PntStart (cadr x) 1e-6))
)
LtsIDPnt
)
)
)
(setq IDEnd
(caar
(vl-remove-if-not
(function (lambda (x) (equal PntEnd (cadr x) 1e-6)))
LtsIDPnt
)
)
)
(setq LtsID_Edge (list))
(foreach e LtsLine
(setq P1 (cdr (assoc 10 (entget e))))
(setq P2 (cdr (assoc 11 (entget e))))
(setq
ID1
(caar (vl-remove-if-not
(function (lambda (x) (equal P1 (cadr x) 1e-6)))
LtsIDPnt
)
)
)
(setq
ID2
(caar (vl-remove-if-not
(function (lambda (x) (equal P2 (cadr x) 1e-6)))
LtsIDPnt
)
)
)
(setq LtsID_Edge
(append
LtsID_Edge
(list
(list ID1
ID2
(distance (nth ID1 LtsPnt)
(nth ID2 LtsPnt)
)
)
)
)
)
)
(setq LtsIDFil (RemoveIDDup LtsID_Edge))
(setq LtsPath (minpath1 IDStart IDEnd LtsID LtsIDFil))
(setq listpoint
(mapcar '(lambda (x) (nth (car x) LtsPnt)) LtsPath)
)
(make3dpl listpoint)
)
(Alert "Qu\U+00E9t ch\U+1ECDn ch\U+01B0a c\U+00F3 LINE ")
)
(setvar 'osmode Olmode)
(princ)
)
(defun SortAB (lstPnt /)
(setq
Lts-Sort (vl-sort
(vl-sort lstPnt
'(lambda (e1 e2) (< (cadr e1) (cadr e2)))
)
'(lambda (e1 e2) (< (car e1) (car e2)))
)
)
Lts-Sort
)
(defun LM:UniqueFuzz (l f)
(if l
(cons (car l)
(LM:UniqueFuzz
(vl-remove-if
(function (lambda (x) (equal x (car l) f)))
(cdr l)
)
f
)
)
)
)
;;; (setq L1 (RemoveIDDup (list '(2 4) '(3 4) '(4 2) '(5 2) '(4 3) )))
(defun RemoveIDDup (l)
(if l
(cons (car l)
(RemoveIDDup
(vl-remove-if
(function (lambda (x)
(or (and (= (car x) (car (car l)))
(= (cadr x) (cadr (car l)))
)
(and (= (car x) (cadr (car l)))
(= (cadr x) (car (car l)))
)
)
)
)
(cdr l)
)
)
)
)
)
(defun LM:ss->ent (ss / i l)
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
)
)
)
(defun make3dpl (ptlst)
(entmake
(list
'(0 . "POLYLINE")
'(100 . "AcDbEntity")
'(100
.
"AcDb3dPolyline"
)
'(66 . 1)
'(62 . 3)
'(10 0.0 0.0 0.0)
'(70 . 8)
'(210 0.0 0.0 1.0)
)
)
(foreach pt ptlst
(entmake
(list
'(0 . "VERTEX")
'(100 . "AcDbEntity")
'(100 . "AcDbVertex")
'(100 . "AcDb3dPolylineVertex")
(cons 10 pt)
'(70 . 32)
)
)
)
(entmake
(list
'(0 . "SEQEND")
'(100 . "AcDbEntity")
)
)
)
(defun minpath1 (g f nodes edges / BRNAME CLNODES CLOSEDL NEW NODNAME
OLD OLDPOS OPENL TOTDIST
)
(setq nodes (vl-remove g nodes))
(setq openl (list (list g 0 nil)))
(setq closedl nil)
(foreach n nodes
(setq nodes (subst (list n 0 nil) n nodes))
)
(while (not (= (caar closedl) f))
(setq nodname (caar openl))
(setq totdist (cadar openl))
(setq closedl (cons (car openl) closedl))
(setq openl (cdr openl))
(setq clnodes (mapcar 'car closedl))
(foreach e edges
(progn
(setq brname nil)
(if (= (car e) nodname)
(setq brname (cadr e))
)
(if (= (cadr e) nodname)
(setq brname (car e))
)
)
(if brname
(progn
(setq new (list brname (+ (caddr e) totdist) nodname))
(cond
((member brname clnodes))
((setq oldpos (vl-position brname (mapcar 'car openl)))
(setq old (nth oldpos openl))
(if (< (cadr new) (cadr old))
(setq openl (subst new old openl))
)
)
(t (setq openl (cons new openl)))
)
(setq edges (vl-remove e edges))
)
)
)
(setq
openl (vl-sort openl
(function (lambda (a b) (< (cadr a) (cadr b))))
)
)
)
(setq minpath (list (car closedl)))
(foreach n closedl
(if (= (car n) (caddr (car minpath)))
(setq minpath (cons n minpath))
)
)
minpath
)
[Code]
; Find the path of minimum total length between two given nodes g and f. ;
; Using Dijkstra Algorithm ;
; ;
; See http://tech-algorithm.com/articles/dijkstra-algorithm/ ;
; ;
; Written by ymg August 2013 ;
(defun minpath ( g f nodes edges / brname clnodes closedl dst1 dst2 m minpath minpathn mp new nodname old oldpos openl totdist )
(setq nodes (vl-remove g nodes)
openl (list (list g 0 nil))
closedl nil
)
(foreach n nodes
(setq nodes (subst (list n 0 nil) n nodes))
)
(while (not (equal (caar closedl) f 1e-6))
(setq nodname (caar openl)
totdist (cadar openl)
closedl (cons (car openl) closedl)
openl (cdr openl)
clnodes (mapcar 'car closedl)
)
(foreach e edges
(setq brname nil)
(if (equal (car e) nodname 1e-6)
(setq brname (cadr e))
)
(if (equal (cadr e) nodname 1e-6)
(setq brname (car e))
)
(if brname
(progn
(setq new (list brname (+ (caddr e) totdist) nodname))
(cond
((member brname clnodes))
((setq oldpos (vl-position brname (mapcar 'car openl)))
(setq old (nth oldpos openl))
(if (< (cadr new) (cadr old))
(setq openl (subst new old openl))
)
)
(t (setq openl (cons new openl)))
)
(setq edges (vl-remove e edges))
)
)
)
(setq
openl (vl-sort openl
(function (lambda (a b) (< (cadr a) (cadr b))))
)
)
)
(setq minpath (list (list (car closedl))))
(setq dst1 (cadr (car closedl)))
(setq m 1)
(foreach k closedl
(setq dst2 (cadr k))
(if (not (equal dst1 dst2 1e-6)) (setq m (1+ m) dst1 dst2))
)
(repeat m
(foreach n closedl
(if (= (length minpath) 1)
(if (equal (car n) (caddr (caar minpath)) 1e-6) (setq mp (cons n mp)))
(mapcar '(lambda (x) (if (equal (car n) (caddr (car x)) 1e-6) (setq mp (cons n mp)))) minpath)
)
)
(setq mp (vl-sort mp '(lambda (a b) (not (equal (car b) (car a) 1e-6)))))
(if (= (length minpath) 1)
(setq minpath (mapcar '(lambda (x) (cons x (car minpath))) mp))
(setq minpath (mapcar '(lambda (x) (mapcar '(lambda (y) (if (equal (car x) (caddr (car y)) 1e-6) (cons x y))) minpath)) mp))
)
(setq minpath (mapcar '(lambda (x) (vl-remove nil x)) minpath))
(if (listp (caaaar minpath)) (setq minpath (apply 'append minpath)))
(mapcar '(lambda (x) (if (eq (caddr (car x)) nil) (setq minpathn (cons x minpathn)))) minpath)
(setq mp nil)
)
(setq minpathn (acet-list-remove-duplicates minpathn nil))
(setq minpathn (vl-remove nil minpathn))
)
(defun make3dpl ( ptlst )
(entmake
(list
'(0 . "POLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDb3dPolyline")
'(66 . 1)
'(62 . 3)
'(10 0.0 0.0 0.0)
'(70 . 8)
'(210 0.0 0.0 1.0)
)
)
(foreach pt ptlst
(entmake
(list
'(0 . "VERTEX")
'(100 . "AcDbEntity")
'(100 . "AcDbVertex")
'(100 . "AcDb3dPolylineVertex")
(cons 10 pt)
'(70 . 32)
)
)
)
(entmake
(list
'(0 . "SEQEND")
'(100 . "AcDbEntity")
)
)
)
(defun c:shortlinespath ( / osm ss i lin p1 p2 linlst ptlst g f dijkstra ptlstpths pl )
(vl-load-com)
(setq osm (getvar 'osmode))
(setq ss (ssget "_:L" '((0 . "LINE"))))
(setq i -1)
(while (setq lin (ssname ss (setq i (1+ i))))
(setq p1 (cdr (assoc 10 (entget lin)))
p2 (cdr (assoc 11 (entget lin)))
)
(setq linlst (cons (list p1 p2 (distance p1 p2)) linlst))
(setq ptlst (cons p1 ptlst) ptlst (cons p2 ptlst))
)
(setq ptlst (acet-list-remove-duplicates ptlst 1e-6))
(setvar 'osmode 1)
(setq g (getpoint "\nPick starting point on LINES NETWORK : ")
f (getpoint "\nPick ending point on LINES NETWORK : ")
)
(setq dijkstra (minpath g f ptlst linlst))
(setq ptlstpths (mapcar '(lambda (x) (mapcar 'car x)) dijkstra))
(mapcar '(lambda (x) (make3dpl x)) ptlstpths)
(prompt "\nShortest path length is : ") (princ (rtos (setq len (cadr (last (car dijkstra)))))) (prompt " - you should check length to match data")
(setq ss (ssget "_X" (list '(0 . "POLYLINE") '(70 . 8) (cons 8 (getvar 'clayer)))))
(setq i -1)
(while (setq pl (ssname ss (setq i (1+ i))))
(if (not (equal (vla-get-length (vlax-ename->vla-object pl)) len 1e-6)) (entdel pl))
)
(setvar 'osmode osm)
(textscr)
(princ)
)
Hi, solution nice!
Is it possible to adopt function to deel not only with endpoints (cdr (assoc 10)) and (cdr (assoc 11)) of lines but with them interseption points too?
Thank you very much in advance.