LISP Routine to Specify Loops in a Network

March 10

Hi,

I design utility networks and wonder if there is a way of finding where loops are in a network? I have attached a CAD drawing and I would like for a routine to somehow pick out the loops (i.e. node 2-3-7-8-8 / 3-4-5-6-7-3 / 2-3-4-6-7-8-2).

Thank you

WATER TEST.dwg

March 10

It may be feasible using Bpoly to make a closed pline then walk along it finding the numbers, the open loops would need a temporary line for that to work.

For 2-3-4-6-7-8-2 remove leg 3-7 then its a loop. One of the things about lisp is that in this situation you can erase an object get all the points then do a UNDO but the points will still be in a lisp variable. I can see a problem with big networks how to determine a multitude of loop combos, with regards to increasing outwards.

March 13

Are you using AutoCAD LT?

March 13

5 hours ago, SLW210 said:

Are you using AutoCAD LT?

Hi, yes I am.

March 13

LISP will not help with AutoCAD LT.

What type of routine are you looking for?

March 13

Look at say Bricscad as an alternative to your LT, it is lisp capable.

March 14

Apologies, maybe I am not using AutoCAD LT as I already use loads of LISP routines. My info says AutoCAD Autodesk 2017.

I need something that looks at the nodes on my drawing and determines where there are loops and then ideally exports the data to a CSV file.

Edited March 14 by andy_06

March 14

I moved your post to the AutoLISP, Visual LISP & DCL Forum. Please post in the appropriate forum.

March 14

30 minutes ago, SLW210 said:

I moved your post to the AutoLISP, Visual LISP & DCL Forum. Please post in the appropriate forum.

Thank you.

March 14

No one replied with starting code... Here is my attempt that enters ~~endless loop~~, so you'll have to debug it and further more, how is programmed it was to only collect numbers - loops are difficult task and if you even consider the fact that one loop can consist of 2, 3, or ... it's even more scary... What do you need this, if I may ask?

(defun c:loops ( / *error* consbylastpt doublepath-chk osm p s blk nolst lw lws lww lwss )

  (vl-load-com)

  (defun *error* ( m )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbylastpt ( lastpt lw / no blk )
    (if (< 
          (distance lastpt (cdr (assoc 10 (entget lw))))
          (distance lastpt (cdr (assoc 10 (reverse (entget lw)))))
        )
      (setq blk (ssname (ssget "_C" (cdr (assoc 10 (reverse (entget lw)))) (cdr (assoc 10 (reverse (entget lw)))) (list (cons 0 "INSERT") (cons 66 1))) 0))
      (setq blk (ssname (ssget "_C" (cdr (assoc 10 (entget lw))) (cdr (assoc 10 (entget lw))) (list (cons 0 "INSERT") (cons 66 1))) 0))
    )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
    blk
  )

  (defun doublepath-chk ( lw )
    (and
      (< 1 (sslength (ssget "_C" (cdr (assoc 10 (entget lw))) (cdr (assoc 10 (entget lw))) (list (cons 0 "LWPOLYLINE")))))
      (< 1 (sslength (ssget "_C" (cdr (assoc 10 (reverse (entget lw)))) (cdr (assoc 10 (reverse (entget lw)))) (list (cons 0 "LWPOLYLINE")))))
    )
  )

  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 1)
  (initget 1)
  (setq p (getpoint "\nPick starting node ending polylines - for ex. node 1..."))
  (if (setq s (ssget "_C" p p (list (cons 0 "INSERT") (cons 66 1))))
    (progn
      (setq blk (ssname s 0))
      (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
        (if (numberp (setq no (atoi (vla-get-textstring att))))
          (setq nolst (cons no nolst))
        )
      )
      (setq nolst (cdr nolst))
      (setq lw (ssname (ssget "_C" p p (list (cons 0 "LWPOLYLINE"))) 0))
      (setq blk (consbylastpt p lw))
      (setq p (cdr (assoc 10 (entget blk))))
      (setq lwss (ssdel lw (ssget "_C" p p (list (cons 0 "LWPOLYLINE")))))
      (setq lws (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex lwss))))
      (setq lws (vl-remove (setq lw (vl-some (function (lambda ( x ) (if (doublepath-chk x) x))) lws)) lws))
      (if lws
        (setq lww (car lws))
      )
      (while
        (and
          (not (vl-position (car nolst) (cdr nolst)))
          (setq p (cdr (assoc 10 (entget blk))))
          (< 1 (sslength (setq lwss (if lw (ssdel lw (ssget "_C" p p (list (cons 0 "LWPOLYLINE")))) (ssget "_C" p p (list (cons 0 "LWPOLYLINE")))))))
        )
        (setq lws (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex lwss))))
        (cond
          ( (vl-position lww lws)
            (setq blk (consbylastpt p lw))
          )
          ( (setq lw (vl-some (function (lambda ( x ) (if (doublepath-chk x) x))) lws))
            (setq blk (consbylastpt p lw))
          )
        )
      )
    )
  )
  (princ (reverse (cdr nolst)))
  (*error* nil)
)

It works only for nodes 1 and 9... If you manage to construct such situations for all branches, then you can get first loop as like (2 8 7 3) from picking 1 or 9...

Edited March 14 by marko_ribar

March 14

Marko the dwg name gives the reason WATER its about water mains and the ability to turn a section off.

I did make a suggestion using bpoly pick inside a loop and can find the numbers using SSGET "F" the fence list is from the bpoly made.

Its very manual way to do it maybe have some time later to have a go.

March 15

Like BIGAL, only I used SSGET "_CP"... You pick inside where boundary is to be created and it extract points representing loop... For bigger composed of 2 smaller, remove pline 3 7...

Here is the code, pretty simple :

(defun c:loops ( / *error* consbyblk osm clay p bound pl ss blk nolst )

  (vl-load-com)

  (defun *error* ( m )
    (if (and bound (not (vlax-erased-p bound)))
      (entdel bound)
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if clay
      (setvar (quote clayer) clay)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbyblk ( blk / no )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
  )

  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (setq clay (getvar (quote clayer)))
  (setvar (quote clayer) "0")
  (vl-cmdf "_.ZOOM" "_Extents")
  (initget 1)
  (if (setq p (getpoint "\nPick point inside loop..."))
    (progn
      (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (cond
        ( (= (strcase (getvar (quote program))) "BRICSCAD")
          (vl-cmdf "_.BOUNDARY" "_A" "_B" "_E" "_I" "_Y" "_X" p)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
        ( (= (strcase (getvar (quote program))) "ACAD")
          (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
          (vl-cmdf "_.BOUNDARY" "_A" "_B" "_N" "_ALL" "_I" "_Y" "_O" "_P")
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
          (bpoly p)
        )
      )
      (setq bound (entlast))
      (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
      (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (foreach p pl
        (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
          (progn
            (setq blk (ssname ss 0))
            (consbyblk blk)
          )
        )
      )
    )
  )
  (princ nolst)
  (*error* nil)
)

Edited March 17 by marko_ribar

March 16

Here is the one that uses REGIONS, but the problem are nodes that lie collinear on 2 branches of LWPOLYLINES... When operating with regions and converting them to LWPOLYLINES those nodes are erased, so correct info is wrong... My suggestion is that you somehow tweak that collinearity to some nudge deviation in order to node be recognized...

Interestingly under ACAD everything is like expected... Only BricsCAD REGIONS are different - simplified at collinearity...

(defun c:loops ( / *error* consbyblk cmd osm clay pea el bound pl ss sss blk nolst nolstt )

  (vl-load-com)

  (defun *error* ( m )
    (if (and bound (not (vlax-erased-p bound)))
      (entdel bound)
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if clay
      (setvar (quote clayer) clay)
    )
    (if pea
      (setvar (quote peditaccept) pea)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbyblk ( blk / no )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq clay (getvar (quote clayer)))
  (setvar (quote clayer) "0")
  (setq pea (getvar (quote peditaccept)))
  (setvar (quote peditaccept) 1)
  (vl-cmdf "_.ZOOM" "_Extents")
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (setq el (entlast))
  (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  (setq sss (ssadd))
  (while (setq el (entnext el))
    (ssadd el sss)
  )
  (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (setq el (entlast))
  (vl-cmdf "_.REGION" sss "")
  (while (/= "REGION" (cdr (assoc 0 (entget (setq el (entnext el)))))))
  (while el
    (vl-cmdf "_.EXPLODE" el)
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
    (vl-cmdf "_.PEDIT" "_M" (ssget "_P") "" "_J")
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
    (setq bound (entlast))
    (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
    (entdel bound)
    (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
      (progn
        (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
        (while (< 0 (getvar (quote cmdactive)))
          (vl-cmdf "")
        )
      )
    )
    (foreach p pl
      (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
        (progn
          (setq blk (ssname ss 0))
          (consbyblk blk)
        )
      )
    )
    (setq nolstt (cons nolst nolstt))
    (setq nolst nil)
    (setq el (entnext el))
  )
  (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
    (progn
      (vl-cmdf "_.ERASE" sss)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (vl-cmdf "_.DRAWORDER" ss "" "_Back")
  (if (and nolstt (listp nolstt) (listp (car nolstt)))
    (setq nolstt (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))
  )
  (princ nolstt)
  (*error* nil)
)

HTH.

M.R.

Edited March 17 by marko_ribar

March 18

I had to make some deviations from collinearity, and it works only in AutoCAD; in BricsCAD ~~it fails~~...

Return :

((3 2 8 7) (4 11 10 5) (5 6 7 3 4) (8 2 3 4 5 6 7) (6 7 3 4 11 10 5) (11 4 3 2 8 7 6 5 10))

Here is the code and new *.DWG...

(defun c:loops ( / *error* consbyblk process cmd osm clay pea el ell s ss sss nolstt )

  (vl-load-com)

  (defun *error* ( m )
    (if (and bound (not (vlax-erased-p bound)))
      (entdel bound)
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.UNDO" "_E")
        (vl-cmdf "_.UNDO" "_E")
      )
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if clay
      (setvar (quote clayer) clay)
    )
    (if pea
      (setvar (quote peditaccept) pea)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbyblk ( blk / no )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
  )

  (defun process ( ss p / nolst bound pl ss blk )
    (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
      (progn
        (setq bound (car (nentselp p)))
        (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
        (entdel bound)
        (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
          (progn
            (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
        (foreach p pl
          (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
            (progn
              (setq blk (ssname ss 0))
              (consbyblk blk)
            )
          )
        )
        (setq nolstt (cons nolst nolstt))
      )
      (progn
        (vl-cmdf "_.JOIN" ss)
        (while (< 0 (getvar (quote cmdactive)))
          (vl-cmdf "")
        )
        (setq bound (car (nentselp p)))
        (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
        (entdel bound)
        (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
          (progn
            (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
        (foreach p pl
          (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
            (progn
              (setq blk (ssname ss 0))
              (consbyblk blk)
            )
          )
        )
        (setq nolstt (cons nolst nolstt))
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq clay (getvar (quote clayer)))
  (setvar (quote clayer) "0")
  (setq pea (getvar (quote peditaccept)))
  (setvar (quote peditaccept) 1)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_M")
  (vl-cmdf "_.-OVERKILL" "_ALL")
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (vl-cmdf "_.ZOOM" "_Extents")
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (setq el (entlast))
  (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  (setq sss (ssadd))
  (while (setq el (entnext el))
    (ssadd el sss)
  )
  (if (= 0 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Lock" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (vl-cmdf "_.REGION" sss "")
  (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
  (vl-cmdf "_.UNDO" "_G")
  (foreach el ell
    (vl-cmdf "_.EXPLODE" el)
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
    (setq s (ssget "_P"))
    (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
  )
  (vl-cmdf "_.UNDO" "_B")
  (setq ell (vl-remove (setq el (car (vl-sort ell (function (lambda ( a b ) (> (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))) ell))
  (entdel el)
  (foreach e1 ell
    (setq ell (vl-remove e1 ell))
    (foreach e2 ell
      (vl-cmdf "_.UNDO" "_G")
      (vl-cmdf "_.UNION" e1 e2)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (cond
        ( (and e1 (not (vlax-erased-p e1)))
          (vl-cmdf "_.EXPLODE" e1)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
        ( (and e2 (not (vlax-erased-p e2)))
          (vl-cmdf "_.EXPLODE" e2)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
        ( t
          (vl-cmdf "_.EXPLODE" "_L")
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
      )
      (if (wcmatch (cdr (assoc 0 (entget (ssname (setq s (ssget "_P")) 0)))) "LINE,ARC")
        (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
      )
      (vl-cmdf "_.UNDO" "_B")
    )
  )
  (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
    (progn
      (vl-cmdf "_.ERASE" sss)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
  (vl-cmdf "_.ERASE" ss)
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (vl-cmdf "_.DRAWORDER" ss "" "_Back")
  (if (and nolstt (listp nolstt) (listp (car nolstt)))
    (setq nolstt (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))
  )
  (princ nolstt)
  (*error* nil)
)

HTH.

M.R.

WATER TEST-NEW.dwg

Edited March 18 by marko_ribar

March 18

I've tried to solve for any tree of loops that may occur in complex situations... However, my mind stuck where I had to code for multiple nested (foreach) loops... Here is the code, so if some guru appear it would be nice that we feel relief upon finding general solution...

(defun c:loops ( / *error* consbyblk process consforeach closeparen body cmd osm clay pea el ell s ss sss nolstt n nn )

  (vl-load-com)

  (defun *error* ( m )
    (if (and bound (not (vlax-erased-p bound)))
      (entdel bound)
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.UNDO" "_E")
        (vl-cmdf "_.UNDO" "_E")
      )
    )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if osm
      (setvar (quote osmode) osm)
    )
    (if clay
      (setvar (quote clayer) clay)
    )
    (if pea
      (setvar (quote peditaccept) pea)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun consbyblk ( blk / no )
    (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
      (if (numberp (setq no (atoi (vla-get-textstring att))))
        (setq nolst (cons no nolst))
      )
    )
  )

  (defun process ( ss p / nolst bound pl ss blk )
    (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
      (progn
        (setq bound (car (nentselp p)))
        (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
        (entdel bound)
        (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
          (progn
            (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
        (foreach p pl
          (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
            (progn
              (setq blk (ssname ss 0))
              (consbyblk blk)
            )
          )
        )
        (setq nolstt (cons nolst nolstt))
      )
      (progn
        (vl-cmdf "_.JOIN" ss)
        (while (< 0 (getvar (quote cmdactive)))
          (vl-cmdf "")
        )
        (setq bound (car (nentselp p)))
        (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
        (entdel bound)
        (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
          (progn
            (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
          )
        )
        (foreach p pl
          (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
            (progn
              (setq blk (ssname ss 0))
              (consbyblk blk)
            )
          )
        )
        (setq nolstt (cons nolst nolstt))
      )
    )
  )
  ;;; this is problematic
  (defun consforeach ( n )
    (if (> n 0)
      (progn
        '(foreach (read (strcat "e" (itoa n))) ell
        (consforeach (1- n))
      )
    )
  )
  ;;; this is problematic
  (defun closeparen ( n )
    (if (> n 0)
      ')
      (closeparen (1- n))
    )
  )
  ;;; this is problematic
  (defun body ( n )
    (vl-cmdf "_.UNDO" "_G")
    (while (> n 0)
      (setq elst (cons (quote (read (strcat "e" (itoa (setq n (1- n)))))) elst))
      (vl-catch-all-apply (function vl-cmdf) (cons "_.UNION" elst))
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
    (foreach e elst
      (cond
        ( (and e (not (vlax-erased-p e)))
          (vl-cmdf "_.EXPLODE" e)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
        ( t
          (vl-cmdf "_.EXPLODE" "_L")
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
        )
      )
    )
    (if (wcmatch (cdr (assoc 0 (entget (ssname (setq s (ssget "_P")) 0)))) "LINE,ARC")
      (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
    )
    (vl-cmdf "_.UNDO" "_B")
  )
  ;;;
  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq clay (getvar (quote clayer)))
  (setvar (quote clayer) "0")
  (setq pea (getvar (quote peditaccept)))
  (setvar (quote peditaccept) 1)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_M")
  (vl-cmdf "_.-OVERKILL" "_ALL")
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (vl-cmdf "_.ZOOM" "_Extents")
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (setq el (entlast))
  (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  (setq sss (ssadd))
  (while (setq el (entnext el))
    (ssadd el sss)
  )
  (if (= 0 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Lock" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (vl-cmdf "_.REGION" sss "")
  (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
  (vl-cmdf "_.UNDO" "_G")
  (foreach el ell
    (vl-cmdf "_.EXPLODE" el)
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
    (setq s (ssget "_P"))
    (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
  )
  (vl-cmdf "_.UNDO" "_B")
  (setq ell (vl-remove (setq el (car (vl-sort ell (function (lambda ( a b ) (> (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))) ell))
  (entdel el)
  (setq nn (length ell))
  ;;; this is problematic
  (while (> nn 0)
    (setq nn (1- nn))
    (consforeach nn)
    (body nn)
    (closeparen nn)
  )
  ;;;
  (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
    (progn
      (vl-cmdf "_.ERASE" sss)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
    (progn
      (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
    )
  )
  (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
  (vl-cmdf "_.ERASE" ss)
  (while (< 0 (getvar (quote cmdactive)))
    (vl-cmdf "")
  )
  (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  (vl-cmdf "_.DRAWORDER" ss "" "_Back")
  (if (and nolstt (listp nolstt) (listp (car nolstt)))
    (setq nolstt (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))
  )
  (princ nolstt)
  (*error* nil)
)

March 19

Now it becomes complicated...

I've continued topic to this link : https://www.theswamp.org/index.php?topic=58155.0

I've called it Challenge topic, as it is not fully operational as it is now...

Remember, we need general solution...

LISP Routine to Specify Loops in a Network

Recommended Posts

andy_06

Link to comment

Share on other sites

BIGAL

Link to comment

Share on other sites

SLW210

Link to comment

Share on other sites

andy_06

Link to comment

Share on other sites

SLW210

Link to comment

Share on other sites

BIGAL

Link to comment

Share on other sites

andy_06

Link to comment

Share on other sites

SLW210

Link to comment

Share on other sites

andy_06

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

BIGAL

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity