TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: hunterxyz on November 08, 2007, 06:00:33 PM

Title: How do you simplify a LWPolyline vertex?
Post by: hunterxyz on November 08, 2007, 06:00:33 PM
How likes the attached figure,
simplifies on "LWPOLYLINE" to duplicate the line segment angle the apex?

Requests fellow masters to be allowed to help to solve ~
to thank ~
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Bob Wahr on November 08, 2007, 06:22:34 PM
try OVERKILL
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Cathy on November 08, 2007, 06:29:06 PM
or try pedit;edit vertex;straighten
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 08, 2007, 07:38:46 PM
Links removed as they did not address the requested lisp help.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Jan ter Aij on November 09, 2007, 08:25:08 AM
try OVERKILL

If You don't like the solution from Bob Wahr or CAB,
then try PEDIT with Edit vertex and optie Straighten,
or try after EXPLODE the command JOIN.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 09, 2007, 09:23:04 AM
look here
http://www.theswamp.org/index.php?topic=2171.msg28102#msg28102
and here.
http://www.theswamp.org/index.php?topic=2024.msg26001#msg26001


Alan,

I think, though I may be wrong, the routines you pointed to don't answer the question in the sense the plines in the example file posted should not need any questions about distance or angle.

As I read it the OP simply wants to remove any vertex which is collinear with the preceding and following vertex.

That's not hard to do when the pline does not contain arcs. When it does, I'm thinking look at what gile posted recently regarding delete a vertex from a pline. Which as I recall, handles bulges correctly when a vertex is deleted.

Regards
Title: Re: How do you simplify a LWPolyline vertex?
Post by: daron on November 09, 2007, 10:30:43 AM
Changed Title for clarity.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 09, 2007, 11:29:22 AM
Joe,
Sorry I was in a hurry & did not find an appropriate routine.

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

;;  Note, very little testing has been done at this time
(defun c:PSimple (/ doc ent elst vlst idx dir keep result hlst len
                  group_on)
  (vl-load-com)

  ;; 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)
    (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)))
  (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 idx 0)
      (repeat (fix (vlax-curve-getendparam ent))
        (cond
          ((null keep)
           (setq keep '(1)
                 dir  (angle '(0 0) (vlax-curve-getFirstDeriv ent 0.0))
           ))
          ((or (null(vlax-curve-getFirstDeriv ent idx))
               (equal dir (setq dir (angle '(0 0)
                             (vlax-curve-getFirstDeriv ent idx))) 0.000001))
           (setq keep (cons 0 keep))
          )
          ((setq keep (cons 1 keep)))
        )
        (setq idx (1+ idx))
      )
      (setq vlst (vl-remove-if-not
                   '(lambda (x) (vl-position (car x) '(40 41 42 10))) 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 (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)
    )
  )
  (vla-EndUndoMark doc)

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

<edit: revised code>
Title: Re: How do you simplify a LWPolyline vertex?
Post by: gile on November 09, 2007, 12:28:34 PM
Hi,

Here's one quite dirty but which works with polyarcs too.

Excuse for non-translated comments.

edit: corrected a bug according to Joe's remark.

edit2: works now with widthes

edit3: EndUndoMark corrected

Code: [Select]
;;; VEC1 Returns the single unit vector from p1 to p2

(defun vec1 (p1 p2 / d)
  (if (not (zerop (setq d (distance p1 p2))))
    (mapcar '(lambda (x1 x2) (/ (- x2 x1) d)) p1 p2)
  )
)

;; BETWEENP Evaluates if pt is between p1 et p2

(defun betweenp (p1 p2 pt)
  (or (equal p1 pt 1e-9)
      (equal p2 pt 1e-9)
      (equal (vec1 p1 pt) (vec1 pt p2) 1e-9)
  )
)

;;; 2d-coord->pt-lst Convert a flat 20 coordinates list into a 2d points list
;;; (2d-coord->pt-lst '(1.0 2.0 3.0 4.0)) -> ((1.0 2.0) (3.0 4.0))

(defun 2d-coord->pt-lst (lst)
  (if lst
    (cons (list (car lst) (cadr lst))
  (2d-coord->pt-lst (cddr lst))
    )
  )
)

;; BulgeData Returns a 'bulge datas list' (angle radius center)
(defun BulgeData (bu p1 p2 / ang rad)
  (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 Returns the angle tangent

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


;; Deletes aligned vertices of a pline (vla-object)

(defun CleanPline (pl     /      regular-width     closed old-p
   n     sw      ew       old-b    old-w new-p
   new-b    new-w    b1       b2
  )

  (defun regular-width (p1 p2 p3 w1 w2 / delta norm)
    (setq delta (- (cadr w2) (car w1))
  norm (vlax-get pl 'Normal)
    )
    (and (= (cadr w1) (car w2))
(equal (/ (- (vlax-curve-getDistAtPoint pl (trans p2 norm 0))
      (vlax-curve-getDistAtPoint pl (trans p1 norm 0))
   )
   (- (vlax-curve-getDistAtPoint pl (trans p3 norm 0))
      (vlax-curve-getDistAtPoint pl (trans p1 norm 0))
   )
)
(/ (- (cadr w1) (- (cadr w2) delta)) delta)
0.01
)
    )
  )

  (setq closed (vla-get-Closed pl)
old-p  (2d-coord->pt-lst (vlax-get pl 'Coordinates))
  )
  (repeat (setq n (if (= closed :vlax-true)
    (1+ (length old-p))
    (length old-p)
  )
  )
    (vla-getWidth pl (setq n (1- n)) 'sw 'ew)
    (setq old-b (cons (vla-getBulge pl n) old-b)
  old-w (cons (list sw ew) old-w)
    )
  )
  (if (= closed :vlax-true)
    (setq old-p (append old-p (list (car old-p))))
  )
  (while (cddr old-p)
    (if (or (= (caar old-w) (cadar old-w) (caadr old-w) (cadadr old-w))
    (regular-width
      (car old-p)
      (cadr old-p)
      (caddr old-p)
      (car old-w)
      (cadr old-w)
    )
)
      (if (and (zerop (car old-b))
       (zerop (cadr old-b))
  )
(if (betweenp (car old-p) (caddr old-p) (cadr old-p))
  (setq old-p (cons (car old-p) (cddr old-p))
old-b (cons (car old-b) (cddr old-b))
old-w (cons (list (caar old-w) (cadadr old-w)) (cddr old-w))
  )
  (setq new-p (cons (car old-p) new-p)
new-b (cons (car old-b) new-b)
new-w (cons (car old-w) new-w)
old-p (cdr old-p)
old-b (cdr old-b)
old-w (cdr old-w)
  )
)
(if
  (and
    (/= 0.0 (car old-b))
    (/= 0.0 (cadr old-b))
    (equal (caddr
     (setq b1 (BulgeData (car old-b) (car old-p) (cadr old-p)))
   )
   (caddr
     (setq b2 (BulgeData (cadr old-b) (cadr old-p) (caddr old-p)))
   )
   1e-4
    )
  )
   (setq old-p (cons (car old-p) (cddr old-p))
old-b (cons (tan (/ (+ (car b1) (car b2)) 4.0)) (cddr old-b))
old-w (cons (list (caar old-w) (cadadr old-w)) (cddr old-w))
   )
   (setq new-p (cons (car old-p) new-p)
new-b (cons (car old-b) new-b)
new-w (cons (car old-w) new-w)
old-p (cdr old-p)
old-b (cdr old-b)
old-w (cdr old-w)
   )
)
      )
      (setq new-p (cons (car old-p) new-p)
    new-b (cons (car old-b) new-b)
    new-w (cons (car old-w) new-w)
    old-p (cdr old-p)
    old-b (cdr old-b)
    old-w (cdr old-w)
      )
    )
  )
  (if (= (vla-get-closed pl) :vlax-true)
    (setq new-p (reverse (append (cdr (reverse old-p)) new-p)))
    (setq new-p (append (reverse new-p) old-p))
  )
  (setq new-b (append (reverse new-b) old-b)
new-w (append (reverse new-w) old-w)
  )
  (vlax-put pl 'Coordinates (apply 'append new-p))
  (setq n (1- n))
  (repeat (length new-b)
    (vla-setBulge pl (setq n (1+ n)) (nth n new-b))
    (vla-setWidth pl n (car (nth n new-w)) (cadr (nth n new-w)))
  )
)

Calling function

Code: [Select]
(defun c:cpl (/ pl)
  (vl-load-com)
  (and
    (setq pl (car (entsel)))
    (setq pl (vlax-ename->vla-object pl))
    (= (vla-get-ObjectName pl) "AcDbPolyline")
    (or (vla-StartUndoMark
  (vla-get-ActiveDocument (vlax-get-acad-object))
)
T
    )
    (vl-catch-all-apply 'CleanPline (list pl))
    (vla-StartUndoMark
      (vla-get-ActiveDocument (vlax-get-acad-object))
    )
  )
  (princ)
)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: hunterxyz on November 11, 2007, 02:25:12 AM
THANK CAB
PSimple.lsp Normal execution
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 11, 2007, 09:56:48 AM
Hi gile,

Check your code with the example file posted. It seems OK with the plines which don't contain arcs. But when arcs are included, I'm getting divide by zero errors.

I'm reworking similar code I started some time ago. I've not worked out all the kinks yet, but I think I'm fairly close.

Regards
Title: Re: How do you simplify a LWPolyline vertex?
Post by: gile on November 11, 2007, 11:28:22 AM
Thanks Joe,

I forgot to check a if the second bulge was 0.0 before comparing two following ones.
I edit the code.

(http://img259.imageshack.us/img259/7656/cleanko0.png)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 11, 2007, 07:16:50 PM
Gile, I got an odd result.
Quote
Command: test
Select object: ; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 11, 2007, 07:18:59 PM
This is the result with my routine.
Also note that the width data is maintained at each vertex, but no interpolation
is attempted on my part.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 11, 2007, 07:54:13 PM
Gile, I got an odd result.
Quote
Command: test
Select object: ; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception

The unwind error with a lwpline usually means an attempt to add or remove more than one vertex at a time. At least in my experience.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: gile on November 12, 2007, 04:42:59 AM
Alan,

I can't reproduce the error you got.

I revised my code so that it has a coherent behavior with widthes : the aligned vertex is removed only if width is constant or 'regular'.



Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 12, 2007, 08:47:18 AM
Gile,
Use the attached drawing for your test.
I tested in ACAD2000, If it test ok for you perhaps it's a version problem.

Title: Re: How do you simplify a LWPolyline vertex?
Post by: gile on November 12, 2007, 09:21:52 AM
Alan,

I've got no problem whith your file, may be a version problem.

Can you see which expression make the routine fail ?
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 12, 2007, 09:37:47 AM
Same problem in ACAD2004:
Quote
Command: cpl

Select object: ; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on unknown exception
With the catchall removed from cpl the VLIDE is still not triggered in eather version of ACAD just the warning message.
See results below.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: gile on November 12, 2007, 10:02:52 AM
It works fine in acad2007.
Regarding what was saying Joe, perhaps the error is due to the (vlax-put pl 'Coordinates (apply 'append new-p)) expression near the ehd of 'CleanPline' routine.

Does it works if you replace it by :

Code: [Select]
(vla-delete pl)
  (setq pl
(vlax-invoke
   (vla-get-ModelSpace
     (vla-get-ActiveDocument (vlax-get-acad-object))
   )
   'addLightWeightPolyline
   (apply 'append new-p)
)
  )

PS : I revised the code to close the undo group in Cpl.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 12, 2007, 10:11:10 AM
The new code also produces the error, but the patch you posted produces good results & no warning.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: gile on November 12, 2007, 10:28:10 AM
OK, so the (vlax-put pl 'Coordinates ...) is not supported.

But the patch isn't a so good solution, cause it creates a new entity and the deleted pline could have been linked by its handle or objectID.

I'm trying to make an 'entmod' release...
Title: Re: How do you simplify a LWPolyline vertex?
Post by: MP on November 12, 2007, 11:06:49 AM
OK, so the (vlax-put pl 'Coordinates ...) is not supported.

Nope:

PROPERTIES

    ("Application" #<VLA-OBJECT IAcadApplication 00d73d3c> VISIBLE READONLY)
    ("Area" 8976.87 VISIBLE READONLY)
    ("Closed" 0 VISIBLE READONLY)
    ("Color" 256 HIDDEN READONLY)
    ("ConstantWidth" 0.0 VISIBLE READONLY)
    ("Coordinate" "<Error: Invalid number of parameters>" VISIBLE READONLY)
    ("Coordinates" (70.326 22.6916 117.289 22.6916 ...) VISIBLE READONLY)
    ("Database" #<VLA-OBJECT IAcadDatabase 0bc4ffd4> HIDDEN READONLY)
    ("Document" #<VLA-OBJECT IAcadDocument 01c35fc8> VISIBLE READONLY)
    ("Elevation" 0.0 VISIBLE READONLY)
    ("EntityName" "AcDbPolyline" HIDDEN READONLY)
    ("EntityType" 24 HIDDEN READONLY)
    ("Handle" "28D6" VISIBLE READONLY)
    ("HasExtensionDictionary" 0 VISIBLE READONLY)
    ("Hyperlinks" #<VLA-OBJECT IAcadHyperlinks 0bf9e2e4> VISIBLE READONLY)
    ("Layer" "0" VISIBLE READONLY)
    ("Length" 254.984 VISIBLE READONLY)
    ("Linetype" "ByLayer" VISIBLE READONLY)
    ("LinetypeGeneration" 0 VISIBLE READONLY)
    ("LinetypeScale" 1.0 VISIBLE READONLY)
    ("Lineweight" -1 VISIBLE READONLY)
    ("Material" "ByLayer" VISIBLE READONLY)
    ("Normal" (0.0 0.0 1.0) VISIBLE READONLY)
    ("ObjectID" 2126299568 VISIBLE READONLY)
    ("ObjectName" "AcDbPolyline" VISIBLE READONLY)
    ("OwnerID" 2130317008 VISIBLE READONLY)
    ("PlotStyleName" "ByLayer" VISIBLE READONLY)
    ("Thickness" 0.0 VISIBLE READONLY)
    ("TrueColor" #<VLA-OBJECT IAcadAcCmColor 0be616a8> VISIBLE READONLY)
    ("Visible" -1 VISIBLE READONLY)(NAME ARGUMENTS VISIBILITY)
   
METHODS   
   
    ("AddRef" nil VISIBLE)
    ("AddVertex" (("Index" INT) ("vertex" variant)) VISIBLE)
    ("ArrayPolar" (("NumberOfObjects" INT) ("AngleToFill" REAL) ("CenterPoint" variant)) VISIBLE)
    ("ArrayRectangular" (("NumberOfRows" INT) ("NumberOfColumns" INT) ("NumberOfLevels" INT) ("DistBetweenRows" REAL) ("DistBetweenCols" REAL) ("DistBetweenLevels" REAL)) VISIBLE)
    ("Copy" nil VISIBLE)
    ("Delete" nil VISIBLE)
    ("Erase" nil HIDDEN)
    ("Explode" nil VISIBLE)
    ("GetBoundingBox" (("MinPoint" variant) ("MaxPoint" variant)) VISIBLE)
    ("GetBulge" (("Index" INT)) VISIBLE)
    ("GetExtensionDictionary" nil VISIBLE)
    ("GetIDsOfNames" (("riid" EMPTY) ("rgszNames" I1) ("cNames" UINT) ("lcid" UI4) ("rgdispid" I4)) VISIBLE)
    ("GetTypeInfo" (("itinfo" UINT) ("lcid" UI4) ("pptinfo" VOID)) VISIBLE)
    ("GetTypeInfoCount" (("pctinfo" UINT)) VISIBLE)
    ("GetWidth" (("Index" INT) ("StartWidth" REAL) ("EndWidth" REAL)) VISIBLE)
    ("GetXData" (("AppName" STR) ("XDataType" variant) ("XDataValue" variant)) VISIBLE)
    ("Highlight" (("HighlightFlag" BOOL)) VISIBLE)
    ("IntersectWith" (("IntersectObject" DISPATCH) ("option" EMPTY)) VISIBLE)
    ("Invoke" (("dispidMember" I4) ("riid" EMPTY) ("lcid" UI4) ("wFlags" UI2) ("pdispparams" EMPTY) ("pvarResult" variant) ("pexcepinfo" EMPTY) ("puArgErr" UINT)) VISIBLE)
    ("Mirror" (("Point1" variant) ("Point2" variant)) VISIBLE)
    ("Mirror3D" (("Point1" variant) ("Point2" variant) ("point3" variant)) VISIBLE)
    ("Move" (("FromPoint" variant) ("ToPoint" variant)) VISIBLE)
    ("Offset" (("Distance" REAL)) VISIBLE)
    ("QueryInterface" (("riid" EMPTY) ("ppvObj" VOID)) VISIBLE)
    ("Release" nil VISIBLE)
    ("Rotate" (("BasePoint" variant) ("RotationAngle" REAL)) VISIBLE)
    ("Rotate3D" (("Point1" variant) ("Point2" variant) ("RotationAngle" REAL)) VISIBLE)
    ("ScaleEntity" (("BasePoint" variant) ("ScaleFactor" REAL)) VISIBLE)
    ("SetBulge" (("Index" INT) ("bulge" REAL)) VISIBLE)
    ("SetWidth" (("Index" INT) ("StartWidth" REAL) ("EndWidth" REAL)) VISIBLE)
    ("SetXData" (("XDataType" variant) ("XDataValue" variant)) VISIBLE)
    ("TransformBy" (("TransformationMatrix" variant)) VISIBLE)
    ("Update" nil VISIBLE)




Sorry, couldn't resist. :)

There's also (vlax-property-available-p lwPolyLineObject 'coordinates t), the t argument checks if the property can be modified.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: gile on November 12, 2007, 11:39:28 AM
MP

I should have said "not supported with A2000 and A2004." because it works fine with A2007, I use it a lot !
(vlax-property-available-p lwPolyLineObject 'coordinates t) returns T, as I understood Joe said the error got by Alan is due to adding or removing too much vertex at the same time.

Anyway, here's a new version using entmod rather than (vlax-put pl 'coordinates ...), perhaps it works on 'old' versions ?


EDIT: revised code, 2 commands (see downer reply 31)
Code: [Select]
;; CPL Calling Function

(defun c:cpl (/ ss n)
  (vl-load-com)
  (princ
    "\nSelect plines or <All>: "
  )
  (or (setq ss (ssget '((0 . "LWPOLYLINE"))))
      (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
  )
  (if ss
    (progn
      (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      (setq n -1)
      (while (setq pl (ssname ss (setq n (1+ n))))
(CleanPline pl nil)
      )
      (princ (strcat "\n\t" (itoa n) " treated pline(s)."))
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
    )
    (princ "\nNone pline selected.")
  )
  (princ)
)

;; PPL Calling Function

(defun c:ppl (/ ss n)
  (vl-load-com)
  (princ
    "\nSelect plines or <All>: "
  )
  (or (setq ss (ssget '((0 . "LWPOLYLINE"))))
      (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
  )
  (if ss
    (progn
      (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      (setq n -1)
      (while (setq pl (ssname ss (setq n (1+ n))))
(CleanPline pl T)
      )
      (princ (strcat "\n\t" (itoa n) " treated pline(s)."))
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
    )
    (princ "\nNone pline selected.")
  )
  (princ)
)

;; CleanPline (gile) 2007/11/13
;; Deletes superfluous vertex (aligned or overlapped) in a lwpolyline
;; Keeps arcs and widthes.
;;
;; Arguments
;; pl : the polyline to be treated (ename)
;; tt : T ou nil
;;    - T deletes all vertex aligned or on the same arc
;;    - nil keeps vertex which come back on the pline traject

(defun CleanPline (pl     tt      /       regular-width elst
   closed   old-p    old-b    old-sw   old-ew new-p
   new-b    new-sw   new-ew   b1       b2
  )

  (defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta norm)
    (setq delta (- we2 ws1)
    )
    (and (= we1 ws2)
(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)
0.01
)
    )
  )

  (setq elst (entget pl))
  (and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T))
  (setq old-p  (vl-remove-if-not
(function (lambda (x) (= (car x) 10)))
elst
       )
old-sw (vl-remove-if-not
(function (lambda (x) (= (car x) 40)))
elst
       )
old-ew (vl-remove-if-not
(function (lambda (x) (= (car x) 41)))
elst
       )
old-b  (vl-remove-if-not
(function (lambda (x) (= (car x) 42)))
elst
       )
elst   (vl-remove-if
(function (lambda (x) (member (car x) '(10 40 41 42))))
elst
       )
  )
  (and closed (setq old-p (append old-p (list (car old-p)))))
  (while (cddr old-p)
    (if (or (= (cdar old-sw)
       (cdar old-ew)
       (cdadr old-sw)
       (cdadr old-ew)
    )
    (regular-width
      (cdar old-p)
      (cdadr old-p)
      (cdaddr old-p)
      (cdar old-sw)
      (cdar old-ew)
      (cdadr old-sw)
      (cdadr old-ew)
    )
)
      (if (and (zerop (cdar old-b))
       (zerop (cdadr old-b))
  )
(if
  (if tt
    (null (inters (cdar old-p)
  (cdaddr old-p)
  (cdar old-p)
  (cdadr old-p)
  )
    )
    (betweenp (cdar old-p) (cdaddr old-p) (cdadr old-p))
  )
   (setq old-p (cons (car old-p) (cddr old-p))
old-b (cons (car old-b) (cddr old-b))
old-sw (cons (car old-sw) (cddr old-sw))
old-ew (cons (cadr old-ew) (cddr old-ew))
   )
   (setq new-p (cons (car old-p) new-p)
new-b (cons (car old-b) new-b)
new-sw (cons (car old-sw) new-sw)
new-ew (cons (car old-ew) new-ew)
old-p (cdr old-p)
old-b (cdr old-b)
old-sw (cdr old-sw)
old-ew (cdr old-ew)
   )
)
(if
  (and
    (/= 0.0 (cdar old-b))
    (/= 0.0 (cdadr old-b))
    (equal (caddr
     (setq
       b1 (BulgeData (cdar old-b) (cdar old-p) (cdadr old-p))
     )
   )
   (caddr
     (setq b2
    (BulgeData (cdadr old-b) (cdadr old-p) (cdaddr old-p))
     )
   )
   1e-4
    )
    (or tt
(or (and (< 0 (car b1)) (< 0 (car b2)))
    (and (< (car b1) 0) (< (car b2) 0))
)
    )
  )
   (setq old-p (cons (car old-p) (cddr old-p))
old-b (cons (cons 42 (tan (/ (+ (car b1) (car b2)) 4.0)))
      (cddr old-b)
)
old-sw (cons (car old-sw) (cddr old-sw))
old-ew (cons (cadr old-ew) (cddr old-ew))
   )
   (setq new-p (cons (car old-p) new-p)
new-b (cons (car old-b) new-b)
new-sw (cons (car old-sw) new-sw)
new-ew (cons (car old-ew) new-ew)
old-p (cdr old-p)
old-b (cdr old-b)
old-sw (cdr old-sw)
old-ew (cdr old-ew)
   )
)
      )
      (setq new-p  (cons (car old-p) new-p)
    new-b  (cons (car old-b) new-b)
    new-sw (cons (car old-sw) new-sw)
    new-ew (cons (car old-ew) new-ew)
    old-p  (cdr old-p)
    old-b  (cdr old-b)
    old-sw (cdr old-sw)
    old-ew (cdr old-ew)
      )
    )
  )
  (if closed
    (setq new-p (reverse (append (cdr (reverse old-p)) new-p)))
    (setq new-p (append (reverse new-p) old-p))
  )
  (setq new-b  (append (reverse new-b) old-b)
new-sw (append (reverse new-sw) old-sw)
new-ew (append (reverse new-ew) old-ew)
  )
  (entmod
    (append elst
    (apply 'append
   (apply 'mapcar
  (cons 'list (list new-p new-sw new-ew new-b))
   )
    )
    )
  )
)

;;; VEC1 Returns the single unit vector from p1 to p2

(defun vec1 (p1 p2 / d)
  (if (not (zerop (setq d (distance p1 p2))))
    (mapcar '(lambda (x1 x2) (/ (- x2 x1) d)) p1 p2)
  )
)

;; BETWEENP Evaluates if pt is between p1 et p2

(defun betweenp (p1 p2 pt)
  (or (equal p1 pt 1e-9)
      (equal p2 pt 1e-9)
      (equal (vec1 p1 pt) (vec1 pt p2) 1e-9)
  )
)

;;; TRUNC Returns the list from the first item to the first occurrence
;;; of expression de l'expression (complementary to MEMBER list)

(defun trunc (expr lst)
  (if (and lst
   (not (equal (car lst) expr))
      )
    (cons (car lst) (trunc expr (cdr lst)))
  )
)

;; BulgeData Returns a 'bulge datas list' (angle radius center)
(defun BulgeData (bu p1 p2 / ang rad)
  (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 Returns the angle tangent

(defun tan (ang)
  (/ (sin ang) (cos ang))
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 12, 2007, 11:52:31 AM
That version works well in ACAD2000. 8-)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: MP on November 12, 2007, 11:54:19 AM
I should have said "not supported with A2000 and A2004." because it works fine with A2007, I use it a lot!

All the more reason to test me thinks.

:)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 13, 2007, 04:34:44 AM
Hi gile and Alan and Michael,

These are comments from a program I wrote a couple years ago.
I was probably using 2004 at the time.

;; Set lwpline not closed and delete one vertex at a
;; time until two vertices remain. Avoids an "unwind error"
;; which occurs with lwplines when more than one vertex
;; is removed at a time.

Since then I haven't seen the unwind error when removing or adding
points in lwplines using the Coordinates property.

This evening I tested the idea in 2006 and 2008 using the following code.
What I found in 2006 was no error if only one point is removed.
If two or more points picked, unwind error, as I expected.
Also note, the lwpline is modified (two points removed) regardless of the
error. In 2008 there is no error when two or more points are removed.

So I don't think there's a problem modifying the Coordinates property
as long as the one-at-time rule is used. Obviously this applies to
recent versions as well for the sake of backwards compatibility.

I hope this sheds some light.

Code: [Select]
;; Returns a nested point list from a lwpline flat point list.
(defun PointList (obj / coord lst)
  (setq coord (vlax-get obj 'Coordinates))
  (repeat (/ (length coord) 2)
    (setq lst (cons (list (car coord) (cadr coord)) lst)
          coord (cddr coord)
    )
  )
  (reverse lst)
) ;end

;; Remove one or more vertices from a lwpline.
(defun c:RemovePoints ( / obj p lst ptlst)
  (setq obj (car (entsel "\nSelect pline: ")))
  (setq obj (vlax-ename->vla-object obj))
  (while (setq p (getpoint "\nPick point at vertex: "))
    (setq lst (cons p lst))
  )
  ;; remove Z coordinates
  (setq lst (mapcar '(lambda (x) (list (car x) (cadr x))) lst))
  (setq ptlst (PointList obj))
  (foreach x lst
    (setq ptlst (vl-remove x ptlst))
  )
  (vlax-put obj 'Coordinates (apply 'append ptlst))
) ;end
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 13, 2007, 04:48:52 AM
One other thought. My testing back when indicated the one-at-a-time idea does not apply to old style heavy plines. Only to lwplines.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 13, 2007, 08:33:34 AM
Michael,

I think this is not correct since experience and dump object says otherwise.

("Coordinates" (70.326 22.6916 117.289 22.6916 ...) VISIBLE READONLY)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: MP on November 13, 2007, 08:46:35 AM
You're absolutely right Joe.

There was a bug in the version of the program at that point. You can tell because all the properties in the post you refer to appear to be read only. Said bug has long been fixed but I had failed to notice it when making the post you caught.

Thanks for the heads up.

:)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 13, 2007, 09:08:13 AM
Michael,

Thanks for confirmation.

Regards
Title: Re: How do you simplify a LWPolyline vertex?
Post by: gile on November 13, 2007, 09:21:31 AM
Hi,

Thanks Joe for your explainations, we had this problem before, but we were unable to fix it.
By my side, I'd rather use entmod than delete or add points one by one.

I revised the code  (link to reply 23)  (http://www.theswamp.org/index.php?topic=19865.msg242560#msg242560), it has now two commands for two (quite) different behavior according to how a vertex is aligned.

Ppl: command removes all aligned (or on the same arc) vertex.
Cpl: keeps the vertex which are 'comming back' on the pline traject.

Somme pictures should tell more than my poor English.

(http://img207.imageshack.us/img207/2801/cplbi5.png)

 (http://img411.imageshack.us/img411/3931/cpl2mc1.png)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 13, 2007, 10:20:52 AM
gile,

You're more than welcome to whatever insights I *might* have provided. But I don't think the implications mean you should back off and use entmode rather than vlisp methods.

I will ry to post my code soon which demonstartes why I don't think it's needed.

Of course there's nothing wrong with entmod... other than it doesn't fit vlisp drift.

Regards
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 13, 2007, 07:25:38 PM
Added support for simplifying arc in the plines.
Code: [Select]
;;;=======================[ PSimple.lsp ]=======================
;;; Author: Charles Alan Butler
;;; Version:  1.2 Nov. 13, 2007
;;; Purpose: To remove unnecessary vertex from a pline
;;; Supports arcs and varying widths within the LWpolylines
;;;=============================================================

(defun c:PSimple (/ aa cpt dir doc elst ent hlst idx keep len newb result
                  v1 v2 v3 vlst x group_on dxf BulgeCenter)
  (vl-load-com)

  ;; CAB 11/03/07
  ;;  group on the elements of a flat list
  ;;  (group_on '(A B C D E F G) 3) --> ((A B C) (D E F) (G nil nil)...)
  (defun group_on (inplst gp# / outlst idx subLst)
    (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)
  )

  (defun dxf (key lst)(cdr(assoc key 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 idx 0)
      (repeat (fix (vlax-curve-getendparam ent))
        (cond
          ((null keep)
           (setq keep '(1)
                 dir  (angle '(0 0) (vlax-curve-getFirstDeriv ent 0.0))
           ))
          ((or (null(vlax-curve-getFirstDeriv ent idx))
               (equal dir (setq dir (angle '(0 0)
                             (vlax-curve-getFirstDeriv ent idx))) 0.000001))
           (setq keep (cons 0 keep))
          )
          ((setq keep (cons 1 keep)))
        )
        (setq idx (1+ idx))
      )
      (setq vlst (vl-remove-if-not
                   '(lambda (x) (vl-position (car x) '(40 41 42 10))) 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
          ;;  catch 2 arcs with same center pt
          ((and (< idx len)
                (not (zerop (cdr(cadddr (setq v1 (nth idx vlst))))))
                (setq v3 (nth (+ idx 2) vlst))
                (not (zerop (cdr(cadddr (setq v2 (nth (1+ idx) vlst))))))
                (equal (setq cpt (BulgeCenter (dxf 42 v1)(dxf 10 v1)(dxf 10 v2)))
                       (BulgeCenter (dxf 42 v2)(dxf 10 v2)(dxf 10 v3))
                       1e-4)
           )
           ;;  combine the arcs
           (setq aa (+ (* 4 (atan (abs (dxf 42 v1))))
                       (* 4 (atan (abs (dxf 42 v2)))))
                  newb (tan (/ aa 4.0)))
           (if (minusp (dxf 42 v1))
             (setq newb (- (abs newb)))
             (setq newb (abs newb))
           )
           (setq vlst (subst (list (car v1)   ; point
                                   (cadr v1)  ; Start Width
                                   (caddr v2) ; End Width
                                   (cons 42 newb) ; Bulge
                                   )
                             (nth (1+ idx) vlst) vlst))
          )
          ((or (not (zerop (cdr(cadddr (nth idx vlst))))) ; keep arcs
               (not (zerop (nth idx keep))))
            (setq result (cons (nth idx vlst) result))
          )
        )
      )

      (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)
    )
  )
  (vla-EndUndoMark doc)

  (princ)
)
(prompt "\nPline Simplify loaded, PSimple to run.")
(princ)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 14, 2007, 05:38:18 AM
Alan,

Given the original example file, try adding a vertex in the last segment of either of the closed plines. The code will miss the added vertex. I mention it because I had trouble with that too.

My routine also uses vlax-curve-getFirstDeriv.

Later... looks like gile's routine also misses the added vertex.

Later... on second thought, I may be wrong about this due to the method I used to add a vertex. It made the new vertex the first vertex.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 14, 2007, 08:53:53 AM
Joe,
On a Closed pline the start point is not removed even though it is not needed.
I'll look into that, thanks.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 14, 2007, 01:44:44 PM
Joe,
On a Closed pline the start point is not removed even though it is not needed.
I'll look into that, thanks.


Alan,

Yes, that's also an issue to consider.

It may go deeper than what you'd expect at first glance. If I draw a closed pline like your example, where the first point is inline with the second point and the point preceding the first point, and then I set the pline to not closed... guess what. The first point is not the first point anymore. It shifted to the point before the actual first point.

Seems to me this means it's problematic at best trying to determine where the first vertex really is. Which in turn leads me to think it may be easier to use some ugly kludge which explodes the pline, heals lines which can be healed, and then puts the pline back together using join.

What a horrible thought...  ;-)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 14, 2007, 01:56:38 PM
Maybe short sighted on my part but if it is a closed polyline what does it matter which is the first point?
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 16, 2007, 09:39:13 AM
Alan,

Agreed, it probably doesn't matter where the start point is within a closed pline in terms of how the user would interface with the object.

What I was trying to say in my last post, albeit poorly, was it may matter how you might attempt to deal the issue codewise per your last example. If typically the start point cannot be a collinear point, then your code should work without alteration. If otherwise, I think the code would have to look at the point before the first point and the point after in order to determine whether the first point should be removed since the firstderiv method doesn't look fowards and backwards.

Stepping back, I'm often reminded of Doug Broad's argument regarding the law of diminshing returns as it applies to code. Your code works well. Perfect isn't required, only desireable.  ;-)

BTW, I've worked on a facilities managment project where the integrity of existing plines was paramount because they are linked to a database. So explode, modify lines, and join would not work since the original pline handle would be lost.

Regards
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 17, 2007, 10:45:18 AM
Well said Joe, but I love a challenge.

This version will remove the first vertex if closed and first & last vertex are collinear or
arcs have the same center.
Code: [Select]
;;;=======================[ PSimple.lsp ]=======================
;;; Author: Charles Alan Butler
;;; Version:  1.3 Nov. 17, 2007
;;; Purpose: To remove unnecessary vertex from a pline
;;; Supports arcs and varying widths
;;;=============================================================
;;  This version will remove the first vertex if closed and first & last vertex are
;;  collinear or arcs have the same center.
(defun c:PSimple (/      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
          (setq d40 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 40)) elst)))
          (setq d41 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 41)) elst)))
          (setq d42 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) elst)))
          (setq plast (1- (length d10)))
          (if (setq closed (vlax-curve-isclosed ent))
            (setq p1 plast  p2 0  p3 1 )
            (setq p1 0  p2 1  p3 2)
          )
          (setq idx -1)
          (while (< (setq idx (1+ idx)) (if closed (1+ plast) plast))
            (cond
              ((and (equal (angle (nth p1 d10) (nth p2 d10))
                           (angle (nth p2 d10) (nth p3 d10)) 1e-6)
                    (zerop (nth p2 d42))
                    (or (= p1 plast)
                        (zerop (nth p1 d42)))
               )
               (setq remove (cons p2 remove))
               (setq p2 (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))
               (setq d42 (replace d42 p1 newb))
               (setq p2 (1+ p2)
                     p3 (if (= p3 plast) 0 (1+ p3))
               )
              )
              (t
               (setq p1 p2
                     p2 (1+ p2)
                     p3 (if (= p3 plast) 0 (1+ p3))
               )
              )
            )
          )
          (if remove
            (progn
              (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)
                                        (cons 40 x)(cons 41 y)
                                        (cons 42 z))) d10 d40 d41 d42)
              )
              (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)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 18, 2007, 11:31:11 AM
Hi Alan,

I haven't had a chance to test your latest code yet, but I will over the weekend.

I mentioned some messages back I was working on my own version. I put it on the back burner, waiting to see what you gile come up with. Both of you were ahead of me from the begining. So now maybe I'm just a beta tester.

Regards
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 18, 2007, 01:31:06 PM
Thanks Joe,
Let us know if you see a better way, or if you find any insects. 8-)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 20, 2007, 07:43:46 AM
Thanks Joe,
Let us know if you see a better way, or if you find any insects. 8-)

Hi Alan,

The new code solves the issue discussed recently for the most part.

Attached is an example file which shows it's not quite perfect yet. I'm almost hesitant to post it lest you think I'm nit-picking.

Regards
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 20, 2007, 08:34:42 PM
I'm glad you did post & thanks for the testing.
It always helps to have a second set of eyes.
Give this a spin when you get time.
Code: [Select]
;;;=======================[ PSimple.lsp ]=======================
;;; Author: Charles Alan Butler
;;; Version:  1.5 Nov. 20, 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 c:PSimple (/      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
          (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)))
          (setq plast (1- (length d10)))
          (setq p1 0  p2 1  p3 2)
          (setq closed (vlax-curve-isclosed ent))
          (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))
                        (equal (nth p2 d10) (nth p3 d10)))
                    (zerop (nth p2 d42))
                    (or (= p1 plast)
                        (zerop (nth p1 d42)))
               )
               (setq remove (cons p2 remove))
               (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))
               (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
              (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)
              )
              (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)

PS Sorry for the late reply. This was one of those rare days that I spent the entire day out of the office. 8-)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Kerry on November 20, 2007, 08:52:39 PM

Alan,

I'm compelled to publically applaud your untiring effort and unstinting generosity with the code you post and for your tenacity regarding assisting solving members problems here.

Regards,
Kerry.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: wizman on November 20, 2007, 11:13:29 PM
i agree kerry, i can say that CAB is not selfish with his codes thank you for that.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 20, 2007, 11:44:23 PM
Well thanks for the complement Kerry and you too Wizman. :-)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 21, 2007, 03:12:21 AM
Alan,

Using 2008, version 1.5 works with the closed (upper) pline but not with the open (lower) one in my example file.

Are you getting the same result?
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 21, 2007, 07:54:15 AM
Alan,

Something I tried while playing with my version. Pre-process the pline to remove duplicate adjacent points. Such a sub-function may not be as easy as it seems at first glance. But it may simplify the primary function significantly.

Just a thought...
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 21, 2007, 08:31:13 AM
Alan,

Using 2008, version 1.5 works with the closed (upper) pline but not with the open (lower) one in my example file.

Are you getting the same result?
Yes, same result & that is intentional.
In my way of thinking it would need to be a closed pline before meeting the criterion to simplify.
I suppose I may have missed that aspect in this discussion. If the pline is open as in the lower example would the desired result
be a closed pline or and open pline with the start/end vertexes at a corner?

Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 21, 2007, 09:52:02 AM
Quote
Yes, same result & that is intentional.
In my way of thinking it would need to be a closed pline before meeting the criterion to simplify.
I suppose I may have missed that aspect in this discussion. If the pline is open as in the lower example would the desired result
be a closed pline or and open pline with the start/end vertexes at a corner?

Alan,

I think the primary criterion to simplify is any collinear vertex should be removed. So the result with the plines in my example file should be the same in the sense there should be a selection grip at each corner and nowhere else.

Whether the closed pline ends up closed and the open pline ends up open doesn't really matter in the sense an attempt to edit/stretch any grip will behave the same... I think.

IOW, I don't think an open pline must remain open after simplify in this case.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 21, 2007, 02:23:26 PM
Here is what I came up with. It closes the pline when the start & end points are the same.
Had to deal with a case where the start & end segment are arcs on open plines.
This case has an ending vertex that has to be removed to get the two arcs to join.
Code: [Select]
;;;=======================[ 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 c:PSimple (/      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)

Title: Re: How do you simplify a LWPolyline vertex?
Post by: LE on November 21, 2007, 11:31:53 PM
...

PS: what you guys have done so far it is excellent - keep it that way!
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 22, 2007, 12:02:58 AM
Hello David.
Trying to run your routine ypu have missing subroutines.
dat_vtx
eqp1
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 22, 2007, 05:24:09 AM
Alan,

Version 1.6 is perfect. Nice work and many thanks.

I hope you agree with the recent changes.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 22, 2007, 08:45:57 AM
That was fine with me as I had no personal requirements.
I did revise the code above just now [ver 1.6], removing 3 lines of stray code from an earlier test version.
They did no harm but garbage none the less. 8-)

I suppose the only thing left to do is modify to except a selection set ILO single select.

Off to Ocala, see you Friday night.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: Joe Burke on November 22, 2007, 10:06:44 AM
Quote

I suppose the only thing left to do is modify to except a selection set ILO single select.


Alan,

I would change it to require an ename or vla-object argument so other functions can call it as need be. I'm not sure what it would return. Maybe the number vertices removed. If zero, the pline was not modified.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 24, 2007, 11:39:54 AM
Thanks David. I'll check it out.

Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on November 24, 2007, 11:40:35 AM
Here is my first run at the modified user interface.
Code: [Select]
;;;=======================[ PSimple.lsp ]=======================
;;; Author: Charles Alan Butler
;;; Version:  1.7 Nov. 24, 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

;;  command line entry, user selection set pick
(defun c:PSimple () (PSimpleUser nil)(princ))
(defun c:PSimpleV () ; Verbose version
  (mapcar '(lambda(x)(print (car x))(princ (cadr x))) (PSimpleUser nil))
  (princ)
)

;;  User interface Function
;;  flag = nil -> user selects a selection set
;;       = ENAME -> call the routine
;;       = OBJECT -> call the routine
;;       = True   -> User to select a single entity, repeats
(defun PSimpleUser (flag / ss ent)
  (cond
    ((null flag)    ; user selection set pick
     (prompt "\n Select polylines to remove extra vertex: ")
     (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
       (PSimple ss)
     )
    )
    ;;  next two already have an object so pass to the main routine
    ((= (type flag) 'ENAME) (PSimple flag))
    ((= (type flag) 'VLA-object) (PSimple flag))
    (t  ; user single pick with repeat
       (while
         (setq ent (car (entsel "\n Select polyline to remove extra vertex: ")))
          (if (equal (assoc 0 (entget ent)) '(0 . "LWPOLYLINE"))
            (PSimple ent)
            (prompt "\nNot a LWPolyline, Try again.")
          )
       )
    )
  )
)





;;;=======================[ PSimple.lsp ]=======================
;;; Author: Charles Alan Butler
;;; Version:  1.7 Nov. 23, 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
;; Open plines that have the same start & end point will be closed

;;  Argument: et
;;    may be an ename, Vla-Object, list of enames or
;;    a selection set
;;  Returns: a list, (ename message)
;;    Massage is number of vertex removed or error message string
;;    If a list or selection set a list of lists is returned
(defun PSimple (et / doc result Tan Replace BulgeCenter RemoveNlst ps1)
  (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)
    )
  )

  ;;  Main function to remove vertex
  ;;  ent must be an ename of a LWPolyline
  (defun ps1 (ent /      aa     cpt    dir    doc    elst   hlst   Remove
                  idx    keep   len    newb   result vlst   x      closed
                  d10    d40    d41    d42    hlst   p1     p2     p3
                  plast  msg)
      ;;=====================================================
      (setq elst (entget ent)
            msg  "")
      (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)
                    msg  " Closed and")
              (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
              (setq count (length d10))
              ;; 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))
              (if (entmod hlst); return ename and number of vertex removed
                (list ent (strcat msg " Vertex removed " (itoa(- count (length d10)))))
                (list ent " Error, may be on locked layer.")
              )
            )
            (list ent "Nothing to remove - no colenier vertex.")
          )
        )
        (list ent "Nothing to do - Only two vertex.")
      )
    )
 

  ;;  ========  S T A R T   H E R E  ===========
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (cond
    ((or (=(type et) 'ENAME)
         (and (=(type et) 'VLA-object)
              (setq et (vlax-vla-object->ename et))))
      (vla-startundomark doc)
      (setq result (ps1 et))
      (vla-endundomark doc)
     )
    ((= (type et) 'PICKSET)
      (vla-startundomark doc)
      (setq result (mapcar '(lambda(x) (ps1 x))
              (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
      (vla-endundomark doc)
    )
    ((listp et)
      (vla-startundomark doc)
      (setq result (mapcar '(lambda(x) (ps1 x)) et))
      (vla-endundomark doc)
    )
    ((setq result "PSimple Error - Wrong Data Type."))
  )
  result
)
(prompt "\nPline Simplify loaded, PSimple to run.")
(princ)

Title: Re: How do you simplify a LWPolyline vertex?
Post by: LE on November 24, 2007, 11:59:07 AM
Alan,

Your routine, does a great job.... I am removing the one I posted, it is super mickey mouse, compared with this one.    :-)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: MP on November 24, 2007, 12:05:21 PM
I am removing the one I posted ...

Please stop doing that already!
Title: Re: How do you simplify a LWPolyline vertex?
Post by: gile 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 (http://www.theswamp.org/index.php?topic=19865.msg242742#msg242742) PPL behavior)

- it keeps the vertex which mark a break in width regularity (see the picture on reply #15 (http://www.theswamp.org/index.php?topic=19865.msg242485#msg242485))

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)
Title: Re: How do you simplify a LWPolyline vertex?
Post by: ribarm 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.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: xxfaxx 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.

Title: Re: How do you simplify a LWPolyline vertex?
Post by: CAB on May 31, 2018, 03:06:51 PM
Welcome to the Swamp.Glad you found the forums it useful.
Title: Re: How do you simplify a LWPolyline vertex?
Post by: ahsattarian 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. )