Anaphoric(aka "Un-hygenic") macros in CL
As an example let’s look at an algorithm that’s fairly common : breadth first traversal of a binary tree. Also called level-order traversal.
Wikipedia:
“In graph theory, breadth-first search (BFS) is a graph search algorithm that begins at the root node and explores all the neighboring nodes. Then for each of those nearest nodes, it explores their unexplored neighbor nodes, and so on, until it finds the goal.”
First let’s define a simple node struct and create a tree :
(defstruct (btnode)
(val nil)
(left nil)
(right nil))
(defun print-node (n) (format t "~A " (btnode-val n)))
(defvar root #S(BTNODE
:VAL 5
:LEFT #S(BTNODE
:VAL 3
:LEFT #S(BTNODE
:VAL 2
:LEFT #S(BTNODE :VAL 1 :LEFT NIL :RIGHT NIL)
:RIGHT NIL)
:RIGHT #S(BTNODE :VAL 4 :LEFT NIL :RIGHT NIL))
:RIGHT #S(BTNODE
:VAL 7
:LEFT #S(BTNODE :VAL 6 :LEFT NIL :RIGHT NIL)
:RIGHT #S(BTNODE
:VAL 8
:LEFT NIL
:RIGHT #S(BTNODE :VAL 9 :LEFT NIL :RIGHT NIL)))))
Let’s add some twists : let’s say we want to be able to traverse horizontally left to right or right to left and vertically from top to bottom or from bottom to top. Also, what if we wanted to do different operations on the nodes and come up with a way to filter certain nodes from the results.
Anaphoric macros make this possible in a few lines of code :
(defmacro with-breadth-first-traversal (&body body)
`(macrolet ((bft-init ((&optional &key test) &body body)
`(let* ((res (list node))
(queue (list node))
(btot (eql vorder 'bottom-to-top))
(rtol (eql horder 'right-to-left))
(rtol (if btot (not rtol) rtol)))
,@body))
(bft-loop-init (&body body)
`(let* ((node (car queue))
(lcnode (btnode-left node))
(rcnode (btnode-right node))
(children (when rcnode
(cons rcnode nil)))
(children (if lcnode
(cons lcnode children) children))
(children (if rtol (reverse children) children))
(nqueue (append (rest queue) children))
(nres (append res children)))
,@body)))
,@body))
;; Define callable variations of breadth first traversal functions
(with-breadth-first-traversal
(defun traverse-tree-by-level
(node fun &optional horder vorder)
(bft-init ()
(loop while queue do
(bft-loop-init
(setf queue nqueue)
(setf res nres)))
(mapcar fun (if btot (reverse res) res))))
(defmacro traverse-tree-by-level-recursive-m
(node fun &optional horder vorder &key test)
(declare (ignore node fun horder vorder))
`(bft-init (:test ,test)
(labels ((traverse (res queue)
(if (not queue)
(if ,test (delete-if-not ,test res) res)
(bft-loop-init (traverse nres nqueue)))))
(let ((res (traverse res queue)))
(mapcar fun (if btot (reverse res) res))))))
(defun traverse-tree-by-level-recursive
(node fun &optional horder vorder)
(traverse-tree-by-level-recursive-m node fun horder vorder))
)
Here we have used anaphoric macros to implement two ways to perform BFS. The first uses a while loop and the second uses recursion. We’ve also allowed for calling code to be able to pass in a :test key lambda that will filter nodes from our results. This is typical of the kind of flexibility that can be derived when implementing algorithms using anaphoric macros.
Here are the results of printing out the traversals :
(defun run-bfs-test-variations (variations)
(let ((orders (mapcar #'(lambda (x)
(mapcar #'(lambda (y) (cons x y))
'(left-to-right right-to-left)))
'(top-to-bottom bottom-to-top))))
(mapcar #'(lambda (test)
(format t (car test))
(map 'list #'(lambda (fnames)
(format t "~13A ~A : " (car fnames) (cdr fnames))
(apply (cadr test) (list root #'print-node
(cdr fnames) (car fnames)))
(format t "~%"))
(apply #'append orders))
(format t "~%"))
variations)))
(run-bfs-test-variations
'(("level order function : ~%" traverse-tree-by-level)
("level order function recursive : ~%" traverse-tree-by-level-recursive)))
;; level order function :
;; TOP-TO-BOTTOM LEFT-TO-RIGHT : 5 3 7 2 4 6 8 1 9
;; TOP-TO-BOTTOM RIGHT-TO-LEFT : 5 7 3 8 6 4 2 9 1
;; BOTTOM-TO-TOP LEFT-TO-RIGHT : 1 9 2 4 6 8 3 7 5
;; BOTTOM-TO-TOP RIGHT-TO-LEFT : 9 1 8 6 4 2 7 3 5
;; level order function recursive :
;; TOP-TO-BOTTOM LEFT-TO-RIGHT : 5 3 7 2 4 6 8 1 9
;; TOP-TO-BOTTOM RIGHT-TO-LEFT : 5 7 3 8 6 4 2 9 1
;; BOTTOM-TO-TOP LEFT-TO-RIGHT : 1 9 2 4 6 8 3 7 5
;; BOTTOM-TO-TOP RIGHT-TO-LEFT : 9 1 8 6 4 2 7 3 5
So we could add some more functions with very little effort to do other BFS traversal variations.
Let’s implement a function to only show nodes that have an odd numeric value.
Or we could decide that we want to show only the leaf nodes in the tree.
(with-breadth-first-traversal
(defun traverse-tree-by-level-only-odd
(node fun &optional horder vorder)
(traverse-tree-by-level-recursive-m
node fun horder vorder
:test #'(lambda (node) (and node (oddp (btnode-val node))))))
(defun traverse-tree-by-level-only-leaves
(node fun &optional horder vorder)
(traverse-tree-by-level-recursive-m
node fun horder vorder
:test #'(lambda (node)
(and node (not (or (btnode-left node)
(btnode-right node)))))))
)
The results :
(run-bfs-test-variations
'(("level order function (odd only) : ~%" traverse-tree-by-level-only-odd)
("level order function (leaves only) : ~%" traverse-tree-by-level-only-leaves)))
;; level order function (odd only) :
;; TOP-TO-BOTTOM LEFT-TO-RIGHT : 5 3 7 1 9
;; TOP-TO-BOTTOM RIGHT-TO-LEFT : 5 7 3 9 1
;; BOTTOM-TO-TOP LEFT-TO-RIGHT : 1 9 3 7 5
;; BOTTOM-TO-TOP RIGHT-TO-LEFT : 9 1 7 3 5
;; level order function (leaves only) :
;; TOP-TO-BOTTOM LEFT-TO-RIGHT : 4 6 1 9
;; TOP-TO-BOTTOM RIGHT-TO-LEFT : 6 4 9 1
;; BOTTOM-TO-TOP LEFT-TO-RIGHT : 1 9 4 6
;; BOTTOM-TO-TOP RIGHT-TO-LEFT : 9 1 6 4
We’ve gained significantly with this approach for only a few lines of code.
How long would a version in other languages be with the same functionality and flexibility ?