Jump to content
chvnprasad

Draw polyline along with 2 or more adjacent closed polylines

Recommended Posts

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

polygons.JPG

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
marko_ribar

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

 

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

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

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

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 by marko_ribar
code little changed

Share this post


Link to post
Share on other sites
chvnprasad

thnks, It is working fine for 2 polygons.

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

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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 :rofl:

 

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. :lol:

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. :)

Share this post


Link to post
Share on other sites
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)

Share this post


Link to post
Share on other sites
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. :lol:

 

But I'll try, no promises though :)

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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.

 

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

 ([color=BLUE]vl-load-com[/color])

 ([color=BLUE]defun[/color] LM:ListClockwise-p ( lst )
   ([color=BLUE]minusp[/color] 
     ([color=BLUE]apply[/color] '[color=BLUE]+[/color] 
       ([color=BLUE]mapcar[/color]
         ([color=BLUE]function[/color]
           ([color=BLUE]lambda[/color] ( a b )
             ([color=BLUE]-[/color] ([color=BLUE]*[/color] ([color=BLUE]car[/color] b) ([color=BLUE]cadr[/color] a)) ([color=BLUE]*[/color] ([color=BLUE]car[/color] a) ([color=BLUE]cadr[/color] b)))
           )
         ) lst ([color=BLUE]cons[/color] ([color=BLUE]last[/color] lst) lst)
       )
     )
   )
 )

 ([color=BLUE]defun[/color] LM:Unique ( lst )
   ([color=BLUE]if[/color] lst ([color=BLUE]cons[/color] ([color=BLUE]car[/color] lst) (LM:Unique ([color=BLUE]vl-remove[/color] ([color=BLUE]car[/color] lst) ([color=BLUE]cdr[/color] lst)))))
 )

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

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

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

 ([color=BLUE]defun[/color] _Rebuild ( v ls_ )
   ([color=BLUE]foreach[/color] s ([color=BLUE]cdr[/color] ([color=BLUE]member[/color] v ls_))
     ([color=BLUE]setq[/color] ls_ ([color=BLUE]vl-remove[/color] s ls_))
   )
   ls_
 )

 ([color=BLUE]defun[/color] _FindNext ( l1 l2 [color=BLUE]/[/color] f g )
   ([color=BLUE]while[/color]  
     ([color=BLUE]and[/color] 
       ([color=BLUE]setq[/color] f ([color=BLUE]car[/color] l1)) 
       ([color=BLUE]not[/color] g)
     )
     ([color=BLUE]if[/color] ([color=BLUE]not[/color] ([color=BLUE]setq[/color] g ([color=BLUE]car[/color] (_FindPoint f l2))))
       ([color=BLUE]setq[/color] l1 ([color=BLUE]cdr[/color] l1))
     )
   )
   ([color=BLUE]car[/color] g)
 )

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

Edited by marko_ribar
changed AT:getvertices with supplied LM:Unique

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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 :lol:

Share this post


Link to post
Share on other sites
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...

 

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

 ([color=BLUE]vl-load-com[/color])

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

 ([color=BLUE]defun[/color] LM:Unique ( lst )
   ([color=BLUE]if[/color] lst ([color=BLUE]cons[/color] ([color=BLUE]car[/color] lst) (LM:Unique ([color=BLUE]vl-remove[/color] ([color=BLUE]car[/color] lst) ([color=BLUE]cdr[/color] lst)))))
 )

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

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

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

 ([color=BLUE]defun[/color] [color=BLUE]prelst[/color] ( lst el [color=BLUE]/[/color] f )
    ([color=BLUE]vl-remove-if[/color] '([color=BLUE]lambda[/color] ( a ) ([color=BLUE]or[/color] f ([color=BLUE]setq[/color] f ([color=BLUE]equal[/color] a el 1e-))) lst)
 )

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

M.R.

Edited by marko_ribar
code updated with AssocOn subfunction

Share this post


Link to post
Share on other sites
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...

 

([color=BLUE]vl-load-com[/color])
([color=BLUE]princ[/color])

([color=BLUE]defun[/color] [color=BLUE]c:plintav[/color] ( [color=BLUE]/[/color] 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 )

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

 ([color=BLUE]defun[/color] LM:Unique ( lst )
   ([color=BLUE]if[/color] lst ([color=BLUE]cons[/color] ([color=BLUE]car[/color] lst) (LM:Unique ([color=BLUE]vl-remove[/color] ([color=BLUE]car[/color] lst) ([color=BLUE]cdr[/color] lst)))))
 )

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

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

 ([color=BLUE]defun[/color] member-fuzz ( expr lst fuzz )
   ([color=BLUE]while[/color] ([color=BLUE]and[/color] lst ([color=BLUE]not[/color] ([color=BLUE]equal[/color] ([color=BLUE]car[/color] lst) expr fuzz)))
     ([color=BLUE]setq[/color] lst ([color=BLUE]cdr[/color] lst))
   )
   lst
 )

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

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

 

M.R.

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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)...

 

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

 ([color=BLUE]vl-load-com[/color])

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

 ([color=BLUE]defun[/color] LM:Unique ( lst )
   ([color=BLUE]if[/color] lst ([color=BLUE]cons[/color] ([color=BLUE]car[/color] lst) (LM:Unique ([color=BLUE]vl-remove[/color] ([color=BLUE]car[/color] lst) ([color=BLUE]cdr[/color] lst)))))
 )

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

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

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

 ([color=BLUE]defun[/color] [color=BLUE]prelst[/color] ( lst el [color=BLUE]/[/color] f )
    ([color=BLUE]vl-remove-if[/color] '([color=BLUE]lambda[/color] ( a ) ([color=BLUE]or[/color] f ([color=BLUE]setq[/color] f ([color=BLUE]equal[/color] a el 1e-))) lst)
 )

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

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 by marko_ribar
code changed finally

Share this post


Link to post
Share on other sites
marko_ribar

Code changed finally...

 

All the best M.R.

Share this post


Link to post
Share on other sites
marko_ribar

Final version

([color=BLUE]defun[/color] [color=BLUE]c:PlPath[/color] ( [color=BLUE]/[/color] 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 )

 ([color=BLUE]vl-load-com[/color])

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

 ([color=BLUE]defun[/color] LM:Unique ( lst )
   ([color=BLUE]if[/color] lst ([color=BLUE]cons[/color] ([color=BLUE]car[/color] lst) (LM:Unique ([color=BLUE]vl-remove[/color] ([color=BLUE]car[/color] lst) ([color=BLUE]cdr[/color] lst)))))
 )

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

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

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

 ([color=BLUE]defun[/color] prelst ( lst el [color=BLUE]/[/color] f )
    ([color=BLUE]vl-remove-if[/color] '([color=BLUE]lambda[/color] ( a ) ([color=BLUE]or[/color] f ([color=BLUE]setq[/color] f ([color=BLUE]equal[/color] a el 1e-))) lst)
 )

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

Share this post


Link to post
Share on other sites
Madruga_SP

@marko_ribar

 

Excellent result. Congratulations!

 

I think OP will be really satisfied with the goal.

 

:thumbsup:

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


×
×
  • Create New...