Jump to content

Alternating poly line trim routine. (edit of previous lisp)

Jamesclark64

By Jamesclark64
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Jamesclark64 Explorer

Jamesclark64

Posted
Posted (edited)

A while back I asked for some help with a routine that could trim unwanted segments of a poly line. 

original post:

 

 

Steven P came up with a solution that works perfectly. However I've been trying to make a second version that deletes every third section of the poly line.(example below) but haven't had any luck😢any help would be greatly appreciated.

example4.jpg

 

(Edit) Steven P original code: 

(defun c:oddeven ( / MyPoly MyEnt acount tenslist removelist n)
  ;;SubFunctions
  (defun LM:RemoveNth ( n l ) ;;Refer to Lee Macs website
    (if (and l (< 0 n))
        (cons (car l) (LM:RemoveNth (1- n) (cdr l)))
        (cdr l)
    )
  )
  ;;end subfunctions

  (setq MyPoly (car (entsel "\nSelect Polyline")))   ;;Select a polyline
  (if (or (= MyPoly nil) 
          (/= (cdr (assoc 0 (entget MyPoly))) "LWPOLYLINE")
      ) ; endor                                      ;;If no polyline selected
    (princ "\nPolyline not selected")                ;;error message 'no polyline'
    (progn                                           ;;If Polyline
      (setq MyEnt (entget MyPoly))                   ;;Get line definition entity codes
      (setq acount 0)                                ;;A counter
      (setq tenslist (list))                         ;;Blank list for the coordinates
      (while (< acount (length MyEnt))               ;;Get list of coordinate positions
        (if (= (car (nth acount MyEnt)) 10)          ;;Loop through list, if assoc code 10 record its position
          (setq tenslist (append tenslist (list acount)))
        )
        (setq acount (+ acount 1))
       ) ; end while                                 ;;End loop

      (setq acount 0)                                ;;reset counter
      (while (< acount (length tenslist))            ;;Loop the number of vertices
        (setq removelist (LM:RemoveNth (+ acount 1) tenslist)) ;;Remove vertex acount + 1 position from list
        (setq removelist (LM:RemoveNth acount removelist))     ;;Remove vertex acount position from list
        (setq MyEnt (entget MyPoly))
        (foreach n (reverse removelist)              ;;remove the remaining vertext position from entity definition
          (setq MyEnt (LM:RemoveNth n MyEnt))
        )
        (entmakex MyEnt)                             ;;Make a new polyline using acount, acount + 1 positions
        (setq acount (+ acount 2))
      ) ; end while                                  ;;end loop
    ) ; end progn
  )
  (entdel MyPoly)                                    ;;Delete original line
  (princ)
)

 

Edited by Jamesclark64
Link to comment
Share on other sites
Steven P Grand Master

Steven P

Posted
Posted

I think make this line: 

(setq acount (+ acount 2))

 

to 

(setq acount (+ acount 3))

 

Link to comment
Share on other sites
Steven P Grand Master

Steven P

Posted
Posted

I'll check next week (if I remember, if not remind me), I think adding a 'remove every nth' user control would make this more versatile and maybe better?

Link to comment
Share on other sites
Tsuky Community Regular

Tsuky

Posted
Posted

@Jamesclark64

This can do the job? 

(vl-load-com)
(defun cut@point (ss lst_pt / n ename dxf_10 rtn_ss pt_brk lst_brk lst_sort dxf_obj dxf_43 dxf_38 dxf_39 dxf_10 dxf_40 dxf_41 dxf_42 dxf_210 ltmp lst_tmp where count nwent indx)
  (repeat (setq n (sslength ss))
    (setq
      ename (ssname ss (setq n (1- n)))
      dxf_10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ename)))
      rtn_ss (ssadd)
    )
    (foreach el (mapcar '(lambda (x) (trans x 0 ename)) lst_pt)
      (setq
        pt_brk el
        lst_brk (cons el lst_brk)
      )
    )
    (setq
      lst_sort (mapcar '(lambda (x) (list (vlax-curve-GetDistAtPoint ename (trans x ename 0)) (list (car x) (cadr x)))) lst_brk)
      lst_brk (reverse (mapcar 'cadr (mapcar '(lambda (x) (assoc x lst_sort)) (vl-sort (mapcar 'car lst_sort) '<))))
      dxf_obj (entget ename)
    )
    (if (cdr (assoc 43 dxf_obj))
      (setq dxf_43 (cdr (assoc 43 dxf_obj)))
      (setq dxf_43 0.0)
    )
    (if (cdr (assoc 38 dxf_obj))
      (setq dxf_38 (cdr (assoc 38 dxf_obj)))
      (setq dxf_38 0.0)
    )
    (if (cdr (assoc 39 dxf_obj))
      (setq dxf_39 (cdr (assoc 39 dxf_obj)))
      (setq dxf_39 0.0)
    )
    (setq
      dxf_10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_obj))
      dxf_40 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 40)) dxf_obj))
      dxf_41 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 41)) dxf_obj))
      dxf_42 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) dxf_obj))
      dxf_210 (cdr (assoc 210 dxf_obj))
    )
    (if (not (zerop (boole 1 (cdr (assoc 70 dxf_obj)) 1)))
      (setq
        dxf_10 (append dxf_10 (list (car dxf_10)))
        dxf_40 (append dxf_40 (list (car dxf_40)))
        dxf_41 (append dxf_41 (list (car dxf_41)))
        dxf_42 (append dxf_42 (list (car dxf_42)))
      )
    )
    (repeat (1+ (length lst_brk))
      (setq
        ltmp nil
        lst_tmp (vl-member-if '(lambda (x) (and (equal (car x) (caar lst_brk) 1E-08) (equal (cadr x) (cadar lst_brk) 1E-08))) dxf_10)
        where (if lst_tmp (vl-position (car lst_tmp) dxf_10) 0)
      )
      (repeat (setq count (- (length dxf_10) where))
        (setq ltmp (cons (mapcar '(lambda (x y) (cons y (nth where x))) (list dxf_10 dxf_40 dxf_41 dxf_42) (list 10 40 41 42)) ltmp))
        (setq where (1+ where))
      )
      (entmake
        (append
          (list
            (cons 0 "LWPOLYLINE")
            (cons 100 "AcDbEntity")
            (assoc 67 dxf_obj)
            (assoc 410 dxf_obj)
            (assoc 8 dxf_obj)
            (if (assoc 62 dxf_obj) (assoc 62 dxf_obj) (cons 62 256))
            (if (assoc 6 dxf_obj) (assoc 6 dxf_obj) (cons 6 "BYLAYER"))
            (if (assoc 370 dxf_obj) (assoc 370 dxf_obj) (cons 370 -1))
            (cons 100 "AcDbPolyline")
            (cons 90 (length ltmp))
            (cons 70 (boole 1 (cdr (assoc 70 dxf_obj)) 128))
            (cons 38 dxf_38)
            (cons 39 dxf_39)
          )
          (apply 'append (reverse ltmp))
          (list (cons 210 dxf_210))
        )
      )
      (repeat (1- count)
        (setq
          dxf_10 (reverse (cdr (reverse dxf_10)))
          dxf_40 (reverse (cdr (reverse dxf_40)))
          dxf_41 (reverse (cdr (reverse dxf_41)))
          dxf_42 (reverse (cdr (reverse dxf_42)))
        )
      )
      (setq lst_brk (cdr lst_brk) ltmp nil nwent (entlast) rtn_ss (ssadd nwent rtn_ss))
    )
    (setq indx (1- (sslength rtn_ss)))
    (repeat (sslength rtn_ss)
      (if (eq (boole 1 indx 1) 1)
        (entdel (ssname rtn_ss indx))
      )
      (setq indx (1- indx))
    )
    (entdel ename)
  )
)
(defun c:altern_poly ( / ss n ss_save ent dxf_ent lst_pt brk_pt)
  (while (not (setq ss (ssget '((0 . "LWPOLYLINE"))))))
  (repeat (setq n (sslength ss))
    (setq
      ss_save (ssadd)
      ent (ssname ss (setq n (1- n)))
      ss_save (ssadd ent ss_save)
      dxf_ent (entget ent)
      lst_pt (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) dxf_ent))
    )
    (if (equal (append (car lst_pt) (list (getvar "ELEVATION"))) (vlax-curve-getendpoint ent) 1E-08)
      (setq lst_pt (append lst_pt (list (car lst_pt))))
    )
    (if (>= (length lst_pt) 3)
      (progn
        (setq brk_pt nil)
        (while (and lst_pt (cadddr lst_pt))
          (setq
            brk_pt (cons (caddr lst_pt) brk_pt)
            lst_pt (cdddr lst_pt)
            brk_pt (cons (car lst_pt) brk_pt)
          )
        )
        (if (eq (boole 1 (cdr (assoc 70 dxf_ent)) 1) 1) (setq brk_pt (cdr brk_pt)))
        (cut@point ss_save brk_pt)
      )
    )
  )
  (prin1)
)

 

  • Like 1
Link to comment
Share on other sites
Steven P Grand Master

Steven P

Posted
Posted 
(defun c:oddeven ( / MyPoly MyEnt acount tenslist removelist n)
  ;;SubFunctions
  (defun LM:RemoveNth ( n l ) ;;Refer to Lee Macs website
    (if (and l (< 0 n))
        (cons (car l) (LM:RemoveNth (1- n) (cdr l)))
        (cdr l)
    )
  )
  ;;end subfunctions

  (setq Remove (getint "Remove every nth Line: "))
  (if (= Remove 1)(princ "Are you sure, this will remove every line (delete polyline)?")


  (setq MyPoly (car (entsel "\nSelect Polyline"))) ;;Select a polyline
  (if (or (= MyPoly nil) 
          (/= (cdr (assoc 0 (entget MyPoly))) "LWPOLYLINE")
      ) ; endor                                    ;;If no polyline selected
    (princ "\nPolyline not selected")              ;;error message 'no polyline'
    (progn                                         ;;If Polyline
      (setq MyEnt (entget MyPoly))                 ;;Get line definition entity codes
      (setq acount 0)                              ;;A counter
      (setq tenslist (list))                       ;;Blank list for the coordinates
      (while (< acount (length MyEnt))             ;;Get list of coordinate positions
        (if (= (car (nth acount MyEnt)) 10)        ;;Loop through list, if assoc code 10 record its position
          (setq tenslist (append tenslist (list acount)))
        )
        (setq acount (+ acount 1))
       ) ; end while                               ;;End loop

      (setq acount 0)                              ;;reset counter
      (while (< acount (length tenslist))          ;;Loop the number of vertices

        (setq removelist tenslist)                 ;;List of vertexes to remove
        (setq counter (- Remove 1))                ;;A counter, remember 1st is zero
        (while (> counter -1)                      ;;Loop remove vertex list
        (setq removelist (LM:RemoveNth (+ acount counter) removelist))  ;;Remove vertex acount position from list
        (setq counter (- counter 1))
        ) ; end while

        (setq MyEnt (entget MyPoly))
        (foreach n (reverse removelist)            ;;remove the remaining vertext position from entity ;definition
          (setq MyEnt (LM:RemoveNth n MyEnt))
        )
        (entmakex MyEnt)                           ;;Make a new polyline using acount, acount + 1 positions
        (setq acount (+ acount Remove))
      ) ; end while                                ;;end loop
    ) ; end progn
  )
  (entdel MyPoly)                                  ;;Delete original line
  (princ)
)

 

Try this, command is oddeven again, and this version will ask which single vertex to remove (as above, delete every 3rd, or in the original every other, or even every 100th)

 

 

 

Suppose it could even be altered to add "start vertex" and "number of vertex to remove" but that isn't for a Sunday night though

 

Link to comment
Share on other sites
Jamesclark64 Explorer

Jamesclark64

Posted
  • Author
Posted
On 03/03/2024 at 03:40, Tsuky said:

@Jamesclark64

This can do the job? 

(vl-load-com)
(defun cut@point (ss lst_pt / n ename dxf_10 rtn_ss pt_brk lst_brk lst_sort dxf_obj dxf_43 dxf_38 dxf_39 dxf_10 dxf_40 dxf_41 dxf_42 dxf_210 ltmp lst_tmp where count nwent indx)
  (repeat (setq n (sslength ss))
    (setq
      ename (ssname ss (setq n (1- n)))
      dxf_10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ename)))
      rtn_ss (ssadd)
    )
    (foreach el (mapcar '(lambda (x) (trans x 0 ename)) lst_pt)
      (setq
        pt_brk el
        lst_brk (cons el lst_brk)
      )
    )
    (setq
      lst_sort (mapcar '(lambda (x) (list (vlax-curve-GetDistAtPoint ename (trans x ename 0)) (list (car x) (cadr x)))) lst_brk)
      lst_brk (reverse (mapcar 'cadr (mapcar '(lambda (x) (assoc x lst_sort)) (vl-sort (mapcar 'car lst_sort) '<))))
      dxf_obj (entget ename)
    )
    (if (cdr (assoc 43 dxf_obj))
      (setq dxf_43 (cdr (assoc 43 dxf_obj)))
      (setq dxf_43 0.0)
    )
    (if (cdr (assoc 38 dxf_obj))
      (setq dxf_38 (cdr (assoc 38 dxf_obj)))
      (setq dxf_38 0.0)
    )
    (if (cdr (assoc 39 dxf_obj))
      (setq dxf_39 (cdr (assoc 39 dxf_obj)))
      (setq dxf_39 0.0)
    )
    (setq
      dxf_10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_obj))
      dxf_40 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 40)) dxf_obj))
      dxf_41 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 41)) dxf_obj))
      dxf_42 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) dxf_obj))
      dxf_210 (cdr (assoc 210 dxf_obj))
    )
    (if (not (zerop (boole 1 (cdr (assoc 70 dxf_obj)) 1)))
      (setq
        dxf_10 (append dxf_10 (list (car dxf_10)))
        dxf_40 (append dxf_40 (list (car dxf_40)))
        dxf_41 (append dxf_41 (list (car dxf_41)))
        dxf_42 (append dxf_42 (list (car dxf_42)))
      )
    )
    (repeat (1+ (length lst_brk))
      (setq
        ltmp nil
        lst_tmp (vl-member-if '(lambda (x) (and (equal (car x) (caar lst_brk) 1E-08) (equal (cadr x) (cadar lst_brk) 1E-08))) dxf_10)
        where (if lst_tmp (vl-position (car lst_tmp) dxf_10) 0)
      )
      (repeat (setq count (- (length dxf_10) where))
        (setq ltmp (cons (mapcar '(lambda (x y) (cons y (nth where x))) (list dxf_10 dxf_40 dxf_41 dxf_42) (list 10 40 41 42)) ltmp))
        (setq where (1+ where))
      )
      (entmake
        (append
          (list
            (cons 0 "LWPOLYLINE")
            (cons 100 "AcDbEntity")
            (assoc 67 dxf_obj)
            (assoc 410 dxf_obj)
            (assoc 8 dxf_obj)
            (if (assoc 62 dxf_obj) (assoc 62 dxf_obj) (cons 62 256))
            (if (assoc 6 dxf_obj) (assoc 6 dxf_obj) (cons 6 "BYLAYER"))
            (if (assoc 370 dxf_obj) (assoc 370 dxf_obj) (cons 370 -1))
            (cons 100 "AcDbPolyline")
            (cons 90 (length ltmp))
            (cons 70 (boole 1 (cdr (assoc 70 dxf_obj)) 128))
            (cons 38 dxf_38)
            (cons 39 dxf_39)
          )
          (apply 'append (reverse ltmp))
          (list (cons 210 dxf_210))
        )
      )
      (repeat (1- count)
        (setq
          dxf_10 (reverse (cdr (reverse dxf_10)))
          dxf_40 (reverse (cdr (reverse dxf_40)))
          dxf_41 (reverse (cdr (reverse dxf_41)))
          dxf_42 (reverse (cdr (reverse dxf_42)))
        )
      )
      (setq lst_brk (cdr lst_brk) ltmp nil nwent (entlast) rtn_ss (ssadd nwent rtn_ss))
    )
    (setq indx (1- (sslength rtn_ss)))
    (repeat (sslength rtn_ss)
      (if (eq (boole 1 indx 1) 1)
        (entdel (ssname rtn_ss indx))
      )
      (setq indx (1- indx))
    )
    (entdel ename)
  )
)
(defun c:altern_poly ( / ss n ss_save ent dxf_ent lst_pt brk_pt)
  (while (not (setq ss (ssget '((0 . "LWPOLYLINE"))))))
  (repeat (setq n (sslength ss))
    (setq
      ss_save (ssadd)
      ent (ssname ss (setq n (1- n)))
      ss_save (ssadd ent ss_save)
      dxf_ent (entget ent)
      lst_pt (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) dxf_ent))
    )
    (if (equal (append (car lst_pt) (list (getvar "ELEVATION"))) (vlax-curve-getendpoint ent) 1E-08)
      (setq lst_pt (append lst_pt (list (car lst_pt))))
    )
    (if (>= (length lst_pt) 3)
      (progn
        (setq brk_pt nil)
        (while (and lst_pt (cadddr lst_pt))
          (setq
            brk_pt (cons (caddr lst_pt) brk_pt)
            lst_pt (cdddr lst_pt)
            brk_pt (cons (car lst_pt) brk_pt)
          )
        )
        (if (eq (boole 1 (cdr (assoc 70 dxf_ent)) 1) 1) (setq brk_pt (cdr brk_pt)))
        (cut@point ss_save brk_pt)
      )
    )
  )
  (prin1)
)

 

Very nice. You whipped that up really from scratch in no time at all? Great work.

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...