Topic: split closed LWPOLY

[ribarm]

I know this is now old topic, but in addition to this issue, I've realized that there may be more general solution not only with orthogonal polygons, but with any type of polygonal LWPOLYLINE... So I am posting here my latest code in order to help if someone find it useful... Note, sometimes it may work correctly, but sometimes with too complex polyline it may fail to convert to split polylines... Also, you need to have loaded plintav.lsp from PLINETOOLS posted here... Also worth of mention is this topic with Evgeniy's code for quadrilaterals...
http://www.theswamp.org/index.php?topic=44590.msg498376#msg498376

Code - Auto/Visual Lisp: [Select]

1. (defun c:splitcllw-boundaryextensions ( / *error* unique colinear-p vk_IsPointInside add_vtx purge-pline BulgeData tan ms *adoc* tot cmd pea qaf reg ent tmp big ss pl i li vtxlst ptlstn lilst linlst linlstt plinlst livlalst p plst pplst )
2.  
3.   (defun *error* ( msg )
4.     (if cmd (setvar 'cmdecho cmd))
5.     (if pea (setvar 'peditaccept pea))
6.     (if qaf (setvar 'qaflags qaf))
7.     (vla-endundomark *adoc*)
8.     (if msg (prompt msg))
9.     (princ)
10.   )
11.  
12.   (defun unique ( l )
13.     (if l (cons (car l) (vl-remove-if '(lambda ( x ) (equal (car l) x 1e-6)) (unique (cdr l)))))
14.   )
15.  
16.   (defun colinear-p ( p1 p2 p3 )
17.     (equal (+ (distance p1 p2) (distance p2 p3)) (distance p1 p3) 1e-6)
18.   )
19.  
20.   (defun vk_IsPointInside ( Point PointsList / PY P1Y P2Y )
21.   ; works with polygons only, i.e. if (equal (car PointsList) (last PointsList))
22.     (if (cdr PointsList)
23.       (/=       (and (or (and (<= (setq PY  (cadr Point)
24.                                   P2Y (cadadr PointsList)
25.                                   P1Y (cadar PointsList)
26.                             )
27.                             PY
28.                         )
29.                         (< PY P2Y)
30.                     )
31.                     (and (> P1Y PY) (>= PY P2Y))
32.                 )
33.                 (> (car Point)
34.                     (+ (* (/ (- PY P1Y) (- P2Y P1Y))
35.                           (- (caadr PointsList) (caar PointsList))
36.                        )
37.                        (caar PointsList)
38.                     )
39.                 )
40.           )
41.           (vk_IsPointInside Point (cdr PointsList))
42.       )
43.     )
44.   )
45.  
46.   (defun add_vtx ( obj add_pt ent_name / bulg sw ew )
47.       (vla-GetWidth obj (fix add_pt) 'sw 'ew)
48.       (vla-addVertex
49.           obj
50.           (1+ (fix add_pt))
51.           (vlax-make-variant
52.               (vlax-safearray-fill
53.                   (vlax-make-safearray vlax-vbdouble (cons 0 1))
54.                       (list
55.                           (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
56.                           (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
57.                       )
58.               )
59.           )
60.       )
61.       (setq bulg (vla-GetBulge obj (fix add_pt)))
62.       (vla-SetBulge obj
63.           (fix add_pt)
64.           (/
65.               (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
66.               (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
67.           )
68.       )
69.       (vla-SetBulge obj
70.           (1+ (fix add_pt))
71.           (/
72.               (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
73.               (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
74.           )
75.       )
76.       (vla-SetWidth obj (fix add_pt) sw (+ sw (* (- ew sw) (- add_pt (fix add_pt)))))
77.       (vla-SetWidth obj (1+ (fix add_pt)) (+ sw (* (- ew sw) (- add_pt (fix add_pt)))) ew)
78.       (vla-update obj)
79.   )
80.  
81.   ;; Purge-Pline (gile) 2007/11/25
82.   ;;
83.   ;; Removes all superfluous vertex (overwritten, colinear or concentric)
84.   ;; Keeps arcs and widths
85.   ;; Keeps aligne vertices which show a width break
86.   ;; Closes pline which start point and end point are overwritten
87.  
88.   (defun purge-pline (pl        /         regular-width       colinear
89.                       concentric          del-cadr  pour-car  elst
90.                       closed    old-p     old-b     old-sw    old-ew
91.                       new-d     new-p     new-b     new-sw    new-ew
92.                       b1        b2
93.                      )
94.  
95.     ;; Evaluates if the pline width is regular on 3 successive points
96.     (defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta)
97.       (or (= ws1 we1 ws2 we2)
98.           (and (= we1 ws2)
99.                (/= 0 (setq delta (- we2 ws1)))
100.                (equal (/ (- (vlax-curve-getDistAtPoint pl (trans p2 pl 0))
101.                             (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
102.                          )
103.                          (- (vlax-curve-getDistAtPoint pl (trans p3 pl 0))
104.                             (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
105.                          )
106.                       )
107.                       (/ (- we1 (- we2 delta)) delta)
108.                       1e-9
109.                )
110.           )
111.       )
112.     )
113.  
114.     ;; Evaluates if 3 successive vertices are aligned
115.     (defun colinear (p1 p2 p3 b1 b2)
116.       (and (zerop b1)
117.            (zerop b2)
118.            (null (inters p1 p2 p1 p3)
119.            )
120.       )
121.     )
122.  
123.     ;; Evaluates if 3 sucessive vertices have the same center
124.     (defun concentric (p1 p2 p3 b1 b2 / bd1 bd2)
125.       (if
126.         (and (/= 0.0 b1)
127.              (/= 0.0 b2)
128.              (equal
129.                (caddr (setq bd1 (BulgeData b1 p1 p2)))
130.                (caddr (setq bd2 (BulgeData b2 p2 p3)))
131.                1e-9
132.              )
133.         )
134.          (tan (/ (+ (car bd1) (car bd2)) 4.0))
135.       )
136.     )
137.  
138.     ;; Removes the second item of the list
139.     (defun del-cadr (lst)
140.       (set lst (cons (car (eval lst)) (cddr (eval lst))))
141.     )
142.  
143.     ;; Pours the first item of a list to another one
144.     (defun pour-car (from to)
145.       (set to (cons (car (eval from)) (eval to)))
146.       (set from (cdr (eval from)))
147.     )
148.  
149.  
150.     (setq elst (entget pl))
151.     (and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T))
152.     (mapcar (function (lambda (x)
153.                         (cond
154.                           ((= (car x) 10) (setq old-p (cons x old-p)))
155.                           ((= (car x) 40) (setq old-sw (cons x old-sw)))
156.                           ((= (car x) 41) (setq old-ew (cons x old-ew)))
157.                           ((= (car x) 42) (setq old-b (cons x old-b)))
158.                           (T (setq new-d (cons x new-d)))
159.                         )
160.                       )
161.             )
162.             elst
163.     )
164.     (mapcar (function (lambda (l)
165.                         (set l (reverse (eval l)))
166.                       )
167.             )
168.             '(old-p old-sw old-ew old-b new-d)
169.     )
170.     (and closed (setq old-p (append old-p (list (car old-p)))))
171.     (and (equal (cdar old-p) (cdr (last old-p)) 1e-9)
172.          (setq closed T
173.                new-d  (subst (cons 70 (Boole 7 (cdr (assoc 70 new-d)) 1))
174.                              (assoc 70 new-d)
175.                              new-d
176.                       )
177.          )
178.     )
179.     (while (cddr old-p)
180.       (if (regular-width
181.             (cdar old-p)
182.             (cdadr old-p)
183.             (cdaddr old-p)
184.             (cdar old-sw)
185.             (cdar old-ew)
186.             (cdadr old-sw)
187.             (cdadr old-ew)
188.           )
189.         (cond
190.           ((colinear (cdar old-p)
191.                      (cdadr old-p)
192.                      (cdaddr old-p)
193.                      (cdar old-b)
194.                      (cdadr old-b)
195.            )
196.            (mapcar 'del-cadr '(old-p old-sw old-ew old-b))
197.           )
198.           ((setq bu (concentric
199.                       (cdar old-p)
200.                       (cdadr old-p)
201.                       (cdaddr old-p)
202.                       (cdar old-b)
203.                       (cdadr old-b)
204.                     )
205.            )
206.            (setq old-b (cons (cons 42 bu) (cddr old-b)))
207.            (mapcar 'del-cadr '(old-p old-sw old-ew))
208.           )
209.           (T
210.            (mapcar 'pour-car
211.                    '(old-p old-sw old-ew old-b)
212.                    '(new-p new-sw new-ew new-b)
213.            )
214.           )
215.         )
216.         (mapcar 'pour-car
217.                 '(old-p old-sw old-ew old-b)
218.                 '(new-p new-sw new-ew new-b)
219.         )
220.       )
221.     )
222.     (if closed
223.       (setq new-p (reverse (cons (car old-p) new-p)))
224.       (setq new-p (append (reverse new-p) old-p))
225.     )
226.     (mapcar
227.       (function
228.         (lambda (new old)
229.           (set new (append (reverse (eval new)) (eval old)))
230.         )
231.       )
232.       '(new-sw new-ew new-b)
233.       '(old-sw old-ew old-b)
234.     )
235.     (if (and closed
236.              (regular-width
237.                (cdr (last new-p))
238.                (cdar new-p)
239.                (cdadr new-p)
240.                (cdr (last new-sw))
241.                (cdr (last new-ew))
242.                (cdar new-sw)
243.                (cdar new-ew)
244.              )
245.         )
246.       (cond
247.         ((colinear (cdr (last new-p))
248.                    (cdar new-p)
249.                    (cdadr new-p)
250.                    (cdr (last new-b))
251.                    (cdar new-b)
252.          )
253.          (mapcar (function (lambda (l)
254.                              (set l (cdr (eval l)))
255.                            )
256.                  )
257.                  '(new-p new-sw new-ew new-b)
258.          )
259.         )
260.         ((setq bu (concentric
261.                     (cdr (last new-p))
262.                     (cdar new-p)
263.                     (cdadr new-p)
264.                     (cdr (last new-b))
265.                     (cdar new-b)
266.                   )
267.          )
268.          (setq new-b
269.                 (cdr (reverse (cons (cons 42 bu) (cdr (reverse new-b)))))
270.          )
271.          (mapcar (function (lambda (l)
272.                              (set l (cdr (eval l)))
273.                            )
274.                  )
275.                  '(new-p new-sw new-ew)
276.          )
277.         )
278.       )
279.     )
280.     (entmod
281.       (append new-d
282.               (apply 'append
283.                      (apply 'mapcar
284.                             (cons 'list (list new-p new-sw new-ew new-b))
285.                      )
286.               )
287.       )
288.     )
289.   )
290.  
291.   ;; BulgeData Retourne les données d'un polyarc (angle rayon centre)
292.  
293.   (defun BulgeData (bu p1 p2 / ang rad cen)
294.     (setq ang (* 2 (atan bu))
295.           rad (/ (distance p1 p2)
296.                  (* 2 (sin ang))
297.               )
298.           cen (polar p1
299.                      (+ (angle p1 p2) (- (/ pi 2) ang))
300.                      rad
301.               )
302.     )
303.     (list (* ang 2.0) rad cen)
304.   )
305.  
306.   ;; TAN Retourne la tangente de l'angle
307.  
308.   (defun tan (ang)
309.     (/ (sin ang) (cos ang))
310.   )
311.  
312.   (vl-load-com)
313.   (setq ms (vla-get-block (vla-get-activelayout (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))))
314.  
315.   (vla-startundomark *adoc*)
316.   (prompt "\nPick closed polygonal LWPOLYLINE...")
317.   (setq ss (ssget "_+.:E:S:L" (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 1) '(70 . 129) '(-4 . "or>"))))
318.   (while (not ss)
319.     (prompt "\nEmpty sel.set... Pick closed polygonal LWPOLYLINE again...")
320.     (setq ss (ssget "_+.:E:S:L" (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 1) '(70 . 129) '(-4 . "or>"))))
321.   )
322.   (setq pl (ssname ss 0))
323.   (setq vtxlst (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (eq (car x) 10)) (entget pl))))
324.   (setq lilst (mapcar '(lambda ( a b ) (list a b)) (cons (last vtxlst) vtxlst) vtxlst))
325.   (setq ptlstn (reverse (cons (car vtxlst) (reverse vtxlst))))
326.   (foreach li1 lilst
327.     (foreach li2 (vl-remove li1 lilst)
328.       (if (setq p (inters (car li1) (cadr li1) (car li2) (cadr li2) nil))
329.         (setq plst (cons p plst))
330.       )
331.     )
332.   )
333.   (setq plst (unique plst))
334.   (foreach p plst
335.     (if (and (vlax-curve-getparamatpoint pl p) (not (equal (fix (+ (vlax-curve-getparamatpoint pl p) 0.01)) (vlax-curve-getparamatpoint pl p) 1e-6)))
336.       (setq pplst (cons p pplst))
337.     )
338.   )
339.   (setq pplst (unique pplst))
340.   (foreach p pplst
341.     (add_vtx (vlax-ename->vla-object pl) (vlax-curve-getparamatpoint pl (vlax-curve-getclosestpointto pl p)) pl)
342.   )
343.   (foreach p pplst
344.     (foreach li lilst
345.       (cond
346.         ( (colinear-p (car li) (cadr li) p)
347.           (entmake (list '(0 . "LINE") (cons 10 (cadr li)) (cons 11 p)))
348.           (if (or (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) 0.01) ptlstn))
349.                   (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)) ptlstn))
350.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) 0.01))
351.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)))
352.               )
353.             (entdel (entlast))
354.             (setq linlst (cons (entlast) linlst))
355.           )
356.         )
357.         ( (colinear-p (cadr li) (car li) p)
358.           (entmake (list '(0 . "LINE") (cons 10 (car li)) (cons 11 p)))
359.           (if (or (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) 0.01) ptlstn))
360.                   (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)) ptlstn))
361.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) 0.01))
362.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)))
363.               )
364.             (entdel (entlast))
365.             (setq linlst (cons (entlast) linlst))
366.           )
367.         )
368.         ( (colinear-p p (car li) (cadr li))
369.           (entmake (list '(0 . "LINE") (cons 10 p) (cons 11 (car li))))
370.           (if (or (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) 0.01) ptlstn))
371.                   (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)) ptlstn))
372.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) 0.01))
373.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)))
374.               )
375.             (entdel (entlast))
376.             (setq linlst (cons (entlast) linlst))
377.           )
378.         )
379.         ( (colinear-p p (cadr li) (car li))
380.           (entmake (list '(0 . "LINE") (cons 10 p) (cons 11 (cadr li))))
381.           (if (or (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) 0.01) ptlstn))
382.                   (not (vk_IsPointInside (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)) ptlstn))
383.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) 0.01))
384.                   (vlax-curve-getparamatpoint pl (vlax-curve-getpointatparam (entlast) (- (vlax-curve-getendparam (entlast)) 0.01)))
385.               )
386.             (entdel (entlast))
387.             (setq linlst (cons (entlast) linlst))
388.           )
389.         )
390.       )
391.     )
392.   )
393.   (setq tot 0.0)
394.   (setq cmd (getvar 'cmdecho))
395.   (setq pea (getvar 'peditaccept))
396.   (setq qaf (getvar 'qaflags))
397.   (setvar 'cmdecho 0)
398.   (setvar 'peditaccept 1)
399.   (setvar 'qaflags 1)
400.   (command "_.EXPLODE" pl)
401.   (while (> (getvar 'cmdactive) 0) (command ""))
402.   (setq ss (ssget "_P"))
403.   (repeat (setq i (sslength ss))
404.     (setq li (ssname ss (setq i (1- i))))
405.     (setq linlstt (cons li linlstt))
406.   )
407.   (foreach lin linlst
408.     (command "_.PEDIT" lin "")
409.     (while (> (getvar 'cmdactive) 0) (command ""))
410.     (setq plinlst (cons (entlast) plinlst))
411.   )
412.   (setq ss (ssadd))
413.   (foreach pll plinlst
414.     (ssadd pll ss)
415.   )
416.   (if plinlst
417.     (progn
418.       (sssetfirst nil ss)
419.       (c:plintav)
420.       (command "_.EXPLODE" ss)
421.       (while (> (getvar 'cmdactive) 0) (command ""))
422.       (setq ss (ssget "_P"))
423.       (repeat (setq i (sslength ss))
424.         (setq li (ssname ss (setq i (1- i))))
425.         (setq linlstt (cons li linlstt))
426.       )
427.     )
428.   )
429.   (foreach li linlstt
430.     (setq livlalst (cons (vlax-ename->vla-object li) livlalst))
431.   )
432.   (setq reg (vlax-invoke ms 'AddRegion livlalst))
433.   (setq ss (ssadd))
434.   (foreach r reg
435.     (setq ent (entlast))
436.     (command "_.pedit" "_m")
437.     (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke r 'explode)))
438.     (command "" "_j" "" "")
439.     (if
440.       (and
441.         (not (eq ent (setq ent (entlast))))
442.         (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
443.       )
444.       (progn
445.         (setq tmp (vlax-curve-getarea ent)
446.               tot (+ tot tmp)
447.         )
448.         (if (< (car big) tmp)
449.           (setq big (list tmp ent))
450.         )
451.         (ssadd ent ss)
452.       )
453.     )
454.     (vla-delete r)
455.   )
456.   (if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
457.     (progn
458.       (ssdel (cadr big) ss)
459.       (entdel (cadr big))
460.     )
461.   )
462.   (foreach obj livlalst (vla-delete obj))
463.   (foreach pl (mapcar 'cadr (ssnamex ss))
464.     (purge-pline pl)
465.   )
466.   (*error* nil)
467. )
468.  

Regards and hope you're all feeling good...
M.R.

[ribarm]

This is correct version... Should work in all kind of situations with LWPOLY in WCS... Test it, please, maybe I missed something...

See attachment - couldn't post in code tags as lisp is bigger now...

Regards, M.R.

[ribarm]

splitcllw-boundaryextensions.lsp updated... Now it uses plintav-new.lsp from PLINETOOLS from link posted above... Tell me if now something's wrong...

M.R.

[DuanJinHui]

splitcllw-boundaryextensions.lsp updated... Now it uses plintav-new.lsp from PLINETOOLS from link posted above... Tell me if now something's wrong...

M.R.

I test with  " split closed LWPOLY.dwg " 
only Leemac's code successful .

splitcllw-boundaryextensions-old.lsp + plintav-new.lsp  unsuccessful.
splitcllw-boundaryextensions.lsp  + plintav.lsp unsuccessful too.
I test with windows xp sp3 + autocad2007 and autocad 2010.

[ribarm]

Hi, have you tried splitcllw-boundaryextensions.lsp & plintav-new.lsp ? It worked well in the time routine was written with my tests... Make sure Lwpoly dont have bulges and that edges are concave (not convex)...

[DuanJinHui]

Hi, have you tried splitcllw-boundaryextensions.lsp & plintav-new.lsp ? It worked well in the time routine was written with my tests... Make sure Lwpoly dont have bulges and that edges are concave (not convex)...

hello ribarm
use "splitcllw-boundaryextensions.lsp" + "plintav-new.lsp"  ,need alittle modify ,

(if plinlst
    (progn
      (sssetfirst nil ss)
      (c:plintav)--->change to (c:plintav-new)
      (command "_.EXPLODE" ss)
      ....
      ....


I test with your drawing at #1

Code: [Select]

Select objects:
24 found
bad argument type: 2D/3D point: nil


[ribarm]

Hi, according to your picture, routine did the job for what was written... I dont know why it throwed an error and I dont know what do you want to achieve... Try debugging an error... I dont have currently PC and I am typing this from my phone so I cant help you much more... If in routine was written (c:plintav), then I suppose it may work as well and without plintav-new... If you want instead to get splitting of lwpoly shown at right of picture, you should use code posted at prevoius page (splitcllw)... I hope you can manage to accomplish desired task with yor knowledge... If something is struggling you, just ask... I think you will get desired answer as well good and without my help... Kind regards, M.R.

[DuanJinHui]

Hi, according to your picture, routine did the job for what was written... I dont know why it throwed an error and I dont know what do you want to achieve... Try debugging an error... I dont have currently PC and I am typing this from my phone so I cant help you much more... If in routine was written (c:plintav), then I suppose it may work as well and without plintav-new... If you want instead to get splitting of lwpoly shown at right of picture, you should use code posted at prevoius page (splitcllw)... I hope you can manage to accomplish desired task with yor knowledge... If something is struggling you, just ask... I think you will get desired answer as well good and without my help... Kind regards, M.R.

Hi ribarm.
last break souce at:
(car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))

[cjw]

Maybe this way:

[DuanJinHui]

Maybe this way:

can't understand.