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)).
   See also the SAMEFRINGE and FACTORIAL examples."
  (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))))
                       (quote `(k ',(cadr 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))))