Author Topic: [challenge] A08 : "Pack" consecutive duplicates of list elements into sublists  (Read 1551 times)

0 Members and 1 Guest are viewing this topic.

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1314
  • Marco
Another… similar.
Code: [Select]
(defun ALE_pack (L / o)
  (mapcar
   '(lambda (x)
      (setq o (if (eq x (caar o)) (cons (cons x (car o)) (cdr o)) (cons (list x) o)))
    )
    L
  )
  (reverse o)
)

JohnK

  • Administrator
  • Seagull
  • Posts: 10140
TIME TRIALS:

Code: [Select]
Elapsed milliseconds / relative speed for 32768 iteration(s):

    (PACK-LEE-3 ARRAYTOUSE)..............1094 / 2.10 <fastest>
    (PACK-LEE-2 ARRAYTOUSE)..............1203 / 1.91
    (PACK-VOVKA ARRAYTOUSE)..............1312 / 1.75
    (PACK-RJP ARRAYTOUSE)................1313 / 1.75
    (PACK-SE7EN ARRAYTOUSE)..............1375 / 1.67
    (PACK_STEF ARRAYTOUSE)...............1390 / 1.65
    (PACK-GILE-2 ARRAYTOUSE).............1407 / 1.63
    (ALE_PACK ARRAYTOUSE)................1532 / 1.50
    (PACK-GILE-1 ARRAYTOUSE).............1656 / 1.39
    (PACK-LEE-1 ARRAYTOUSE)..............1812 / 1.27
    (PACK-WELL20152016-2 ARRAYTOUSE).....2297 / 1.00 <slowest>
---- Benchmark utility: In memory of Michael Puckett ----

Code: [Select]
Elapsed milliseconds / relative speed for 32768 iteration(s):

    (PACK_STEF ARRAYTOUSE)...............1359 / 1.91 <fastest>
    (PACK-GILE-2 ARRAYTOUSE).............1391 / 1.86
    (PACK-SE7EN ARRAYTOUSE)..............1500 / 1.73
    (PACK-RJP ARRAYTOUSE)................1500 / 1.73
    (ALE_PACK ARRAYTOUSE)................1547 / 1.68
    (PACK-GILE-1 ARRAYTOUSE).............1609 / 1.61
    (PACK-LEE-3 ARRAYTOUSE)..............1734 / 1.50
    (PACK-LEE-1 ARRAYTOUSE)..............1765 / 1.47
    (PACK-VOVKA ARRAYTOUSE)..............1828 / 1.42
    (PACK-WELL20152016-2 ARRAYTOUSE).....2297 / 1.13
    (PACK-LEE-2 ARRAYTOUSE)..............2594 / 1.00 <slowest>
 ---- Benchmark utility: In memory of Michael Puckett ----

Code: [Select]
Elapsed milliseconds / relative speed for 65536 iteration(s):

    (PACK-LEE-2 ARRAYTOUSE)...............1985 / 7.34 <fastest>
    (PACK-LEE-3 ARRAYTOUSE)...............2046 / 7.12
    (PACK-SE7EN ARRAYTOUSE)...............2297 / 6.34
    (PACK-RJP ARRAYTOUSE).................2328 / 6.26
    (PACK-VOVKA ARRAYTOUSE)...............2532 / 5.75
    (PACK_STEF ARRAYTOUSE)................2563 / 5.68
    (PACK-GILE-2 ARRAYTOUSE)..............2672 / 5.45
    (ALE_PACK ARRAYTOUSE).................2812 / 5.18
    (PACK-GILE-1 ARRAYTOUSE)..............3062 / 4.76
    (PACK-LEE-1 ARRAYTOUSE)...............8015 / 1.82
    (PACK-WELL20152016-2 ARRAYTOUSE).....14563 / 1.00 <slowest>
 ---- Benchmark utility: In memory of Michael Puckett ----

Code: [Select]
Elapsed milliseconds / relative speed for 65536 iteration(s):

    (PACK-SE7EN ARRAYTOUSE)..............1953 / 4.09 <fastest>
    (PACK-LEE-3 ARRAYTOUSE)..............2797 / 2.85
    (PACK-VOVKA ARRAYTOUSE)..............2953 / 2.70
    (PACK-LEE-2 ARRAYTOUSE)..............3016 / 2.65
    (PACK-RJP ARRAYTOUSE)................3078 / 2.59
    (PACK_STEF ARRAYTOUSE)...............3235 / 2.47
    (PACK-GILE-1 ARRAYTOUSE).............3594 / 2.22
    (PACK-GILE-2 ARRAYTOUSE).............3625 / 2.20
    (ALE_PACK ARRAYTOUSE)................4016 / 1.99
    (PACK-LEE-1 ARRAYTOUSE)..............7875 / 1.01
    (PACK-WELL20152016-2 ARRAYTOUSE).....7985 / 1.00 <slowest>
 ---- Benchmark utility: In memory of Michael Puckett ----

Testing function:
Code - Auto/Visual Lisp: [Select]
  1. ( (lambda ( / ArrayToUse)
  2.     ;;
  3.     ;; FUNCTIONS
  4.  
  5.         (defun pack-se7en (aList / segment)
  6.           (defun group-subarray (element seg aList)
  7.             (cond
  8.               ((null aList)
  9.                (list (cons element seg)))
  10.               ((eq element (car aList))
  11.                (group-subarray element (cons element seg) (cdr aList)))
  12.               (t
  13.                 (cons
  14.                   (cons element seg)
  15.                   (group-subarray (car aList) '() (cdr aList))))
  16.               )
  17.             )
  18.           (if (null aList)
  19.             '()
  20.             (group-subarray (car aList) '() (cdr aList)))
  21.           )
  22.  
  23.         ;;(defun pack-well20152016-1 (l / l1 l2)
  24.         ;;  (while l
  25.         ;;    (setq n (length l)
  26.         ;;          a (car l)
  27.         ;;          l (vl-remove-if '(lambda (b) (equal a b)) l)
  28.         ;;          n (repeat (- n (length l)) (setq l1 (cons a l1)))
  29.         ;;        )
  30.         ;;  (setq l2 (cons l1 l2) l1 nil))
  31.         ;; (reverse l2) )
  32.  
  33.         (defun pack-well20152016-2 (l / l1 l2 l3)
  34.           (while l
  35.             (setq l1 nil l2 nil l1 (list (car l))
  36.                   n (foreach a (cdr l) (if (= (car l) a ) (setq l1 (cons a l1)) (setq l2 (cons a l2))))
  37.                   l3 (cons l1 l3)
  38.                   l (reverse l2)
  39.                   ))
  40.          (reverse l3) )
  41.  
  42.         (defun pack-lee-1 ( l / f )
  43.             (defun f ( l a )
  44.                 (if l
  45.                     (if (= (car l) (car a))
  46.                         (f (cdr l) (cons (car l) a))
  47.                         (cons a (pack-lee-1 l))
  48.                     )
  49.                     (list a)
  50.                 )
  51.             )
  52.             (if l (f (cdr l) (list (car l))))
  53.         )
  54.  
  55.         (defun pack-lee-2 ( l / r s x y )
  56.             (while l
  57.                 (setq x (car  l)
  58.                       s (list x)
  59.                       l (cdr  l)
  60.                 )
  61.                 (while (and l (= x (setq y (car l))))
  62.                     (setq s (cons y s)
  63.                           l (cdr  l)
  64.                     )
  65.                 )
  66.                 (setq r (cons s r))
  67.             )
  68.             (reverse r)
  69.         )
  70.  
  71.         (defun pack-lee-3 ( l / s x y )
  72.             (if l
  73.                 (progn
  74.                     (setq x (car  l)
  75.                           s (list x)
  76.                           l (cdr  l)
  77.                     )  
  78.                     (while (and l (= x (setq y (car l))))
  79.                         (setq s (cons y s)
  80.                               l (cdr  l)
  81.                         )
  82.                     )
  83.                     (cons s (pack-lee-3 l))
  84.                 )
  85.             )
  86.         )
  87.  
  88.         (defun pack-vovka (l / nl)
  89.           (foreach e l
  90.             (setq nl (if (= e (caar nl))
  91.                        (cons (cons e (car nl)) (cdr nl))
  92.                        (cons (list e) nl)
  93.                      )
  94.             )
  95.           )
  96.           (reverse nl)
  97.         )
  98.  
  99.         (defun pack-gile-1 (l / loop)
  100.           (defun loop (l a)
  101.             (cond
  102.               ((null l) (reverse a))
  103.               ((/= (car l) (caar a)) (loop (cdr l) (cons (list (car l)) a)))
  104.               (T (loop (cdr l) (cons (cons (car l) (car a)) (cdr a))))
  105.             )
  106.           )
  107.           (loop l nil)
  108.         )
  109.  
  110.         (defun pack-gile-2 (l / loop)
  111.           (defun loop (l a)
  112.             (if l
  113.               (loop
  114.                 (cdr l)
  115.                 (if (= (car l) (caar a))
  116.                   (cons (cons (car l) (car a)) (cdr a))
  117.                   (cons (list (car l)) a)
  118.                 )
  119.               )
  120.               (reverse a)
  121.             )
  122.           )
  123.           (loop l nil)
  124.         )
  125.  
  126.         (defun pack_stef (l / p r)
  127.           (setq p (list (car l)) l (cdr l))
  128.           (while
  129.             (cond
  130.               ( (not l) nil)
  131.               ( (eq (car l) (car p))
  132.                 (setq p (cons (car l) p)
  133.                       l (cdr l)
  134.                 )
  135.               )
  136.               (T
  137.                 (setq r (cons p r)
  138.                       p (list (car l))
  139.                       l (cdr l)
  140.                 )
  141.               )
  142.             )
  143.           )
  144.           (reverse (cons p r))
  145.         )
  146.  
  147.         (defun pack-rjp (l / a r)
  148.           (while l
  149.             (setq a (list (car l)))
  150.             (setq l (cdr l))
  151.             (while (and l (equal (car a) (car l))) (setq a (cons (car l) a)) (setq l (cdr l)))
  152.             (setq r (cons a r))
  153.           )
  154.           (reverse r)
  155.         )
  156.  
  157.         (defun ALE_pack (L / o)
  158.           (mapcar
  159.            '(lambda (x)
  160.               (setq o (if (eq x (caar o)) (cons (cons x (car o)) (cdr o)) (cons (list x) o)))
  161.             )
  162.             L
  163.           )
  164.           (reverse o)
  165.         )
  166.     ;;
  167.     ;; Setup
  168.     (setq ArrayToUse '(a a a a b c c a a d e e e e))
  169.  
  170.     ;;
  171.     ;; Run the bechmark
  172.     (benchmark '((pack-se7en ArrayToUse)
  173.                  (pack-well20152016-2 ArrayToUse)
  174.                  (pack-lee-1 ArrayToUse)
  175.                  (pack-lee-2 ArrayToUse)  
  176.                  (pack-lee-3 ArrayToUse)
  177.                  (pack-vovka ArrayToUse)
  178.                  (pack-gile-1 ArrayToUse)
  179.                  (pack-gile-2 ArrayToUse)
  180.                  (pack_stef ArrayToUse)
  181.                  (pack-rjp ArrayToUse)
  182.                  (ALE_pack ArrayToUse))
  183.     )
  184.   )
  185. )


EDIT: Sorry, I forgot that one function was DQ for using VL. New results posted.
« Last Edit: December 29, 2021, 05:52:13 PM by John Kaul (Se7en) »
TheSwamp.org (serving the CAD community since 2003)

Donate to TheSwamp.org

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1314
  • Marco
Another version (slower) but pretty good if MANY repetitions:
Code: [Select]
(defun ALE_pack3 (L / a p o)
  (while
    (progn
      (setq a (car L))
      (cond
        ( (equal (setq p (list a (cadr L) (caddr L) (cadddr L))) (list a a a a)) (setq L (cddddr L)) )
        ( (equal (setq p (list a (cadr L) (caddr L)           )) (list a a a  )) (setq L (cdddr  L)) )
        ( (equal (setq p (list a (cadr L)                     )) (list a a    )) (setq L (cddr   L)) )
        (        (setq p (list a))                                               (setq L (cdr    L)) )
      )
      (if (= a (caar o)) (setq o (cons (append p (car o)) (cdr o))) (setq o (cons p o)))
      L
    )
  )
  (reverse o)
)

Edit: >>> wrong results if more then 4 repetitions > need more work… sorry  :uglystupid2:
Edit2: fixed but slow  :tickedoff:

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1314
  • Marco
Very short…
Code: [Select]
(defun ALE_pack4 (L / a p o)
  (and
    L
    (while
      (setq
        o (if (equal (setq p (car L)) (caar o)) (cons (cons p (car o)) (cdr o)) (cons (list p) o))
        L (cdr L)
      )
    )
  )
  (reverse o)
)

Edit: non more "Very short"... thanks Lee  :-) :-(

Lee Mac

  • Seagull
  • Posts: 12696
  • London, England
Code: [Select]
_$ (ale_pack4 nil)
:wink:

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Similar to my A09 code: https://www.theswamp.org/index.php?topic=57274.msg607958#msg607958 :whistling:
Code - Auto/Visual Lisp: [Select]
  1. (defun pack-roy (lst / tmp)
  2.   (if (not (atom lst))
  3.     (apply
  4.       'append
  5.       (mapcar
  6.         '(lambda (cur / ret)
  7.           (cond
  8.             ((not cur)
  9.               nil
  10.             )
  11.             ((not (atom cur)) ; Added last item.
  12.               (list tmp)
  13.             )
  14.             ((not tmp)
  15.               (setq tmp (list cur))
  16.               nil
  17.             )
  18.             ((equal cur (car tmp))
  19.               (setq tmp (cons cur tmp))
  20.               nil
  21.             )
  22.             (T
  23.               (setq ret (list tmp))
  24.               (setq tmp (list cur))
  25.               ret
  26.             )
  27.           )
  28.         )
  29.         (append lst '((nil)))
  30.       )
  31.     )
  32.   )
  33. )

bruno_vdh

  • Newt
  • Posts: 82
Hello, if it's not too late to play

For long lists,
Code: [Select]
(defun pack-vdh-1 (l / m grp)
  (mapcar '(lambda (x1 x2)
     (if (= x1 x2)
       (setq grp (cons x1 grp))
       (setq m (cons grp m)
     grp (list x1)
       )
     )
   )
  l
  (cons (car l) l)
  )
  (if l
    (reverse (cons grp m))
  )
)

A recursive version with accumulator
Code: [Select]
(defun pack-vdh-2 (l)
  (if l
    ((lambda (x m)
       (if (= x (caar m))
(cons (cons x (car m)) (cdr m))
(cons (list x) m)
       )
     )
      (car l)
      (pack-vdh-2 (cdr l))
    )
  )
)

The same when looking for optimization
Code: [Select]
(defun pack-vdh-3 (l / m)
  (if l
    (if (= (car l) (cadr l))
      (cons (cons (car l) (car (setq m (pack-vdh-3 (cdr l))))) (cdr m))
      (cons (list (car l)) (pack-vdh-3 (cdr l)))
    )
  )
)

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Code - Auto/Visual Lisp: [Select]
  1. (defun f (l)
  2.   (cond ((not l) l)
  3.         ((atom (car l)) (f (cons (list (car l)) (cdr l))))
  4.         ((= (caar l) (cadr l)) (f (cons (cons (cadr l) (car l)) (cddr l))))
  5.         ((cons (car l) (f (cdr l))))
  6.   )
  7. )

VovKa

  • Swamp Rat
  • Posts: 1475
  • Ukraine