Topic: tracing through the network

[subbup]

I have bunch of polylines conected together and forms a big chain and some of the polylines connected to this chain somewhere and hanging.
I know the start point of chain and endpoint of the chain.

I want to trace the route between startpoint and endpoint and return the selection set of entites that are in that route.

all the polylines are insame layer.

Thanks,

[CAB]

Your wish is my command.

Code: [Select]

;; based on Inline.lsp by John Uhden
;; modified Joe Burke 5/15/03
;; pick a line, arc or lwpline
;; creates a selection set of objects which meet end to end
;; only selects objects on the same layer as picked object
;; pass selection set to pedit join...

;; CUT_LIST.LSP (c)1995-96, John F. Uhden, CADvantage
;; This function deletes the first instance of an item from a list:
;; Corrected thanks to trouble shooting by Peter B. Tobey
(defun @cv_cut_list (|item |list / |m)
  (if (setq |m (member |item |list))
    (progn
      (setq |list (reverse |list))
      (repeat (length |m) (setq |list (cdr |list)))
      (append (reverse |list) (cdr |m))
    )
    |list
  )
) ;end

(defun @arc (ent / e rp r ba ea p1 p2)
  (setq e  (cdr (assoc -1 ent))
        rp (cdr (assoc 10 ent))
        r  (cdr (assoc 40 ent))
        ba (cdr (assoc 50 ent))
        ea (cdr (assoc 51 ent))
        p1 (trans (polar rp ba r) e 0)
        p2 (trans (polar rp ea r) e 0)
  )
  (list e p1 p2)
) ;end

(defun @line (ent)
  (list
    (cdr (assoc -1 ent))
    (cdr (assoc 10 ent))
    (cdr (assoc 11 ent))
  )
) ;end

(defun @pline (ent / e)
  (setq e (cdr (assoc -1 ent)))
  (list
    e
    (car (getends e))
    (cadr (getends e))
  )
) ;end

(defun @list (e / ent)
  (setq ent (entget e))
  (cond
    ((= (cdr (assoc 0 ent)) "LINE")
     (setq sslist (cons (@line ent) sslist))
    )
    ((= (cdr (assoc 0 ent)) "ARC")
     (setq sslist (cons (@arc ent) sslist))
    )
    ((= (cdr (assoc 0 ent)) "LWPOLYLINE")
     (setq sslist (cons (@pline ent) sslist))
    )
  )
) ;end

(defun @closest (sym / item e p1 p2 i found)
  (setq i 0
        p (eval sym)
  )
  (while (and (not found) (< i (length sslist)))
    (setq item (nth i sslist)
          e    (car item)
          p1   (cadr item)
          p2   (caddr item)
          i    (1+ i)
    )
    (cond
      ((equal p p1 fuzz)
       (setq found 1)
       (set sym p2)
      )
      ((equal p p2 fuzz)
       (setq found 1)
       (set sym p1)
      )
    )
  )
  (cond
    ((not found) nil)
    ((= sym 'start)
     (setq elist (cons e elist))
     (setq sslist (@cv_cut_list item sslist))
    )
    ((= sym 'end)
     (setq elist (reverse (cons e (reverse elist))))
     (setq sslist (@cv_cut_list item sslist))
    )
  )
) ;end

 ;argument: an ename - returns: Start and End points as a list
(defun getends (vobj / name stpt endpt)
  (if (= (type vobj) 'ename)
    (setq vobj (vlax-ename->vla-object vobj))
  )
  (and
    (setq name (vla-get-objectname vobj))
    (cond
      ((vl-position
         name
         '("AcDbArc"           "AcDbLine"          "AcDbEllipse"
           "AcDbSpline"        "AcDbPolyline"      "AcDb2dPolyline"
           "AcDb3dPolyline"
          )
       )
       (setq stpt (vlax-curve-getstartpoint vobj))
       (setq endpt (vlax-curve-getendpoint vobj))
      )
    ) ;cond
  ) ;and
  (list stpt endpt)
) ;end

;; -------------------------------
;; main function
;; renamed Inline.lsp by John Uhden
(defun c:ssend2end (/      sslist elist  ss     ssres  i      e
                    ent    ok     start  end    fuzz   layer  ssex
                    typlst
                   )
  (if
    (and
      (cadr (ssgetfirst)) ;objects are selected
 ;at least one arc, line or pline
      (setq ssex (ssget "i" (list (cons 0 "LINE,ARC,LWPOLYLINE"))))
    ) ;and
     (setq e (ssname ssex 0)) ;then
     (progn ;else
       (sssetfirst)
       (setq typlst '("LINE" "ARC" "LWPOLYLINE"))
       (while
         (or
           (not (setq e (car (entsel "\nSelect line, pline or arc: "))))
           (not (member (cdr (assoc 0 (entget e))) typlst))
         )
          (princ "\nMissed pick or wrong object type: ")
       ) ;while
     ) ;progn
  ) ;if
  (and
    (setq ok   1
          fuzz 1e-8
    )
    (setq ent (entget e))
    (setq layer (cdr (assoc 8 ent)))
    (cond
      ((= (cdr (assoc 0 ent)) "ARC")
       (setq ent (@arc ent))
      )
      ((= (cdr (assoc 0 ent)) "LINE")
       (setq ent (@line ent))
      )
      ((= (cdr (assoc 0 ent)) "LWPOLYLINE")
       (setq ent (@pline ent))
      )
    )
    (setq elist (list e)
          start (cadr ent)
          end   (caddr ent)
    )
    (setq ss
           (ssget "X" (list '(0 . "LINE,ARC,LWPOLYLINE") (cons 8 layer)))
    )
    (ssdel e ss)
    (setq i 0)
    (repeat (sslength ss)
      (@list (ssname ss i))
      (setq i (1+ i))
    ) ;repeat
    (while ok
      (setq ok
             (or
               (@closest 'start)
               (@closest 'end)
             )
      )
      1
    ) ;while
  ) ;and
  (setq ssres (ssadd))
  (foreach x elist
    (ssadd x ssres)
  )
  (sssetfirst nil ssres)
  (princ)
) ;end
;; -------------------------------

 ;shortcut
(defun c:e2e () (c:ssend2end))

[Anonymous]

Your lisp is working very good. what it is doing select pline or line or arc it will go to till end.
But thing is that as per subbu is he know the startpoint and endpoint how can we trace the route inbetween those points. there may be other route also connected to that.
Your lisp is give connected chains result. we don't have control on endpoint where it will go. is there any control to do this

Thanks,

[Serge J. Gianolla]

Sounds like you might be after the Travelling salesman Algorithm!
Imagine a travelling salesman who has to visit once each of a given set of cities [points] by car using the shortest itinerary. Is this what you'd be after

[Anonymous]

Ya, that's correct. I think some option is there in Autocad map.
Do you have any idea

[Serge J. Gianolla]

http://w1.859.telia.com/~u85905224/tsp/TSP.htm
http://www.physics.carleton.ca/courses/75.502/slides/java/MetroApplet/MetroApplet.html
http://www.pcug.org.au/~dakin/tsp.htm
A lot more can be found via search engines!

[Anonymous]

you gave something that completely out of lisp.
I am looking in lisp.

[Serge J. Gianolla]

My bad Guest, I thought you wanted me to show you where the fish is, but you want me to catch it for you too OK, what next? Shall I eat it too!

[CAB]

This was no easy fish to catch, for me that is.

So I guess I'll feed subbup today. Because it was a fun project.

Could use some more testing I'm sure.

Code: [Select]

;;  ***************************************************************
;;   pline path finder.lsp
;;   Charles Alan Butler 07/08/2004
;;   Modified routine to find a path from picked start entity
;;   to picked end entity.
;;
;;   Returns the first path if it exist else nil, not the shortest path
;;   Selects & highlites the path also
;;  ***************************************************************

 ;shortcut
(defun c:plp () (c:PlinePath))

;;;  ***************************************************************
;;;               Original Routine                                  
;;;
;;;  ;; based on Inline.lsp by John Uhden
;;;  ;; modified Joe Burke 5/15/03
;;;  ;; pick a line, arc or lwpline
;;;  ;; creates a selection set of objects which meet end to end
;;;  ;; only selects objects on the same layer as picked object
;;;  ;; pass selection set to pedit join...
;;;
;;;  ***************************************************************


;;===================================
;;      -=<  Sub Routines  >=-      
;;===================================

;;  Return (ename Startpt Endpt)
(defun @arc (ent / e rp r ba ea p1 p2)
  (setq e  (cdr (assoc -1 ent))
        rp (cdr (assoc 10 ent))
        r  (cdr (assoc 40 ent))
        ba (cdr (assoc 50 ent))
        ea (cdr (assoc 51 ent))
        p1 (trans (polar rp ba r) e 0)
        p2 (trans (polar rp ea r) e 0)
  )
  (list e p1 p2)
) ;end

;;  Return (ename Startpt Endpt)
(defun @line (ent)
  (list
    (cdr (assoc -1 ent))
    (cdr (assoc 10 ent))
    (cdr (assoc 11 ent))
  )
) ;end

;;  Return (ename Startpt Endpt)
(defun @pline (ent / e)
  (setq e (cdr (assoc -1 ent)))
  (list
    e
    (car (getends e))
    (cadr (getends e))
  )
) ;end

;;  Add ent-> (ename Startpt Endpt) to list
(defun @list (e / ent)
  (setq ent (entget e))
  (cond
    ((= (cdr (assoc 0 ent)) "LINE")
     (setq sslist (cons (@line ent) sslist))
    )
    ((= (cdr (assoc 0 ent)) "ARC")
     (setq sslist (cons (@arc ent) sslist))
    )
    ((= (cdr (assoc 0 ent)) "LWPOLYLINE")
     (setq sslist (cons (@pline ent) sslist))
    )
  )
) ;end

;;argument: an ename - returns: Start and End points as a list
(defun getends (vobj / name stpt endpt)
  (if (= (type vobj) 'ename)
    (setq vobj (vlax-ename->vla-object vobj))
  )
  (and
    (setq name (vla-get-objectname vobj))
    (cond
      ((vl-position
         name
         '("AcDbArc"           "AcDbLine"          "AcDbEllipse"
           "AcDbSpline"        "AcDbPolyline"      "AcDb2dPolyline"
           "AcDb3dPolyline"
          )
       )
       (setq stpt (vlax-curve-getstartpoint vobj))
       (setq endpt (vlax-curve-getendpoint vobj))
      )
    ) ;cond
  ) ;and
  (list stpt endpt)
) ;end

;; get list of (ename startpt endpt) for picked ent
(defun get:elst(ent)
  (cond
    ((= (cdr (assoc 0 ent)) "ARC")
     (setq ent (@arc ent))
    )
    ((= (cdr (assoc 0 ent)) "LINE")
     (setq ent (@line ent))
    )
    ((= (cdr (assoc 0 ent)) "LWPOLYLINE")
     (setq ent (@pline ent))
    )
  )
  ent
); end defun


;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
;;          main function              
;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
(defun c:plinepath (/      sslist elist  ss     ssres  i      e      e2
                    found  ent    ent2   ok     start  end    start2 end2
                    fuzz   layer  ssex   typlst
                   )
  ;; Get the start object
  (if ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
    (and
      (cadr (ssgetfirst)) ;objects are selected
      ;;at least one arc, line or pline
      (setq ssex (ssget "i" (list (cons 0 "LINE,ARC,LWPOLYLINE"))))
    ) ;and

     ;; ======  then  =============
     (setq e (ssname ssex 0))
     ;; ======  else  =============
     (progn
       (sssetfirst)
       (setq typlst '("LINE" "ARC" "LWPOLYLINE"))
       (while
         (or
           (not (setq e (car (entsel "\nSelect Starting line, pline or arc: "))))
           (not (member (cdr (assoc 0 (entget e))) typlst))
         )
          (princ "\nMissed pick or wrong object type: ")
       ) ;while
     ) ;progn
  ) ;if  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

  ;;  Get the End object added by CAB
  (setq typlst '("LINE" "ARC" "LWPOLYLINE"))
  (while
    (or
      (not (setq e2 (car (entsel "\nSelect Ending line, pline or arc: "))))
      (not (member (cdr (assoc 0 (entget e2))) typlst))
    )
     (princ "\nMissed pick or wrong object type: ")
  ) ;while

  (and
    (setq ok   1
          fuzz 1e-8 ; 0.00000001
    )
    (setq ent (entget e)) ; first or picked ent
    (setq ent2 (entget e2)) ; second picked ent, CAB
    (setq layer (cdr (assoc 8 ent))) ; layer to match
    (= layer (cdr (assoc 8 ent2))) ; layers match
    (setq ent    (get:elst ent)
          elist  '()
          start  (cadr ent)
          end    (caddr ent)
          ent2   (get:elst ent2); CAB
          start2 (cadr ent2)
          end2   (caddr ent2)
    )
    (setq ss ; get all objects that matched picked
           (ssget "X" (list '(0 . "LINE,ARC,LWPOLYLINE") (cons 8 layer)))
    )
    (ssdel e ss) ; remove picked start from selection set

    ;;  make a list of all from ss  ((ename startpt endpt) ....)
    (setq i 0)
    (repeat (sslength ss)
      (@list (ssname ss i))
      (setq i (1+ i))
    ) ;repeat
    ;;  CAB revised from here down
    ;;  find attached items, does not test all branches
    (@ckpoint start ent sslist)
    (if (not found)
      (@ckpoint end ent sslist)
    )
  ) ;and
  (if found
    (progn
      (setq elist (cons ent elist))
      (setq ssres (ssadd))
      (foreach x elist ; creat a selection set of the list
        (ssadd (car x) ssres)
      )
      (prompt "\n*-* Done *-*\n")
      (cadr(sssetfirst nil ssres)) ; display the selected items
    ); progn
    (prompt "\n*-* Path not found *-*")
  )
) ;end
;; -------------------------------

;;  @ckPoint by CAB
;;  check the list for matching points
;;  p point to match
;;  elst (ename startpt endpt) of pt
;;  |List list pf remaining elst
(defun @ckpoint( p elst |list / entx ex p1 p2 idx res)
  (setq idx (length |List))
  (while (and (not found) (>= (setq idx (1- idx)) 0))
    (setq entx (nth idx |List)
          ex  (car entx)
          p1  (cadr entx)
          p2  (caddr entx)
     )
    (cond ; test point match with fuzz factor
      ((equal p start2 fuzz) ; text for target
       (setq found 1)
       (setq elist (cons ent2 elist))
      )
      ((equal p end2 fuzz) ; text for target
       (setq found 1)
       (setq elist (cons ent2 elist))
      )
      ((equal p p1 fuzz) ; test for next branch
       (setq res (@ckpoint p2 entx (vl-remove entx |List)))
       (if found ; we are backing out collecting the path
        (setq elist (cons entx elist))
       )
      )
      ((equal p p2 fuzz) ; test for next branch
       (setq res (@ckpoint p1 entx (vl-remove entx |List)))
       (if found; we are backing out collecting the path
        (setq elist (cons entx elist))
       )
      )
    )
  ); while
  T ; return to satisfy AND
); defun

;;========================
;;   End Of File          
;;========================

[t-bear]

WOW!!  That is sweeeet!   Nice job, CAB.....

[CAB]

Thank you Big t