PLdiet lisp which works fine in autocad wont work in IntelliCad

#1
I have a polyline which I want to make smooth by reducing it vertices.I have drawing with a polyline containing vertices over 5000 vertices in it .Pldiet lisp works fine for that drawing in Autocad but in IntelliCad it crashes for that drawing. In IntelliCad it only work for polyline which has vertices less than 2000. This is the Pldiet.lisp developed by Kent Cooper.

Code: Select all

;;;  PLDIET.lsp [command name: PLD]
;;;  To put lightweight PolyLines on a DIET (remove excess vertices); usually
;;;    used for contours with too many too-closely-spaced vertices.
;;;  Concept from PVD routine [posted on AutoCAD Customization Discussion
;;;    Group by oompa_l, July 2009] by Brian Hailey, added to by CAB, and
;;;    WEED and WEED2 routines by Skyler Mills at Cadalyst CAD Tips [older
;;;    routines for "heavy" Polylines that won't work on newer lightweight ones];
;;;    simplified in entity data list processing, and enhanced in other ways [error
;;;    handling, default values, join collinear segments beyond max. distance,
;;;    limit to current space/tab, account for change in direction across 0 degrees,
;;;    option to keep or eliminate arc segments] by Kent Cooper, August 2009.
;
(defun C:PLD
  (/ *error* cmde disttemp cidtemp arctemp plinc plsel pldata
  ucschanged front 10to42 vinc verts vert1 vert2 vert3)
;
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort"))
      (princ (strcat "\nError: " errmsg))
    ); end if
    (if ucschanged (command "_.ucs" "_prev"))
      ; ^ i.e. don't go back unless routine reached UCS change but didn't change back
    (command "_.undo" "_end")
    (setvar 'cmdecho cmde)
  ); end defun - *error*
;
  (setq cmde (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (command "_.undo" "_begin")
  (setq
    disttemp
      (getdist
        (strcat
          "\nMaximum distance between non-collinear vertices to straighten"
          (if *distmax* (strcat " <" (rtos *distmax* 2 2) ">") ""); default only if not first use
          ": "
        ); end strcat
      ); end getdist & disttemp
    *distmax*
      (cond
        (disttemp); user entered number or picked distance
        (T *distmax*); otherwise, user hit Enter - keep value
      ); end cond & *distmax*
    cidtemp
      (getangle
        (strcat
          "\nMaximum change in direction to straighten"
          (strcat ; offer prior choice if not first use; otherwise 15 degrees
            " <"
            (if *cidmax* (angtos *cidmax*) (angtos (/ pi 12)))
            ">"
          ); end strcat
          ": "
        ); end strcat
      ); end getdist & cidtemp
    *cidmax*
      (cond
        (cidtemp); user entered number or picked angle
        (*cidmax*); Enter with prior value set - use that
        (T (/ pi 12)); otherwise [Enter on first use] - 15 degrees
      ); end cond & *cidmax*
    plinc 0 ; incrementer through selection set of Polylines
  ); end setq
  (initget "Retain Straighten")
  (setq
    arctemp
      (getkword
        (strcat
          "\nRetain or Straighten arc segments [R/S] <"
          (if *arcstr* (substr *arcstr* 1 1) "S"); at first use, S default; otherwise, prior choice
          ">: "
        ); end strcat
      ); end getkword
    *arcstr*
      (cond
        (arctemp); if User typed something, use it
        (*arcstr*); if Enter and there's a prior choice, keep that
        (T "Straighten"); otherwise [Enter on first use], Straighten
      ); end cond & *arcstr*
  ); end setq
;
  (prompt "\nSelect LWPolylines to put on a diet, or press Enter to select all: ")
  (cond
    ((setq plsel (ssget '((0 . "LWPOLYLINE"))))); user-selected Polylines
    ((setq plsel (ssget "X" (list '(0 . "LWPOLYLINE") (cons 410 (getvar 'ctab))))))
      ; all Polylines [in current space/tab only]
  ); end cond
;
  (repeat (sslength plsel)
    (setq pldata (entget (ssname plsel plinc)))
    (if (/= (cdr (last pldata)) (trans '(0 0 1) 1 0)); extr. direction not parallel current CS
        ; for correct angle & distance calculations [projected onto current construction
        ; plane], since 10-code entries for LWPolylines are only 2D points:
      (progn
        (command "_.ucs" "_new" "_object" (ssname plsel plinc)) ; set UCS to match object
        (setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't
      ); end progn
    ); end if
    (setq
      front ; list of "front end" [pre-vertices] entries, minus entity names & handle
        (vl-remove-if
          '(lambda (x)
            (member (car x) '(-1 330 5 10 40 41 42 210))
          ); end lambda
          pldata
        ); end removal & front
      10to42 ; list of all code 10, 40, 41, 42 entries only
        (vl-remove-if-not
          '(lambda (x)
            (member (car x) '(10 40 41 42))
          ); end lambda
          pldata
        ); end removal & 10to42
      vinc (/ (length 10to42) 4); incrementer for vertices within each Polyline
      verts nil ; eliminate from previous Polyline [if any]
    ); end setq
    (if (= *arcstr* "Straighten")
      (progn
        (setq bulges ; find any bulge factors
          (vl-remove-if-not
            '(lambda (x)
              (and
                (= (car x) 42)
                (/= (cdr x) 0.0)
              ); end and
            ); end lambda
            10to42
          ); end removal & bulges
        ); end setq
        (foreach x bulges (setq 10to42 (subst '(42 . 0.0) x 10to42)))
          ; straighten all arc segments to line segments
      ); end progn
    ); end if
    (repeat vinc
      (setq
        verts ; sub-group list: separate list of four entries for each vertex
          (cons
            (list
              (nth (- (* vinc 4) 4) 10to42)
              (nth (- (* vinc 4) 3) 10to42)
              (nth (- (* vinc 4) 2) 10to42)
              (nth (1- (* vinc 4)) 10to42)
            ); end list
            verts
          ); end cons & verts
        vinc (1- vinc) ; will be 0 at end
      ); end setq
    ); end repeat
    (while (nth (+ vinc 2) verts); still at least 2 more vertices
      (if
        (or ; only possible if chose to Retain arc segments
          (/= (cdr (assoc 42 (nth vinc verts))) 0.0); next segment is arc
          (/= (cdr (assoc 42 (nth (1+ vinc) verts))) 0.0); following segment is arc
        ); end or
        (setq vinc (1+ vinc)); then - don't straighten from here; move to next
        (progn ; else - analyze from current vertex
          (setq
            vert1 (cdar (nth vinc verts)) ; point-list location of current vertex
            vert2 (cdar (nth (1+ vinc) verts)); of next one
            vert3 (cdar (nth (+ vinc 2) verts)); of one after that
            ang1 (angle vert1 vert2)
            ang2 (angle vert2 vert3)
          ); end setq
          (if
            (or
              (equal ang1 ang2 0.0001); collinear, ignoring distance
              (and
                (<= (distance vert1 vert3) *distmax*)
                  ; straightens if direct distance from current vertex to two vertices later is
                  ; less than or equal to maximum; if preferred to compare distance along
                  ; Polyline through intermediate vertex, replace above line with this:
                  ; (<= (+ (distance vert1 vert2) (distance vert2 vert3)) *distmax*)
                (<=
                  (if (> (abs (- ang1 ang2)) pi); if difference > 180 degrees
                    (+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2)))
                      ; then - compensate for change in direction crossing 0 degrees
                    (abs (- ang1 ang2)); else - size of difference
                  ); end if
                  *cidmax*
                ); end <=
              ); end and
            ); end or
            (setq verts (vl-remove (nth (1+ vinc) verts) verts))
              ; then - remove next vertext, stay at current vertex for next comparison
            (setq vinc (1+ vinc)); else - leave next vertex, move to it as new base
          ); end if - distance & change in direction analysis
        ); end progn - line segments
      ); end if - arc segment check
    ); end while - working through vertices
    (setq
      front (subst (cons 90 (length verts)) (assoc 90 front) front)
        ; update quantity of vertices for front end
      10to42 nil ; clear original set
    ); end setq
    (foreach x verts (setq 10to42 (append 10to42 x)))
      ; un-group four-list vertex sub-lists back to one list of all 10, 40, 41, 42 entries
    (setq pldata (append front 10to42 (list (last pldata))))
      ; put front end, vertex entries and extrusion direction back together
    (entmake pldata)
    (entdel (ssname plsel plinc)); remove original
    (setq plinc (1+ plinc)); go on to next Polyline
    (if ucschanged
      (progn
        (command "_.ucs" "_prev")
        (setq ucschanged nil) ; eliminate UCS reset in *error* since routine did it already
      ); end progn
    ); end if - UCS reset
  ); end repeat - stepping through set of Polylines
  (command "_.undo" "_end")
  (setvar 'cmdecho cmde)
  (princ)
); end defun - PLD
(prompt "\nType PLD to put PolyLines on a Diet.")

Re: PLdiet lisp which works fine in autocad wont work in IntelliCad

#3
Hi Vik,
I've made some modify of the lisp routine PLD then it works in IntelliCad now .
Please have a try.
Regards.

Code: Select all

;| PLDIET.lsp [command name: PLD]
To put lightweight PolyLine(s) on a DIET (remove excess vertices); usually used for
  contour lines with more too-closely-spaced vertices than necessary, but applicable
  for other purposes, such as to simplify a many-sided polygon to fewer sides.
Asks User for max. distance between non-collinear vertices, and max. change in
  direction, to straighten [i.e. remove vertices between], and whether to straighten arc
  segments to line segments.  No initial default max. length-to-straighten value on first
  use; initial default max. bend-to-straighten: 15 degrees; initial default for arc
  segments: Straighten.  Remembers choices; offers as defaults on subsequent use.
  [Search for   ;; EDIT   below to find locations to change first-use defaults.]
Removes all intermediate vertices through collinear stretches, regardless of max.
  length-to-straighten setting.
Note that removal of vertex at bend changes angle of combined segment, which
  changes comparison of change-in-direction to next segment.  Example: In regular
  dodecagon, change in direction between segments is 30 degrees, so setting at least
  that large will remove vertices.  When given vertex is removed, next change-in-
  direction comparison will be between new, longer, straightened segment and next
  shorter original one, which will now be 45 degrees.  If intent is to keep every third
  vertex [change dodecagon to square], in order to remove that next vertex, change in
  direction setting must allow for 45 degrees, not just 30 degrees of original shape's
  changes in direction.
Concept from PVD routine by Brian Hailey [posted on AutoCAD Customization
  Forum by oompa_l, July 2009], added to by CAB, and WEED and WEED2 routines
  by Skyler Mills at Cadalyst CAD Tips [older routines for "heavy" Polylines that don't
  work on newer lightweight ones]; simplified in entity data list processing, and
  enhanced in other ways [error handling, default values, join collinear segments
  beyond max. distance, limit to current space/tab, account for change in direction
  across 0 degrees, option to keep or eliminate arc segments, forbid locked Layers].
Variable names surrounded by :colons: and beginning with :PLD are global for
  subsequent defaults.
[Note:  Written for new-enough versions that LWPolyline entity data contains (91 . ...)
  entry for each vertex.  As of Acad 2019, those are always (91 . 0), but if usage changes
  in future version and they can differ, may need to adjust this routine.  Also for new-
  enough versions to have (command-s) function, for UCS reset in *error*.]
Kent Cooper, last edited 30 October 2019
|;

(defun C:PLD ; = PolyLine Diet
  (/ *error* modPL doc svn svv pldss n pl pldata front
  10to91 vinc closed verts bulges ucsch v1 v2 v3 ang1 ang2)

  (setq maxVertices 400)
  
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
      ); if
    (if ucsch (command-s "_.ucs" "_previous"))
      ; i.e. don't go back unless routine reached UCS change but didn't change back
    (mapcar 'setvar svn svv)
    (vla-endundomark doc)
  ); defun -- *error*

  (defun modPL ()
    (setq
      front (subst (cons 90 (length verts)) (assoc 90 front) front)
        ; update quantity of vertices for front end
      10to91 nil ; clear original set
    ); setq
    (foreach x verts (setq 10to91 (append 10to91 x)))
      ; un-group five-list vertex sub-lists back to one list of all 10, 40, 41, 42, 91 entries
    (setq pldata (append front 10to91 (list (last pldata))))
      ; put front end, vertex entries and extrusion direction back together
    (entmod pldata)
  ); defun -- modPL
  
  (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
  (setq
    svn '(cmdecho ucsfollow); = System Variable Names
    svv (mapcar 'getvar svn); = System Variable Values
  ); setq
  (mapcar 'setvar svn '(0 0)); turn off command echoing, UCS following
  (initget (if :PLDdist: 6 7)); no zero, no negative, no Enter on first use
  (setq
    :PLDdist:
    (cond
      ( (getdist
          (strcat
            "\nMaximum distance between non-collinear vertices to straighten"
            (if :PLDdist: (strcat " <" (rtos :PLDdist:) ">") ""); default after first use
            ": "
          ); strcat
        ); getdist
      ); User-input condition
      (:PLDdist:); on Enter [when permitted] -- keep prior value
    ); cond & :PLDdist:
  ); setq
  (initget 6); no zero, no negative
  (setq
    :PLDcid:
    (cond
      ( (getangle
          (strcat
            "\nMaximum change in direction to straighten <"
            (angtos (cond (:PLDcid:) ((/ pi 12)))) ;; EDIT for different initial default
              ; prior choice if present; otherwise 15 degrees
            ">: "
          ); strcat
        ); getangle
      ); User-input condition
      (:PLDcid:); on Enter with prior value -- keep it
      ((/ pi 12)); otherwise [Enter on first use] -- 15 degrees
        ;; EDIT for different initial default
    ); cond & :PLDcid:
  ); setq
  (initget "Retain Straighten")
  (setq :PLDarc:
    (cond
      ( (getkword
          (strcat
            "\nRetain or Straighten arc segments [Retain/Straighten] <"
            (if :PLDarc: (substr :PLDarc: 1 1) "S"); prior default if present, otherwise S
              ;; EDIT for different initial default ["R"]
            ">: "
          ); strcat
        ); getkword
      ); User-input condition    
      (:PLDarc:); on Enter with prior choice -- keep that
      ("Straighten"); Enter on first use ;; EDIT for different initial default ["Retain"]
    ); cond & :PLDarc:
  ); setq
  
  (prompt "\nTo put LWPolyline(s) on a diet {All option available},")
  (if (setq pldss (ssget (list (cons 0 "LWPOLYLINE") )))
    (progn ; then
      (repeat (setq n (sslength pldss))
	(setq ent (ssname pldss (setq n (1- n)))
	      plLst (BreakPline ent maxVertices)); break to plines with smaller vertices
	(setq ss (ssadd ))
	(foreach pl plLst
	  (setq
	    pldata (entget pl)	  

	    front ; list of "front end" [other-than-vertex] entries, also minus extr. dir.
	     (vl-remove-if
	       '(lambda (x)
		  (member (car x) '(10 40 41 42 91 210))
		  ); lambda
	       pldata
	       ); remove & front
	    10to91 ; list of all code 10, 40, 41, 42, 91 entries only
	     (vl-remove-if-not '(lambda (x) (member (car x) '(10 40 41 42 91))) pldata)
	    vinc (/ (length 10to91) 5); incrementer for vertices within each Polyline
	    ;          closed (vlax-curve-isClosed pl)
	    closed (= 1 (cdr (assoc 70 pldata)) )
	    verts nil ; eliminate from previous Polyline [if any]
	    ); setq
	  (if (= :PLDarc: "Straighten")
	    (progn
	      (setq bulges ; find any non-zero bulge factors [= arc segments]
		     (vl-remove-if-not
		       '(lambda (x)
			  (and
			    (= (car x) 42)
			    (/= (cdr x) 0.0)
			    ); and
			  ); lambda
		       10to91
		       ); removal & bulges
		    ); setq
	      (foreach x bulges (setq 10to91 (subst '(42 . 0.0) x 10to91)))
	      ; straighten all arc segments to line segments
	      ); progn
	    ); if
	  (repeat vinc
	    (setq
	      verts ; sub-group list: separate lists of five entries for each vertex
	       (cons
                (list
                  (nth (- (* vinc 5) 5) 10to91); 10
                  (nth (- (* vinc 5) 4) 10to91); 40
                  (nth (- (* vinc 5) 3) 10to91); 41
                  (nth (- (* vinc 5) 2) 10to91); 42
                  (nth (1- (* vinc 5)) 10to91); 91
		  ); list
		verts
		); cons & verts
	      vinc (1- vinc) ; will be 0 at end
	      ); setq
	    ); repeat
	  (while (equal (caar verts) (caadr verts) 1e-6) (setq verts (cdr verts)))
	  ; eliminate possible coincident vertices at beginning, which would
          ; mean Pline does not define a CS under UCS OBject, causing error
	  (modPL); to re-establish pldata
	  (if (/= (cdr (assoc 210 pldata)) (trans '(0 0 1) 1 0)); extr. dir. not parallel current CS
          ; for correct angle & distance calculations [projected onto current construction
          ; plane], since 10-code entries for LWPolylines are only 2D points:
	    (progn
	      (command "_.ucs" "_new" "_object" pl) ; set UCS to match object
	      (setq ucsch T) ; marker for *error* to reset UCS if routine doesn't
	      ); progn
	    ); if
	  (while (nth (+ vinc (if closed 1 2)) verts)
	    (if
	      (or ; only possible if chose to Retain arc segments
		(/= (cdr (assoc 42 (nth vinc verts))) 0.0); next segment is arc
		(/= (cdr (assoc 42 (nth (1+ vinc) verts))) 0.0); following segment is arc
		); or
	      (setq vinc (1+ vinc)); then -- don't straighten from here; move to next
	      (progn ; else -- analyze from current vertex
		(setq
		  v1 (cdar (nth vinc verts)) ; point-list location of current vertex
		  v2 (cdar (nth (1+ vinc) verts)); of next one
		  v3 (cdar (nth (if (and closed (= (+ vinc 2) (length verts))) 0 (+ vinc 2)) verts))
                  ; of second one after current, or of start if closed and at end
		  ang1 (angle v1 v2)
		  ang2 (angle v2 v3)
		  ); setq
		(if
		  (or
		    (equal ang1 ang2 1e-4); collinear [ignoring distance]
		    (and
		      (<= (distance v1 v3) :PLDdist:) ; EDIT if desired:
                      ; straightens if direct distance from current vertex to two vertices later,
                      ; ignoring any bend, is less than or equal to maximum; if preferred to
                      ; compare distance along Polyline through intermediate vertex,
                      ; replace above line with this:
                      ;   (<= (+ (distance v1 v2) (distance v2 v3)) :PLDdist:)
		      (<=
			(if (> (abs (- ang1 ang2)) pi); if difference > 180 degrees
			  (+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2)))
                          ; then -- compensate for change in direction crossing 0 degrees
			  (abs (- ang1 ang2)); else -- size of difference
			  ); if
			:PLDcid:
			); <=
		      ); and
		    ); or
		  (setq verts (vl-remove (nth (1+ vinc) verts) verts))
                  ; then -- remove next vertex, stay at current vertex for next comparison
		  (setq vinc (1+ vinc)); else -- leave next vertex, move to it as new base
		  ); if -- distance & change in direction analysis
		); progn -- line segments
	      ); if -- arc segment check
	    ); while -- working through vertices
	  (modPL)
	  (if ucsch
	    (progn
	      (command "_.ucs" "_previous")
	      (setq ucsch nil); eliminate UCS reset in *error* since routine did it already
	      ); progn
	    ); if -- UCS reset

	  (ssadd pl ss)
	  )
	
	; join to Polyline
	(if(> (sslength ss) 1)
	  (command "Pedit" "m" ss "" "J" "" "X" ""))	

	); repeat -- step through set of Polylines

      (princ "\nDone.")
      ); progn [then -- selection]
    (prompt "\nNo Polyline(s) selected."); else
    ); if

  (mapcar 'setvar svn svv)
  (vla-endundomark doc)
  (princ)
); defun -- C:PLD


(defun CoordinatesOfPline ( ent / edata pt)
  (setq edata (entget ent))
  (setq lst (list))
  (foreach it edata
    (if (= (car it) 10 )
      (setq lst (cons (cdr it) lst))
      )
    )
  (reverse lst)
  )

(defun GetLastEnt ( / ename result )
  (if (setq result (entlast))
    (while (setq ename (entnext result))
      (setq result ename)
      )
    )
  result
  )

(defun BreakPline(ent maxVertices / pt)
  (setq coors (CoordinatesOfPline ent)
	)
  (setq res (list ent))
  (if (> (length coors) (* 2 maxVertices))
    (progn
      (setq breakPtLst (list) i maxVertices)
      (while (< i (-(length coors) (* maxVertices 0.2)))
	(setq breakPtLst (cons (nth i coors) breakPtLst)
	      i (+ i maxVertices)) )
      (setq lastEnt (GetLastEnt))
      (foreach pt breakPtLst
	(command "break" ent "_non" (trans pt 0 1) "_non" (trans pt 0 1))
	(if (not (equal LastEnt (entlast)))
	  (setq lastEnt (entlast)
		res (cons lastEnt res)) )
	)
      )
    )
  res
  )


(vl-load-com)
(prompt "\nType PLD to put PolyLine(s) on a Diet.")