[Commo Lisp] mapf

わだばLisperになる(g000001さん)のお題 【どう書く】MDL/Muddleのmapfを作る をやってみた。

ちなみに g000001 さんの回答と、onjo さんの回答が公開されてる。そっか、throw catch を使うのね。思いつかなかった。prog* がいかにも g000001 さんらしい。onjo さんのリストが省略された場合循環リストを使うのはエレガントだ。効率もちゃんと考えられているし。

throw catch は思いつかなかった結果、defvar したものをループの度に cond で判定してる。日頃からあまりにもエラーハンドリングを無視しすぎかな。

(defvar *mapleave* nil)
(defvar *mapret*   nil)
(defvar *mapstop*  nil)

(defun mapf (final-function loop-function &rest lists)
  (let (collect)
    (if lists
        ;; lists 指定あり
        (loop for i in (apply #'mapcar #'list lists)
              do (let (*mapleave* *mapret* *mapstop*)
                   (let ((ret (apply loop-function i)))
                     #1=(cond (*mapleave*
                               (return-from mapf (car *mapleave*)))
                              (*mapret*
                               (loop for i in (car *mapret*)
                                     do (push i collect)))
                              (*mapstop*
                               (push (car *mapstop*) collect)
                               (return-from mapf (nreverse collect)))
                              (t
                               (push ret collect))))))
        ;; lists 指定なし
        (loop (let (*mapleave* *mapret* *mapstop*)
                (let ((ret (funcall loop-function)))
                  #1#))))
    (if final-function
        (apply final-function (nreverse collect))
        (car lists))))

(defun mapleave (x)
  (setf *mapleave* (list x)))

(defun mapret (&rest args)
  (setf *mapret* (list args)))

(defun mapstop (x)
  (setf *mapstop* (list x)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 以下テスト
(assert (equal (mapf #'list #'identity '(1 2 3 4))
               '(1 2 3 4)))

(defun mappend (fn &rest lists)
  (apply #'mapf #'append fn lists))

(assert (equal (mappend #'list
                        '(1 2 3 4 5)
                        '(a b c d e))
               '(1 A 2 B 3 C 4 D 5 E)))

(defun first-nonzero (list)
  (mapf ()
        (lambda (x)
          (when (not (zerop x)) (mapleave x)))
        list))

(assert (= (first-nonzero '(0 0 0 0 9 0 0))
           9))

(defun odd-list (list)
  (mapf #'list
        (lambda (x) (if (oddp x)
                        x
                        (mapret)))
        list))

(assert (equal (odd-list '(1 2 3 4 5))
               '(1 3 5)))

(defun odd-list2 (list)
  (mapf #'list
        (lambda (x) (if (oddp x)
                        x
                        (mapret 'e 'ven)))
        list))

(assert (equal (odd-list2 '(1 2 3 4 5))
               '(1 E VEN 3 E VEN 5)))

(defun first-ten (list)
  (let ((cnt 10))
    (mapf #'list
          (lambda (x)
            (when (zerop (decf cnt)) (mapstop 10))
            x)
          list)))

(assert (equal (first-ten '(1 2 3 4 5 6 7 8 9 10 11 12))
               '(1 2 3 4 5 6 7 8 9 10)))

(defun lnum (n &aux (cnt 0))
  (mapf #'list
        (lambda ()
          (if (<= n (incf cnt))
              (mapstop n)
              cnt))))

(assert (equal (lnum 10)
               '(1 2 3 4 5 6 7 8 9 10)))