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

0 Members and 1 Guest are viewing this topic.

Logan

  • Newt
  • Posts: 41
« Last Edit: June 25, 2015, 06:02:42 PM by Kerry »

jvillarreal

  • Bull Frog
  • Posts: 332
Re: Help Finding Block Route
« Reply #46 on: November 05, 2015, 03:06:15 PM »
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!

ronjonp

  • Needs a day job
  • Posts: 7526
Re: Help Finding Block Route
« Reply #47 on: November 05, 2015, 04:24:20 PM »
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!  :)

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

ymg

  • Guest
Re: Help Finding Block Route
« Reply #48 on: November 05, 2015, 07:10:49 PM »
jvillarreal,

Enhorabuena!,  Glad I could help some.

ymg

thanhduan2407

  • Mosquito
  • Posts: 5
Re: Help Finding Block Route
« Reply #49 on: June 14, 2017, 01:44:53 AM »
I use by ID for Point! However! It is as a little slower
Code: [Select]
(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]
« Last Edit: June 14, 2017, 02:05:05 AM by thanhduan2407 »

topshelfvalueinc

  • Mosquito
  • Posts: 7
Re: Help Finding Block Route
« Reply #50 on: September 03, 2022, 03:12:04 AM »
For the code below is there anyway you can make it work with circles? my drawings usually looks like something in the attachment

Code: [Select]
; 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)
)
 
« Last Edit: September 03, 2022, 03:15:36 AM by topshelfvalueinc »

BIGAL

  • Swamp Rat
  • Posts: 1398
  • 40 + years of using Autocad
Re: Help Finding Block Route
« Reply #51 on: September 04, 2022, 09:18:18 PM »
Post a dwg with before and after.
A man who never made a mistake never made anything

siimao

  • Mosquito
  • Posts: 2
Re: Help Finding Block Route
« Reply #52 on: October 18, 2023, 09:46:54 AM »
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.
« Last Edit: October 18, 2023, 10:33:04 AM by siimao »

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Help Finding Block Route
« Reply #53 on: October 21, 2023, 08:59:44 AM »
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.

Intersection of 2 lines are 4 lines... Obviously, you have to double break all intersecting lines with BREAK command prior running A star minpath algorithm...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

siimao

  • Mosquito
  • Posts: 2
Re: Help Finding Block Route
« Reply #54 on: October 23, 2023, 05:27:41 AM »
Deer Marko,

Thank you for the respond.
You mentioned on "A star minpath algorithm". Is it lisp-function denoted on this chat?

Breaking lines is not the variant.
I think by such way.
If I understand 1) the end point of all lines is collected, 2) algorithm runs

What if we assign intersection points to a set of line endpoints. it’s okay if the lines along the entire length were highlighted.

Left of the picture - algorithm result. Center - I wish I could. Right - polyline result.

I just wanted to clarify if this could work?