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))))

## No comments:

## Post a Comment

It's OK to comment on old posts.