Author Topic: How do you simplify a LWPolyline vertex?  (Read 33349 times)

0 Members and 1 Guest are viewing this topic.

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: How do you simplify a LWPolyline vertex?
« Reply #60 on: November 24, 2007, 12:05:21 PM »
I am removing the one I posted ...

Please stop doing that already!
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.comhttp://cadanalyst.slack.comhttp://linkedin.com/in/cadanalyst

gile

  • Water Moccasin
  • Posts: 2275
  • Marseille, France
Re: How do you simplify a LWPolyline vertex?
« Reply #61 on: November 25, 2007, 10:52:45 AM »
Hi,

Here's my contribution, I tried to reply to the last request about the first vertex of a closed pline.

It seems to have the same behavior as Alan's one expcted :

- it removes aligned vertex which turn back on the pline traject (see the picture on reply #31 PPL behavior)

- it keeps the vertex which mark a break in width regularity (see the picture on reply #15)

Code: [Select]
;; Purge-Pline (gile) 2007/11/25
;;
;; Removes all superfluous vertex (overwritten, colinear or concentric)
;; Keeps arcs and widths
;; Keeps aligne vertices which show a width break
;; Closes pline which start point and end point are overwritten

(defun purge-pline (pl       / regular-width     colinear  concentric
    del-cadr  pour-car elst   closed    old-p     old-b
    old-sw    old-ew new-d   new-p     new-b     new-sw
    new-ew    b1 b2
   )

  ;; Evaluates if the pline width is regular on 3 successive points
  (defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta)
    (or (= ws1 we1 ws2 we2)
(and (= we1 ws2)
     (/= 0 (setq delta (- we2 ws1)))
     (equal (/ (- (vlax-curve-getDistAtPoint pl (trans p2 pl 0))
  (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
       )
       (- (vlax-curve-getDistAtPoint pl (trans p3 pl 0))
  (vlax-curve-getDistAtPoint pl (trans p1 pl 0))
       )
    )
    (/ (- we1 (- we2 delta)) delta)
    1e-9
     )
)
    )
  )

  ;; Evaluates if 3 successive vertices are aligned
  (defun colinear (p1 p2 p3 b1 b2)
    (and (zerop b1)
(zerop b2)
(null (inters p1 p2 p1 p3)
)
    )
  )

  ;; Evaluates if 3 sucessive vertices have the same center
  (defun concentric (p1 p2 p3 b1 b2 / bd1 bd2)
    (if
      (and (/= 0.0 b1)
   (/= 0.0 b2)
   (equal
     (caddr (setq bd1 (BulgeData b1 p1 p2)))
     (caddr (setq bd2 (BulgeData b2 p2 p3)))
     1e-9
   )
      )
       (tan (/ (+ (car bd1) (car bd2)) 4.0))
    )
  )

  ;; Removes the second item of the list
  (defun del-cadr (lst)
    (set lst (cons (car (eval lst)) (cddr (eval lst))))
  )

  ;; Pours the first item of a list to another one
  (defun pour-car (from to)
    (set to (cons (car (eval from)) (eval to)))
    (set from (cdr (eval from)))
  )


  (setq elst (entget pl))
  (and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T))
  (mapcar (function (lambda (x)
      (cond
((= (car x) 10) (setq old-p (cons x old-p)))
((= (car x) 40) (setq old-sw (cons x old-sw)))
((= (car x) 41) (setq old-ew (cons x old-ew)))
((= (car x) 42) (setq old-b (cons x old-b)))
(T (setq new-d (cons x new-d)))
      )
    )
  )
  elst
  )
  (mapcar (function (lambda (l)
      (set l (reverse (eval l)))
    )
  )
  '(old-p old-sw old-ew old-b new-d)
  )
  (and closed (setq old-p (append old-p (list (car old-p)))))
  (and (equal (cdar old-p) (cdr (last old-p)) 1e-9)
       (setq closed T
     new-d  (subst (cons 70 (Boole 7 (cdr (assoc 70 new-d)) 1))
   (assoc 70 new-d)
   new-d
    )
       )
  )
  (while (cddr old-p)
    (if (regular-width
  (cdar old-p)
  (cdadr old-p)
  (cdaddr old-p)
  (cdar old-sw)
  (cdar old-ew)
  (cdadr old-sw)
  (cdadr old-ew)
)
      (cond
((colinear (cdar old-p)
   (cdadr old-p)
   (cdaddr old-p)
   (cdar old-b)
   (cdadr old-b)
)
(mapcar 'del-cadr '(old-p old-sw old-ew old-b))
)
((setq bu (concentric
    (cdar old-p)
    (cdadr old-p)
    (cdaddr old-p)
    (cdar old-b)
    (cdadr old-b)
  )
)
(setq old-b (cons (cons 42 bu) (cddr old-b)))
(mapcar 'del-cadr '(old-p old-sw old-ew))
)
(T
(mapcar 'pour-car
'(old-p old-sw old-ew old-b)
'(new-p new-sw new-ew new-b)
)
)
      )
      (mapcar 'pour-car
      '(old-p old-sw old-ew old-b)
      '(new-p new-sw new-ew new-b)
      )
    )
  )
  (if closed
    (setq new-p (reverse (cons (car old-p) new-p)))
    (setq new-p (append (reverse new-p) old-p))
  )
  (mapcar
    (function
      (lambda (new old)
(set new (append (reverse (eval new)) (eval old)))
      )
    )
    '(new-sw new-ew new-b)
    '(old-sw old-ew old-b)
  )
  (if (and closed
   (regular-width
     (cdr (last new-p))
     (cdar new-p)
     (cdadr new-p)
     (cdr (last new-sw))
     (cdr (last new-ew))
     (cdar new-sw)
     (cdar new-ew)
   )
      )
    (cond
      ((colinear (cdr (last new-p))
(cdar new-p)
(cdadr new-p)
(cdr (last new-b))
(cdar new-b)
       )
       (mapcar (function (lambda (l)
   (set l (cdr (eval l)))
)
       )
       '(new-p new-sw new-ew new-b)
       )
      )
      ((setq bu (concentric
  (cdr (last new-p))
  (cdar new-p)
  (cdadr new-p)
  (cdr (last new-b))
  (cdar new-b)
)
       )
       (setq new-b (cdr (reverse (cons (cons 42 bu) (cdr (reverse new-b))))))
       (mapcar (function (lambda (l)
   (set l (cdr (eval l)))
)
       )
       '(new-p new-sw new-ew)
       )
      )
    )
  )
  (entmod
    (append new-d
    (apply 'append
   (apply 'mapcar
  (cons 'list (list new-p new-sw new-ew new-b))
   )
    )
    )
  )
)

;; BulgeData Retourne les données d'un polyarc (angle rayon centre)

(defun BulgeData (bu p1 p2 / ang rad cen)
  (setq ang (* 2 (atan bu))
rad (/ (distance p1 p2)
       (* 2 (sin ang))
    )
cen (polar p1
   (+ (angle p1 p2) (- (/ pi 2) ang))
   rad
    )
  )
  (list (* ang 2.0) rad cen)
)

;; TAN Retourne la tangente de l'angle

(defun tan (ang)
  (/ (sin ang) (cos ang))
)

;; SPL Calling function

(defun c:spl (/ ss n pl)
  (vl-load-com)
  (or *acad* (setq *acad* (vlax-get-acad-object)))
  (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*)))
  (princ
    "\nSelect les polylines to be treated or <All>: "
  )
  (or
    (setq ss (ssget '((0 . "LWPOLYLINE"))))
    (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
  )
  (if
    ss
     (progn
       (vla-StartUndoMark *acdoc*)
       (setq n -1)
       (while (setq pl (ssname ss (setq n (1+ n))))
(purge-pline pl)
       )
       (princ (strcat "\n\t" (itoa n) " treated polyline(s)."))
       (vla-EndUndoMark *acdoc*)
     )
     (princ "\nNone selected polyline.")
  )
  (princ)
)

(princ
  "\nSimp-Pline loaded, type SPL to launch the function."
)
(princ)
« Last Edit: November 25, 2007, 11:05:38 AM by gile »
Speaking English as a French Frog

ribarm

  • Gator
  • Posts: 2520
  • Marko Ribar, architect
Re: How do you simplify a LWPolyline vertex?
« Reply #62 on: November 08, 2014, 05:33:38 AM »
Hi Gile, I want to inform you that I have added your code into library PLINETOOLS BY MR+GC+LM.ZIP posted on www.cadtutor.net
here :
http://www.cadtutor.net/forum/showthread.php?67924-Draw-polyline-along-with-2-or-more-adjacent-closed-polylines/page3&p=#25

I have taken also your clean_poly.lsp as it was also open source posted on www, so I am hoping that you don't mind for my action... I only wanted to make ZIP more complete in a way of various polyline handling...

If you have some disagreements with me, please inform me... I've taken the codes entirely and done just some minor mods. changing name of lisp from SPL.lsp to SLWS.lsp and added (ssget "_:L") selection mode...

I only wanted to help and I wrote something similar like your code, but my versions has to have min. 2 vertices on arced segment of LWPOLYLINE in order to work correctly - please see : "cseglws2lws.lsp" and "cseglws2lws-lins-b.lsp" both included in ZIP... Any suggestion or approval is welcome...

Sincerely, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

xxfaxx

  • Mosquito
  • Posts: 3
Re: How do you simplify a LWPolyline vertex?
« Reply #63 on: May 24, 2018, 08:34:19 AM »
Hello guys. I know this is an old topic, I just want to leave my feedback about the two routines. The “psimple v1.7” made by Charles Alan Butle, works like a charm. You can select multiple objects and all of them will lose their extra vertices.
The other routine called “Purge-Pline” made by Gile, also works pretty well, but i could see that sometimes it does not delete some curved vertices (lets say about 10% of the vertices in curved segments).
Thank you for the routines guys.


CAB

  • Global Moderator
  • Seagull
  • Posts: 10395
Re: How do you simplify a LWPolyline vertex?
« Reply #64 on: May 31, 2018, 03:06:51 PM »
Welcome to the Swamp.Glad you found the forums it useful.
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

ahsattarian

  • Newt
  • Posts: 65
Re: How do you simplify a LWPolyline vertex?
« Reply #65 on: January 23, 2021, 08:40:16 AM »
A little more simple   :



Code - Auto/Visual Lisp: [Select]
  1. (defun c:a ()
  2.   (setq s (car (entsel "\n Select Pline : ")))
  3.   (setq en (entget s))
  4.   (setq obj (vlax-ename->vla-object s))
  5.   (setq i 0)
  6.   (setq li0 nil)
  7.   (repeat n1
  8.     (cond
  9.       ((null li0) (setq li0 '(1)) (setq ang1 (angle '(0 0) (vlax-curve-getfirstderiv obj 0.0))))
  10.       ((or
  11.          (null (vlax-curve-getfirstderiv obj i))
  12.          (and
  13.            (setq ang0 ang1)
  14.            (setq ang1 (angle '(0 0) (vlax-curve-getfirstderiv obj i)))
  15.            (equal ang0 ang1 0.000001)
  16.          )
  17.        )
  18.        (setq li0 (cons 0 li0))
  19.       )
  20.       ((setq li0 (cons 1 li0)))
  21.     )
  22.     (setq i (1+ i))
  23.   )
  24.   (setq li1 (vl-remove-if-not '(lambda (x) (vl-position (car x) '(40 41 42 10))) en))
  25.   (setq li2 nil)
  26.   (while li1
  27.     (setq i -1)
  28.     (setq lii nil)
  29.     (while (< (setq i (1+ i)) 4) (setq lii (cons (nth i li1) lii)))
  30.     (setq li2 (cons (reverse lii) li2))
  31.     (repeat 4 (setq li1 (cdr li1)))
  32.   )
  33.   (setq li1 (reverse li2))
  34.   (setq i -1)
  35.   (setq len (1- (length li1)))
  36.   (setq li0 (reverse (cons 1 li0)))
  37.   (setq li3 nil)
  38.   (while (<= (setq i (1+ i)) len)
  39.     (cond
  40.       ((not (zerop (cdr (cadddr (nth i li1))))) (setq li3 (cons (nth i li1) li3)))
  41.       ((not (zerop (nth i li0))) (setq li3 (cons (nth i li1) li3)))
  42.     )
  43.   )
  44.   (setq en1 (vl-remove-if '(lambda (x) (vl-position (car x) '(40 41 42 10))) en))
  45.   (mapcar '(lambda (x) (setq en1 (append en1 x))) (reverse li3))
  46.   (setq en1 (subst (cons 90 (length li3)) (assoc 90 en1) en1))
  47.   (entmod en1)
  48.   (cond
  49.     ((= (vla-get-closed obj) :vlax-true)
  50.      (princ (strcat "\n  >>  " (itoa n1) "  ==>  " (itoa n2) "  <<  "))
  51.     )
  52.     ((= (vla-get-closed obj) :vlax-false)
  53.      (princ (strcat "\n  >>  " (itoa (1+ n1)) "  ==>  " (itoa (1+ n2)) "  <<  "))
  54.     )
  55.   )
  56.   (command "pselect" s "")
  57.   (princ)
  58. )