寻找一种算法来重新排列列表

Question

我将尝试找出一种能够实现以下功能的算法：

算法将接收到像这样的列表：

((start a b c) (d e f (start g h i) (j k l) (end)) (end) (m n o))

接下来，它会将包含元素start的列表与包含元素end的列表之前的所有列表连接起来。最后返回的列表应该如下所示：

((start a b c (d e f (start g h i (j k l)))) (m n o))

该算法必须能够处理包含start的列表，这些列表也可能包含其他的start。

编辑：

现在我有这个：

(defun conc-lists (l)
  (cond
      ((endp l) '())
      ((eq (first (first l)) 'start) 
          (cons (cons (first (first l)) (conc-lists (rest (first l))))) 
              (conc-lists (rest l)))
      ((eq (first (first l)) 'end) '())
      (t (cons (first l) (conc-lists (rest l))))))

但是它没有起作用。也许我应该列出或添加而不是 consing？

编辑2：

上面的程序不应该工作，因为我正在尝试从非列表中获取第一个元素。到目前为止，这是我想出来的：

(defun conc-lists (l)
  (cond
      ((endp l) '())
      ((eq (first (first l)) 'start) 
          (append (cons (first (first l)) (rest (first l))) 
              (conc-lists (rest l))))
      ((eq (first (first l)) 'end) '())
      (t (cons (first l) (conc-lists (rest l))))))

这是我得到的结果:

(conc-lists ((START A B C) (D E F (START G H I) (J K L) (END)) (END) (M N O)))
1. Trace: (CONC-LISTS '((START A B C) (D E F (START G H I) (J K L) (END)) (END) (M N O)))
2. Trace: (CONC-LISTS '((D E F (START G H I) (J K L) (END)) (END) (M N O)))
3. Trace: (CONC-LISTS '((END) (M N O)))
3. Trace: CONC-LISTS ==> NIL
2. Trace: CONC-LISTS ==> ((D E F (START G H I) (J K L) (END)))
1. Trace: CONC-LISTS ==> (START A B C (D E F (START G H I) (J K L) (END)))
(START A B C (D E F (START G H I) (J K L) (END)))

- user1176517

---

你的实现中有几个bug：(t (cons (first l) (conc-lists (rest l))))：你需要在(first l)上递归调用conc-lists，这样(first l)内部的(start)子列表才会被处理。另一个bug是当你到达一个(end)时，你停止了递归；而可能还有更多的元素跟在(end)后面，它们将会丢失。因为在当前嵌套级别已经看到(start)时，对(start)和(end)的处理是不同的，所以我认为你应该有两个递归函数，而不是一个。（请参见我的答案中的示例。） - Alex D

Answer 1

我对CL也是相对初学者，但这似乎是一个有趣的挑战，所以我试着去做了。有经验的Lispers，请评论一下我的代码！@user1176517，如果你发现任何错误，请告诉我！

首先有几点注释：我想让它是O(n)，而不是O(n^2)，所以我让递归函数返回两个列表的头和尾（即最后一个cons），这些列表是从树的分支递归处理结果得出的。这样，在conc-lists-start中，我可以将一个列表的最后一个cons连接到另一个列表的第一个cons上，而无需nconc遍历一个列表。我用多个返回值来实现这个，不幸的是这让代码变得有些臃肿。为了确保tail是结果列表的最后一个cons，我需要在递归之前检查cdr是否为空。

有两个递归函数处理树：conc-lists和conc-lists-first。当conc-lists看到一个(start)时，递归处理将继续使用conc-lists-start。同样地，当conc-lists-start看到一个(end)时，递归处理将继续使用conc-lists。

我确定它需要更多的注释……我以后可能会添加更多。

这是可工作的代码：

;;; conc-lists
;;; runs recursively over a tree, looking for lists which begin with 'start
;;; such lists will be nconc'd with following lists a same level of nesting,
;;;   up until the first list which begins with 'end
;;; lists which are nconc'd onto the (start) list are first recursively processed
;;;   to look for more (start)s
;;; returns 2 values: head *and* tail of resulting list
;;; DESTRUCTIVELY MODIFIES ARGUMENT!
(defun conc-lists (lst)
  (cond
    ((or  (null lst) (atom lst)) (values lst lst))
    ((null (cdr lst))            (let ((head (conc-process-rest lst)))
                                   (values head head)))
    (t (conc-process-rest lst))))

;;; helper to factor out repeated code
(defun conc-process-rest (lst)
  (if (is-start (car lst))
      (conc-lists-start (cdar lst) (cdr lst))
      (multiple-value-bind (head tail) (conc-lists (cdr lst))
         (values (cons (conc-lists (car lst)) head) tail))))

;;; conc-lists-start
;;; we have already seen a (start), and are nconc'ing lists together
;;; takes *2* arguments so that 'start can easily be stripped from the
;;;   arguments to the initial call to conc-lists-start
;;; recursive calls don't need to strip anything off, so the car and cdr
;;;   are just passed directly
(defun conc-lists-start (first rest)
  (multiple-value-bind (head tail) (conc-lists first)
    (cond
      ((null rest) (let ((c (list head))) (values c c)))
      ((is-end (car rest))
         (multiple-value-bind (head2 tail2) (conc-lists (cdr rest))
           (values (cons head head2) tail2)))
      (t (multiple-value-bind (head2 tail2) (conc-lists-start (car rest) (cdr rest))
           (nconc tail (car head2))
           (values (cons head (cdr head2)) tail2))))))

(defun is-start (first)
  (and (listp first) (eq 'start (car first))))
(defun is-end   (first)
  (and (listp first) (eq 'end (car first))))

- Alex D