«Классическое» рекурсивное решение
(defun identity-groups (l &key (test #'eql))
(labels ((group (l last-group acc)
(cond ((null l) (cons last-group acc))
((and last-group (funcall test (car l) (car last-group)))
(group (cdr l) (cons (car l) last-group) acc))
(t
(group (cdr l) (list (car l)) (cons last-group acc))))))
(cdr (reverse (group l '() '())))))
Старая версия (требуется начальное значение, не равное первому элементу списка)
Таким образом, вышеприведенная версия избавилась от этого ключевого аргумента.
(defun identity-groups (l &key (test #'eql) (initial-value '(0)))
(labels ((group (l last-group acc)
(cond ((null l) (cons last-group acc))
((funcall test (car l) (car last-group))
(group (cdr l) (cons (car l) last-group) acc))
(t
(group (cdr l) (list (car l)) (cons last-group acc))))))
(cdr (reverse (group l initial-value '())))))
Циклическая конструкция в императивном стиле
Попробовала для забавы также циклическую конструкцию с do
.
(defun group-identicals (l &key (test #'eql))
(let ((lx) (tmp) (res)) ;; initiate variables
(dolist (x l (reverse (cons tmp res))) ;; var list return/result-value
(cond ((or (null lx) (funcall test x lx)) ;; if first round or
(push x tmp) ;; if last x (lx) equal to current `x`,
(setf lx x)) ;; collect it in tmp and set lx to x
(t (push tmp res) ;; if x not equal to lastx, push tmp to result
(setf tmp (list x)) ;; and begin new tmp list with x
(setf lx x)))))) ;; and set last x value to current x
(cdr (reverse (group l initial-value '())))))
;; cdr removes initial last-group value
;; test:
(group-identicals '(1 2 3 3 4 4 4 4 5 5 6 3 3 3 3))
;; ((1) (2) (3 3) (4 4 4 4) (5 5) (6) (3 3 3 3))
(group-identicals '("a" "b" "b" "c" "d" "d" "d" "e") :test #'string=)
;; (("a") ("b" "b") ("c") ("d" "d" "d") ("e"))