memo.lisp

;; See http://malisper.me/2015/11/10/defmemo/

(defmacro defmemo (name-and-cache args &body body)
  "Define a memoized function. NAME-AND-CACHE may be a symbol naming
the function, or a property list in which case the name is specified
in the property :name. When a list is supplied, a set of functions
named by the properties :cache, :reader and :writer may be
supplied. The cache function must return an object that supports a
protocol like hash-table with equality test sufficient to discriminate
the arguments to the memoized function. The reader accepts
arguments (key cache), the writer (value key cache). A cache clearing
function taking no arguments may be specified with :clearer.

When the clearer is generated, a second function is defined for it,
called by default \"clear-memo-~A\" where ~A is NAME."
  (labels ((grab (key &optional default)
             (or (and (consp name-and-cache)
                      (getf name-and-cache key))
                 default)))
    (let* ((name (or (grab :name name-and-cache)
                     (error ":NAME parameter required")))
           (cache (grab :cache '(make-hash-table :test #'equalp)))
           (reader (grab :reader '(function gethash)))
           (writer (grab :writer '(function (setf gethash))))
           (clearer (grab :clearer '(function clrhash)))
           (clearer-passed-p (grab :clearer nil))
           (clearer-name (grab :clearer-name (and (not clearer-passed-p)
                                                  (intern (concatenate 'string
                                                                       (string-upcase "clear-memo-")
                                                                       (symbol-name name))))))
           (cache-sym (gensym "CACHE")))
      `(let ((,cache-sym ,cache))
         (defun ,name (&rest args)
           (multiple-value-bind (result found-p) (funcall ,reader args ,cache-sym)
             (if found-p
                 result
                 (funcall ,writer (apply (lambda ,args ,@body) args) args ,cache-sym))))
         ,@(when (and clearer (not clearer-passed-p))
             `((defun ,clearer-name ()
                 (funcall ,clearer ,cache-sym)
                 (values))))))))

(defmemo fib (n)
  (if (< n 2)
      n
      (+ (fib (- n 1))
         (fib (- n 2)))))

;; CL-USER> (time (fib 100))
;; Evaluation took:
;;   0.000 seconds of real time
;;   0.004000 seconds of total run time (0.004000 user, 0.000000 system)
;;   100.00% CPU
;;   198,176 processor cycles
;;   32,768 bytes consed
  
;; 354224848179261915075

;; CL-USER> (time (fib 100))
;; Evaluation took:
;;   0.000 seconds of real time
;;   0.000000 seconds of total run time (0.000000 user, 0.000000 system)
;;   100.00% CPU
;;   8,659 processor cycles
;;   0 bytes consed
  
;; 354224848179261915075