Mercurial > core / lisp/std/fu/curry.lisp
changeset 698: |
96958d3eb5b0 |
parent: |
a0dfde3cb3c4
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; std/fu/curry.lisp --- Standard Currying Functors 8 ;;; Alexandria Functions 9 (declaim (inline ensure-function)) 11 (declaim (ftype (function (t) (values function &optional)) 13 (defun ensure-function (function-designator) 14 "Returns the function designated by FUNCTION-DESIGNATOR: 15 if FUNCTION-DESIGNATOR is a function, it is returned, otherwise 16 it must be a function name and its FDEFINITION is returned." 17 (if (functionp function-designator) 19 (fdefinition function-designator))) 21 (define-modify-macro ensure-functionf/1 () ensure-function) 23 (defmacro ensure-functionf (&rest places) 24 "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of 25 PLACES contains a function." 26 `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places))) 28 (defun disjoin (predicate &rest more-predicates) 29 "Returns a function that applies each of PREDICATE and MORE-PREDICATE 30 functions in turn to its arguments, returning the primary value of the first 31 predicate that returns true, without calling the remaining predicates. 32 If none of the predicates returns true, NIL is returned." 33 (declare (optimize (speed 3) (safety 1) (debug 1))) 34 (let ((predicate (ensure-function predicate)) 35 (more-predicates (mapcar #'ensure-function more-predicates))) 36 (lambda (&rest arguments) 37 (or (apply predicate arguments) 39 (declare (type function p)) 43 (defun conjoin (predicate &rest more-predicates) 44 "Returns a function that applies each of PREDICATE and MORE-PREDICATE 45 functions in turn to its arguments, returning NIL if any of the predicates 46 returns false, without calling the remaining predicates. If none of the 47 predicates returns false, returns the primary value of the last predicate." 48 (if (null more-predicates) 50 (lambda (&rest arguments) 51 (and (apply predicate arguments) 52 ;; Cannot simply use CL:EVERY because we want to return the 53 ;; non-NIL value of the last predicate if all succeed. 54 (do ((tail (cdr more-predicates) (cdr tail)) 55 (head (car more-predicates) (car tail))) 57 (apply head arguments)) 58 (unless (apply head arguments) 61 (defun compose (function &rest more-functions) 62 "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its 63 arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS, 64 and then calling the next one with the primary value of the last." 65 (declare (optimize (speed 3) (safety 1) (debug 1))) 67 (let ((f (ensure-function f)) 68 (g (ensure-function g))) 69 (lambda (&rest arguments) 70 (declare (dynamic-extent arguments)) 71 (funcall f (apply g arguments))))) 73 :initial-value function)) 75 (define-compiler-macro compose (function &rest more-functions) 76 (labels ((compose-1 (funs) 78 `(funcall ,(car funs) ,(compose-1 (cdr funs))) 79 `(apply ,(car funs) arguments)))) 80 (let* ((args (cons function more-functions)) 81 (funs (make-gensym-list (length args) "COMPOSE"))) 82 `(let ,(loop for f in funs for arg in args 83 collect `(,f (ensure-function ,arg))) 84 (declare (optimize (speed 3) (safety 1) (debug 1))) 85 (lambda (&rest arguments) 86 (declare (dynamic-extent arguments)) 87 ,(compose-1 funs)))))) 89 (defun multiple-value-compose (function &rest more-functions) 90 "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies 91 its arguments to each in turn, starting from the rightmost of 92 MORE-FUNCTIONS, and then calling the next one with all the return values of 94 (declare (optimize (speed 3) (safety 1) (debug 1))) 96 (let ((f (ensure-function f)) 97 (g (ensure-function g))) 98 (lambda (&rest arguments) 99 (declare (dynamic-extent arguments)) 100 (multiple-value-call f (apply g arguments))))) 102 :initial-value function)) 104 (define-compiler-macro multiple-value-compose (function &rest more-functions) 105 (labels ((compose-1 (funs) 107 `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs))) 108 `(apply ,(car funs) arguments)))) 109 (let* ((args (cons function more-functions)) 110 (funs (make-gensym-list (length args) "MV-COMPOSE"))) 111 `(let ,(mapcar #'list funs args) 112 (declare (optimize (speed 3) (safety 1) (debug 1))) 113 (lambda (&rest arguments) 114 (declare (dynamic-extent arguments)) 115 ,(compose-1 funs)))))) 117 (declaim (inline curry rcurry)) 119 (defun curry (function &rest arguments) 120 "Returns a function that applies ARGUMENTS and the arguments 121 it is called with to FUNCTION." 122 (declare (optimize (speed 3) (safety 1))) 123 (let ((fn (ensure-function function))) 125 (declare (dynamic-extent more)) 126 ;; Using M-V-C we don't need to append the arguments. 127 (multiple-value-call fn (values-list arguments) (values-list more))))) 129 (define-compiler-macro curry (function &rest arguments) 130 (let ((curries (make-gensym-list (length arguments) "CURRY")) 131 (fun (gensym "FUN"))) 132 `(let ((,fun (ensure-function ,function)) 133 ,@(mapcar #'list curries arguments)) 134 (declare (optimize (speed 3) (safety 1))) 136 (declare (dynamic-extent more)) 137 (apply ,fun ,@curries more))))) 139 (defun rcurry (function &rest arguments) 140 "Returns a function that applies the arguments it is called 141 with and ARGUMENTS to FUNCTION." 142 (declare (optimize (speed 3) (safety 1))) 143 (let ((fn (ensure-function function))) 145 (declare (dynamic-extent more)) 146 (multiple-value-call fn (values-list more) (values-list arguments))))) 148 (define-compiler-macro rcurry (function &rest arguments) 149 (let ((rcurries (make-gensym-list (length arguments) "RCURRY")) 150 (fun (gensym "FUN"))) 151 `(let ((,fun (ensure-function ,function)) 152 ,@(mapcar #'list rcurries arguments)) 153 (declare (optimize (speed 3) (safety 1))) 155 (declare (dynamic-extent more)) 156 (multiple-value-call ,fun (values-list more) ,@rcurries))))) 158 (declaim (notinline curry rcurry))