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 ?

Tree traversal code.

Ruby ‘compiler’ in CL

The implementers of existing Ruby VMs have gone the way of C, C++ and Java.
There is another possibility. Why not implement Ruby in Common Lisp ?

Ok, let’s take the first shot and implement a subset of the Ruby language. Just enough to run some simple contrived numeric benchmarks. The following pseudo BNF describing a minimal subset of Ruby should do (taken from the rubydocs here).

PROGRAM         : COMPSTMT

COMPSTMT        : STMT (TERM EXPR)* [TERM]

STMT            : CALL 
                | EXPR

EXPR            | ARG

CALL            : FUNCTION

FUNCTION        : OPERATION [`(' [CALL_ARGS] `)']

ARG             : LHS `=' ARG
                | ARG `..' ARG
                | ARG `+' ARG
                | ARG `-' ARG
                | ARG `*' ARG
                | PRIMARY

PRIMARY         : LITERAL
                | VARIABLE
                | for BLOCK_VAR in EXPR DO
                   COMPSTMT
                  end
                | def FNAME ARGDECL
                   COMPSTMT
                  end

LHS             : VARIABLE

CALL_ARGS       : ARGS

ARGS            : ARG (`,' ARG)*

ARGDECL         : `(' ARGLIST `)'

ARGLIST         : IDENTIFIER(`,'IDENTIFIER)*

VARIABLE        : VARNAME
                | nil

LITERAL         : numeric
                | STRING

TERM            : `;'
                | `n'

FNAME           : IDENTIFIER

OPERATION       : IDENTIFIER

VARNAME         : IDENTIFIER

STRING          : `"' any_char* `"'

IDENTIFIER is the sequence of characters in the pattern of /[a-zA-Z_][a-zA-Z0-9_]*/.

Let’s write two functions in our new Ruby subset language. First a function to calculate fibonacci numbers.

def fib(n)
  curr = 0
  succ = 1
  presucc = nil

  for i in 1..n do
    presucc = succ
    succ = curr + succ
    curr = presucc
  end

  curr
end

fib(100000)

Then run it on ruby1.9 :

jgrant@pluto:~/cl-ruby$ ruby1.9 fib_it.rb
195328212870775773163201494759...<208928 digits>...719893411568996526838242546875
50.352559375 seconds of real time

Next a function to calculate factorials

def fact (n)
  tot = 1

  for i in 1..n do
    tot = tot * i
  end

  tot
end

Then run it on ruby1.9 :

jgrant@pluto:~/cl-ruby$ ruby1.9 fact.rb 
282422940796034787429342157802...<456514 digits>...000000000000000000000000000000
20.71802105 seconds of real time

Now let’s compare by running the same code on our Ruby subset implemented in Lisp

(defun test-fib()
  (let* ((fun (compile-ruby
               "def fib (n)
                  curr = 0
                  succ = 1
                  presucc = nil

                  for i in 1..n do
                    presucc = succ
                    succ = curr + succ
                    curr = presucc
                  end

                  curr
                end"))
         (funcall (compile-ruby
                   "fib(1000000)"))
         (res (progn (run-ruby fun)
                     (format t "~A~%~A" fun funcall)
                     (time (run-ruby funcall))))
         (resstr (format nil "~A" res)))
    (format t "~A...<~A digits>...~A"
            (subseq resstr 0 30)
            (- (length resstr) 60)
            (subseq resstr (- (length resstr) 30))))
  nil)


* (test-fib)
Evaluation took:
  31.734 seconds of real time
  31.810000 seconds of total run time (30.070000 user, 1.740000 system)
  [ Run times consist of 1.260 seconds GC time, and 30.550 seconds non-GC time. ]
  100.24% CPU
  3 forms interpreted
  50,639,978,358 processor cycles
  43,412,830,352 bytes consed
  
195328212870775773163201494759...<208928 digits>...719893411568996526838242546875

And factorial

(defun test-fact()
  (let* ((fun (compile-ruby
               "def fact (n)
                  tot = 1

                  for i in 1..n do
                    tot = tot * i
                  end

                  tot
                end"))
         (funcall (compile-ruby
                   "fact(100000)"))
         (res (progn (run-ruby fun)
                     (format t "~A~%~A" fun funcall)
                     (time (run-ruby funcall))))
         (resstr (format nil "~A" res)))
    (format t "~A...<~A digits>...~A"
            (subseq resstr 0 30)
            (- (length resstr) 60)
            (subseq resstr (- (length resstr) 30))))
  nil)

*  (test-fact)
Evaluation took:
  5.772 seconds of real time
  5.790000 seconds of total run time (5.470000 user, 0.320000 system)
  [ Run times consist of 0.230 seconds GC time, and 5.560 seconds non-GC time. ]
  100.31% CPU
  3 forms interpreted
  9,210,473,724 processor cycles
  9,030,853,008 bytes consed
  
282422940796034787429342157802...<456514 digits>...000000000000000000000000000000

We’re seeing ~ 1.5 – 3.5 X improvement with our toy CL Ruby ‘compiler’ without even trying to generate performant code.

Code is here.