Author Topic: ( Challenge ) Shortest & Longest line  (Read 12004 times)

0 Members and 1 Guest are viewing this topic.

Stefan

  • Bull Frog
  • Posts: 319
  • The most I miss IRL is the Undo button
Re: ( Challenge ) Shortest & Longest line
« Reply #15 on: January 31, 2013, 04:36:12 AM »
I have two more functions for all lines and one that consider layers.
Here is the test function:
Code: [Select]
(defun C:TEST ( / acDoc cm)
  (setq cm (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (foreach fun '((ph:byLayer) (ph:all1) (ph:all2))
    (vla-StartUndoMark acDoc)
    (gc)
    (time-it fun)
    (vla-EndUndoMark acDoc)
    (command "U")
    )
  (setvar 'cmdecho cm)
  (textscr)
  (princ)
  )

(defun time-it ( expr / et st )
    (setq st (getvar 'millisecs))
    (eval expr)
    (setq et (getvar 'millisecs))
    (princ (strcat "\nProgram running time: " (vl-princ-to-string expr) " - " (itoa (- et st)) " msecs."))
    (princ)
)
And results
Code: [Select]
Command:  TEST
("CYAN" 19.6269 1468.04)
("RED" 20.5474 1504.13)
("BLUE" 20.1582 1442.59)
("GREEN" 20.9117 1528.89)
Program running time: (PH:BYLAYER) - 765 msecs.
(19.6269 1528.89)
Program running time: (PH:ALL1) - 625 msecs.
(19.6269 1528.89)
Program running time: (PH:ALL2) - 672 msecs.

Command:  TEST
("CYAN" 19.6269 1468.04)
("RED" 20.5474 1504.13)
("BLUE" 20.1582 1442.59)
("GREEN" 20.9117 1528.89)
Program running time: (PH:BYLAYER) - 875 msecs.
(19.6269 1528.89)
Program running time: (PH:ALL1) - 547 msecs.
(19.6269 1528.89)
Program running time: (PH:ALL2) - 563 msecs.

Command:  TEST
("CYAN" 19.6269 1468.04)
("RED" 20.5474 1504.13)
("BLUE" 20.1582 1442.59)
("GREEN" 20.9117 1528.89)
Program running time: (PH:BYLAYER) - 875 msecs.
(19.6269 1528.89)
Program running time: (PH:ALL1) - 531 msecs.
(19.6269 1528.89)
Program running time: (PH:ALL2) - 562 msecs.
I've run the test several times with contradictory results. For example, for the first function the running time was in range 703... 1265 ms.
The results above are the most homogenous 3 consecutive tests.

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: ( Challenge ) Shortest & Longest line
« Reply #16 on: January 31, 2013, 06:00:53 AM »
With layers...
Code - Auto/Visual Lisp: [Select]
  1. (defun C:ShortLongestByLyr ( / TblDat)
  2.   (defun Dxf (DxfCod EntDat)  (cdr (assoc DxfCod EntDat)))
  3.   (defun ShortLongestLyr (LyrNam / SelSet  Countr EntSht EntLng EntDat EntNam LenVal MaxLen MinLen)
  4.     (if (setq SelSet (ssget "_X" (list '(0 . "LINE") (cons 8 LyrNam))))
  5.       (progn
  6.         (setq
  7.           Countr 0
  8.           EntSht (ssname SelSet 0)
  9.           EntLng EntSht
  10.           EntDat (entget EntSht)
  11.           MaxLen (distance (Dxf 10 EntDat) (Dxf 11 EntDat))
  12.           MinLen  MaxLen
  13.         )
  14.         (repeat (sslength SelSet)
  15.           (setq
  16.             EntNam (ssname SelSet Countr) EntDat (entget EntNam)
  17.             LenVal (distance (Dxf 10 EntDat) (Dxf 10 EntDat))
  18.             Countr (1+ Countr)
  19.           )
  20.           (cond
  21.             ( (> LenVal MaxLen) (setq MaxLen LenVal  EntLng EntNam) )
  22.             ( (< LenVal MinLen) (setq MinLen LenVal  EntSht EntNam) )
  23.           )
  24.         )
  25.         (command "_.ERASE" SelSet "_R" (ssadd EntSht (ssadd EntLng)) "")
  26. ;       (princ (strcat "\nLayer: " LyrNam " > " (itoa Countr) " erased entity(es). "))
  27.       )
  28. ;     (alert "No lines to erase.")
  29.     )
  30.   )
  31.   (setvar "HIGHLIGHT" 0)
  32.   (while (setq TblDat (tblnext "LAYER" (null TblDat)))
  33.     (ShortLongestLyr (cdr (assoc 2 TblDat)))
  34.   )
  35.   (setvar "HIGHLIGHT" 1)
  36. )

pBe

  • Bull Frog
  • Posts: 402
Re: ( Challenge ) Shortest & Longest line
« Reply #17 on: January 31, 2013, 06:09:40 AM »
Very good solution using an 'unerase'
x2  :)
 

David Bethel

  • Swamp Rat
  • Posts: 656
Re: ( Challenge ) Shortest & Longest line
« Reply #18 on: January 31, 2013, 07:44:16 AM »
R12 Dos - A2K

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: ( Challenge ) Shortest & Longest line
« Reply #19 on: January 31, 2013, 07:46:27 AM »
This was my original version:

Code: [Select]
(defun LM:shortlong ( / _max _min d e i l r s )
    (if (setq s (ssget "_X" '((0 . "LINE"))))
        (progn
            (setq _min 1e308
                  _max 0.0
            )
            (repeat (setq i (sslength s))
                (setq e (ssname s (setq i (1- i)))
                      l (entget e)
                      d (distance (cdr (assoc 10 l)) (cdr (assoc 11 l)))
                )
                (if (< _min d _max)
                    (entdel e)
                    (progn
                        (if (< d _min) (setq _min d))
                        (if (< _max d) (setq _max d))
                        (setq r (cons (list d e) r))
                    )
                )
            )
            (foreach x r
                (or (equal  (car  x) _min 1e-8)
                    (equal  (car  x) _max 1e-8)
                    (entdel (cadr x))
                )
            )
        )
    )
    (list _min _max)
)

But using Stefan's 'unerase' trick, I would change it to:

Code: [Select]
(defun LM:shortlong2 ( / _max _min d e i l m n r s )
    (if (setq s (ssget "_X" '((0 . "LINE"))))
        (progn
            (setq _min 1e308
                  _max 0.0
            )
            (repeat (setq i (sslength s))
                (setq e (ssname s (setq i (1- i)))
                      l (entget e)
                      d (distance (cdr (assoc 10 l)) (cdr (assoc 11 l)))
                )
                (if (< d _min) (setq _min d m e))
                (if (< _max d) (setq _max d n e))
                (entdel e)
            )
            (entdel m)
            (entdel n)
        )
    )
    (list _min _max)
)

Regarding the times, I must have a slow computer - I don't get much below 1800ms...
« Last Edit: January 31, 2013, 07:58:46 AM by Lee Mac »

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: ( Challenge ) Shortest & Longest line
« Reply #20 on: January 31, 2013, 07:58:35 AM »
Here are my times for the programs posted so far, comparing those returning overall shortest/longest lines:

Code: [Select]
(LM:SHORTLONG2) running time:  1732 msecs.
(LM:SHORTLONG)  running time:  1779 msecs.
(PH:MINMAXLINE) running time:  1857 msecs.
(C:KRU)         running time:  8487 msecs.
(THARWAT:TEST)  running time: 11061 msecs.

c:shortlongest by Marc'Antonio Alessi didn't return the correct result, so I didn't compare it.

Tharwat

  • Swamp Rat
  • Posts: 707
  • Hypersensitive
Re: ( Challenge ) Shortest & Longest line
« Reply #21 on: January 31, 2013, 08:02:09 AM »
OMG , mine is the slowest !  :-(

Stefan

  • Bull Frog
  • Posts: 319
  • The most I miss IRL is the Undo button
Re: ( Challenge ) Shortest & Longest line
« Reply #22 on: January 31, 2013, 08:11:12 AM »
My second version
Code - Auto/Visual Lisp: [Select]
  1. (defun ph:all1 (/ ss i l e e1 e2 m n)
  2.   (if
  3.     (setq ss (ssget "_X" '((0 . "LINE"))))
  4.      (progn
  5.        (setq e (ssname ss 0)
  6.              e1 e e2 e
  7.              m (vlax-curve-GetEndParam e)
  8.              n m
  9.              )
  10.        (repeat (setq i (sslength ss))
  11.          (setq l (vlax-curve-GetEndParam (setq e (ssname ss (setq i (1- i))))))
  12.          (if (< l m) (setq m l e1 e))
  13.          (if (> l n) (setq n l e2 e))
  14.          )
  15.        (command "ERASE" ss "")
  16.        (entdel e1)
  17.        (entdel e2)
  18.        (list m n)
  19.        )
  20.      )
  21.   )

David Bethel

  • Swamp Rat
  • Posts: 656
Re: ( Challenge ) Shortest & Longest line
« Reply #23 on: January 31, 2013, 08:13:15 AM »
A more basic approach:

Code - Auto/Visual Lisp: [Select]
  1. (defun c:lines (/ var rst td ln mn mx el es ss i en ed d1)
  2.  
  3.  (setq var '(("CMDECHO"   . 0) ("MENUECHO"   . 0)
  4.              ("MENUCTL"   . 0) ("MACROTRACE" . 0)
  5.              ("OSMODE"    . 0) ("SORTENTS"   . 0)
  6.              ("BLIPMODE"  . 0) ("SNAPMODE"   . 0)
  7.              ("HIGHLIGHT" . 0) ("MODEMACRO" . ".")))
  8.  
  9.  (foreach v var
  10.    (and (getvar (car v))
  11.         (setq rst (cons (cons (car v) (getvar (car v))) rst))
  12.         (setvar (car v) (cdr v))))
  13.  
  14.  (while (setq td (tblnext "LAYER" (not td)))
  15.         (setq ln (cdr (assoc 2 td))
  16.               mn nil)
  17.         (if (setq ss (ssget "X" (list (cons 0 "LINE")(cons 8 ln))))
  18.             (progn
  19.                (princ (strcat "\nProcessing " ln))
  20.                (setq i -1)
  21.                (while (setq en (ssname ss (setq i (1+ i))))
  22.                       (setq ed (entget en)
  23.                             d1 (distance (cdr (assoc 10 ed))
  24.                                          (cdr (assoc 11 ed))))
  25.                       (cond ((not mn)
  26.                              (setq mn d1 mx d1 el en es en))
  27.                             ((> d1 mx)
  28.                              (setq mx d1 el en))
  29.                             ((< d1 mn)
  30.                              (setq mn d1 es en))))
  31.                (setq ss (ssdel el ss)
  32.                      ss (ssdel es ss))
  33.                (command "_.ERASE" ss ""))))
  34.  
  35.  (foreach v rst (setvar (car v) (cdr v)))
  36.  (redraw)
  37.  (prin1))
-David
R12 Dos - A2K

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: ( Challenge ) Shortest & Longest line
« Reply #24 on: January 31, 2013, 08:34:55 AM »
New times, including ph:all1 (I have not included David Bethel's code, since it processes layer-by-layer and hence would not be comparing apples with apples):

Code: [Select]
(PH:ALL1)       running time:  702 msecs.
(LM:SHORTLONG)  running time: 1809 msecs.
(LM:SHORTLONG2) running time: 1872 msecs.
(PH:MINMAXLINE) running time: 1950 msecs.
(C:KRU)         running time: 8767 msecs.
(THARWAT:TEST)  running time: 9999 msecs.

Bravo Stefan!  :-)

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: ( Challenge ) Shortest & Longest line
« Reply #25 on: January 31, 2013, 08:36:03 AM »
c:shortlongest by Marc'Antonio Alessi didn't return the correct result, so I didn't compare it.

Yes, was a typo:  (Dxf 10 EntDat) (Dxf 11 EntDat))

Code - Auto/Visual Lisp: [Select]
  1. (defun C:ShortLongest ( / SelSet Countr EntSht EntLng LenVal MaxLen MinLen)
  2.  (defun Dxf (DxfCod EntDat)  (cdr (assoc DxfCod EntDat)))
  3.  (if (setq SelSet (ssget "_X" '((0 . "LINE"))))
  4.    (progn
  5.      (if (= 1 (logand 1 (getvar "UNDOCTL"))) (command "_.UNDO" "_C" "_N"))
  6.      (setvar "HIGHLIGHT" 0)
  7.      (setq
  8.        Countr 0
  9.        EntSht (ssname SelSet 0)
  10.        EntLng EntSht
  11.        EntDat (entget EntSht)
  12.        MaxLen (distance (Dxf 10 EntDat) (Dxf 11 EntDat))
  13.        MinLen  MaxLen
  14.      )
  15.      (repeat (sslength SelSet)
  16.        (setq
  17.          EntNam (ssname SelSet Countr) EntDat (entget EntNam)
  18.          LenVal (distance (Dxf 10 EntDat) (Dxf 11 EntDat))
  19.          Countr (1+ Countr)
  20.        )
  21.        (cond
  22.          ( (> LenVal MaxLen) (setq MaxLen LenVal  EntLng EntNam) )
  23.          ( (< LenVal MinLen) (setq MinLen LenVal  EntSht EntNam) )
  24.        )
  25.      )
  26.      (command "_.ERASE" SelSet "_R" (ssadd EntSht (ssadd EntLng)) "")
  27. ;      (princ (strcat "\n" (itoa Countr) " erased entity(es). Use Oops to restore. "))
  28.      (setvar "HIGHLIGHT" 1)
  29.    )
  30.    (alert "No lines to erase.")
  31.  )
  32. )
  33. (defun C:ShortLongestByLyr ( / TblDat)
  34.   (defun Dxf (DxfCod EntDat)  (cdr (assoc DxfCod EntDat)))
  35.   (defun ShortLongestLyr (LyrNam / SelSet  Countr EntSht EntLng EntDat EntNam LenVal MaxLen MinLen)
  36.     (if (setq SelSet (ssget "_X" (list '(0 . "LINE") (cons 8 LyrNam))))
  37.       (progn
  38.         (setq
  39.           Countr 0
  40.           EntSht (ssname SelSet 0)
  41.           EntLng EntSht
  42.           EntDat (entget EntSht)
  43.           MaxLen (distance (Dxf 10 EntDat) (Dxf 11 EntDat))
  44.           MinLen  MaxLen
  45.         )
  46.         (repeat (sslength SelSet)
  47.           (setq
  48.             EntNam (ssname SelSet Countr) EntDat (entget EntNam)
  49.             LenVal (distance (Dxf 10 EntDat) (Dxf 11 EntDat))
  50.             Countr (1+ Countr)
  51.           )
  52.           (cond
  53.             ( (> LenVal MaxLen) (setq MaxLen LenVal  EntLng EntNam) )
  54.             ( (< LenVal MinLen) (setq MinLen LenVal  EntSht EntNam) )
  55.           )
  56.         )
  57.         (command "_.ERASE" SelSet "_R" (ssadd EntSht (ssadd EntLng)) "")
  58. ;       (princ (strcat "\nLayer: " LyrNam " > " (itoa Countr) " erased entity(es). "))
  59.       )
  60. ;     (alert "No lines to erase.")
  61.     )
  62.   )
  63.   (if (= 1 (logand 1 (getvar "UNDOCTL"))) (command "_.UNDO" "_C" "_N"))
  64.   (setvar "HIGHLIGHT" 0)
  65.   (while (setq TblDat (tblnext "LAYER" (null TblDat)))
  66.     (ShortLongestLyr (cdr (assoc 2 TblDat)))
  67.   )
  68.   (setvar "HIGHLIGHT" 1)
  69. )

(time-it '(c:ShortLongest)) > Program running time: 3354 msecs.
(time-it '(c:ShortLongest)) > Program running time: 2964 msecs.

(time-it '(LM:shortlong2))  > Program running time: 6677 msecs.
(time-it '(LM:shortlong2))  > Program running time: 6755 msecs.

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: ( Challenge ) Shortest & Longest line
« Reply #26 on: January 31, 2013, 08:41:47 AM »
(time-it '(c:ShortLongest)) > Program running time: 3369 msecs.
(time-it '(ph:all1))              > Program running time: 5460 msecs.

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: ( Challenge ) Shortest & Longest line
« Reply #27 on: January 31, 2013, 08:47:03 AM »
With undo turned off, I get:
Code: [Select]
(PH:ALL1)        running time:  686 msecs.
(C:SHORTLONGEST) running time: 1311 msecs.

ronjonp

  • Needs a day job
  • Posts: 7526
Re: ( Challenge ) Shortest & Longest line
« Reply #28 on: January 31, 2013, 08:52:09 AM »
Here is mine:

Quote
(C:TEST3) Program running time: 2140 msecs.

(("RED" <Entity name: 7f62825c520> <Entity name: 7f628264750>)
  ("GREEN" <Entity name: 7f6292e9210> <Entity name: 7f628207f60>)
  ("CYAN" <Entity name: 7f62eaf6480> <Entity name: 7f62eade230>)
  ("BLUE" <Entity name: 7f62770cbd0> <Entity name: 7f62b641330>)
)


Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: ( Challenge ) Shortest & Longest line
« Reply #29 on: January 31, 2013, 08:57:38 AM »
Wow you'll have busy this morning.  :-)
My offering.
Code - Auto/Visual Lisp: [Select]
  1. (defun c:CABtest(/ ss i ent elst lst len lay)
  2.   (and (setq ss (ssget "_X" '((0 . "LINE"))))
  3.        (setq i -1)
  4.        (while (setq ent (ssname ss (setq i (1+ i))))
  5.          (setq elst (entget ent)
  6.                len (distance (cdr (assoc 10 elst))(cdr (assoc 11 elst)))
  7.                lay (cdr (assoc 8 elst)))
  8.          (cond
  9.            ((null lst)(setq lst (list(list lay len len ent ent))))
  10.            ((setq itm (assoc lay lst))
  11.             (if (or (if (< len (cadr itm)) (setq itm (list lay len (caddr itm) ent (last itm))))
  12.                     (if (> len (caddr itm)) (setq itm (list lay (cadr itm) len (cadddr itm) ent))))
  13.               (setq lst (subst itm (assoc lay lst) lst))))
  14.            ((setq lst (cons (list lay len len ent ent) lst)))
  15.          )
  16.        )
  17.    )
  18.   (mapcar(function(lambda(x) (ssdel (last x) ss))) lst)
  19.   (and lst (command "_.erase" ss ""))
  20.   (print)(princ lst)(princ)
  21. )
« Last Edit: January 31, 2013, 10:36:34 AM by CAB »
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.