foldx.lisp

(defun foldr (f lst)
  (if (null (cdr lst)) (car lst)
      (funcall f (car lst) (foldr f (cdr lst)))))

(defun foldl (f lst)
  (if (null (cdr lst)) (car lst)
      (funcall f (foldl f (butlast lst)) (car (last lst)))))

(defun foldr-tail (f a lst)
  (if (null lst) a
      (foldr-tail f (funcall f (car (last lst)) a) (butlast lst))))

(defun foldl-tail (f a lst)
  (if (null lst) a
      (foldl-tail f (funcall f a (first lst)) (rest lst))))

(defun compr (&rest fs)
  (if (null (cdr fs)) (car fs)
      (let ((f (car fs))
            (g (apply #'compr (cdr fs))))
        (lambda (&rest args)
          (funcall f (apply g args))))))

(defun compl (&rest fs)
  (if (null (cdr fs)) (car fs)
      (let ((f (apply #'compl (butlast fs)))
            (g (car (last fs))))
        (lambda (&rest args)
          (funcall f (apply g args))))))

;; (funcall (compl #'not #'evenp #'+) 1 2 3 4 5) ;=> T
;; (funcall (compr #'not #'evenp #'+) 1 2 3 4 5) ;=> T

;; おまけ
(defun comp (f g) (lambda (&rest args) (funcall f (apply g args))))
(defun compr% (&rest fs) (foldr #'comp fs))
(defun compl% (&rest fs) (foldl #'comp fs))
(defmacro compose (&rest fs)
  (labels ((rec (fs)
             (if (null (cdr fs))
                 `(apply #',(car fs) args)
                 `(,(car fs) ,(rec (cdr fs))))))
    `(lambda (&rest args) ,(rec fs))))
;; (compose not evenp +)
;;-> (LAMBDA (&REST ARGS) (NOT (EVENP (APPLY #'+ ARGS))))