;; A library of functionals that are not built into Lisp.
;; Version: 2003 October 20

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Binding a parameter of a binary function to a fixed value, thereby creating
;; a function of one argument.  It is also called currying from the
;; mathematician Curry who developed the idea.  The effect to convert a
;; binary function to a unary function.
;;
;; For example (bu '+ 3) creates a function to add 3.
              ;; Thus we could define an operator 3+ as follows.
;;      (defun 3+ (x) (funcall (bu '+ 3) x))
;;      (3+ 8) = 11
;;
;; Or a function to cons 3 to a value.
;;      (defun cons3 (x) (funcall (bu 'cons 3) x))
;;      (cons3 'a) = (3 . a)

(defun bu (f x)
 (function (lambda (y) (funcall f x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The functional rev is used to reverse the order of the paramters to a
;; function.
;;
;; For example in the above (cons3 'a) = (3 . a).  Suppose you want (a . 3).
;; Try the following to reverse the expected order of arguments to cons.
;;      (defun rcons3 (x) (funcall (bu (rev 'cons) 3) x))
;;
;; Notice funcall is only needed at the "outer level" of the definition for
;; bu but not for rev which is an "inner call".

(defun rev (f)
 (function (lambda (x y) (funcall f y x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General purpose curry macro that creates an n-1 parameter function
;; from an n parameter function by fixing the parameter at position pos
;; with the given value.
;;
;; Example that curries the first paramter of a binary - with 3.
;;    (mapcar (curry '- 1 2 3) '(1 2 3 4)) ==> (2 1 0 -1)
;; The previous expression is equivalent to the following expression
;; as in each case the first parameter is curried.
;;    (mapcar (bu '- 3) '(1 2 3 4))
;; The following example curries the second paramter of -
;;    (mapcar (curry '- 2 2 3) '(1 2 3 4)) ==> (-2 -1 0 1)
;; The previous expression is equivalent to the following expression
;; as in each case the second parameter is curried.
;;    (mapcar (bu (rev '-) 3) '(1 2 3 4))

(defmacro curry (func pos parm-cnt value)
 (let ((parm (mapcar 'gensym (range 1 parm-cnt))))
  (let ((first-parms (prefix (1- pos) parm))
        (last-parms (suffix (1+ pos) parm)))
   (list 'function
    (list 'lambda (append first-parms last-parms)
           (append (list 'funcall func)
                   first-parms (list value) last-parms)))
)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; comp  defines a function as being the composition of a pair of unary
;; functions.
;;
;; For example an expensive donothing to add one and then subtract one.
;;      (defun donothing (x) (funcall (comp '1- '1+) x))

(defun comp (f g)
  (function (lambda (x) (funcall f ( funcall g x)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; compl defines a function as being the composition of a list of unary
;; functions.
;;
;; The previous example can be constructed using compl as follows.
;;      (defun donothing2 (x) (funcall (compl '1- '1+) x))
;; Now do a plus 7 using 3+ and 1+.
;;      (defun 7+ (x) (funcall (compl '3+ '3+ '1+) x))

(defun compl (&rest funlist)
  (function (lambda (x) (compbody x funlist))))

(defun compbody (x funlist)
  (cond ((null funlist) x)
        (t (funcall (car funlist) (compbody x (cdr funlist))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Manipulating lists to get them into the right shape for functions is
;; also required.  Here are three such operations with variations on
;; implementation to give you an idea of the different ways in which functions
;; can be written.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; trans -- transpose a two-dimensional matrix.
;;

(defun trans (matrix) (apply 'mapcar 'list matrix))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Distribute left distributes the first parameter to the left of each of the
;; items in the second parameter.
;;
;; (distl 'a '(1 2 3)) = ((a 1) (a 2) (a 3))
;;
;; DISTLR is the distribute left recursive version.
;; DISTL  is the functional two parameter version.
;; DISTL1 is the functional one parametern version in the style of Backus.

(defun distlr (x b)
 (cond ((null b) nil)
       (t (cons (list x (car b)) (distl x (cdr b))))))

(defun distl (x b)
  (mapcar (function (lambda (y) (list x y))) b))

(defun distl1 (x-b)
  (mapcar (function (lambda (y) (list (first x-b) y))) (second x-b)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Distribute right distributes the first parameter to the right of each of
;; the items in the second parameter.
;;
;; (distr 'a '(1 2 3)) = ((1 a) (2 a) (3 a))
;
;; DISTRR is the distribute right recursive version.
;; DISTR  is the functional two parameter version.
;; DISTR1 is the functional one parameter version in the style of Backus.

(defun distrr (x b)
 (cond ((null b) nil)
       (t (cons (list (car b) x) (distrr x (cdr b))))))

(defun distr (x b)
  (mapcar (function (lambda (y) (list y x))) b))

(defun distr1 (x-b)
  (mapcar (function (lambda (y) (list y (first x-b)))) (second x-b)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reduce is defined as it is not available in PowerLisp.  It is defined
;; in Clisp.  Renamed here to distunquish them.
;; The optional base is useful when the input list could be empty
;; and a non-nil value is needed.   For example using (reduce '* list)
;; where if the list could be empty it would be better to use
;; (reduce '* list 1) as 1 is the zero for multiplication.
;;
;; Two versions of reduce are given -- one from front to back the other from
;; back to front.   For commutative operators the same result is obtained.  For
;; non-cummutative operators different results are obtained.


(defun reduce-pl (func theList &optional base)
  (cond ((null theList) base)
        ((null (cdr theList)) (car theList))
        ((null (cddr theList)) (apply func theList))
        (t (funcall func (reduce-pl func (butlast theList))
                         (car (last theList))))
))

;; Reduce for 1-parameter functions.  The function is applied to a
;; pair of values as a list.

(defun reduce1 (func theList &optional base)
 (cond ((null theList) base)
       ((null (cdr theList)) (car theList))
       ((null (cddr theList)) (funcall func theList))
       (t (funcall func (cons (reduce1 func (butlast theList))
                              (last theList))))
))

;; reduce from back to front

(defun reduceb (func theList &optional (base nil bflag))
  (cond (bflag
           (cond ((null theList) base)
                 (t (funcall func (car theList) (reduceb func (cdr theList) base)))))
        (t (cond ((null theList) base)
                 ((null (cdr theList)) (car theList))
                 ((null (cddr theList)) (apply func theList))
                 (t (funcall func (car theList) (reduceb func (cdr theList))))))
))

;; Reduce for 1-parameter functions.  The function is applied to a
;; pair of values as a list.

(defun reduceb1 (func theList &optional (base nil bflag))
  (cond (bflag
           (cond ((null theList) base)
                 (t (funcall func (list (car theList) (reduceb func (cdr theList) base))))))
        (t (cond ((null theList) base)
                 ((null (cdr theList)) (car theList))
                 ((null (cddr theList)) (funcall func theList))
                 (t (funcall func (list (car theList) (reduceb1 func (cdr theList)))))))
))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Range gives a list of integers in the range lowerBound to upperBound
;; inclusive.
;; Precondition: lowerBound <= upperBound

(defun range (lowerBound upperBound)
 (cond ((> lowerBound upperBound) nil)
       (t (cons lowerBound (range (1+ lowerBound) upperBound)))
))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Filter a list.  Keep items that satisfy the predicate.

(defun filter (predicate list)
 (apply 'append (mapcar #'(lambda (item)
                             (cond ((funcall predicate item) (list item)))) list)
))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Math function - sigma
;; Add a function of the integers between lowerBound and upperBound
;; inclusive but the function can involve real numbers and return real
;; numbers.

(defun sigma (lowerBound upperBound func)
 (reduce-pl '+ (mapcar func (range lowerBound upperBound)))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General generate a list function.
;; start is the first item in the list
;; next is a one parameter function that generates the second
;;      item in the list from the starting item
;; length is the length of the list to generate
;;
;; An example that is equivalent to (range -10 14)
;;    (genlist 25 '1+ -10)

(defun genlist (length next start)
 (cond ((= length 0) nil)
       (t (cons start (genlist (1- length) next (funcall next start))))
))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Iterate a function for a count number of times
;; Similar to genlist, except only the final result is kept.

(defun iter (count func state)
 (cond ((= count 0) state)
       (t (iter (1- count) func (funcall func state)))
))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; For i = k to n by p do func(state, i)

(defun for (k n p func state)
 (cond ((> k n) state)
       (t (for (+ k p) n p func (funcall func state k)))
))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; while cond(state) do func(state)

(defun while (condition func state)
 (cond ((funcall condition state)
           (while condition func (funcall func state)))
       (t state)
))