On Lisp復習

4章に大量に載ってるユーティリティ関数を早く復習しちゃわないと。。
例のごとく書籍とは完全一致してません。
4.3 のつづき(d:id:Nobuhisa:20071128:1196180768)

CL-USER 1 > 
;; 簡易版
(defun flatten1 (x)
  (mapcan #'(lambda (x)
              (if (atom x)
                  (list x)
                (flatten1 x) ))
          x))
FLATTEN1
CL-USER 2 > (flatten1 '(1 (2 3) 4 (5 (6 (7) 8)) 9))
(1 2 3 4 5 6 7 8 9)

CL-USER 3 > 
;; 高速版
(defun flatten2 (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x) (rec (cdr x) acc))) )))
    (rec x nil) ))
FLATTEN2
CL-USER 4 > (flatten2 '(1 (2 3) 4 (5 (6 (7) 8)) 9))
(1 2 3 4 5 6 7 8 9)


;; 簡易版
CL-USER 5 > 
(defun prune1 (test tree)
  (if (atom tree)
      tree
    (mapcar #'(lambda (x) (prune1 test x))
            (remove-if #'(lambda (y)
                           (and (atom y) (funcall test y)) )
                       tree) )))
PRUNE1
CL-USER 6 > (prune1 #'evenp '(1 (2 (3 4) (5 6 7)) 8 9))
(1 ((3) (5 7)) 9)

;; 高速版
CL-USER 7 > 
(defun prune2 (test tree)
  (labels ((rec (tree acc)
             (cond ((null tree) (nreverse acc))
                   ((consp (car tree))
                    (rec (cdr tree)
                         (cons (rec (car tree) nil) acc) ))
                   (t
                    (rec (cdr tree)
                         (if (funcall test (car tree))
                             acc
                           (cons (car tree) acc) ))))))
    (rec tree nil) ))
PRUNE2
CL-USER 8 > (prune2 #'evenp '(1 (2 (3 4) (5 6 7)) 8 9))
(1 ((3) (5 7)) 9)

再帰はちょっぴり慣れてきたけど，二重再帰になると苦しい。
特にprune2は本見ないと書けにゃい。。。

4.4 検索

CL-USER 1 > 
(defun split-if (fn lst)
  (let (acc)
    (do ((src lst (cdr src)))
        ((or (null src) (funcall fn (car src)))
         (values (nreverse acc) src) )
      (push (car src) acc) )))
SPLIT-IF
CL-USER 2 > (split-if #'(lambda (x) (> x 4))
                      (loop for x from 1 to 10 collect x) )
(1 2 3 4)
(5 6 7 8 9 10)

;; やっぱり載せとく
(defun before (x y lst &key (test #'eql))
  (and lst
       (let ((first (car lst)))
         (cond ((funcall test y first) nil)
               ((funcall test x first) lst)
               (t (before x y (cdr lst) :test test)) ))))
BEFORE

CL-USER > (before 'a 'b '(w a w w b))
(A W W B)
CL-USER > (before 'a 'b '(w w a w w))
(A W W)

CL-USER > 
(defun after (x y lst &key (test #'eql))
  (let ((rest (before y x lst :test test)))
    (and rest (member x rest :test test)) ))
AFTER

CL-USER > (after 'a 'b '(x b x a x))
(A X)
CL-USER > (after 'a 'b '(x x a x))
NIL

この辺で寝よう。