Skip to content

Instantly share code, notes, and snippets.

@kaz-yos
Forked from ha2ne2/foldx.lisp
Last active August 29, 2015 14:19
Show Gist options
  • Save kaz-yos/c734d4b28133866fb668 to your computer and use it in GitHub Desktop.
Save kaz-yos/c734d4b28133866fb668 to your computer and use it in GitHub Desktop.
(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))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment