« previous next »
Pages: [1] 2 3 4  All |   Go Down

Author Topic: ( Challenge ) Shortest & Longest Pline  (Read 13476 times)

0 Members and 1 Guest are viewing this topic.

Mark

  • Custom Title
  • Seagull
  • Posts: 28762
( Challenge ) Shortest & Longest Pline
« on: February 04, 2013, 08:52:49 AM »
The challenge is to find the shortest and longest Pline by layer. Erase all others. The attached .dwg contains 1624 3D polylines on 4 layers. Bonus points to the fastest code. :)

Thanks again to Lee Mac for the code to create the .dwg  WARNING: do not try to create 2000 polylines and then erase them! You will be waiting on your computer for some time. LOL

Good luck!
Logged
TheSwamp.org  (serving the CAD community since 2003)

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: ( Challenge ) Shortest & Longest Pline
« Reply #1 on: February 04, 2013, 09:32:11 AM »
Surely this type of approach (as previous) has its greatest speed in DWG with large number of objects:
Code - Auto/Visual Lisp: [Select]
  1. (defun C:ShortLongestPL ( / SelSet Countr EntSht EntLng LenVal MaxLen MinLen)
  2.  (if (setq SelSet (ssget "_X" '((0 . "POLYLINE"))))
  3.    (progn
  4.      (if (= 1 (logand 1 (getvar "UNDOCTL"))) (command "_.UNDO" "_C" "_N"))
  5.      (setvar "HIGHLIGHT" 0)
  6.      (setq
  7.        Countr 0
  8.        EntSht (ssname SelSet 0)
  9.        EntLng EntSht
  10.        MaxLen (vla-get-length (vlax-ename->vla-object EntSht))
  11.        MinLen  MaxLen
  12.      )
  13.      (repeat (sslength SelSet)
  14.        (setq
  15.          EntNam (ssname SelSet Countr)
  16.          LenVal (vla-get-length (vlax-ename->vla-object EntNam))
  17.          Countr (1+ Countr)
  18.        )
  19.        (cond
  20.          ( (> LenVal MaxLen) (setq MaxLen LenVal  EntLng EntNam) )
  21.          ( (< LenVal MinLen) (setq MinLen LenVal  EntSht EntNam) )
  22.        )
  23.      )
  24.      (command "_.ERASE" SelSet "_R" (ssadd EntSht (ssadd EntLng)) "")
  25. ;      (princ (strcat "\n" (itoa Countr) " erased entity(es). Use Oops to restore. "))
  26.    )
  27.    (alert "No lines to erase.")
  28.  )
  29. )
  30. ; By Layer version
  31. (defun C:ShortLongestPLByLyr ( / TblDat SelSet SelSt2 Countr EntSht EntLng
  32.                                  EntDat EntNam LenVal MaxLen MinLen AllSet)
  33.   (if (= 1 (logand 1 (getvar "UNDOCTL"))) (command "_.UNDO" "_C" "_N"))
  34.   (setvar "HIGHLIGHT" 0)
  35.   (setq SelSt2 (ssadd))
  36.   (while (setq TblDat (tblnext "LAYER" (null TblDat)))
  37.     (if (setq
  38.           SelSet (ssget "_X" (list '(0 . "POLYLINE") (cons 8 (cdr (assoc 2 TblDat)))))
  39.         )
  40.       (progn
  41.         (setq
  42.           Countr 0
  43.           EntSht (ssname SelSet 0)
  44.           EntLng EntSht
  45.           MaxLen (vla-get-length (vlax-ename->vla-object EntSht))
  46.           MinLen  MaxLen
  47.         )
  48.         (repeat (sslength SelSet)
  49.           (setq
  50.             EntNam (ssname SelSet Countr)
  51.             LenVal (vla-get-length (vlax-ename->vla-object EntNam))
  52.             Countr (1+ Countr)
  53.           )
  54.           (cond
  55.             ( (> LenVal MaxLen) (setq MaxLen LenVal  EntLng EntNam) )
  56.             ( (< LenVal MinLen) (setq MinLen LenVal  EntSht EntNam) )
  57.           )
  58.         )
  59.         (setq
  60.           SelSt2 (ssadd EntSht SelSt2)  SelSt2 (ssadd EntLng SelSt2)
  61.           AllSet (cons SelSet AllSet)
  62.         )
  63.       )
  64.     )
  65.   )
  66.   (command "_.ERASE") (foreach ForElm AllSet (command ForElm))
  67.   (command  "_R" SelSt2 "")
  68. )
Logged

irneb

  • Water Moccasin
  • Posts: 1794
  • ACad R9-2016, Revit Arch 6-2016
Re: ( Challenge ) Shortest & Longest Pline
« Reply #2 on: February 04, 2013, 11:20:51 PM »
Didn't you have the same question just recently? If using the vlax-curve-* functions it would work the same (or at least very similar) to the method for finding the longest & shortest lines.
Logged
Common sense - the curse in disguise. Because if you have it, you have to live with those that don't.

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: ( Challenge ) Shortest & Longest Pline
« Reply #3 on: February 05, 2013, 04:21:24 AM »
Quote from: irneb on February 04, 2013, 11:20:51 PM
Didn't you have the same question just recently? If using the vlax-curve-* functions it would work the same (or at least very similar) to the method for finding the longest & shortest lines.

My apologies for my english, is it a question for me? If so please can you give me an example?

Marco
Logged

Tharwat

  • Swamp Rat
  • Posts: 710
  • Hypersensitive
Re: ( Challenge ) Shortest & Longest Pline
« Reply #4 on: February 05, 2013, 05:44:40 AM »
Quote from: Marc'Antonio Alessi on February 05, 2013, 04:21:24 AM
Quote from: irneb on February 04, 2013, 11:20:51 PM
Didn't you have the same question just recently? If using the vlax-curve-* functions it would work the same (or at least very similar) to the method for finding the longest & shortest lines.

My apologies for my english, is it a question for me? If so please can you give me an example?

Marco

I think irneb indicating to the following thread .  :-D

http://www.theswamp.org/index.php?topic=43714.0
Logged

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: ( Challenge ) Shortest & Longest Pline
« Reply #5 on: February 05, 2013, 07:33:46 AM »
Quote
I think irneb indicating to the following thread .  :-D

http://www.theswamp.org/index.php?topic=43714.0

Maybe the question it is not for me.
Logged

Mark

  • Custom Title
  • Seagull
  • Posts: 28762
Re: ( Challenge ) Shortest & Longest Pline
« Reply #6 on: February 05, 2013, 07:38:21 AM »
Quote from: irneb on February 04, 2013, 11:20:51 PM
Didn't you have the same question just recently?
The only difference in this challenge is the .dwg contains 3D Plines.

Try doing it without vlax-*.
Logged
TheSwamp.org  (serving the CAD community since 2003)

irneb

  • Water Moccasin
  • Posts: 1794
  • ACad R9-2016, Revit Arch 6-2016
Re: ( Challenge ) Shortest & Longest Pline
« Reply #7 on: February 05, 2013, 07:45:00 AM »
Quote from: Mark on February 05, 2013, 07:38:21 AM
The only difference in this challenge is the .dwg contains 3D Plines.

Try doing it without vlax-*.
Fine I assumed it's something like that. Thus you'd want this to be a case of adding polyline segment lengths together.

Now I can just imagine the next challenge  ;) : 2d Polylines with curved sgments.
Logged
Common sense - the curse in disguise. Because if you have it, you have to live with those that don't.

irneb

  • Water Moccasin
  • Posts: 1794
  • ACad R9-2016, Revit Arch 6-2016
Re: ( Challenge ) Shortest & Longest Pline
« Reply #8 on: February 05, 2013, 12:55:42 PM »
OK, to pre-empt all this  :lmao: :
Code - Auto/Visual Lisp: [Select]
  1. (defun curveLength  (start end bulge)
  2.   (cond ((or (not bulge) (zerop bulge)) (distance start end))
  3.         (t (* 4.0 (atan (abs bulge)) (/ (* (distance start end) (1+ (* bulge bulge))) 4 (abs bulge))))))
  4.  
  5. (defun getEntityLayer+Length  (eName / eDXF 70DXF eType points bulges)
  6.   (setq eDXF (entget eName '("*")))
  7.   (list
  8.     (cdr (assoc 8 eDXF))
  9.     (cond
  10.       ((wcmatch (setq eType (cdr (assoc 0 eDXF))) "LINE") ;Line
  11.        (distance (cdr (assoc 10 eDXF)) (cdr (assoc 11 eDXF))))
  12.       ((wcmatch eType "POLYLINE") ;Heavy Polyline
  13.        (setq 70DXF (cdr (assoc 70 eDXF)))
  14.        ;; Get vector info
  15.        (while (and (setq eName (entnext eName))
  16.                    (setq eDXF (entget eName))
  17.                    (wcmatch (cdr (assoc 0 eDXF)) "VERTEX"))
  18.          (setq points (cons (cdr (assoc 10 eDXF)) points)
  19.                bulges (cons (cdr (assoc 42 eDXF)) bulges)))
  20.        (setq points (reverse points)
  21.              bulges (reverse bulges))
  22.        (cond
  23.          ((> (logand 70DXF 0) ;If 3d Polyline
  24.           (cond ((> (logand 70DXF 1) 0) ;If closed
  25.                  (apply '+ (mapcar 'distance (cons (last points) points) points)))
  26.                 ;; Else not closed
  27.                 (t (apply '+ (mapcar 'distance points (cdr points))))))
  28.          ;; Else 2d Polyline - possibly bulges
  29.          (t
  30.           (cond ((> (logand 70DXF 1) 0) ;If closed
  31.                  (apply '+ (mapcar 'curveLength (cons (last points) points) points (cons (last bulges) bulges))))
  32.                 ;; Else not closed
  33.                 (t (apply '+ (mapcar 'curveLength points (cdr points) bulges)))))))
  34.       ((wcmatch eType "LWPOLYLINE")
  35.        (setq 70DXF (cdr (assoc 70 eDXF)))
  36.        (foreach item  (member (assoc 90 eDXF) eDXF)
  37.          (cond ((= (car item) 10) (setq points (cons (cdr item) points)))
  38.                ((= (car item) 42) (setq bulges (cons (cdr item) bulges)))))
  39.        (setq points (reverse points)
  40.              bulges (reverse bulges))
  41.        (cond ((> (logand 70DXF 1) 0) ;If closed
  42.               (apply '+ (mapcar 'curveLength (cons (last points) points) points (cons (last bulges) bulges))))
  43.              ;; Else not closed
  44.              (t (apply '+ (mapcar 'curveLength points (cdr points) bulges))))))))
  45.  
  46. (defun c:RemAllButLongest&Shortest  (/ ss long short n en)
  47.   (setq long  '(nil nil -1.0)
  48.         short '(nil nil 1.7976931348623158e308))
  49.   (if (setq ss (ssget "_X" '((0 . "LINE,POLYLINE,LWPOLYLINE"))))
  50.     (progn (repeat (setq n (sslength ss))
  51.              (setq en (ssname ss (setq n (1- n)))
  52.                    en (cons en (getEntityLayer+Length en)))
  53.              (if (> (caddr en) (caddr long))
  54.                (setq long en))
  55.              (if (< (caddr en) (caddr short))
  56.                (setq short en))
  57.              (entdel (car en)))
  58.            (entdel (car long))
  59.            (entdel (car short))
  60.            (princ (strcat "\nLongest :\tLayer="
  61.                           (cadr long)
  62.                           ";\tLength ="
  63.                           (rtos (caddr long))
  64.                           "\nShortest:\tLayer="
  65.                           (cadr short)
  66.                           ";\tLength ="
  67.                           (rtos (caddr short))
  68.                           "\n"))))
  69.   (princ))
  70.  
And the test:
Code: [Select]
_$ (DoTest '((c:RemAllButLongest&Shortest)))

(C:REMALLBUTLONGEST&SHORTEST)
Longest :    Layer=RED;    Length =71652.0653
Shortest:    Layer=RED;    Length =243.2759
Program running time: 1030 msecs.
« Last Edit: February 05, 2013, 12:59:30 PM by irneb »
Logged
Common sense - the curse in disguise. Because if you have it, you have to live with those that don't.

irneb

  • Water Moccasin
  • Posts: 1794
  • ACad R9-2016, Revit Arch 6-2016
Re: ( Challenge ) Shortest & Longest Pline
« Reply #9 on: February 05, 2013, 01:13:10 PM »
or using the vlax-curve-* idea (despite your comment to "not" use it):
Code - Auto/Visual Lisp: [Select]
  1. (defun c:RemAllButLongest&Shortest1  (/ ss long short n en lay len)
  2.   (setq long  '(nil nil -1.0)
  3.         short '(nil nil 1.7976931348623158e308))
  4.   (if (setq ss (ssget "_X" '((0 . "LINE,POLYLINE,LWPOLYLINE"))))
  5.     (progn (repeat (setq n (sslength ss))
  6.              (setq en (ssname ss (setq n (1- n)))
  7.                    lay (cdr (assoc 8 (entget en)))
  8.                    len (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))
  9.              (if (> len (caddr long))
  10.                (setq long (list en lay len)))
  11.              (if (< len (caddr short))
  12.                (setq short (list en lay len)))
  13.              (entdel en))
  14.            (entdel (car long))
  15.            (entdel (car short))
  16.            (princ (strcat "\nLongest :\tLayer="
  17.                           (cadr long)
  18.                           ";\tLength ="
  19.                           (rtos (caddr long))
  20.                           "\nShortest:\tLayer="
  21.                           (cadr short)
  22.                           ";\tLength ="
  23.                           (rtos (caddr short))
  24.                           "\n"))))
  25.   (princ))
And the test:
Code: [Select]
_$ (DoTest '((c:RemAllButLongest&Shortest) (c:RemAllButLongest&Shortest1)))

(C:REMALLBUTLONGEST&SHORTEST)
Longest :    Layer=RED;    Length =71652.0653
Shortest:    Layer=RED;    Length =243.2759
Program running time: 1045 msecs.
(C:REMALLBUTLONGEST&SHORTEST1)
Longest :    Layer=RED;    Length =71652.0653
Shortest:    Layer=RED;    Length =243.2759
Program running time: 93 msecs.BTW, I've used Lee's time-it function in a combined version, so I am assured of "equal" allowance for each version:
Code - Auto/Visual Lisp: [Select]
  1. (defun time-it  (expr / et st)
  2.   ;; by: Lee Mac
  3.   (setq st (getvar 'millisecs))
  4.   (eval expr)
  5.   (setq et (getvar 'millisecs))
  6.   (princ (strcat "Program running time: " (itoa (- et st)) " msecs."))
  7.   (princ))
  8.  
  9. (defun DoTest  (exprlist /)
  10.   (foreach expr exprlist (command "_.undo" "_Back" "_Yes") (print expr) (time-it expr))
  11.   (princ))
Not much in the order of which version to perform first:
Code: [Select]
_$ (DoTest '((c:RemAllButLongest&Shortest1) (c:RemAllButLongest&Shortest)))

(C:REMALLBUTLONGEST&SHORTEST1)
Longest :    Layer=RED;    Length =71652.0653
Shortest:    Layer=RED;    Length =243.2759
Program running time: 78 msecs.
(C:REMALLBUTLONGEST&SHORTEST)
Longest :    Layer=RED;    Length =71652.0653
Shortest:    Layer=RED;    Length =243.2759
Program running time: 1077 msecs.
Logged
Common sense - the curse in disguise. Because if you have it, you have to live with those that don't.

irneb

  • Water Moccasin
  • Posts: 1794
  • ACad R9-2016, Revit Arch 6-2016
Re: ( Challenge ) Shortest & Longest Pline
« Reply #10 on: February 05, 2013, 02:01:53 PM »
Just to compare apples with apples:
Code - Auto/Visual Lisp: [Select]
  1. (defun c:RemAllButLongest&ShortestByLayer  (/ ss long short n en lay len)
  2.   (while (setq lay (tblnext "LAYER" (not lay)))
  3.     (setq long  '(nil nil -1.0)
  4.           short '(nil nil 1.7976931348623158e308))
  5.     (if (setq ss (ssget "_X" (list '(0 . "LINE,POLYLINE,LWPOLYLINE") (cons 8 (cdr (assoc 2 lay))))))
  6.       (progn (repeat (setq n (sslength ss))
  7.                (setq en  (ssname ss (setq n (1- n)))
  8.                      len (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))
  9.                (if (> len (caddr long))
  10.                  (setq long (list en lay len)))
  11.                (if (< len (caddr short))
  12.                  (setq short (list en lay len)))
  13.                (entdel en))
  14.              (entdel (car long))
  15.              (entdel (car short)))))
  16.   (princ))
And the test for all 5:
Code: [Select]
_$ (DoTest '((c:RemAllButLongest&Shortest1) (c:RemAllButLongest&Shortest) (C:ShortLongestPL) (C:ShortLongestPLByLyr) (c:RemAllButLongest&ShortestByLayer)))

(C:REMALLBUTLONGEST&SHORTEST1)
Longest :    Layer=RED;    Length =71652.0653
Shortest:    Layer=RED;    Length =243.2759
Program running time: 63 msecs.
(C:REMALLBUTLONGEST&SHORTEST)
Longest :    Layer=RED;    Length =71652.0653
Shortest:    Layer=RED;    Length =243.2759
Program running time: 967 msecs.
(C:SHORTLONGESTPL) Program running time: 125 msecs.
(C:SHORTLONGESTPLBYLYR) Program running time: 141 msecs.
(C:REMALLBUTLONGEST&SHORTESTBYLAYER) Program running time: 47 msecs.
Logged
Common sense - the curse in disguise. Because if you have it, you have to live with those that don't.

irneb

  • Water Moccasin
  • Posts: 1794
  • ACad R9-2016, Revit Arch 6-2016
Re: ( Challenge ) Shortest & Longest Pline
« Reply #11 on: February 05, 2013, 02:08:47 PM »
Oh! Noticed a slight hiccup: If there's only one entity on the layer, then it will get erased. So here's the fix (with a minor optimization):
Code - Auto/Visual Lisp: [Select]
  1. (defun c:RemAllButLongest&ShortestByLayer  (/ ss long short n en lay len)
  2.   (while (setq lay (tblnext "LAYER" (not lay)))
  3.     (setq long  '(nil -1.0)
  4.           short '(nil 1.7976931348623158e308))
  5.     (if (and (setq ss (ssget "_X" (list '(0 . "LINE,POLYLINE,LWPOLYLINE") (cons 8 (cdr (assoc 2 lay))))))
  6.              (> (setq n (sslength ss)) 1))
  7.       (progn (repeat n
  8.                (setq en  (ssname ss (setq n (1- n)))
  9.                      len (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))
  10.                (if (> len (cadr long))
  11.                  (setq long (list en len)))
  12.                (if (< len (cadr short))
  13.                  (setq short (list en len)))
  14.                (entdel en))
  15.              (entdel (car long))
  16.              (entdel (car short)))))
  17.   (princ))
Test:
Code: [Select]
(C:REMALLBUTLONGEST&SHORTEST1)
Longest :    Layer=RED;    Length =71652.0653
Shortest:    Layer=RED;    Length =243.2759
Program running time: 78 msecs.
(C:REMALLBUTLONGEST&SHORTEST)
Longest :    Layer=RED;    Length =71652.0653
Shortest:    Layer=RED;    Length =243.2759
Program running time: 983 msecs.
(C:SHORTLONGESTPL) Program running time: 125 msecs.
(C:SHORTLONGESTPLBYLYR) Program running time: 141 msecs.
(C:REMALLBUTLONGEST&SHORTESTBYLAYER) Program running time: 47 msecs.
Logged
Common sense - the curse in disguise. Because if you have it, you have to live with those that don't.

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: ( Challenge ) Shortest & Longest Pline
« Reply #12 on: February 05, 2013, 02:42:00 PM »
Quote from: irneb on February 05, 2013, 02:08:47 PM
(C:REMALLBUTLONGEST&SHORTESTBYLAYER) Program running time: 47 msecs.

I think I know why this version is faster, is there anyone who knows?
Logged

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: ( Challenge ) Shortest & Longest Pline
« Reply #13 on: February 05, 2013, 04:17:08 PM »
Quote from: Marc'Antonio Alessi on February 05, 2013, 02:42:00 PM
I think I know why this version is faster, is there anyone who knows?

This is the answer:
Code - Auto/Visual Lisp: [Select]
  1. ;AutoCAD 2010
  2. ;(time-it '(c:RemAllButLongest&Shortest1)) ;Program running time: 421 msecs.
  3. ;(time-it '(c:ALE_ShortLongestPL))       ;Program running time: 265 msecs
  4.  
  5. (defun C:ALE_ShortLongestPL ( / SelSet Countr EntSht LenVal MinLen InfLst)
  6.  (if (setq SelSet (ssget "_X" '((0 . "POLYLINE"))))
  7.    (progn
  8.      (setq
  9.        Countr 0
  10.        EntSht (ssname SelSet 0)
  11.        MinLen (vla-get-length (vlax-ename->vla-object EntSht))
  12.        InfLst (list EntSht MinLen EntSht MinLen)
  13.      )
  14.      (repeat (sslength SelSet)
  15.        (setq
  16.          EntNam (ssname SelSet Countr)
  17.          LenVal (vla-get-length (vlax-ename->vla-object EntNam))
  18.          Countr (1+ Countr)
  19.        )
  20.        (cond
  21.          ( (> LenVal (cadddr InfLst))
  22.            (setq InfLst (list (car InfLst) (cadr InfLst) EntNam LenVal))
  23.          )
  24.          ( (< LenVal (cadr   InfLst))
  25.            (setq InfLst (list EntNam LenVal (caddr InfLst) (cadddr InfLst)))
  26.          )
  27.        )
  28.      )
  29.      (command "_.ERASE" SelSet "_R" (ssadd (car InfLst) (ssadd (caddr InfLst))) "")
  30.    )
  31.  )
  32. )
Logged

ronjonp

  • Needs a day job
  • Posts: 7527
Re: ( Challenge ) Shortest & Longest Pline
« Reply #14 on: February 05, 2013, 04:46:15 PM »
This one fares pretty well:

Program running time: 188 msecs.

Code - Auto/Visual Lisp: [Select]
  1. (defun c:testfoo (/ e el l l2 lyr n o ss)
  2.   (if (setq ss (ssget "_x" '((0 . "POLYLINE"))))
  3.     (progn (setq n -1)
  4.            (while (setq e (ssname ss (setq n (1+ n))))
  5.              (setq o (vlax-ename->vla-object e))
  6.              (setq l (cons (list (vla-get-layer o) (vla-get-length o) e) l))
  7.              (entdel e)
  8.            )
  9.            (setq l (vl-sort l (function (lambda (a b) (< (car a) (car b))))))
  10.            (while (setq lyr (caar l))
  11.              (while (eq (caar l) lyr) (setq l2 (cons (car l) l2)) (setq l (cdr l)))
  12.              (setq l2 (vl-sort l2 (function (lambda (a b) (< (cadr a) (cadr b))))))
  13.              (entdel (last (car l2)))
  14.              (entdel (last (last l2)))
  15.              (setq l2 nil)
  16.            )
  17.     )
  18.   )
  19. )

Nice Irneb  8-)
Quote
C:REMALLBUTLONGEST&SHORTESTBYLAYER
Program running time: 78 msecs.
« Last Edit: February 05, 2013, 04:52:03 PM by ronjonp »
Logged

Windows 11 x64 - AutoCAD /C3D 2023
Custom Build PC
Pages: [1] 2 3 4  All |   Go Up
« previous next »