Topic: [challenge] A08 : "Pack" consecutive duplicates of list elements into sublists

[Marc'Antonio Alessi]

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]

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.

[Marc'Antonio Alessi]

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 
Edit2: fixed but slow 

[Marc'Antonio Alessi]

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]

Code: [Select]

_$ (ale_pack4 nil)

[roy_043]

Similar to my A09 code: https://www.theswamp.org/index.php?topic=57274.msg607958#msg607958

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]

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]

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]

(f '(1 nil))

[ElpanovEvgeniy]

(f '(1 nil))

thanks, I'll fix it.