### Composition that works

My earlier implementation of composition without combinators was lacking in detail, and did not support recursion, even though `samefringe` requires it. Here is a more complete version in Common Lisp.

First, the combinators we're trying to hide:

``````(defun b* (f g)
"Multiargument composition: apply G to every argument of F."
(lambda (&rest args) (apply f (mapcar g args))))

(defun h (f &rest funs)
"Multiargument composition: apply a different function to every argument of F.
(The name is from 'high-order'.)"
(lambda (&rest args)
(apply f (mapcar (lambda (f) (apply f args)) funs))))

(defun and* (a b) "AND as a function." (and a b))

(defun hand (f g)
"High-order AND (conjunction of functions)."
(lambda (&rest args) (and (apply f args) (apply g args))))

(defun hor (f g)
"High-order OR (disjunction of functions)."
(lambda (&rest args) (or (apply f args) (apply g args))))

(defun hif (testf thenf &optional (elsef #'identity))
"High-order if: conditional function."
(lambda (&rest args) (if (apply testf args)
(apply thenf args)
(apply elsef args))))

(defun k (x) "The K combinator." (lambda (&rest ignore) x))

(defun while (test step)
"Iteration combinator.
Returns a function that iterates STEP until TEST returns false."
(labels ((iterate (init)
(if (funcall test init)
(iterate (funcall step init))
init)))
#'iterate))``````

Now for the `composition` macro. This version η-expands symbols, to allow recursion. (This makes the expansion ugly, which could be mostly avoided by not expanding symbols from the CL package. Ideally, it should only η-expand symbols that aren't fbound or are being redefined now. But that would excessively complicate the example.) It also adds a `funcall` special form, to turn off composition, so you can usefully call combinators like `while`.

``````(defmacro composition (body)
"Defines a function in an abbreviated combinator language.
For example, (COMPOSITION (= CAR 2)) expands to
(H #'= #'CAR (K 2)), which is equivalent to
(LAMBDA (x) (= (CAR X) 2)).
(labels ((translate (term)
(typecase term
(symbol `(lambda (&rest args)
(apply #',term args)))
(cons (case (car term)
(or `(hor ,@(mapcar #'translate (cdr term))))
(and `(hand ,@(mapcar #'translate (cdr term))))
(if `(hif ,@(mapcar #'translate (cdr term))))
(funcall `(,(car term) ,@(mapcar #'translate (cdr term))))
(t (cons (if (cddr term) 'h 'b*)
(mapcar #'translate term)))))
(t `(k ',term)))))
(translate body)))

(defmacro defcomposition (name exp &optional docstring)
"Shorthand defining macro for COMPOSITION."
`(progn (setf (symbol-function ',name) (composition ,exp))
,@(if docstring
`((setf (documentation ',name 'function) ,docstring))
nil)))``````

That's all we need to define `samefringe` and `factorial`:

``````(defcomposition rotate-right
(funcall while (consp car) (cons caar (cons cdar cdr))))

(defcomposition samefringe (or eq (and (and* consp)
((and (eq car) (samefringe cdr))
rotate-right))))

;;Samefringe expands (without η-expansion) to:
;; (HOR #'EQ
;;      (HAND (B* #'AND* #'CONSP)
;;     (B* (HAND (B* #'EQ #'CAR)
;;                   (B* (LAMBDA (&REST ARGS) (APPLY #'SAMEFRINGE ARGS))
;;                       #'CDR))
;;             #'ROTATE-RIGHT))))

(defun test-samefringe ()
(assert (samefringe nil nil))
(assert (not (samefringe '(1 2) '(1 . 2))))
(assert (samefringe '(1 nil 2 3) '((1) (2 . 3))))
(assert (not (samefringe '(1 2 3 (4 . 5) 6 . 7) '(1 2 3 4 5 6 7)))))

(defcomposition factorial (if zerop 1 (* identity (factorial 1-))))``````

This minilanguage is quite convenient, except for the long `composition` and `defcomposition` names. Presumably you'd shorten those names if you intended to use it much.

It would also be nice to be able to define new noncomposing operations like `and`. If `while` were recognized as one, it would make `rotate-right` even simpler:

``````(defcomposition rotate-right
(while (consp car) (cons caar (cons cdar cdr))))``````