Draw polyline along with 2 or more adjacent closed polylines

[chvnprasad]

Hi i required a lisp to draw a poly line along with 2 closed poly lines. If i pick 2 vertexes on 2 polygons, 1 new poly line should be created between these two points along with polygon walls. can any body help.

 

Please refer screen shot for your reference

 

thanks,

Prasad

[Lee Mac]

My approach would be:

 

 

• Collect set of candidate polygons
  

 

• Collect set of all possible vertices from set of candidate polygons
  

 

• Prompt user for source vertex and destination vertex
  

 

• Use Dijkstra's Algorithm to determine the shortest path between the two vertices from the set of available vertices, the weight for each segment being the distance between the vertices for that segment.
  

[marko_ribar]

Assuming that the polygons are at elevation 0.0, this should work :

 

(defun getverticies ( pl / lst )
 (mapcar '(lambda (x) (if (eq (car x) 10) (setq lst (cons (cdr x) lst)))) (entget pl))
 (reverse lst)
)

(defun ChIV ( pl nthpt / ed edd q ec ed eddd eddd1 eddd2 eddd3 newed m n i )
 (setq ed (entget pl))
 (setq edd nil)
 (setq q -1)
 (while (< q 0)
   (progn
   (setq ec (car ed))
   (setq ed (cdr ed))
   (if (eq (car ec) 10) (progn (setq ed (cons ec ed)) (setq edd (reverse edd)) (setq q 1)) (setq edd (cons ec edd)))
   )
 )
 (setq eddd nil)
 (setq eddd1 nil)
 (setq eddd2 nil)
 (setq eddd ed)
 (setq m nthpt)
 (setq n (* m 4))
 (setq i 0)
 (foreach ec eddd
   (progn
   (setq i (+ i 1))
   (if (<= i n)
     (setq eddd1 (cons ec eddd1))
   )
   (if (> i n)
     (setq eddd2 (cons ec eddd2))
   )
   )
 )
 (setq eddd1 (reverse eddd1))
 (setq eddd2 (cdr eddd2))
 (setq eddd2 (reverse eddd2))
 (setq eddd3 '((210 0.0 0.0 1.0)))
 (setq newed (append edd eddd2 eddd1 eddd3))
 (entmod newed)
 (entupd pl)
)

(defun c:2pl-pl ( / oldv v pt1 pt2 pt3 pl1 pl2 pl1vert pl2vert k nthpt1 nthpt3 pl1vertpt2 pl2vertpt2 newplvert )
 (setq oldv (mapcar 'getvar (setq v '(cmdecho osmode))))
 (mapcar 'setvar v '(0 1))
 (setq pt1 (getpoint "\nPick start point on first polyline : "))
 (setq pt2 (getpoint "\nPick point on 2 pline connection : "))
 (setq pt3 (getpoint "\nPick end point on second polyline : "))
 (setq pt1 (reverse (cdr (reverse pt1))))
 (setq pt2 (reverse (cdr (reverse pt2))))
 (setq pt3 (reverse (cdr (reverse pt3))))
 (setvar 'osmode 0)
 (vl-cmdf "osnap" "off")
 (prompt "\nPick first polyline")
 (setq pl1 (ssname (ssget "_+.:E:L" '((0 . "LWPOLYLINE"))) 0))
 (setq pl1vert (getverticies pl1))
 (if (not (member pt1 pl1vert)) (progn (alert "\nWarning - start point not member of first polyline") (exit)))
 (prompt "\nPick second polyline")
 (setq pl2 (ssname (ssget "_+.:E:L" '((0 . "LWPOLYLINE"))) 0))
 (setq pl2vert (getverticies pl2))
 (if (not (member pt3 pl2vert)) (progn (alert "\nWarning - end point not member of second polyline") (exit)))
 (setq k -1)
 (foreach pt pl1vert
   (setq k (1+ k))
   (if (equal pt pt1 1e- (setq nthpt1 k))
 )
 (setq k -1)
 (foreach pt pl2vert
   (setq k (1+ k))
   (if (equal pt pt3 1e- (setq nthpt3 k))
 )
 (ChIV pl1 nthpt1)
 (ChIV pl2 nthpt3)
 (setq pl1vert (getverticies pl1))
 (setq pl2vert (getverticies pl2))
 (ChIV pl1 (- (length pl1vert) nthpt1))
 (ChIV pl2 (- (length pl2vert) nthpt3))
 (setq pl1vertpt2 (vl-remove pt2 (reverse (member pt2 (reverse pl1vert)))))
 (setq pl2vertpt2 (vl-remove pt2 (reverse (member pt2 (reverse pl2vert)))))
 (if (member (last pl2vertpt2) pl1vert)
   (progn
   (setq pl2vert (cons pt3 (reverse (cdr pl2vert))))
   (setq pl2vertpt2 (vl-remove pt2 (reverse (member pt2 (reverse pl2vert)))))
   )
 )
 (if (member (last pl1vertpt2) pl2vert)
   (progn
   (setq pl1vert (cons pt1 (reverse (cdr pl1vert))))
   (setq pl1vertpt2 (vl-remove pt2 (reverse (member pt2 (reverse pl1vert)))))
   )
 )
 (setq newplvert (append pl1vertpt2 (list pt2) (reverse pl2vertpt2)))
 (entmakex (append
               (list
                   (cons 0 "LWPOLYLINE")
                   (cons 100 "AcDbEntity")
                   (cons 100 "AcDbPolyline")
                   (cons 62 3)
                   (cons 90 (length newplvert))
                   (cons 70 0)
                   (cons 210 (list 0.0 0.0 1.0))
               )
               (mapcar '(lambda (x) (cons 10 x)) newplvert)
           )
 )
 (mapcar 'setvar v oldv)
 (princ)
)

 

Regards,

M.R.

 

[EDIT] : changed code so that you can select first and second polyline to make it easier to create consecutive contours of new connection polylines that could be joined in later step...

Edited March 29, 2023 by marko_ribar
code little changed

[chvnprasad]

thnks, It is working fine for 2 polygons.

same lisp i am unable to use for multiple polygons. can u modify this please.

[marko_ribar]

Repeat executing routine like I explained from 2nd polygon to 3rd, then repeat from 3rd to 4th, and so on... At the end you can join contour with PEDIT command...

 

M.R.

[pBe]

My approach would be:

• Use Dijkstra's algorithm to determine the shortest path between the two vertices from the set of available vertices, the weight for each segment being the distance between the vertices for that segment.
  

 

After spending half-a-day reading Dijkstra's algorithm as Lee suggested. well after a while ..... it started to look like 3D Stereogram to me

 

I did however use the approach on Les's post (items 1-3). So here's a draft:

(defun c:PlPath (/ LM:ListClockwise-p LM:Unique AT:GetVertices _Buildlist
                _FindPoint _rebuild _FindNext
                sp ep ss i a Pls  PtlSt)
(vl-load-com)
(defun LM:ListClockwise-p (lst)
   (minusp (apply '+ (mapcar
       (function
  (lambda (a b)
    (- (* (car b) (cadr a)) (* (car a) (cadr b)))
    ) ) lst (cons (last lst) lst)
       )))
  )
(defun LM:Unique ( l )
 (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))
)  
(defun AT:GetVertices (e / p l)
 ;; Alan J. Thompson, 09.30.10
 (if e
   (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
     (repeat (setq p (1+ (fix p)))
(setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
     )
     (list (vlax-curve-getStartPoint e)
    (vlax-curve-getEndPoint e)
     )
   )
 )
)
(defun _Buildlist (pt ls)
   (setq Pt (_findpoint sp ls)
  Pt (append (car Pt) (vl-remove-if
 '(lambda (q) (member q (car Pt)))
(setq nl (nth (cadr Pt) ls))
      )
     )
  ls (vl-remove nl ls)
   )
   (list Pt ls)
 )
(defun _FindPoint (v l / a b c d)
(setq d -1)  
 (while (and (setq a (car l)) (not c))
   (setq d (1+ d))
   (if (setq b (member v a))
     (setq c (cons b c) )
   )
   (setq l (vl-remove a l))
 ) (list (car c) d)
)
(defun _rebuild (v ls_)
  (foreach s (cdr (member v ls_))
     (setq ls_ (vl-remove s ls_))) ls_)
(defun _FindNext (l1 l2 / f g h)
 (while (and (setq f (car l1)) (not g))
   (if (not (setq g (car (_FindPoint f l2))))
     (setq l1 (cdr l1))
   )
 )
 (car g)
)
(cond ((and      
(Setq Lst nil PtlSt nil
 sp (getpoint "\nSelect Start Point:"))
(Setq ep (getpoint sp "\nSelect End Point:"))
(setq ss (ssget  '((0 . "LWPOLYLINE")
        (-4 . "&=") (70 . 1)
        (410 . "MODEL")
       )
      )
    )
       (progn
             (initget 1 "T B")
             (setq opt (getkword "\nSelect option [Top/Bottom]: ")) opt)
(repeat (setq i (sslength ss))
               (setq a (AT:GetVertices (ssname ss (setq i (1- i)))))
              (if (eq opt "B") 
   (setq a (if (LM:ListClockwise-p a)
      (reverse a) a ))
               (setq a (if (LM:ListClockwise-p a)
      a (reverse a) )))    
   (setq lst (cons a lst)))
(repeat (length lst)
(setq Pls (_Buildlist sp lst)
      PtlSt (cons (car Pls) PtlSt)
      lst (cadr Pls))
(setq sp (_FindNext (car PtlSt) lst))
(setq PtlSt (subst (_rebuild sp (car PtlSt)) (car PtlSt) PtlSt))
  )
(setq PtlSt (LM:Unique
          (apply 'append
                 (reverse
                       (subst (_rebuild ep (car PtlSt))
                              (car PtlSt)
                              PtlSt)))))
(entmakex (append (list (cons 0 "LWPOLYLINE")
                          (cons 100 "AcDbEntity")
                          (cons 100 "AcDbPolyline")
                          (cons 90 (length PtlSt))
                          (cons 70 0))
                    (mapcar (function (lambda (p) (cons 10 p))) PtlSt)))
       (sssetfirst nil (ssadd (entlast)))
       )
      )
     )

     (princ)
 )

 

Right now, if you pick a point form left to right , you'll be prompted for Top or Bottom, then select the polygons any which way you want it doesnt matter.

 

But if you somehow pick the points right to left, whats top is bottom and bottom is top.

We could easily add the option for that, but first try it out and tell me what you think

 

Cheers.

 

BTW: kudos to Lee Mac amd Alanjt for the subs i included on the code.

[chvnprasad]

Thanks pBe, its working fine. this is exactly what i want. But this is not working for open polygons.

 

Is there any possibilities to develop lisp without select all polygons(select only start vertices and end vertices)

[pBe]

Thanks pBe, its working fine. this is exactly what i want. But this is not working for open polygons.

 

I guess the code can be modified to handle open polygons, but you did asked for Closed Polygons

 

Is there any possibilities to develop lisp without select all polygons(select only start vertices and end vertices)

 

Oh boy.. now that would be something. That is beyond my math skils. I gues i need to read Dijkstra's algorithm more seriously this time.

 

But I'll try, no promises though

[chvnprasad]

Thanks pBe

Tnks for ur patience. Can u please tell me which part i need to modify in this lisp for Open polygons. For my side it difficult to me, Because i am Newbie to Autolisp.

[marko_ribar]

Hi, chaps...

 

Recently, I've checked my code I posted above on A2012, and it fails - it skips some vertices, but on A2009 on the same PC it works fine... Can someone confirm what I am saying... What could cause this bug?

 

Nevertheless, pBe code works fine - still I was unable to understand it all and as I had some free time I've formatted code so it just looks better for my eyes and I suppose for someone that wants to analyze it...

 

Thanks to pBe for the code and hoping that won't mind for my remarks ab formatting - nowadays I see improvement on that manner...

 

Cheers...

M.R.

 

(defun c:PlPath ( / LM:ListClockwise-p LM:Unique AT:GetVertices _Buildlist _FindPoint _Rebuild _FindNext
                   sp ep ss opt i a Pls PtlSt )

 (vl-load-com)

 (defun LM:ListClockwise-p ( lst )
   (minusp 
     (apply '+ 
       (mapcar
         (function
           (lambda ( a b )
             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
           )
         ) lst (cons (last lst) lst)
       )
     )
   )
 )

 (defun LM:Unique ( lst )
   (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
 )

 (defun AT:GetVertices ( e / p l )
   ;; Alan J. Thompson, 09.30.10
   (LM:Unique
     (if e
       (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
         (repeat (setq p (1+ (fix p)))
           (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
         )
         (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
       )
     )
   )
 )

 (defun _Buildlist ( pt ls )
   (setq Pt (_FindPoint sp ls)
         Pt (append 
              (car Pt) 
              (vl-remove-if
                (function 
                  (lambda ( q ) (member q (car Pt)))
                )
                (setq nl (nth (cadr Pt) ls))
              )
            )
         ls (vl-remove nl ls)
   )
   (list Pt ls)
 )

 (defun _FindPoint ( v l / a b c d )
   (setq d -1)  
   (while  
     (and 
       (setq a (car l)) 
       (not c)
     )
     (setq d (1+ d))
     (if (setq b (member v a))
       (setq c (cons b c))
     )
     (setq l (vl-remove a l))
   )
   (list (car c) d)
 )

 (defun _Rebuild ( v ls_ )
   (foreach s (cdr (member v ls_))
     (setq ls_ (vl-remove s ls_))
   )
   ls_
 )

 (defun _FindNext ( l1 l2 / f g )
   (while  
     (and 
       (setq f (car l1)) 
       (not g)
     )
     (if (not (setq g (car (_FindPoint f l2))))
       (setq l1 (cdr l1))
     )
   )
   (car g)
 )

 (if 
   (and      
     (setq Lst nil PtlSt nil
           sp (getpoint "\nSelect Start Point:")
     )
     (setq ep (getpoint sp "\nSelect End Point:"))
     (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1) (410 . "MODEL"))))
     (progn
       (initget 1 "T B")
       (setq opt (getkword "\nSelect option [Top/Bottom]: "))
       opt
     )
     (repeat (setq i (sslength ss))
       (setq a (AT:GetVertices (ssname ss (setq i (1- i)))))
       (if (eq opt "B") 
         (setq a (if (LM:ListClockwise-p a)
                   (reverse a) 
                   a
                 )
         )
         (setq a (if (LM:ListClockwise-p a)
                   a 
                   (reverse a)
                 )
         )
       )    
       (setq lst (cons a lst))
     )
     (repeat (length lst)
       (setq Pls (_Buildlist sp lst)
             PtlSt (cons (car Pls) PtlSt)
             lst (cadr Pls)
       )
       (setq sp (_FindNext (car PtlSt) lst))
       (setq PtlSt (subst (_Rebuild sp (car PtlSt)) (car PtlSt) PtlSt))
     )
     (setq PtlSt 
       (LM:Unique
         (apply 'append
           (reverse
             (subst (_Rebuild ep (car PtlSt)) (car PtlSt) PtlSt)
           )
         )
       )
     )
   )
   (progn
     (entmakex 
       (append 
         (list 
           (cons 0 "LWPOLYLINE")
           (cons 100 "AcDbEntity")
           (cons 100 "AcDbPolyline")
           (cons 90 (length PtlSt))
           (cons 70 0)
         )
         (mapcar (function (lambda ( p ) (cons 10 p))) PtlSt)
       )
     )
     (sssetfirst nil (ssadd (entlast)))
   )
 )
 (princ)
)

 

Edited March 29, 2023 by marko_ribar
changed AT:getvertices with supplied LM:Unique

[marko_ribar]

After I analyzed pBe's code, I discovered that original AT:Getvertices subfunction here isn't applicable like it was - if picked for start point the same point as start point of first polygon, plpath.lsp will draw polyline from next vertex, but not start... So I removed duplicate start-end point in AT:Getvertices, and _Rebuild subfunction from plpath.lsp should return correct list of points... Also corrected one more localized variable in _FindNext subfunction - variable h was sufficient...

 

Can someone confirm bug that occurs on A2012 with mine lisp 2pl-pl.lsp posted above, or it's my comp. that has this bug...?

 

Regards, M.R.

[pBe]

Can someone confirm bug that occurs on A2012 with mine lisp 2pl-pl.lsp posted above, or it's my comp. that has this bug...?

 

I didn't really go into details on this routine Marko . If it is indeed flawed what is your solution then?. To be honest, can't remember what the routine is for

[marko_ribar]

pBe - look at the picture posted at first OP request... Please, inform me for 2pl-pl.lsp on A2012 and versions above - is it working without skipping vertices...

 

In addition, I've modified your code further more to accept arcs - so polygon can be real closed LWPOLYLINE...

Test it also, as I only briefly tested...

 

(defun c:PlPath ( / AssocOn LM:ListClockwise-p LM:Unique AT:GetVertices MR:GetBulge _intl prelst suflst _Buildlist
                   sp ep ss opt i pl pll a b bb ab lst lstab Pls PtlSt PtBulg PttBulg )

 (vl-load-com)

 (defun AssocOn ( SearchTerm Lst func fuzz )
   (car
     (vl-member-if
       (function
         (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
       )
       lst
     )
   )
 )
 
 (defun LM:ListClockwise-p ( lst )
   (minusp 
     (apply '+ 
       (mapcar
         (function
           (lambda ( a b )
             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
           )
         ) lst (cons (last lst) lst)
       )
     )
   )
 )

 (defun LM:Unique ( lst )
   (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
 )

 (defun AT:GetVertices ( e / p l )
   ;; Alan J. Thompson, 09.30.10
   (LM:Unique
     (if e
       (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
         (repeat (setq p (1+ (fix p)))
           (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
         )
         (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
       )
     )
   )
 )

 (defun MR:GetBulge ( e / o p l )
   (cond ( (eq (type e) 'ENAME) 
           (setq o (vlax-ename->vla-object e)) )
         ( (eq (type e) 'VLA-OBJECT) 
           (setq o e) )
   )
   (if e
     (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
       (repeat (fix p)
         (setq l (cons (vla-getbulge o (setq p (1- p))) l))
       )
     )
   )
 )

 (defun _intl (l1 l2 / ll1 ll2 a ls1 ls2)
   (setq ll1 l1
         ll2 l2
   )
   (while
     (setq a (car ll2))
     (while ll1
       (if (equal a (car ll1) 1e-6)
         (setq ls1 (append ls1 (list a))
               ll1 (cdr ll1)
         )
         (setq ll1 (cdr ll1))
       )
     )
     (setq ll2 (cdr ll2)
           ll1 (vl-remove a l1)
     )
   )
   (setq ll1 l1
         ll2 l2
   )
   (while
     (setq a (car ll1))
     (while ll2
       (if (equal a (car ll2) 1e-6)
         (setq ls2 (append ls2 (list a))
               ll2 (cdr ll2)
         )
         (setq ll2 (cdr ll2))
       )
     )
     (setq ll1 (cdr ll1)
           ll2 (vl-remove a l2)
     )
   )
   (if (< (length ls1) (length ls2)) ls1 ls2)
 )

 (defun prelst ( lst el / f )
    (vl-remove-if '(lambda ( a ) (or f (setq f (equal a el 1e-6)))) lst)
 )

 (defun suflst ( lst el )
   (cdr (vl-member-if '(lambda ( a ) (equal a el 1e-6)) lst))
 )
 
 (defun _Buildlist ( sp lst )
   (append (list sp) (suflst lst sp) (prelst lst sp))
 )
 
     (setq sp (getpoint "\nSelect Start Point:"))
     (setq ep (getpoint sp "\nSelect End Point:"))
     (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1) (410 . "MODEL"))))
     (progn
       (initget 1 "T B")
       (setq opt (getkword "\nSelect option [Top/Bottom]: "))
     )
     (setq pl (car (nentselp sp)))
     (while (>= (sslength ss) 1)
       (setq a (AT:GetVertices pl))
       (setq b (MR:GetBulge pl))
       (if (eq opt "T") 
         (if (LM:ListClockwise-p a)
           (setq ab (mapcar '(lambda (x y) (cons x y)) a b))
           (setq a (reverse a) b (reverse (mapcar '(lambda (x) (* (- 1.0) x)) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar '(lambda (x y) (cons x y)) a b))
         )
         (if (LM:ListClockwise-p a)
           (setq a (reverse a) b (reverse (mapcar '(lambda (x) (* (- 1.0) x)) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar '(lambda (x y) (cons x y)) a b)) 
           (setq ab (mapcar '(lambda (x y) (cons x y)) a b))
         )
       )    
       (setq lst (cons a lst) lstab (cons ab lstab))
       (ssdel pl ss)
       (repeat (setq i (sslength ss))
         (setq ent (ssname ss (setq i (1- i))))
         (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith (vlax-ename->vla-object pl) (vlax-ename->vla-object ent) AcExtendNone)))))))
           (setq pll ent)
         )
       )
       (if pll (setq pl pll))
     )
     (setq i -1)
     (setq lst (reverse lst) lstab (reverse lstab))
     (while (< (setq i (1+ i)) (length lst))
       (setq Pls (_Buildlist sp (nth i lst)))
       (if (nth (1+ i) lst)
         (setq sp (car (_intl Pls (nth (1+ i) lst))))
         (setq sp ep)
       )
       (setq Pls (prelst Pls sp))
       (setq PtlSt (append PtlSt Pls))
     )
     (setq PtlSt (append PtlSt (list ep)))
     (foreach pt PtlSt
       (if (assoc ep (car lstab))
         (setq PtBulg (cons (cdr (assocon pt (reverse (apply 'append (reverse lstab))) 'car 1e-6)) PtBulg))
         (setq PtBulg (cons (cdr (assocon pt (reverse (apply 'append lstab)) 'car 1e-6)) PtBulg))
       )
     )
     (mapcar '(lambda (x) (if (equal x nil) (setq PttBulg (cons 0.0 PttBulg)) (setq PttBulg (cons x PttBulg)))) PtBulg)
     (entmakex 
       (append 
         (list 
           (cons 0 "LWPOLYLINE")
           (cons 100 "AcDbEntity")
           (cons 100 "AcDbPolyline")
           (cons 90 (length PtlSt))
           (cons 70 0)
         )
         (apply 'append (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) PtlSt PttBulg))
       )
     )
     (sssetfirst nil (ssadd (entlast)))
 (princ)
)

 

M.R.

Edited March 29, 2023 by marko_ribar
code updated with AssocOn subfunction

[marko_ribar]

In addition to my last code, I am posting this one that adds vertexes to selected polylines at all intersection points with all other objects... So these two can be combined to quickly get resulting PlPath... Just run this code firstly...

 

(vl-load-com)
(princ)

(defun c:plintav ( / intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz add_vtx
                    ss sspl i ent n ent1 ss-ent1 k ent2 intpts intptsall pl plpts restintpts par )

 (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
   (if (eq (type obj1) 'ENAME) (setq obj1 (vlax-ename->vla-object obj1)))
   (if (eq (type obj2) 'ENAME) (setq obj2 (vlax-ename->vla-object obj2)))
   (setq coords (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith obj1 obj2 AcExtendNone))))))
   (if (vl-catch-all-error-p coords)
     (setq ptlst nil)
     (repeat (/ (length coords) 3)
       (setq pt (list (car coords) (cadr coords) (caddr coords)))
       (setq ptlst (cons pt ptlst))
       (setq coords (cdddr coords))
     )
   )
   ptlst
 )  

 (defun LM:Unique ( lst )
   (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
 )

 (defun AT:GetVertices ( e / p l )
   (LM:Unique
     (if e
       (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
         (repeat (setq p (1+ (fix p)))
           (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
         )
         (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
       )
     )
   )
 )

 (defun _reml ( l1 l2 / a n ls )
   (while 
     (setq n nil 
           a (car l2)
     )
     (while (and l1 (null n))
       (if (equal a (car l1) 1e-6)
         (setq l1 (cdr l1) 
               n t
         )
         (setq ls (append ls (list (car l1)))
               l1 (cdr l1)
         )
       )
     )
     (setq l2 (cdr l2))
   )
   (append ls l1)
 )

 (defun member-fuzz ( expr lst fuzz )
   (while (and lst (not (equal (car lst) expr fuzz)))
     (setq lst (cdr lst))
   )
   lst
 )

 (defun add_vtx ( obj add_pt ent_name / bulg )
     (vla-addVertex
         obj
         (1+ (fix add_pt))
         (vlax-make-variant
             (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 1))
                     (list
                         (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                         (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                     )
             )
         )
     )
     (setq bulg (vla-GetBulge obj (fix add_pt)))
     (vla-SetBulge obj
         (fix add_pt)
         (/
             (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
             (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
         )
     )
     (vla-SetBulge obj
         (1+ (fix add_pt))
         (/
             (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
             (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
         )
     )
     (vla-update obj)
 )

 (setq ss (ssget "_:L" '((0 . "*LINE,RAY,ELLIPSE,CIRCLE,ARC"))))
 (setq sspl (ssadd))
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (if (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
     (ssadd ent sspl)
   )
 )
 (repeat (setq n (sslength ss))
   (setq ent1 (ssname ss (setq n (1- n))))
   (setq ss-ent1 (ssdel ent1 ss))
   (repeat (setq k (sslength ss-ent1))
     (setq ent2 (ssname ss-ent1 (setq k (1- k))))
     (setq intpts (intersobj1obj2 ent1 ent2))
     (setq intptsall (append intpts intptsall))
   )
 )
 (setq i -1)
 (while (setq pl (ssname sspl (setq i (1+ i))))
   (setq plpts (AT:GetVertices pl))
   (setq restintpts (_reml intptsall plpts))
   (foreach pt restintpts
     (if 
       (and
         (not (member-fuzz pt plpts 1e-6))
         (setq par (vlax-curve-getparamatpoint pl pt))
       )
       (add_vtx (vlax-ename->vla-object pl) par pl)        
     )
   )
 )
 (princ)
)

 

 

M.R.

Edited March 29, 2023 by marko_ribar

[marko_ribar]

In addition, I've modified your code further more to accept arcs - so polygon can be real closed LWPOLYLINE...

Test it also, as I only briefly tested...

 

Code changed further more. It had lacks, and even now if trying it in various cases - it may confuse bulges... If firstly created LWPOLYLINE through BPOLY command from multiple LWPOLYLINES than it should work well...

 

M.R.

[marko_ribar]

What is computer... The code was all correct only (assoc) function didn't work with fuzz factor because it doesn't have... So I implemented AssocOn subfunction with fuzz 1e-6 and now it should work perfect...

 

So check code here

 

Regards, M.R.

[marko_ribar]

Assuming that you have A2010 or above 2011, 2012, ...

 

And assuming that you applied c:plintav posted in my previous post, this should work and for opened LWPOLYLINES, just make sure path is possible (no gaps, or common intersection points - that are made with c:plintav)...

 

(defun c:PlPath ( / AssocOn LM:ListClockwise-p LM:Unique AT:GetVertices MR:GetBulge _intl prelst suflst _Buildlist
                   sp ep ss opt i pl pll a b bb ab lst lstab Pls PtlSt PtBulg PttBulg )

 (vl-load-com)

 (defun AssocOn ( SearchTerm Lst func fuzz )
   (car
     (vl-member-if
       (function
         (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
       )
       lst
     )
   )
 )
 
 (defun LM:ListClockwise-p ( lst )
   (minusp 
     (apply '+ 
       (mapcar
         (function
           (lambda ( a b )
             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
           )
         ) lst (cons (last lst) lst)
       )
     )
   )
 )

 (defun LM:Unique ( lst )
   (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
 )

 (defun AT:GetVertices ( e / p l )
   ;; Alan J. Thompson, 09.30.10
   (LM:Unique
     (if e
       (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
         (repeat (setq p (1+ (fix p)))
           (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
         )
         (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
       )
     )
   )
 )

 (defun MR:GetBulge ( e / o p l )
   (cond ( (eq (type e) 'ENAME) 
           (setq o (vlax-ename->vla-object e)) )
         ( (eq (type e) 'VLA-OBJECT) 
           (setq o e) )
   )
   (if e
     (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
       (repeat (fix p)
         (setq l (cons (vla-getbulge o (setq p (1- p))) l))
       )
     )
   )
 )

 (defun _intl (l1 l2 / ll1 ll2 a ls1 ls2)
   (setq ll1 l1
         ll2 l2
   )
   (while
     (setq a (car ll2))
     (while ll1
       (if (equal a (car ll1) 1e-6)
         (setq ls1 (append ls1 (list a))
               ll1 (cdr ll1)
         )
         (setq ll1 (cdr ll1))
       )
     )
     (setq ll2 (cdr ll2)
           ll1 (vl-remove a l1)
     )
   )
   (setq ll1 l1
         ll2 l2
   )
   (while
     (setq a (car ll1))
     (while ll2
       (if (equal a (car ll2) 1e-6)
         (setq ls2 (append ls2 (list a))
               ll2 (cdr ll2)
         )
         (setq ll2 (cdr ll2))
       )
     )
     (setq ll1 (cdr ll1)
           ll2 (vl-remove a l2)
     )
   )
   (if (< (length ls1) (length ls2)) ls1 ls2)
 )

 (defun prelst ( lst el / f )
    (vl-remove-if '(lambda ( a ) (or f (setq f (equal a el 1e-6)))) lst)
 )

 (defun suflst ( lst el )
   (cdr (vl-member-if '(lambda ( a ) (equal a el 1e-6)) lst))
 )
 
 (defun _Buildlist ( sp lst )
   (append (list sp) (suflst lst sp) (prelst lst sp))
 )
 
     (setq sp (getpoint "\nSelect Start Point:"))
     (setq ep (getpoint sp "\nSelect End Point:"))
     (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 0) (410 . "MODEL"))))
     (progn
       (initget 1 "T B")
       (setq opt (getkword "\nSelect option [Top/Bottom]: "))
     )
     (setq pl (car (nentselp sp)))
     (while (>= (sslength ss) 1)
       (if (eq opt "T")
         (if (not (LM:ListClockwise-p (AT:GetVertices pl)))
           (command "_.reverse" pl "")
         )
         (if (LM:ListClockwise-p (AT:GetVertices pl))
           (command "_.reverse" pl "")
         )
       )
       (setq a (AT:GetVertices pl))
       (setq b (MR:GetBulge pl))
       (if (eq opt "T") 
         (if (LM:ListClockwise-p a)
           (setq ab (mapcar '(lambda (x y) (cons x y)) a b))
           (setq a (reverse a) b (reverse (mapcar '(lambda (x) (* (- 1.0) x)) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar '(lambda (x y) (cons x y)) a b))
         )
         (if (LM:ListClockwise-p a)
           (setq a (reverse a) b (reverse (mapcar '(lambda (x) (* (- 1.0) x)) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar '(lambda (x y) (cons x y)) a b)) 
           (setq ab (mapcar '(lambda (x y) (cons x y)) a b))
         )
       )    
       (setq lst (cons a lst) lstab (cons ab lstab))
       (ssdel pl ss)
       (repeat (setq i (sslength ss))
         (setq ent (ssname ss (setq i (1- i))))
         (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith (vlax-ename->vla-object pl) (vlax-ename->vla-object ent) AcExtendNone)))))))
           (setq pll ent)
         )
       )
       (if pll (setq pl pll))
     )
     (setq i -1)
     (setq lst (reverse lst) lstab (reverse lstab))
     (while (< (setq i (1+ i)) (length lst))
       (setq Pls (_Buildlist sp (nth i lst)))
       (if (nth (1+ i) lst)
         (setq sp (car (_intl Pls (nth (1+ i) lst))))
         (setq sp ep)
       )
       (setq Pls (prelst Pls sp))
       (setq PtlSt (append PtlSt Pls))
     )
     (setq PtlSt (append PtlSt (list ep)))
     (foreach pt PtlSt
       (if (assoc ep (car lstab))
         (setq PtBulg (cons (cdr (assocon pt (reverse (apply 'append (reverse lstab))) 'car 1e-6)) PtBulg))
         (setq PtBulg (cons (cdr (assocon pt (reverse (apply 'append lstab)) 'car 1e-6)) PtBulg))
       )
     )
     (mapcar '(lambda (x) (if (equal x nil) (setq PttBulg (cons 0.0 PttBulg)) (setq PttBulg (cons x PttBulg)))) PtBulg)
     (entmakex 
       (append 
         (list 
           (cons 0 "LWPOLYLINE")
           (cons 100 "AcDbEntity")
           (cons 100 "AcDbPolyline")
           (cons 90 (length PtlSt))
           (cons 70 0)
         )
         (apply 'append (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) PtlSt PttBulg))
       )
     )
     (sssetfirst nil (ssadd (entlast)))
 (princ)
)

 

P.S. This is my best - I couldn't think of anything better than checking top/bottom option and perform REVERSE command on those plines that omit rule of the same CW or CCW direction...

 

M.R.

Edited March 29, 2023 by marko_ribar
code changed finally

[marko_ribar]

Code changed finally...

 

All the best M.R.

[marko_ribar]

Final version

(defun c:PlPath ( / rlw AssocOn LM:ListClockwise-p LM:Unique AT:GetVertices MR:GetBulge _intl prelst suflst _Buildlist
                   sp ep ss opt i pl pll a b bb ab lst lstab Pls PtlSt PtBulg PttBulg )

 (vl-load-com)

 (defun rlw (LW / E X1 X2 X3 X4 X5 X6)
   ;; by ElpanovEvgeniy
   ;; reverse lwpolyline
   (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
     (progn (foreach a1 e
              (cond ((= (car a1) 10) (setq x2 (cons a1 x2)))
                    ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)))
                    ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)))
                    ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)))
                    ((= (car a1) 210) (setq x6 (cons a1 x6)))
                    (t (setq x1 (cons a1 x1)))
              )
            )
            (entmod (append (reverse x1)
                            (append (apply (function append)
                                           (apply (function mapcar)
                                                  (cons 'list
                                                        (list x2
                                                              (cdr (reverse (cons (car x3) (reverse x3))))
                                                              (cdr (reverse (cons (car x4) (reverse x4))))
                                                              (cdr (reverse (cons (car x5) (reverse x5))))
                                                        )
                                                  )
                                           )
                                    )
                                    x6
                            )
                    )
            )
            (entupd lw)
     )
   )
 )
 
 (defun AssocOn ( SearchTerm Lst func fuzz )
   (car
     (vl-member-if
       (function
         (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))
       )
       lst
     )
   )
 )
 
 (defun LM:ListClockwise-p ( lst )
   (minusp 
     (apply '+ 
       (mapcar
         (function
           (lambda ( a b )
             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
           )
         ) lst (cons (last lst) lst)
       )
     )
   )
 )

 (defun LM:Unique ( lst )
   (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
 )

 (defun AT:GetVertices ( e / p l )
   ;; Alan J. Thompson, 09.30.10
   (LM:Unique
     (if e
       (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
         (repeat (setq p (1+ (fix p)))
           (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
         )
         (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
       )
     )
   )
 )

 (defun MR:GetBulge ( e / o p l )
   (cond ( (eq (type e) 'ENAME) 
           (setq o (vlax-ename->vla-object e)) )
         ( (eq (type e) 'VLA-OBJECT) 
           (setq o e) )
   )
   (if e
     (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
       (repeat (fix p)
         (setq l (cons (vla-getbulge o (setq p (1- p))) l))
       )
     )
   )
 )

 (defun _intl (l1 l2 / ll1 ll2 a ls1 ls2)
   (setq ll1 l1
         ll2 l2
   )
   (while
     (setq a (car ll2))
     (while ll1
       (if (equal a (car ll1) 1e-6)
         (setq ls1 (append ls1 (list a))
               ll1 (cdr ll1)
         )
         (setq ll1 (cdr ll1))
       )
     )
     (setq ll2 (cdr ll2)
           ll1 (vl-remove a l1)
     )
   )
   (setq ll1 l1
         ll2 l2
   )
   (while
     (setq a (car ll1))
     (while ll2
       (if (equal a (car ll2) 1e-6)
         (setq ls2 (append ls2 (list a))
               ll2 (cdr ll2)
         )
         (setq ll2 (cdr ll2))
       )
     )
     (setq ll1 (cdr ll1)
           ll2 (vl-remove a l2)
     )
   )
   (if (< (length ls1) (length ls2)) ls1 ls2)
 )

 (defun prelst ( lst el / f )
    (vl-remove-if '(lambda ( a ) (or f (setq f (equal a el 1e-6)))) lst)
 )

 (defun suflst ( lst el )
   (cdr (vl-member-if '(lambda ( a ) (equal a el 1e-6)) lst))
 )
 
 (defun _Buildlist ( sp lst )
   (append (list sp) (suflst lst sp) (prelst lst sp))
 )
 
     (setq sp (getpoint "\nSelect Start Point:"))
     (setq ep (getpoint sp "\nSelect End Point:"))
     (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 0) (410 . "MODEL"))))
     (progn
       (initget 1 "T B")
       (setq opt (getkword "\nSelect option [Top/Bottom]: "))
     )
     (setq pl (car (nentselp sp)))
     (while (>= (sslength ss) 1)
       (if (eq opt "T")
         (if (not (LM:ListClockwise-p (AT:GetVertices pl)))
           (rlw pl)
         )
         (if (LM:ListClockwise-p (AT:GetVertices pl))
           (rlw pl)
         )
       )
       (setq a (AT:GetVertices pl))
       (setq b (MR:GetBulge pl))
       (if (eq opt "T") 
         (if (LM:ListClockwise-p a)
           (setq ab (mapcar '(lambda (x y) (cons x y)) a b))
           (setq a (reverse a) b (reverse (mapcar '(lambda (x) (* (- 1.0) x)) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar '(lambda (x y) (cons x y)) a b))
         )
         (if (LM:ListClockwise-p a)
           (setq a (reverse a) b (reverse (mapcar '(lambda (x) (* (- 1.0) x)) b)) bb (cdr b) b (append bb (list (car b))) ab (mapcar '(lambda (x y) (cons x y)) a b)) 
           (setq ab (mapcar '(lambda (x y) (cons x y)) a b))
         )
       )    
       (setq lst (cons a lst) lstab (cons ab lstab))
       (ssdel pl ss)
       (repeat (setq i (sslength ss))
         (setq ent (ssname ss (setq i (1- i))))
         (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith (vlax-ename->vla-object pl) (vlax-ename->vla-object ent) AcExtendNone)))))))
           (setq pll ent)
         )
       )
       (if pll (setq pl pll))
     )
     (setq i -1)
     (setq lst (reverse lst) lstab (reverse lstab))
     (while (< (setq i (1+ i)) (length lst))
       (setq Pls (_Buildlist sp (nth i lst)))
       (if (nth (1+ i) lst)
         (setq sp (car (_intl Pls (nth (1+ i) lst))))
         (setq sp ep)
       )
       (setq Pls (prelst Pls sp))
       (setq PtlSt (append PtlSt Pls))
     )
     (setq PtlSt (append PtlSt (list ep)))
     (foreach pt PtlSt
       (if (assoc ep (car lstab))
         (setq PtBulg (cons (cdr (assocon pt (reverse (apply 'append (reverse lstab))) 'car 1e-6)) PtBulg))
         (setq PtBulg (cons (cdr (assocon pt (reverse (apply 'append lstab)) 'car 1e-6)) PtBulg))
       )
     )
     (mapcar '(lambda (x) (if (equal x nil) (setq PttBulg (cons 0.0 PttBulg)) (setq PttBulg (cons x PttBulg)))) PtBulg)
     (entmakex 
       (append 
         (list 
           (cons 0 "LWPOLYLINE")
           (cons 100 "AcDbEntity")
           (cons 100 "AcDbPolyline")
           (cons 90 (length PtlSt))
           (cons 70 0)
         )
         (apply 'append (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) PtlSt PttBulg))
       )
     )
     (sssetfirst nil (ssadd (entlast)))
 (princ)
)

 

Edited March 29, 2023 by marko_ribar

[Madruga_SP]

@marko_ribar

 

Excellent result. Congratulations!

 

I think OP will be really satisfied with the goal.