[Small-cl-src] Transforming recursion into dynamic programming

[Darius Bacon]

;;; Everyone's seen Lisp code to automatically memoize a function.
;;; This is a bit different: it changes the evaluation order from
;;; top-down to bottom-up.  A recursive call turns into a direct 
;;; reference into the memo table, with no check for whether that
;;; part of the table has been computed yet.  See the discussion at
;;; http://lambda.weblogs.com/discuss/msgReader$6437

defmacro defun-recurrence (name params inits &body body)
  "Define a recursive function that's evaluated by dynamic programming,
   bottom-up from the INITS values to the PARAMS values."
  (let ((tabulate-name (concat-symbol "TABULATE-" name))
        (table `(make-array (list ,@(mapcar (lambda (p) `(+ ,p 1))
                                            params))))
        (ranges (mapcar (lambda (p init) `(for ,p from ,init to ,p))
                        params
                        inits)))
    `(progn
       (defun ,tabulate-name ,params
         (tabulate ,name ,table ,ranges , at body))
       (defun ,name ,params
         (aref (,tabulate-name , at params) , at params)))))

(defmacro tabulate (name table-exp ranges &body body)
  "Evaluate a recursive function by dynamic programming, returning
   the memo-table."
  (let ((table (gensym))
        (vars (mapcar #'second ranges)))
    `(let ((,table ,table-exp))
       ,(nest-loops ranges
                    `(setf (aref ,table , at vars)
                           (flet ((,name ,vars (aref ,table , at vars)))
                             , at body)))
       ,table)))

(defun nest-loops (ranges body-exp)
  "Build a nested LOOP form."
  (if (null ranges)
      body-exp
      `(loop ,@(car ranges)
             do ,(nest-loops (cdr ranges) body-exp))))

(defun concat-symbol (&rest parts)
  "Concatenate symbols or strings to form an interned symbol."
  (intern (format nil "~{~a~}" parts)))