reducing number of vertices of a polyline in a loop

[Anonymous]

Hello,

I'm trying to modify a routine created by "CAB" that works for one polyline to another one that works for all polylines of a layer. But, something goes wrong if the drawing has more than one polyline. Works for the first polyline but, to the others the polyline are mixing up with the first one.

Here is the code:

;;;=======================[ PSimple.lsp ]=======================
;;; Author: Charles Alan Butler
;;; Version: 1.1 Nov. 09, 2007
;;; Purpose: To remove un needed vertex from a pline
;;;=============================================================

(vl-load-com)

(defun c:PSimple (/ doc ent elst vlst idx dir keep result hlst len
group_on)
;; CAB 11/03/07
;; group on the elements of a flat list
;; (group_on '(A B C D E F G) 3)
;; Result ((A B C) (D E F) (G nil nil)...)
(defun group_on (inplst gp# / outlst idx subLst)
(setq outlst nil)
(setq subLst nil)
(while inplst
(setq idx -1
subLst nil
)
(while (< (setq idx (1+ idx)) gp#)
(setq subLst (cons (nth idx inplst) subLst))
)
(setq outlst (cons (reverse subLst) outlst))
(repeat gp#
(setq inplst (cdr inplst))
)
)
(reverse outlst)
)

(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))

(setq entlayer (car (entsel "\nSelect Object on Layer to Search and Report: ")))
(setq layer (cdr (assoc 8 (entget entlayer))))

(setq SelSet (ssget "_X" (list (cons 0 "*POLYLINE,LWPOLYLINE" )(cons 8 layer ))) Index 0 ) ; (automatic selection polyline from layer variable)
(setq i 0)
(setq n_ent (sslength SelSet)) ; Sets n to the length of the variable a. Ie. the number of entities selected by the user.

(repeat n_ent ; Starts SelSet loop that repeats n times.
(vla-StartUndoMark doc)

(setq na (ssname SelSet i)) ; Sets na to the entityname. Changes for each time i increase.
(setq elst (entget na))
(setq idx 0)

(repeat (fix (vlax-curve-getendparam na)) ; loop dentro de cada polyline (na)
(cond
((null keep)
(setq keep '(1)
dir (angle '(0 0) (vlax-curve-getFirstDeriv na 0.0))
))
((or (null(vlax-curve-getFirstDeriv na idx))
(equal dir (setq dir (angle '(0 0)
(vlax-curve-getFirstDeriv na idx))) 0.000001))
(setq keep (cons 0 keep))
)
((setq keep (cons 1 keep)))
)
(setq idx (1+ idx))
)

(setq vlst nil)
(setq vlst (vl-remove-if-not
'(lambda (x) (vl-position (car x) '(40 41 42 10))) elst)) ; elst

(setq vlst (group_on vlst 4))
(setq idx -1
len (1- (length vlst))
keep (reverse (cons 1 keep))
)
(while (<= (setq idx (1+ idx)) len)
(cond
((not (zerop (cdr(cadddr (nth idx vlst))))) ; keep arcs
(setq result (cons (nth idx vlst) result))
)
((not (zerop (nth idx keep)))
(setq result (cons (nth idx vlst) result))
)
)
)
(setq hlst nil)
(setq hlst (vl-remove-if
'(lambda (x) (vl-position (car x) '(40 41 42 10))) elst))
(mapcar '(lambda(x) (setq hlst (append hlst x))) (reverse result))
(setq hlst (subst (cons 90 (length result)) (assoc 90 hlst) hlst))
(entmod hlst)

(setq i (+ i 1))
(vla-EndUndoMark doc)
)

(princ)
)
(prompt "\nPline Simplify loaded, PSimple to run.")
(princ)

---

Sorry, I'm newbie at LISP.

Thanks in advance + regards,

lzucco

[ВeekeeCZ]

Post the original code or a link to that.

[Anonymous]

http://www.theswamp.org/index.php?PHPSESSID=13f39ec355c7ae55a0ea3c8e53f4d93b&topic=19865.0

Attached is the code I'm working on

[ВeekeeCZ · Accepted solution]

This one works.

You took some older version... not sure what you have done wrong though.

(defun c:PSimpleM (/ lay ss ii )
  (if (and (setq lay (entsel "\nSelect object for layer: "))
           (setq ss (ssget "_A" (list '(0 . "LWPOLYLINE") (assoc 8 (entget (car lay))) (cons 410 (getvar 'CTAB))))))
    (repeat (setq ii (sslength ss))
      (psimple (ssname ss (setq ii (1- ii))))))
  (princ)
)


;;;=======================[ PSimple.lsp ]======================= 
;;; Author: Charles Alan Butler 
;;; Version:  1.6 Nov. 21, 2007
;;; Purpose: To remove unnecessary vertex from a pline
;;; Supports arcs and varying widths
;;;=============================================================
;; This version will remove the first vertex if it is colinear
;; and first & last arcs that have the same center
(defun PSimple (ent /      aa     cpt    dir    doc    elst   ent    hlst
                  idx    keep   len    newb   result vlst   x      closed
                  d10    d40    d41    d42    hlst   p1     p2     p3
                  plast remove  BulgeCenter   RemoveNlst    
                  )
  (vl-load-com)

  (defun tan (a) (/ (sin a) (cos a)))

  (defun replace (lst i itm)
    (setq i (1+ i))
    (mapcar '(lambda (x) (if (zerop (setq i (1- i))) itm x)) lst)
  )

  
  ;;  CAB 11.16.07
  ;;  Remove based on pointer list
  (defun RemoveNlst (nlst lst)
    (setq i -1)
    (vl-remove-if  '(lambda (x) (not (null (vl-position (setq i (1+ i)) nlst)))) lst)
  )
  
  (defun BulgeCenter (bulge p1 p2 / delta chord radius center)
    (setq delta  (* (atan bulge) 4)
          chord  (distance p1 p2)
          radius (/ chord (sin (/ delta 2)) 2)
          center (polar p1 (+ (angle p1 p2) (/ (- pi delta) 2)) radius)
    )
  )


  ;;  ========  S T A R T   H E R E  ===========
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark doc)
  ;(setq ent (car (entsel "\n Select polyline to remove extra vertex: ")))
  (if (and ent
           (setq elst (entget ent))
           (equal (assoc 0 elst) '(0 . "LWPOLYLINE"))
      )
    (progn
      ;;=====================================================
      (setq d10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) elst)))
      (if (> (length d10) 2)
        (progn
          ;;  seperate vertex data
          (setq d40 (vl-remove-if-not '(lambda (x) (= (car x) 40)) elst))
          (setq d41 (vl-remove-if-not '(lambda (x) (= (car x) 41)) elst))
          (setq d42 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) elst)))
          ;;  remove extra vertex from point list
          (setq plast (1- (length d10)))
          (setq p1 0  p2 1  p3 2)
          (if (and (not (setq closed (vlax-curve-isclosed ent)))
                   (equal (car d10) (last d10) 1e-6))
            (progn
              (setq Closed t ; close the pline
                    elst (subst (cons 70 (1+(cdr(assoc 70 elst))))(assoc 70 elst) elst))
              (if (and (not(zerop (nth plast d42)))(not(zerop (nth 0 d42))))
                (setq d10 (reverse(cdr(reverse d10)))
                      d40 (reverse(cdr(reverse d40)))
                      d41 (reverse(cdr(reverse d41)))
                      d42 (reverse(cdr(reverse d42)))
                      plast (1- plast)
                )
              )
            )
          )
          (setq idx -1)
          (while (<= (setq idx (1+ idx)) (if closed (+ plast 2) (- plast 2)))
            (cond
              ((and (or (equal (angle (nth p1 d10) (nth p2 d10))
                               (angle (nth p2 d10) (nth p3 d10)) 1e-6)
                        (equal (nth p1 d10) (nth p2 d10) 1e-6)
                        (equal (nth p2 d10) (nth p3 d10) 1e-6))
                    (zerop (nth p2 d42))
                    (or (= p1 plast)
                        (zerop (nth p1 d42)))
               )
               (setq remove (cons p2 remove)) ; build a pointer list
               (setq p2 (if (= p2 plast) 0 (1+ p2))
                     p3 (if (= p3 plast) 0 (1+ p3))
               )
              )
              ((and (not (zerop (nth p2 d42)))
                    (or closed (/= p1 plast))
                    (not (zerop (nth p1 d42))) ; got two arcs
                    (equal
                      (setq cpt (BulgeCenter (nth p1 d42) (nth p1 d10) (nth p2 d10)))
                      (BulgeCenter (nth p2 d42) (nth p2 d10) (nth p3 d10))
                      1e-4)
               )
               ;;  combine the arcs
               (setq aa   (+ (* 4 (atan (abs (nth p1 d42))))(* 4 (atan (abs (nth p2 d42)))))
                     newb (tan (/ aa 4.0))
               )
               (if (minusp (nth p1 d42))
                 (setq newb (- (abs newb)))
                 (setq newb (abs newb))
               )
               (setq remove (cons p2 remove)) ; build a pointer list
               (setq d42 (replace d42 p1 newb))
               (setq p2 (if (= p2 plast) 0 (1+ p2))
                     p3 (if (= p3 plast) 0 (1+ p3))
               )
              )
              (t
               (setq p1 p2
                     p2 (if (= p2 plast) 0 (1+ p2))
                     p3 (if (= p3 plast) 0 (1+ p3))
               )
              )
            )
          )
          (if remove
            (progn
              ;; Rebuild the vertex data with pt, start & end width, bulge
              (setq d10 (RemoveNlst remove d10)
                    d40 (RemoveNlst remove d40)
                    d41 (RemoveNlst remove d41)
                    d42 (RemoveNlst remove d42)
              )
              (setq result (mapcar '(lambda(w x y z) (list(cons 10 w)
                                        x  y
                                        (cons 42 z))) d10 d40 d41 d42)
              )
              ;;  rebuild the entity data with new vertex data
              (setq hlst (vl-remove-if
                           '(lambda (x) (vl-position (car x) '(40 41 42 10))) elst)
              )
              (mapcar '(lambda (x) (setq hlst (append hlst x))) result)
              (setq hlst (subst (cons 90 (length result)) (assoc 90 hlst) hlst))
              (entmod hlst)
            )
            (prompt "\nNothing to remove.")
          )
        )
        (prompt "\nNothing to do - Only two vertex.")
      )
    )
    (prompt "\nError - Not a LWpolyline.")
  )
  (vla-endundomark doc)
  (princ)
)
(prompt "\nPline Simplify loaded, PSimple to run.")
(princ)

[Kent1Cooper]

Are any of your Polylines "heavy"?  That would throw the whole thing off.  This part:

... (cons 0 "*POLYLINE,LWPOLYLINE" ) ...

is clearly designed to be able to accept selection of "heavy" as well as "lightweight" Polylines [though it's redundant, and could be simply  '(0 . "*POLYLINE")  instead].  But this part:

(setq vlst (vl-remove-if-not
  '(lambda (x) (vl-position (car x) '(40 41 42 10))) elst))

clearly will work only with LWPolylines, and not  with "heavy" ones.  They don't have entries within their entity data for each vertex [the 10] with widths [40 & 41] and bulge factor [42], but each vertex is its own separate entity  that would need to be stepped through with (entnext).

EDIT:  BUT MORE IMPORTANTLY, can't you do the same with OVERKILL if you have it set to Optimize Polylines?

Without analyzing too closely, isn't that what your routine is doing -- eliminating intermediate vertices in collinear straight stretches, and between consecutive concentric arc segments?  And it works on multiple objects at once, and on both "heavy" and "lightweight" Polylines.