Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Actually put some useful stuff in dynamic-programming.lisp. Defined t…

…hree new

macros, DEFUN-MEMOIZED, DEFUN-ARRAY-MEMOIZED, and MEMO-LABELS, which do what you
might think.
  • Loading branch information...
commit 22b305b1801414b9cd6ae65c7b5a40321d102a3b 1 parent f44af8f
Zach Kost-Smith authored

Showing 3 changed files with 205 additions and 143 deletions. Show diff stats Hide diff stats

  1. +202 143 dynamic-programming.lisp
  2. +2 0  package.lisp
  3. +1 0  toolbox.asd
345 dynamic-programming.lisp
... ... @@ -1,151 +1,210 @@
  1 +
  2 +(in-package :toolbox)
  3 +
1 4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 5 ;;;; Dynamic Programming ;;;;
3 6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 7
5   -(defmacro defun-dynammic (name-options args &body body)
6   - (list name-options args body) )
7   -
8   -(macroexpand-1 '(defun-dynammic manhattan (a b c) hello))
9   -
10   -(make-symbol "HELLO")
11   -
12   -(with-gensyms ("Hello")
13   - 5 )
14   -
15   -#|
16   -;;; This would be a cool tool. We would need to use a code walker to walk the
17   -;;; _returned_ form in order to find free symbols and gensym them.
18   -(defmacro defmacro-hyg (name args &body body)
19   - (let ((free-symbols (collect-free-symbols args body)))
20   - `(defmacro ,name ,args
21   - (with-gensyms ,free-symbols))))
22   -|#
23   -
24   -(dbind (name &key val win) '(hello :val 5)
25   - (list name val win) )
26   -
27   -(destructuring-bind (name &key (test #'eql)) '(hello :test #.#'car)
28   - (list name test) )
29   -
30   -(defun default-memoization (name)
31   - (list name :test #'eql :key #'identity) )
32   -
33   -(defmacro defun-dynprog (name-spec arg-list &body body)
34   - (with-gensyms (cache "DYN-PROG-")
35   - `(let ((,cache (make-hash-table)))
36   - (defun ,name-spec ,arg-list
37   - (let ((,cache (make-hash-table)))
38   - (funcall
39   - (alambda ,arg-list
40   - (declare (notinline self))
41   - (macrolet ((,name-spec ,arg-list
42   - '`,(self ,@arg-list) ))
43   - ,@body ))
44   - ,@arg-list ))))))
45   -
46   -(macroexpand-1 '(defun-dynprog fact (n) (cond ((= n 1) 1) (t (* n (fact (1- n)))))))
47   -
48   -(defun-dynprog fib (n)
49   - (cond ((< n 3) n)
50   - (t (+ (fib (1- n)) (* n (fib (- n 2))))) ))
51   -
52   -(trace fib)
53   -
54   -(fib 2)
55   -
56   -(defun dyn-label (name args &rest fbody)
57   - (let ((label-spec
58   - (if (atom name)
59   - (default-memoization name)
60   - name ))
61   - (name-internal 'internal) )
62   - (destructuring-bind (name &key test key) label-spec
63   - (values 'cache
64   - `(,name ,args
65   - (setf cache (make-hash-table :test ,test))
66   - (,name-internal ,@args) )
67   - `(,name-internal ,args
68   - (declare (notinline ,name-internal))
69   - (mvb (val win) (gethash (funcall ,key ,args) cache)
70   - (if win
71   - val
72   - (setf (gethash (funcall ,key ,args) cache)
73   - (macrolet
74   - ((,name ,args
75   - (,name-internal ,@args) ))
76   - ,@fbody )))))))))
77   -
78   -(defmacro dyn-labels (label-specs &body body)
79   - (multiple-value-bind (cache-names cache-decl funcs)
80   - (mvmapcar (/. (x) (apply #'values (mvl (apply #'dyn-label x)))) label-specs)
81   - (print (list cache-names cache-decl funcs))
82   - `(let ,cache-decl
83   - (labels ,funcs
  8 +(defmacro defun-memoized (name-spec arg-list &body body)
  9 + "Define a memoized function, otherwise known as dynamic programming. This
  10 +trys to be about as general as you'll ever need, which makes it somewhat
  11 +complicated to understand. If you don't use any of the fancy options, it should
  12 +still work fine for most cases.
  13 +
  14 +To `efficiently' compute Fibonacci numbers:
  15 +
  16 + (defun-memoized fib (n)
  17 + (if (< n 2) n
  18 + (+ (fib (- n 1))
  19 + (fib (- n 2)) )))
  20 +
  21 +To save computed values in-between calls:
  22 +
  23 + (defun-memoized (fib :persistent t) (n)
  24 + (if (< n 2) n
  25 + (+ (fib (- n 1))
  26 + (fib (- n 2)) )))
  27 +
  28 +To return the current state of the cache after the run:
  29 +
  30 + (defun-memoized (fib :return-cache t) (n)
  31 + (if (< n 2) n
  32 + (+ (fib (- n 1))
  33 + (fib (- n 2)) )))
  34 +
  35 +The behavior of the memoization is controlled by the NAME-SPEC. It has the following form:
  36 +
  37 +name-spec = name
  38 + | (name &key persistent return-cache
  39 + (arg-fn ''identity)
  40 + access-fn setter-fn
  41 + (cached-test #'second)
  42 + (storage '(make-hash-table :test 'equal)) )
  43 +
  44 +PERSISTENT decides whether the memoization will remain in between calls to the
  45 +defined function \(non-NIL) or if a fresh cache is created on each call \(NIL).
  46 +Memoization libraries usually do this by default. Dynamic programming tends to
  47 +include building the cache as part of the algorithm. We default to persistent
  48 +cache unless RETURN-CACHE is true.
  49 +
  50 +RETURN-CACHE decides whether the function should return the cache along with
  51 +it's result. For some problems the cache is more important the result. It is
  52 +tacked on as the last value.
  53 +
  54 +ARG-FN specifies a function which will be called on the list of function
  55 +arguments prior to trying against the cache. This allows you to remove
  56 +arguments that don't actually effect the result, or to re-arrange arguments
  57 +prior to trying the cache.
  58 +
  59 +ACCESS-FN, SETTER-FN, CACHE-TEST tells DEFUN-MEMOIZED how to access, set, and
  60 +query the cache. ACCESS-FN is applied on the cache and a list of the \(ARG-FN
  61 +processed) arguments. SETTER-FN is applied on the new value, the cache, and a
  62 +list of the \(ARG-FN processed) arguments. CACHE-TEST is called on the multiple
  63 +value list of the ACCESS-FN's value. These allow you to use other cache
  64 +structures than hash-tables. Again, most memoization libraries use only
  65 +hash-tables which are a good fit for most problems. Dynamic programming tends
  66 +to use arrays. Arrays might have certain performance \(space or time) gains.
  67 +
  68 +STORAGE instructs the macro on how to build a new cache. If there is a simple
  69 +form that will build it, just place it here. If it is more complicated, specify
  70 +a function that, when given the arguments of the initial call to the defined
  71 +function, will build a new cache. Of course this only works when PERSISTENT is
  72 +NIL.
  73 +
  74 +For in-depth examples, see the documentation."
  75 + (destructuring-bind (name
  76 + &key return-cache (persistent (not return-cache))
  77 + (arg-fn ''identity)
  78 + access-fn setter-fn
  79 + (cache-test #'second)
  80 + (storage '(make-hash-table :test 'equal)) )
  81 + (ensure-list name-spec)
  82 + (with-gensyms (cache args processed-args query sol)
  83 + `(let ((,cache ,(if persistent storage nil)))
  84 + (declare (ignorable ,cache))
  85 + (defun ,name (,@arg-list)
  86 + (let ((,cache ,(if persistent cache
  87 + `(if (functionp ,storage)
  88 + (funcall ,storage ,@arg-list)
  89 + ,storage ))))
  90 + (labels
  91 + ((,name (&rest ,args)
  92 + (let ((,processed-args (funcall ,arg-fn ,args)))
  93 + (let ((,query (multiple-value-list
  94 + ,(if access-fn
  95 + `(apply ,access-fn ,cache ,processed-args)
  96 + `(gethash ,processed-args ,cache) ))))
  97 + (if (funcall ,cache-test ,query)
  98 + (values-list ,(if access-fn
  99 + `(apply ,access-fn ,cache ,processed-args)
  100 + `(gethash ,processed-args ,cache) ))
  101 + (let ((,sol (multiple-value-list
  102 + (destructuring-bind
  103 + ,arg-list ,args
  104 + ,@body ))))
  105 + (values-list
  106 + ,(if setter-fn
  107 + `(apply ,setter-fn ,sol ,cache ,processed-args)
  108 + `(setf (gethash (funcall ,arg-fn ,args) ,cache)
  109 + ,sol )))))))))
  110 + (declare (notinline ,name))
  111 + ,(if return-cache
  112 + `(values-list
  113 + (append (multiple-value-list (,name ,@arg-list))
  114 + (list ,cache) ))
  115 + `(,name ,@arg-list) ))))))))
  116 +
  117 +(defmacro defun-array-memoized (name builder return-array arg-list &body body)
  118 + "Define a memoized function using an array for a cache. BUILDER must specify
  119 +a function that will build an array large enough to hold any results.
  120 +RETURN-ARRAY is a boolean which determines if the function should return the
  121 +cache array as its last value.
  122 +
  123 +This is included as an alternative to the hash-table memoization as it might
  124 +have some advantages in terms of speed and memory."
  125 + `(defun-memoized ,(cons name `(:access-fn
  126 + #'aref :setter-fn #'(setf aref)
  127 + :cache-test #'first
  128 + :storage ,builder
  129 + :return-cache ,return-array ))
  130 + ,arg-list
  131 + ,@body ))
  132 +
  133 +(defun expand-labels-cache (name-specs)
  134 + (mapcar (/. (name-spec)
  135 + (list cache-sym
  136 + (destructuring-bind
  137 + (name
  138 + &key return-cache
  139 + (arg-fn ''identity)
  140 + access-fn setter-fn
  141 + (cache-test #'second)
  142 + (storage '(make-hash-table :test 'equal)) )
  143 + (ensure-list name-spec)
  144 + storage )))
  145 + name-specs ))
  146 +
  147 +(defun expand-labels-def (defs cache-forms)
  148 + (mapcar
  149 + (lambda (def cache-form)
  150 + (destructuring-bind
  151 + ((name
  152 + &key return-cache
  153 + (arg-fn ''identity)
  154 + access-fn setter-fn
  155 + (cache-test #'second)
  156 + &allow-other-keys )
  157 + arg-list
  158 + &rest body ) def
  159 + (let ((cache (first cache-form)))
  160 + (with-gensyms (args processed-args query sol)
  161 + `(,name (,@arg-list)
  162 + (labels
  163 + ((,name (&rest ,args)
  164 + (let ((,processed-args (funcall ,arg-fn ,args)))
  165 + (let ((,query (multiple-value-list
  166 + ,(if access-fn
  167 + `(apply ,access-fn ,cache
  168 + ,processed-args )
  169 + `(gethash ,processed-args
  170 + ,cache )))))
  171 + (if (funcall ,cache-test ,query)
  172 + (values-list ,(if access-fn
  173 + `(apply ,access-fn ,cache
  174 + ,processed-args )
  175 + `(gethash ,processed-args
  176 + ,cache )))
  177 + (let ((,sol (multiple-value-list
  178 + (destructuring-bind
  179 + ,arg-list ,args
  180 + ,@body ))))
  181 + (values-list
  182 + ,(if setter-fn
  183 + `(apply ,setter-fn ,sol ,cache
  184 + ,processed-args )
  185 + `(setf (gethash (funcall ,arg-fn ,args)
  186 + ,cache )
  187 + ,sol )))))))))
  188 + (declare (notinline ,name))
  189 + ,(if return-cache
  190 + `(values-list
  191 + (append (multiple-value-list (,name ,@arg-list))
  192 + (list ,cache) ))
  193 + `(,name ,@arg-list) )))))))
  194 + defs cache-forms ))
  195 +
  196 +(defmacro memo-labels (((name-spec arg-list &body lab-body) &rest more-funcs)
  197 + &body body )
  198 + "A labels memoized definer for lexically scoped functions. This is takes the same functions as DEFUN-MEMOIZED, except for the PERSISTENT keyword \(all memoized functions cache for the extent of their scope)."
  199 + (let ((cache-forms (expand-labels-cache (cons name-spec (mapcar #'first more-funcs)))))
  200 + `(let ,cache-forms
  201 + (labels ,(expand-labels-def
  202 + (mapcar (lambda (x) (cons (ensure-list (first x))
  203 + (rest x) ))
  204 + (cons `(,name-spec ,arg-list ,@lab-body)
  205 + more-funcs ))
  206 + cache-forms )
84 207 ,@body ))))
85 208
86   -(apply #'floor '(3 2))
87   -
88   -(mvmapcar (lambda (x) (apply #'dyn-label x))
89   - '((hello (a b c) (hello (1- a) (1- b) (1- c)))) )
90   -
91   -(mvmapcar #'floor '((3 2) (4 3) (5 4)))
92   -
93   -(asdf:oos 'asdf:load-op :cl-ode)
94   -
95   -(with-debug
96   -(macroexpand-1 '(dyn-labels ((hello (a)
97   - (cond ((= a 1) 1)
98   - (t (* a (hello (1- a)))) )))
99   - (hello 5) ))
100   -)
101   -
102   -(describe 'apply)
103   -
104   -(defun mvmapcar (fn &rest lists)
105   - (cond ((null (car lists)) (apply #'values lists))
106   - (t (apply #'values
107   - (mapcar #'cons (mvl (apply fn (mapcar #'car lists)))
108   - (mvl (apply #'mvmapcar fn (mapcar #'cdr lists))) )))))
109   -
110   -(mvmapcar #'values '(1 2 3) '(4 5 6))
111   -
112   -(caddr '#1=(1 #1# (2 #1#)))
113   -
114   -'#1=(1 . #1#)
115   -
116   -(setf *print-circle* t)
117   -
118   -(asdf:oos 'asdf:load-op :pal)
119   -
120   -#|
121   -
122   -defun-dyn:
123   -
124   -1. Define a function that creates a function with a cache that saves previous evaluations
125   -
126   -2. Calling the function creates a (clean) cache and calls the internal function with the proper arguments
127   -
128   -|#
129   -
130   -(defun mv-mapcar (fn &rest lists)
131   - (
132   -
133   -(mapcar (/. (x y) (mvl (floor x y))) '(1 2 3) '(3 2 1))
134   -
135   -(macroexpand-1 '(dyn-labels (dyn (a b c) (list a b c)) (dyn 1 2 3)))
136   -
137   -
138   -(let ((cache (make-hash-table)))
139   - (defun dyn (mat x y)
140   - (labels ((%dyn (&rest args)
141   - (asif2 (gethash args cache)
142   - it
143   - (setf it (apply %dyn args)) )))
144   - (%dyn
145   - (mvb (val win) (gethash args cache)
146   - (
147   - (defun %dyn (x y)
148   - (
149   -
150 209
151 210
2  package.lisp
@@ -115,4 +115,6 @@
115 115 ;#:command-line ;#:raw-command-line #:getenv #:quit
116 116 ;;; FCASE
117 117 #-clisp #:fcase
  118 + ;; Dynamic programming
  119 + #:defun-memoized #:defun-array-memoized #:memo-labels
118 120 ))
1  toolbox.asd
@@ -18,6 +18,7 @@
18 18 (:file "numerics")
19 19 (:file "string-algs")
20 20 (:file "number-theory")
  21 + (:file "dynamic-programming")
21 22 (:file "infix") )
22 23 :serial t
23 24 :depends-on (:anaphora :alexandria :cl-fad :iterate :cl-ppcre

0 comments on commit 22b305b

Please sign in to comment.
Something went wrong with that request. Please try again.