├── .gitignore ├── README.md ├── ch1-complexity.lisp ├── ch10-graphs.lisp ├── ch11-strings.lisp ├── ch12-dynamic-programming.lisp ├── ch13-approximation.lisp ├── ch14-compression.lisp ├── ch15-synchronization.lisp ├── ch4-data-structures.lisp ├── ch5-arrays.lisp ├── ch6-lists.lisp ├── ch7-kvs.lisp ├── ch8-hash-tables.lisp ├── ch9-trees.lisp ├── package.lisp └── progalgs.asd /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl 3 | \#* 4 | .* 5 | !.gitignore 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Code for the book [Programmin Algorithms in Lisp](https://www.apress.com/gp/book/9781484264270) 2 | -------------------------------------------------------------------------------- /ch1-complexity.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | 4 | (defun mat-max (mat) 5 | (let (max) 6 | (dotimes (i (array-dimension mat 0)) 7 | (dotimes (j (array-dimension mat 1)) 8 | (when (or (null max) 9 | (> (aref mat i j) max)) 10 | (setf max (aref mat i j))))) 11 | max)) 12 | 13 | (deftest mat-max () 14 | (should be null (mat-max #2A())) 15 | (should be = 42 (mat-max #2A((42)))) 16 | (should be = 6 (mat-max #2A((1 2 3) (4 5 6))))) 17 | -------------------------------------------------------------------------------- /ch10-graphs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | 4 | (defstruct node 5 | id edges) 6 | 7 | (defstruct edge 8 | src dst label) 9 | 10 | (defstruct (graph (:conc-name nil) (:print-object pprint-graph)) 11 | (nodes (make-hash-table))) ; mapping of node ids to nodes 12 | 13 | (defun pprint-graph (graph stream) 14 | (let ((ids (sort (rtl:keys (nodes graph)) '<))) 15 | (format stream "~{ ~A~}~%" ids) ; here, Tab is used for space 16 | (dolist (id1 ids) 17 | (let ((node (rtl:? graph 'nodes id1))) 18 | (format stream "~A" id1) 19 | (dolist (id2 ids) 20 | (format stream " ~:[~;x~]" ; here, Tab as well 21 | (find id2 (rtl:? node 'edges) :key 'edge-dst))) 22 | (terpri stream))))) 23 | 24 | (defun init-graph (edges) 25 | (rtl:with ((rez (make-graph)) 26 | (nodes (nodes rez))) 27 | (loop :for (src dst) :in edges :do 28 | (let ((src-node (rtl:getsethash src nodes (make-node :id src)))) 29 | (rtl:getset# dst nodes (make-node :id dst)) 30 | (push (make-edge :src src :dst dst) 31 | (rtl:? src-node 'edges)))) 32 | rez)) 33 | 34 | (deftest graph () 35 | (should print-to *standard-output* 36 | " 37 | 1 2 3 4 5 6 7 8 38 | 1 x x 39 | 2 x x 40 | 3 x x 41 | 4 x 42 | 5 x x 43 | 6 44 | 7 x 45 | 8 46 | " 47 | (print (init-graph '((7 8) 48 | (1 3) 49 | (1 2) 50 | (3 4) 51 | (3 5) 52 | (2 4) 53 | (2 5) 54 | (5 4) 55 | (5 6) 56 | (4 6)))))) 57 | 58 | (defun topo-sort (graph) 59 | (let ((nodes (nodes graph)) 60 | (visited (make-hash-table)) 61 | (rez (rtl:vec))) 62 | (rtl:dokv (id node nodes) 63 | (unless (gethash id visited) 64 | (visit node nodes visited rez))) 65 | rez)) 66 | 67 | (defun visit (node nodes visited rez) 68 | (dolist (edge (node-edges node)) 69 | (rtl:with ((id (edge-dst edge)) 70 | (child (gethash id nodes))) 71 | (unless (find id rez) 72 | (assert (not (gethash id visited)) nil 73 | "The graph isn't acyclic for vertex: ~A" id) 74 | (setf (gethash id visited) t) 75 | (visit child nodes visited rez)))) 76 | (vector-push-extend (node-id node) rez) 77 | rez) 78 | 79 | (deftest topo-sort () 80 | (should be equalp #(8 7 6 4 5 2 3 1) 81 | (topo-sort (init-graph '((7 8) 82 | (1 3) 83 | (1 2) 84 | (3 4) 85 | (3 5) 86 | (2 4) 87 | (2 5) 88 | (5 4) 89 | (5 6) 90 | (4 6)))))) 91 | 92 | (defvar *heap-indices*) 93 | 94 | (defun prim-mst (graph) 95 | (let ((initial-weights (list)) 96 | (mst (list)) 97 | (total 0) 98 | (*heap-indices* (make-hash-table)) 99 | weights 100 | edges 101 | cur) 102 | (rtl:dokv (id node (nodes graph)) 103 | (if cur 104 | (push (rtl:pair id (or (elt edges id) 105 | ;; a standard constant that is 106 | ;; a good enough substitute for infinity 107 | most-positive-fixnum)) 108 | initial-weights) 109 | (setf cur id 110 | edges (node-edges node)))) 111 | (setf weights (heapify initial-weights)) 112 | (loop 113 | (rtl:with (((id weight) (heap-pop weights))) 114 | (unless id (return)) 115 | (when (elt edges id) 116 | ;; if not, we have moved to the new connected component 117 | ;; so there's no edge connecting it to the previous one 118 | (push (rtl:pair cur id) mst) 119 | (incf total weight)) 120 | (rtl:dokv (id w edges) 121 | (when (< w weight) 122 | (heap-decrease-key weights id w))) 123 | (setf cur id 124 | edges (rtl:? graph 'nodes id 'edges)))) 125 | (values mst 126 | total))) 127 | 128 | (defun heap-down (vec beg &optional (end (length vec))) 129 | (let ((l (hlt beg)) 130 | (r (hrt beg))) 131 | (when (< l end) 132 | (let ((child (if (or (>= r end) 133 | (> (aref vec l) 134 | (aref vec r))) 135 | l r))) 136 | (when (> (aref vec child) 137 | (aref vec beg)) 138 | (rotatef (gethash (aref vec beg) *heap-indices*) 139 | (gethash (aref vec child) *heap-indices*)) 140 | (rotatef (aref vec beg) 141 | (aref vec child)) 142 | (heap-down vec child end))))) 143 | vec) 144 | 145 | (defun heap-decrease-key (vec key decrement) 146 | (let ((i (pop (gethash key *heap-indices*)))) 147 | (unless i (error "No key ~A found in the heap: ~A" key vec)) 148 | (when (null (gethash key *heap-indices*)) 149 | (remhash key *heap-indices*)) 150 | (push i (gethash (- key decrement) *heap-indices*)) 151 | (decf (aref vec i) decrement) 152 | (heap-up vec i))) 153 | 154 | (defun heap-up (vec i) 155 | (rtl:with ((i-key (aref vec i)) 156 | (parent (hparent i)) 157 | (parent-key (aref vec parent))) 158 | (when (> i-key parent-key) 159 | (rtl:removef (gethash i-key *heap-indices*) i) 160 | (rtl:removef (gethash parent-key *heap-indices*) parent) 161 | (push i (gethash parent-key *heap-indices*)) 162 | (push parent (gethash i-key *heap-indices*)) 163 | (rotatef (aref vec i) 164 | (aref vec parent)) 165 | (heap-up vec parent))) 166 | vec) 167 | 168 | (defun heap-up-correct (vec i) 169 | (let ((parent (hparent i))) 170 | (when (> (aref vec i) 171 | (aref vec parent)) 172 | (rotatef (gethash (aref vec i) *heap-indices*) 173 | (gethash (aref vec parent) *heap-indices*))) 174 | (rotatef (aref vec i) 175 | (aref vec parent)) 176 | (heap-up vec parent)) 177 | vec) 178 | 179 | (defun heap-decrease-key-correct (vec key decrement) 180 | (let ((i (gethash key *heap-indices*))) 181 | (unless i (error "No key ~A found in the heap: ~A" key vec)) 182 | (remhash key *heap-indices*) 183 | (setf (gethash (- key decrement) *heap-indices*) i) 184 | (decf (aref vec i) decrement) 185 | (heap-up vec i))) 186 | 187 | (defstruct heap-item 188 | key val) 189 | 190 | (defun heap-up (vec i) 191 | (rtl:with ((i-key (heap-item-key (aref vec i))) 192 | (parent (hparent i)) 193 | (parent-key (heap-item-key (aref vec parent)))) 194 | (when (> i-key parent-key) 195 | (rtl:removef (gethash i-key *heap-indices*) i) 196 | (rtl:removef (gethash parent-key *heap-indices*) parent) 197 | (push i (gethash parent-key *heap-indices*)) 198 | (push parent (gethash i-key *heap-indices*)) 199 | (rotatef (aref vec i) 200 | (aref vec parent)) 201 | (heap-up vec parent))) 202 | vec) 203 | 204 | ;; TODO test heap 205 | 206 | (defstruct (spf-node (:include node)) 207 | (weight most-positive-fixnum) 208 | (path (list))) 209 | 210 | (defun spf (graph src dst) 211 | (rtl:with ((nodes (graph-nodes graph)) 212 | ;; the following code should express initialize the heap 213 | ;; with a single node of weight 0 and all other nodes 214 | ;; of weight MOST-POSITIVE-FIXNUM 215 | ;; (instead of running a O(n*log n) HEAPIFY) 216 | (weights (init-weights-heap nodes src))) 217 | (loop 218 | (rtl:with (((id weight) (heap-pop weights))) 219 | (cond ((eql id dst) 220 | (let ((dst (elt nodes dst))) 221 | ;; we return two values: the path and its length 222 | (return (values (cons dst (spf-node-path dst)) 223 | (spf-node-weight dst))))) 224 | ((= most-positive-fixnum weight) 225 | (return))) ; no path exists 226 | (dolist (edge (rtl:? nodes id 'edges)) 227 | (rtl:with ((cur (edge-dst edge)) 228 | (node (elt nodes cur)) 229 | (w (+ weight (spf-node-weight cur)))) 230 | (when (< w (spf-node-weight node)) 231 | (heap-decrease-key weights cur w) 232 | (setf (spf-node-weight node) w 233 | (spf-node-path node) (cons (rtl:? nodes id) 234 | (rtl:? nodes id 'path)))))))))) 235 | 236 | ;; TODO test spf 237 | 238 | (defstruct mf-edge 239 | beg end capacity) 240 | 241 | (defun max-flow (g) 242 | (assert (= (array-dimension g 0) 243 | (array-dimension g 1))) 244 | (let ((rg (rtl:copy-array g)) ; residual graph 245 | (rez 0)) 246 | (loop :for path := (aug-path rg) :while path :do 247 | (let ((flow most-positive-fixnum)) 248 | ;; the flow along the path is the residual capacity of the thinnest edge 249 | (dolist (edge path) 250 | (let ((cap (mf-edge-capacity edge))) 251 | (when (< (abs cap) flow) 252 | (setf flow (abs cap))))) 253 | (dolist (edge path) 254 | (with-slots (beg end) edge 255 | (decf (aref rg beg end) flow) 256 | (incf (aref rg end beg) flow))) 257 | (incf rez flow))) 258 | rez)) 259 | 260 | (defun aug-path (g) 261 | (rtl:with ((sink (1- (array-dimension g 0))) 262 | (visited (make-array (1+ sink) :initial-element nil))) 263 | (labels ((dfs (g i) 264 | (setf (aref visited i) t) 265 | (if (zerop (aref g i sink)) 266 | (dotimes (j sink) 267 | (unless (or (zerop (aref g i j)) 268 | (aref visited j)) 269 | (rtl:when-it (dfs g j) 270 | (return (cons (make-mf-edge 271 | :beg i :end j 272 | :capacity (aref g i j)) 273 | rtl:it))))) 274 | (list (make-mf-edge 275 | :beg i :end sink 276 | :capacity (aref g i sink)))))) 277 | (dfs g 0)))) 278 | 279 | (deftest max-flow () 280 | (should be = 7 (max-flow #2A((0 4 4 0 0 0) 281 | (0 0 0 4 2 0) 282 | (0 0 0 1 2 0) 283 | (0 0 0 0 0 3) 284 | (0 0 0 0 0 5) 285 | (0 0 0 0 0 0))))) 286 | 287 | ;; code prototypes 288 | 289 | (defun pagerank (g &key (d 0.85) (repeat 100)) 290 | (rtl:with ((nodes (nodes g)) 291 | (n (length nodes)) 292 | (pr (make-array n :initial-element (/ 1 n)))) 293 | (loop :repeat repeat :do 294 | (let ((pr2 (map 'vector (lambda (x) (- 1 (/ x n))) 295 | pr))) 296 | (rtl:dokv (i node nodes) 297 | (let ((p (aref pr i)) 298 | (m (length (node-children node)))) 299 | (rtl:dokv (j _ (node-children node)) 300 | (incf (aref pr2 j) (* d (/ p m)))))) 301 | (setf pr pr2))) 302 | pr)) 303 | 304 | (defun pr1 (node n p &key (d 0.85)) 305 | (let ((pr (make-array n :initial-element 0)) 306 | (m (hash-table-count (node-children node)))) 307 | (rtl:dokv (j child (node-children node)) 308 | (setf (aref pr j) (* d (/ p m)))) 309 | pr)) 310 | 311 | (defun pagerank-mr (g &key (d 0.85) (repeat 100)) 312 | (rtl:with ((n (length (nodes g))) 313 | (pr (make-array n :initial-element (/ 1 n)))) 314 | (loop :repeat repeat :do 315 | (setf pr (map 'vector (lambda (x) (- 1 (/ x n))) 316 | (reduce 'vec+ (map 'vector (lambda (node p) 317 | (pr1 node n p :d d)) 318 | (nodes g) 319 | pr))))) 320 | pr)) 321 | -------------------------------------------------------------------------------- /ch11-strings.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | (defstruct (mb-string (:conc-name mbs-)) 4 | bytes 5 | bitmap) 6 | 7 | (defparameter *mb-threshold* 10) 8 | 9 | (defun mb-char-index (string i) 10 | (let ((off 0)) 11 | (loop 12 | (rtl:with ((cnt (count 1 (mbs-bitmap string) 13 | :start off :end (+ off i)))) 14 | (diff (- i cnt))) 15 | (cond 16 | ((= cnt i) 17 | (return (+ off i))) 18 | ((< diff *mb-threshold*) 19 | (return (mb-linear-char-index string diff off))) 20 | ((< cnt (floor i 2)) 21 | (incf off i) 22 | (decf i cnt)) 23 | (t 24 | (incf off (floor i 2)) 25 | (decf i cnt)))))) 26 | 27 | (defun mb-length (string) 28 | (count 1 (mbs-bitmap string))) 29 | 30 | (defun naive-match (pat str) 31 | (dotimes (i (- (1+ (length str)) (length pat))) 32 | (let ((mis (mismatch pat (rtl:slice str i)))) 33 | (when (or (null mis) 34 | (= mis (length pat))) 35 | (return-from naive-match i))))) 36 | 37 | (defun kmp-table (pat) 38 | (let ((rez (make-array (length pat))) 39 | (i 0)) ; prefix length 40 | (setf (aref rez 0) -1) 41 | (loop :for j :from 1 :below (length pat) :do 42 | (if (char= (char pat i) (char pat j)) 43 | (setf (aref rez j) (aref rez i)) 44 | (progn ;; we have to use parallel version of setf here 45 | (psetf (aref rez j) i 46 | i (aref rez i)) 47 | (loop :while (and (>= i 0) 48 | (not (char= (char pat i) 49 | (char pat j)))) 50 | :do (setf i (aref rez i))))) 51 | (incf i)) 52 | rez)) 53 | 54 | (defun kmp-match (pat str) 55 | (let ((s 0) 56 | (p 0) 57 | (ff (kmp-table pat))) 58 | (loop :while (< s (length str)) :do 59 | (if (char= (char pat p) (char str s)) 60 | ;; if the current chars match 61 | (if (= (1+ p) (length pat)) 62 | ;; if we reached the end of the pattern - success 63 | (return (- s p)) 64 | ;; otherwise, match the subsequent chars 65 | (setf p (1+ p) 66 | s (1+ s))) 67 | ;; if the characters don't match 68 | (if (= -1 (aref ff p)) 69 | ;; shift the pattern for the whole length 70 | (setf p 0 71 | ;; and skip to the next char in the string 72 | s (1+ s)) 73 | ;; try matching the current char again, 74 | ;; shifting the pattern to align the prefix 75 | ;; with the already matched part 76 | (setf p (aref ff p))))))) 77 | 78 | (defun rk-match (pat str) 79 | (let ((len (length pat)) 80 | (phash (rk-hash pat))) 81 | (loop :for i :from len :to (length str) 82 | :for beg := (- i len) 83 | :for shash := (rk-hash (rtl:slice str 0 len)) 84 | :then (rk-rehash shash len 85 | (char str (1- beg)) (char str (1- i))) 86 | :when (and (= phash shash) 87 | (string= pat (rtl:slice str beg (+ beg len)))) 88 | :collect beg))) 89 | 90 | (defun rk-hash-naive (str) 91 | (loop :for ch :across str :sum (char-code ch))) 92 | 93 | (defun rk-hash (str) 94 | (assert (> (length str) 0)) 95 | (let ((rez (char-code (char str 0)))) 96 | (loop :for ch :across (rtl:slice str 1) :do 97 | (setf rez (+ (rem (* rez 256) 101) 98 | (char-code ch)))) 99 | (rem rez 101))) 100 | 101 | (defun rk-rehash (hash len ch1 ch2) 102 | (rem (+ (* 256 103 | (+ hash 101 104 | (- (rem (* (char-code ch1) 105 | (loop :repeat (max 0 (- len 2)) 106 | :with val := 256 107 | :do (setf val (rem (* val 256) 101)) 108 | :finally (return val))) 109 | 101)))) 110 | (char-code ch2)) 111 | 101)) 112 | 113 | (deftest match () 114 | (should be = 0 (naive-match "foo" "foobar")) 115 | (should be = 3 (naive-match "bar" "foobar")) 116 | (should be null (naive-match "baz" "foobar")) 117 | (should be = 0 (kmp-match "foo" "foobar")) 118 | (should be = 3 (kmp-match "bar" "foobar")) 119 | (should be null (kmp-match "baz" "foobar")) 120 | (should be equal '(0) (rk-match "foo" "foobar")) 121 | (should be equal '(3) (rk-match "bar" "foobar")) 122 | (should be equal '(0 6) (rk-match "bar" "barfoobar")) 123 | (should be null (rk-match "baz" "foobar"))) 124 | 125 | (defun re-match (regex text) 126 | "Search for REGEX anywhere in TEXT." 127 | (if (rtl:starts-with "^" regex) 128 | (when (> (length regex) 1) 129 | (match-here (rtl:slice regex 1) text)) 130 | (dotimes (i (length text)) 131 | (when (match-here regex (rtl:slice text i)) 132 | (return t))))) 133 | 134 | (defun match-here (regex text) 135 | "Search for REGEX at beginning of TEXT." 136 | (cond ((= 0 (length regex)) 137 | t) 138 | ((and (> (length regex) 1) 139 | (char= #\* (char regex 1))) 140 | (match-star (char regex 1) (rtl:slice regex 2) text)) 141 | ((string= "$" regex) 142 | (= 0 (length text))) 143 | ((and (> (length text) 0) 144 | (member (char regex 0) (list #\. (char text 0))) 145 | (match-here (rtl:slice regex 1) (rtl:slice text 1)))))) 146 | 147 | (defun match-star (c regex text) 148 | "Search for C*REGEX at beginning of TEXT." 149 | (loop 150 | (when (match-here regex text) (return t)) 151 | (setf text (rtl:slice text 1)) 152 | (unless (and (> (length text) 0) 153 | (member c (list #\. (char text 0)))) 154 | (return)))) 155 | 156 | (deftest re-match () 157 | (should be null (re-match "foo" "bar")) 158 | (should be rtl:true (re-match "foo" "foo")) 159 | (should be rtl:true (re-match "bar" "foobar")) 160 | (should be rtl:true (re-match "f.o" "foo")) 161 | (should be rtl:true (re-match "^foo" "foobar")) 162 | (should be null (re-match "^bar" "foobar")) 163 | (should be null (re-match "foo$" "foobar")) 164 | (should be rtl:true (re-match "bar$" "foobar")) 165 | (should be rtl:true (re-match "fo*" "foobar"))) 166 | 167 | (define-condition check-start-anchor () ()) 168 | 169 | (defgeneric th-part (next-state kind &rest args) 170 | (:documentation 171 | "Emit the TH-STATE structure of a certain KIND 172 | (which may be a keyword or a raw string) 173 | using the other ARGS and pointing to NEXT-STATE struct.") 174 | (:method (next-state (kind (eql :sequence)) &rest args) 175 | (apply 'th-part (if (rest args) 176 | (apply 'th-part :sequence (rest args)) 177 | next-state) 178 | (first args))) 179 | (:method (next-state (kind (eql :greedy-repetition)) &rest args) 180 | ;; this method can handle *, +, {n}, and {n,m} regex modifiers 181 | ;; in any case, there's a prefix sequence of fixed nonnegative length 182 | ;; of identical elements that should unconditionally match, 183 | ;; followed by a bounded or unbounded sequence that, 184 | ;; in case of a failed match, transitions to the next state 185 | (apply 'th-part 186 | (let ((*initial-state* next-state)) 187 | (apply 'th-part next-state :sequence 188 | (loop :repeat (or (second args) 1) 189 | :collect (rtl:mklist (third args))))) 190 | :sequence (loop :repeat (first args) 191 | :collect (rtl:mklist (third args))))) 192 | (:method (next-state (kind character) &rest args) 193 | (th-state kind next-state 194 | ;; Usually, *initial-state* will be null, 195 | ;; i.e. further computations along this path will be aborted, 196 | ;; but, for some variants (? or *), they will just continue 197 | ;; normally to the next state. 198 | ;; The special variable controls this setting, 199 | ;; as you can see in the method for :greedy-repetition 200 | t *initial-state*)) 201 | (:method (next-state (kind (eql :end-anchor)) &rest args) 202 | (th-state nil *matched-state* 203 | t *initial-state*)) 204 | (:method (next-state (kind (eql :start-anchor)) &rest args) 205 | ;; This part is unique as all the other parts consume the next character 206 | ;; (we're not implementing lookahead here), but this one shouldn't. 207 | ;; To implement such behavior without the additional complexity 208 | ;; of passing the search string to this function (which we'll still 209 | ;; probably need to do later on, but were able to avoid so far), 210 | ;; we can resort to a cool Lisp technique of signaling a condition 211 | ;; that can be handled specially in the top-level code 212 | (signal 'check-start-anchor) 213 | next-state)) 214 | 215 | (defun run-nfa (nfa str) 216 | (let ((i 0) 217 | (start 0) 218 | (matches (list)) 219 | (states (list nfa))) 220 | ;; this is the counterpart for the start-anchor signal 221 | (handler-bind ((check-start-anchor 222 | ;; there's no sense to proceed matching 223 | ;; a ^... regex if the string is not 224 | ;;at its start 225 | (lambda (c) 226 | (when (> i 0) (return-from run-nfa))))) 227 | (dovec (char (concatenate 'vector str 228 | #(nil))) ; end-anchor 229 | (let ((new-states (list))) 230 | (dolist (state states) 231 | (dolist (tr (th-state-transitions state)) 232 | (when (th-match tr char) 233 | (case (rtl:rt tr) 234 | (*matched-state* (push start matches)) 235 | ((nil) ) ; ignore it 236 | (t (pushnew (rtl:rt tr) new-states))) 237 | (return)))) 238 | (if new-states 239 | (setf states new-states) 240 | (setf states (list nfa) 241 | start nil))) 242 | (incf i) 243 | (unless start (setf start i)))) 244 | matches)) 245 | 246 | ;; TODO (deftest nfa () 247 | 248 | (defstruct grammar 249 | rules 250 | max-length) 251 | 252 | (defmacro grammar (&rest rules) 253 | `(make-grammar 254 | :rules (rtl:pairs->ht (mapcar (lambda (rule) 255 | (rtl:pair (nthcdr 2 rule) (first rule))) 256 | ',rules) 257 | :test 'equal) 258 | :max-length 259 | (let ((max 0)) 260 | (dolist (rule ',rules) 261 | ;; Here, #1= and #1# are reader-macros for capturing 262 | ;; a form and re-evaluating it again 263 | (when (> #1=(length (nthcdr 2 rule)) max) 264 | (setf max #1#))) 265 | max))) 266 | 267 | (defun parse (grammar queue) 268 | (let ((stack (list))) 269 | (loop :while queue :do 270 | (print stack) ; diagnostic output 271 | (rtl:if-it (find-rule stack grammar) 272 | ;; reduce 273 | (dotimes (i (length (cdr rtl:it)) 274 | (push rtl:it stack)) 275 | (pop stack)) 276 | ;; shift 277 | (push (pop queue) stack)) 278 | :finally (return (find-rule stack grammar))))) 279 | 280 | (defun find-rule (stack grammar) 281 | (let (prefix) 282 | (loop :for item in stack 283 | :repeat (grammar-max-length grammar) :do 284 | (push (first (rtl:mklist item)) prefix) 285 | (rtl:when-it (rtl:? grammar 'rules prefix) 286 | ;; otherwise parsing will fail with a stack 287 | ;; containing a number of partial subtrees 288 | (return (cons rtl:it (reverse (subseq stack 0 (length prefix))))))))) 289 | 290 | (deftest parse () 291 | (let ((*standard-output* (make-broadcast-stream))) 292 | (should be equal '(S (NP DET ADJ NOUN) 293 | (VP VERB 294 | (VP VERB 295 | (NP PRP$ NOUN))) 296 | |.|) 297 | (parse (grammar (S -> NP VP |.|) 298 | (NP -> DET ADJ NOUN) 299 | (NP -> PRP$ NOUN) 300 | (VP -> VERB VP) 301 | (VP -> VERB NP)) 302 | '(DET ADJ NOUN VERB VERB PRP$ NOUN |.|))))) 303 | -------------------------------------------------------------------------------- /ch12-dynamic-programming.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | (defun naive-fib (i) 4 | (check-type i (integer 0)) 5 | (if (< i 2) 1 6 | (+ (naive-fib (- i 1)) 7 | (naive-fib (- i 2))))) 8 | 9 | (let ((fib (rtl:vec 1 1))) ; our table will be an adjustable vector 10 | (defun fib (i) 11 | (when (< (length fib) i) 12 | (vector-push-extend (fib (- i 1)) fib)) 13 | (+ (aref fib (- i 1)) 14 | (aref fib (- i 2))))) 15 | 16 | (let ((fib (rtl:vec 1 1))) 17 | (defun bottom-up-fib (i) 18 | (let ((off (length fib))) 19 | (adjust-array fib (1+ i) :fill-pointer t) 20 | (dotimes (j (- (1+ i) off)) 21 | (let ((j (+ j off))) 22 | (setf (aref fib j) 23 | (+ (aref fib (- j 1)) 24 | (aref fib (- j 2))))))) 25 | (aref fib i))) 26 | 27 | (deftest fib () 28 | (should be = (fib 20) (naive-fib 20)) 29 | (should be = (fib 22) (naive-fib 22)) 30 | (should be = 165580141 (fib 40)) 31 | (should be = 433494437 (fib 42)) 32 | (should be = 165580141 (bottom-up-fib 40)) 33 | (should be = 433494437 (bottom-up-fib 42))) 34 | 35 | (defun shortest-first-restore-spaces (dict str) 36 | (dotimes (i (length str)) 37 | (let ((word (rtl:slice str 0 (1+ i)))) 38 | (when (rtl:? dict word) 39 | (return (rtl:cond-it 40 | ((= (1+ i) (length str)) 41 | word) 42 | ((shortest-first-restore-spaces dict (rtl:slice str (1+ i))) 43 | (format nil "~A ~A" word rtl:it)))))))) 44 | 45 | 46 | 47 | (defun bt-shortest-first-restore-spaces (dict str) 48 | (dotimes (i (length str)) 49 | (let ((word (rtl:slice str 0 (1+ i)))) 50 | (when (rtl:in# word dict) 51 | (when (= (1+ i) (length str)) 52 | (return word)) 53 | (rtl:when-it (bt-shortest-first-restore-spaces dict (rtl:slice str (1+ i))) 54 | (return (format nil "~A ~A" word rtl:it))))))) 55 | 56 | (defun dp-restore-spaces (dict str) 57 | (let ((dp (make-array (1+ (length str)) :initial-element nil)) 58 | ;; in the production implementation, the following calculation 59 | ;; should be performed at the pre-processing stage 60 | (w (reduce 'max (mapcar 'length (rtl:keys dict)))) 61 | (begs (list)) 62 | (rez (list))) 63 | ;; the outer loop tries to find the next word 64 | ;; only starting from the ends of the words that were found previously 65 | (do ((i 0 (pop begs))) 66 | ((or (null i) 67 | (= i (length str)))) 68 | ;; the inner loop checks all substrings of length 1..w 69 | (do ((j (1+ i) (1+ j))) 70 | ((>= j (1+ (min (length str) 71 | (+ w i))))) 72 | (when (rtl:? dict (rtl:slice str i j)) 73 | (setf (aref dp j) i) 74 | (push j begs))) 75 | (setf begs (reverse begs))) 76 | ;; the backward pass 77 | (do ((i (length str) (aref dp i))) 78 | ((null (aref dp i))) 79 | (push (rtl:slice str (aref dp i) i) rez)) 80 | (rtl:strjoin #\Space rez))) 81 | 82 | (deftest restore-spaces () 83 | (let ((dict (rtl:hash-set 'equal "a" "i" "at" "is" "hi" "ate" 84 | "his" "sat" "test" "this"))) 85 | (should be null (shortest-first-restore-spaces dict "thisisatest")) 86 | (should be string= "this is a test" 87 | (bt-shortest-first-restore-spaces dict "thisisatest")) 88 | (should be string= "this is a test" 89 | (dp-restore-spaces dict "thisisatest")))) 90 | 91 | (defun tj-penalty (length limit) 92 | (if (<= length limit) 93 | (expt (- limit length) 3) 94 | most-positive-fixnum)) 95 | 96 | (defun justify (limit str) 97 | (rtl:with ((toks (reverse (rtl:split #\Space str))) 98 | (n (length toks)) 99 | (penalties (make-array n)) 100 | (backptrs (make-array n)) 101 | (lengths (make-array n))) 102 | ;; forward pass (from the end of the string) 103 | (rtl:doindex (i tok toks) 104 | (let ((len (+ (length tok) (if (plusp i) (max 0 (aref lengths (1- i))) 105 | 0)))) 106 | (setf (aref lengths i) (1+ len)) 107 | (if (<= len limit) 108 | (setf (aref penalties i) (tj-penalty len limit) 109 | (aref backptrs i) -1) 110 | ;; minimization loop 111 | (let ((min most-positive-fixnum) 112 | arg) 113 | (dotimes (j i) 114 | (rtl:with ((j (- i j 1)) 115 | (len (- (aref lengths i) 116 | (aref lengths j))) 117 | (penalty (+ (tj-penalty len limit) 118 | (aref penalties j)))) 119 | (cond ((> len limit) (return)) 120 | ((< penalty min) (setf min penalty 121 | arg j))))) 122 | (setf (aref penalties i) min 123 | (aref backptrs i) arg))))) 124 | ;; backward pass (decoding) 125 | (with-output-to-string (out) 126 | (loop :for end := (1- n) :then beg 127 | :for beg := (aref backptrs end) 128 | :do ;; if there's no path some words were longer thn the limit 129 | (unless beg (return-from justify)) 130 | (format out "~A~%" 131 | (rtl:strjoin #\Space (reverse (subseq toks 132 | (1+ beg) 133 | (1+ end))))) 134 | :until (= -1 beg))))) 135 | 136 | (deftest justify () 137 | (let ((str "Common Lisp is the modern, multi-paradigm, high-performance, compiled, ANSI-standardized, most prominent descendant of the long-running family of Lisp programming languages.")) 138 | (should be null (justify 0 str)) 139 | (should be null (justify 10 str)) 140 | (should be string= "Common Lisp 141 | is the modern, 142 | multi-paradigm, 143 | high-performance, 144 | compiled, 145 | ANSI-standardized, 146 | most prominent 147 | descendant of the 148 | long-running family 149 | of Lisp programming 150 | languages. 151 | " (justify 20 str)) 152 | (should be string= "Common Lisp is the modern, multi-paradigm, 153 | high-performance, compiled, ANSI-standardized, 154 | most prominent descendant of the long-running 155 | family of Lisp programming languages. 156 | " (justify 50 str)))) 157 | 158 | (defun lev-dist (s1 s2 &optional 159 | (i1 (1- (length s1))) 160 | (i2 (1- (length s2))) 161 | (ld (make-array (list (1+ (length s1)) 162 | (1+ (length s2))) 163 | :initial-element nil) 164 | ldp)) ; a flag indicating that the argument 165 | ; was supplied 166 | ;; initialization of the 0-th column and row 167 | (unless ldp 168 | (dotimes (k (1+ (length s1))) (setf (aref ld k 0) 0)) 169 | (dotimes (k (1+ (length s2))) (setf (aref ld 0 k) 0))) 170 | (values (or (aref ld (1+ i1) (1+ i2)) 171 | (setf (aref ld (1+ i1) (1+ i2)) 172 | (if (eql (aref s1 i1) (aref s2 i2)) 173 | (lev-dist s1 s2 (1- i1) (1- i2) ld) 174 | (1+ (min (lev-dist s1 s2 (1- i1) (1- i2) ld) 175 | (lev-dist s1 s2 i1 (1- i2) ld) 176 | (lev-dist s1 s2 (1- i1) i2 ld)))))) 177 | ld)) 178 | 179 | (defun align (s1 s2) 180 | (rtl:with ((i1 (length s1)) 181 | (i2 (length s2)) 182 | ;; our Levenstein distance procedure returns the whole DP matrix 183 | ;; as a second value 184 | (ld (nth-value 1 (lev-dist s1 s2))) 185 | (rez (list))) 186 | (loop 187 | (let ((min (min (aref ld (1- i1) (1- i2)) 188 | (aref ld i1 (1- i2)) 189 | (aref ld (1- i1) i2)))) 190 | (cond ((= min (aref ld (1- i1) (1- i2))) 191 | (push (rtl:pair (char s1 (1- i1)) 192 | (char s2 (1- i2))) 193 | rez) 194 | (decf i1) 195 | (decf i2)) 196 | ((= min (aref ld (1- i1) i2)) 197 | (push (rtl:pair (char s1 (1- i1)) nil) 198 | rez) 199 | (decf i1)) 200 | ((= min (aref ld i1 (1- i2))) 201 | (push (rtl:pair nil (char s2 (1- i2))) 202 | rez) 203 | (decf i2)))) 204 | (when (= 0 i1) 205 | (loop :for j :from (1- i2) :downto 0 :do 206 | (push (rtl:pair #\* (char s2 j)) rez)) 207 | (return)) 208 | (when (= 0 i2) 209 | (loop :for j :from (1- i1) :downto 0 :do 210 | (push (rtl:pair (char s1 j) nil) rez)) 211 | (return))) 212 | ;; pretty output formatting 213 | (with-output-to-string (s1) 214 | (with-output-to-string (s2) 215 | (with-output-to-string (s3) 216 | (loop :for (c1 c2) :in rez :do 217 | (format s1 "~C " (or c1 #\.)) 218 | (format s2 "~C " (cond ((null c1) #\↓) 219 | ((null c2) #\↑) 220 | ((char= c1 c2) #\|) 221 | (t #\x))) 222 | (format s3 "~C " (or c2 #\.))) 223 | (format t "~A~%~A~%~A~%" 224 | (get-output-stream-string s1) 225 | (get-output-stream-string s2) 226 | (get-output-stream-string s3))))) 227 | rez)) 228 | 229 | (deftest alignment () 230 | (should be = 5 (lev-dist "democracy" "remorse")) 231 | (should print-to *standard-output* "d e m o c r a c y 232 | x | | | ↑ | ↑ x x 233 | r e m o . r . s e 234 | " 235 | (align "democracy" "remorse"))) 236 | -------------------------------------------------------------------------------- /ch13-approximation.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | 4 | (defstruct city 5 | name lat lon) 6 | 7 | (defun earth-dist (c1 c2) 8 | (rtl:with ((lat1 (city-lat c1)) 9 | (lat2 (ciyte-lat c2)) 10 | (a (+ (expt (sin (/ (- lat2 lat1) 2)) 11 | 2) 12 | (* (cos lat1) 13 | (cos lat2) 14 | (expt (sin (/ (- (city-lon c2) (city-lon c1)) 2)) 15 | 2))))) 16 | (* 1.2742e7 ; Earth diameter 17 | (atan (sqrt a) (sqrt (- 1 a)))))) 18 | 19 | (defun path-length (path) 20 | (let ((rez (earth-dist (aref path 0) (aref path -1)))) 21 | (dotimes (i (1- (length path))) 22 | (incf rez (earth-dist (aref path i) (aref path (1+ i))))) 23 | rez)) 24 | 25 | (defun random-search (path n) 26 | (let ((min (path-length path)) 27 | (arg path)) 28 | (loop :repeat n :do 29 | (rtl:with ((path (rtl:shuffle path)) 30 | (len (path-length path))) 31 | (when (< len min) 32 | (setf min len 33 | arg path)))) 34 | (values arg 35 | min))) 36 | 37 | (defun local-search (path improve-fn) 38 | (let ((min (path-length path)) 39 | (cc 0)) ; iteration count 40 | (loop 41 | (incf cc) 42 | (rtl:if-it (funcall improve-fn path) 43 | (setf min (path-length rtl:it) 44 | path rtl:it) 45 | (return (values path 46 | min 47 | cc)))))) 48 | 49 | (defun 2-opt (path) 50 | (loop :repeat (* 2 (length path)) :do 51 | (rtl:with ((len (length path)) 52 | (v1 (random len)) 53 | (v1* (if (= (1+ v1) len) 0 (1+ v1))) 54 | (v2 (loop :for v := (random len) 55 | :when (and (/= v v1) (/= v (1- v1))) 56 | :do (return v))) 57 | (v2* (if (= #2=(1+ v2) len) 0 #2#))) 58 | (when (< (+ (path-length (vec (aref path v1) (aref path v2))) 59 | (path-length (vec (aref path v1*) (aref path v2*)))) 60 | (+ (path-length (vec (aref path v1) (aref path v1*))) 61 | (path-length (vec (aref path v2) (aref path v2*))))) 62 | (let ((beg (min v1* v2*)) 63 | (end (max v1* v2*))) 64 | (return (concatenate 'vector 65 | (subseq path 0 beg) 66 | (reverse (subseq path beg end)) 67 | (subseq path end)))))))) 68 | 69 | (defun multi-local-search (path n) 70 | (let ((min (path-length path)) 71 | (arg path)) 72 | (loop :repeat n :do 73 | (rtl:with ((cur (local-search (rtl:shuffle path) '2-opt))) 74 | (when (< #1=(path-length cur) min) 75 | (setf min #1# 76 | arg cur)))) 77 | (values arg 78 | min))) 79 | 80 | ;; TODO add tests for searches 81 | 82 | 83 | (defun size (set) 84 | (length set)) 85 | 86 | (defun empty? (set) 87 | (null set)) 88 | 89 | (defun remove-item (set item) 90 | (rtl:removef item set)) 91 | 92 | (defun sample (n set &key (with-replacement t)) 93 | (loop :repeat n 94 | :for i := (random (size set)) 95 | :collect (rtl:? set i) 96 | :unless with-replacement :do 97 | (remove-item set i) 98 | (when (empty? set) (loop-finish)))) 99 | 100 | (defun sample-from-dist (n dist) 101 | ;; here, DIST is a hash-table with keys being items 102 | ;; and values — their probabilities 103 | (let ((scale (reduce '+ (rtl:vals dist)))) 104 | (loop :repeat n 105 | :collect (let ((r (* scale (random 1.0))) 106 | (acc 0)) 107 | (rtl:dotable (k v dist) 108 | (incf acc v) 109 | (when (>= acc r) 110 | (return k))))))) 111 | 112 | (defun reservoir-sample (n stream) 113 | (let ((rez (make-array n :initial-element nil))) ; reservoir 114 | (handler-case 115 | (loop :for item := (read stream) 116 | :for i :from 0 117 | :for r := (random (1+ i)) 118 | :do (cond 119 | ;; fill the reservoir with the first N items 120 | ((< i n) (setf (aref rez i) item)) 121 | ;; replace the R-th item with probability 122 | ;; proportionate to (- 1 (/ R N)) 123 | ((< r n) (setf (aref rez r) item)))) 124 | ;; sampling stops when the stream is exhausted 125 | ;; we'll use an input stream and read items from it 126 | (end-of-file () rez)))) 127 | 128 | (deftest sampling () 129 | (let ((42-count 0) 130 | (foo-count 0) 131 | (bar-count 0) 132 | (baz-count 0) 133 | (count 10000)) 134 | (loop :repeat count :do 135 | (let ((sample (sample 10 (rtl:range 0 100))) 136 | (rsample (with-input-from-string (in "foo foo foo foo bar bar baz") 137 | (reservoir-sample 3 in)))) 138 | (incf 42-count (count 42 sample)) 139 | (incf foo-count (count 'foo rsample)) 140 | (incf bar-count (count 'bar rsample)) 141 | (incf baz-count (count 'baz rsample)))) 142 | (should be approx= 1/100 (/ 42-count (* 10 count))) 143 | (should be approx= 4/7 (/ foo-count (* 3 count))) 144 | (should be approx= 2/7 (/ bar-count (* 3 count))) 145 | (should be approx= 1/7 (/ baz-count (* 3 count))))) 146 | 147 | 148 | ;; code prototypes 149 | 150 | (defstruct branch 151 | (upper most-positive-fixnum) 152 | (lower 0) 153 | (edges (list))) 154 | 155 | (defun b&b (g &key n) 156 | (rtl:with ((cur (vertices g)) 157 | (min (cost cur))) 158 | (arg cur) 159 | (q (make-branch :upper min :lower (lower-bound g (list)))) 160 | (loop :for i :from 0 161 | :for branch := (pop q) :while branch :do 162 | (when (eql i n) (return)) 163 | (if (branchp branch) 164 | (dolist (item (branch-out branch)) 165 | ;; we leave only the subbranches that can, 166 | ;; at least in theory, improve on the current solution 167 | (when (< (branch-lower item) upper) 168 | (push item q))) 169 | (let ((cost (branch-upper branch))) 170 | (when (< cost lower) 171 | (setf lower cost 172 | arg branch))))) 173 | (values cur 174 | cost))) 175 | 176 | (defun lower-bound (graph pinned-edges) 177 | (let ((cost 0) 178 | (forbidden-edges (apply 'rtl:hash-set 'eql pinned-edges))) 179 | (dolist (v (vertices graph)) 180 | (let ((min1 most-positive-fixnum) 181 | (min2 most-positive-fixnum)) 182 | (dolist (e (edges v)) 183 | (unless (rtl:in# e forbidden-edges)) 184 | (let ((len (edge-length e))) 185 | (cond ((< len min1) (setf min1 len)) 186 | ((< len min2) (setf min2 len)))))) 187 | (incf cost (/ (+ min1 min2) 2))) 188 | (reduce '+ (mapcar 'edge-length pinned-edges) 189 | :initial-value cost))) 190 | 191 | (defun gd (fn data &key n (learning-rate 0.1) (precision 1e-6)) 192 | (let ((ws (init-weights fn)) 193 | (cost (cost fn ws)) 194 | (i 0)) 195 | (loop 196 | (update-weights ws learning-rate 197 | (grad fn ws data)) 198 | (let ((prev cost)) 199 | (setf cost (cost fn ws)) 200 | (when (or (< (abs (- cost prev)) precision) 201 | (eql n (incf i))) 202 | (return)))) 203 | (values ws 204 | cost))) 205 | 206 | ;; TODO: add full GD variants 207 | ;; (let ((dws 0)) 208 | ;; (loop 209 | ;; (rtl:with ((batch (sample data batch-size)) 210 | ;; (g (calculate-gradient batch))) 211 | ;; (setf dws (- (* decay-rate dws) 212 | ;; (* learning-rate g))) 213 | ;; (incf ws dws)))) 214 | ;; (let ((dws 0)) 215 | ;; (loop 216 | ;; (incf ws dws) 217 | ;; (rtl:with ((batch (sample data batch-size)) 218 | ;; (g (- (* learning-rate (calculate-gradient batch))))) 219 | ;; (setf dws (+ (* decay-rate dws) g)) 220 | ;; (incf ws g)))) 221 | 222 | (defun dft (vec) 223 | (rtl:with ((n (length vec)) 224 | (rez (make-array n)) 225 | (scale (/ (- (* 2 pi #c(0 1))) n))) 226 | ;; #c(0 1) is imaginary unit (i) - Lisp allows us 227 | ;; to operate on complex numbers directly 228 | (dotimes (i n) 229 | (setf (aref rez i) 230 | (loop :for j :from 0 :below n 231 | :sum (* (aref vec j) 232 | (exp (* scale i j)))))))) 233 | 234 | ;; (let ((e (fft-of-even-indexed-part)) 235 | ;; (o (fft-of-odd-indexed-part)) 236 | ;; (scale (exp (/ (- (* 2 pi #c(0 1) i)) 237 | ;; n))) 238 | ;; (n/2 (floor n 2))) 239 | ;; (setf (aref rez i) (+ (aref e i) (* scale (aref o i))) 240 | ;; (aref rez (+ i n/2)) (- (aref e i) (* scale (aref o i))))) 241 | -------------------------------------------------------------------------------- /ch14-compression.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | (defparameter *b64-dict* 4 | (coerce (append (loop :for ch :from (char-code #\A) :to (char-code #\Z) 5 | :collect (code-char ch)) 6 | (loop :for ch :from (char-code #\a) :to (char-code #\z) 7 | :collect (code-char ch)) 8 | (loop :for ch :from (char-code #\0) :to (char-code #\9) 9 | :collect (code-char ch)) 10 | '(#\+ #\/ #\=)) 11 | 'simple-vector)) 12 | 13 | (defun b64-encode (in out) 14 | (let ((key 0) 15 | (limit 6)) 16 | (flet ((fill-key (byte off beg limit) 17 | (setf (ldb (byte limit off) key) 18 | (ldb (byte limit beg) byte)) 19 | (setf off (- 6 beg))) 20 | (emit1 (k) 21 | (write-byte (char-code (svref *b64-dict* k)) out))) 22 | (loop :for byte := (read-byte in nil) :while byte :do 23 | (let ((beg (- 8 limit))) 24 | (fill-key byte 0 beg limit) 25 | (emit1 key) 26 | (fill-key byte (setf limit (- 6 beg)) 0 beg) 27 | (when (= 6 beg) 28 | (emit1 key) 29 | (setf limit 6)))) 30 | (when (< limit 6) 31 | (setf (ldb (byte limit 0) key) 32 | (ldb (byte limit 0) 0)) 33 | (emit1 key) 34 | (loop :repeat (ceiling limit 2) :do 35 | (emit1 64)))))) 36 | 37 | (defun b64str (str) 38 | (let ((in (flex:make-in-memory-input-stream (map 'vector 'char-code str))) 39 | (out (flex:make-in-memory-output-stream))) 40 | (b64-encode in out) 41 | (map 'string 'code-char (rtl:? out 'vector)))) 42 | 43 | (deftest base64 () 44 | (should be rtl:blankp (b64str "")) 45 | (should be string= "TWFu" (b64str "Man")) 46 | (should be string= "TWFuIA==" (b64str "Man ")) 47 | (should be string= "TWFuIGk=" (b64str "Man i"))) 48 | 49 | (defun huffman-encode (envocab str) 50 | (let ((rez (make-array 0 :element-type 'bit :adjustable t :fill-pointer t))) 51 | (rtl:dovec (char str) 52 | (rtl:dovec (bit (rtl:? envocab char)) 53 | (vector-push-extend bit rez))) 54 | rez)) 55 | 56 | (defun huffman-decode (devocab vec) 57 | (let (rez) 58 | (dotimes (i (length vec)) 59 | (dotimes (j (- (length vec) i)) 60 | (rtl:when-it (rtl:? devocab (rtl:slice vec i (+ i j 1))) 61 | (push rtl:it rez) 62 | (incf i j) 63 | (return)))) 64 | (coerce (reverse rez) 'string))) 65 | 66 | (defun huffman-vocabs (str) 67 | ;; here we assume more than a single unique character in STR 68 | (let ((counts (make-hash-table)) 69 | (q (make-heap :op '< :key 'rt)) 70 | (envocab (make-hash-table)) 71 | (devocab (make-hash-table :test 'equal))) ; bit-vectors as keys require 72 | ; equal comparison 73 | ;; count character frequencies 74 | (rtl:dovec (char str) 75 | (incf (gethash char counts 0))) ; here, we use the default third argument 76 | ; of get# with the value of 0 77 | ;; heapsort the characters based on their frequency 78 | (rtl:dotable (char count counts) 79 | (heap-push (rtl:pair char count) q)) 80 | ;; build the tree 81 | (dotimes (i (1- (heap-size q))) 82 | (rtl:with (((lt cl) (heap-pop q)) 83 | ((rt cr) (heap-pop q))) 84 | (heap-push (rtl:pair (list lt rt) (+ cl cr)) 85 | q))) 86 | ;; traverse the tree in DFS manner 87 | ;; encoding the path to each leaf node as a bit-vector 88 | (labels ((dfs (node &optional (level 0) path) 89 | (if (listp node) 90 | (progn 91 | (dfs (rtl:lt node) (1+ level) (cons 0 path)) 92 | (dfs (rtl:rt node) (1+ level) (cons 1 path))) 93 | (let ((vec (make-array level :element-type 'bit 94 | :initial-contents (reverse path)))) 95 | (setf (rtl:? envocab node) vec 96 | (rtl:? devocab vec) node))))) 97 | (dfs (lt (heap-pop q)))) 98 | (list envocab devocab))) 99 | 100 | (defun huffman-tables (hts envocab) 101 | (declare (optimize sb-c::instrument-consing)) 102 | (mapcar (lambda (ht) 103 | (let ((rez (make-hash-table :test 'equal))) 104 | (rtl:dotable (str logprob ht) 105 | (setf (rtl:? rez (huffman-encode envocab str)) logprob)) 106 | rez)) 107 | hts)) 108 | 109 | (defun huffman-encode2 (envocab str) 110 | (let ((vecs (map 'vector (lambda (ch) (rtl:get# ch envocab)) 111 | str)) 112 | (total-size 0)) 113 | (rtl:dovec (vec vecs) 114 | (incf total-size (length vec))) 115 | (let ((rez (make-array total-size :element-type 'bit)) 116 | (i 0)) 117 | (rtl:dovec (vec vecs) 118 | (let ((size (length vec))) 119 | (setf (subseq rez i) vec) 120 | (incf i size))) 121 | rez))) 122 | 123 | (defun huffman-encode3 (envocab str) 124 | (let ((rez (make-array 0 :element-type 'bit :adjustable t :fill-pointer t))) 125 | (rtl:dovec (char str) 126 | ;; here, we have changed the hash-table to a jump-table 127 | (rtl:dovec (bit (svref envocab (char-code char))) 128 | (vector-push-extend bit rez))) 129 | rez)) 130 | 131 | (defun find-shortest-bitvec (lo hi) 132 | (let ((rez (make-array 0 :element-type 'bit :adjustable t :fill-pointer t))) 133 | (loop 134 | (rtl:with ((lod lof (floor (* lo 2))) 135 | (hid hif (floor (* hi 2)))) 136 | (when (or (zerop lof) 137 | (zerop hif) 138 | (/= lod hid)) 139 | (vector-push-extend hid rez) 140 | (return)) 141 | (vector-push-extend lod rez) 142 | (setf lo lof 143 | hi hif))) 144 | rez)) 145 | 146 | (deftest find-shortest-bitvec () 147 | (should be equalp #*01 (find-shortest-bitvec 0.214285714 0.357142857))) 148 | 149 | (defun arithm-encode (envocab message) 150 | (let ((lo 0.0) 151 | (hi 1.0)) 152 | (rtl:dovec (char message) 153 | (let ((coef (- hi lo))) 154 | (rtl:dotable (ch prob envocab) 155 | (let ((off (* prob coef))) 156 | (when (eql char ch) 157 | (setf hi (+ lo off)) 158 | (return)) 159 | (incf lo off))))) 160 | (find-shortest-bitvec lo hi))) 161 | 162 | (defun arithm-encode-correct (envocab message) 163 | (let ((lo 0) 164 | (hi (1- (expt 2 32))) 165 | (pending-bits 0) 166 | (rez (make-array 0 :element-type 'bit :adjustable t :fill-pointer t))) 167 | (flet ((emit-bit (bit) 168 | (vector-push-extend bit rez) 169 | (let ((pbit (if (zerop bit) 1 0))) 170 | (loop :repeat pending-bits :do (vector-push-extend pbit rez)) 171 | (setf pending-bits 0)))) 172 | (rtl:dovec (char message) 173 | (rtl:with ((range (- hi lo -1)) 174 | ((plo phi) (rtl:? envocab char))) 175 | (psetf lo (round (+ lo (* plo range))) 176 | hi (round (+ lo (* phi range) -1))) 177 | (loop 178 | (cond ((< hi #.(expt 2 31)) 179 | (emit-bit 0)) 180 | ((>= lo #.(expt 2 31)) 181 | (emit-bit 1) 182 | (decf lo #.(expt 2 31)) 183 | (decf hi #.(expt 2 31))) 184 | ((and (>= lo #.(expt 2 30)) 185 | (< hi (+ #.(expt 2 30) #.(expt 2 31)))) 186 | (decf lo #.(expt 2 30)) 187 | (decf hi #.(expt 2 30)) 188 | (incf pending-bits)) 189 | (t (return))) 190 | (psetf lo (mask32 (ash lo 1)) 191 | hi (mask32 (1+ (ash hi 1))))))) 192 | (incf pending-bits) 193 | (emit-bit (if (< lo #.(expt 2 30)) 0 1))) 194 | rez)) 195 | 196 | (defun mask32 (num) 197 | ;; this utility is used to confine the number in 32 bits 198 | (logand num #.(1- (expt 2 32)))) 199 | 200 | (defun bitvec->int (bits) 201 | (reduce (lambda (bit1 bit2) (+ (ash bit1 1) bit2)) 202 | bits)) 203 | 204 | (defun arithm-decode (dedict vec size) 205 | (rtl:with ((len (length vec)) 206 | (lo 0) 207 | (hi (1- (expt 2 32))) 208 | (val (bitvec->int (subseq vec 0 (min 32 len)))) 209 | (off 32) 210 | (rez (make-string size))) 211 | (dotimes (i size) 212 | (rtl:with ((range (- hi lo -1)) 213 | (prob (/ (- val lo) range))) 214 | (rtl:dotable (char r dedict) 215 | (rtl:with (((plo phi) r)) 216 | (when (>= phi prob) 217 | (psetf (char rez i) char 218 | lo (round (+ lo (* plo range))) 219 | hi (round (+ lo (* phi range) -1))) 220 | (return)))) 221 | (loop 222 | (cond ((< hi #.(expt 2 31)) 223 | ;; do nothing 224 | ) 225 | ((>= lo #.(expt 2 31)) 226 | (decf lo #.(expt 2 31)) 227 | (decf hi #.(expt 2 31)) 228 | (decf val #.(expt 2 31))) 229 | ((and (>= lo #.(expt 2 30)) 230 | (< hi #.(* 3 (expt 2 30)))) 231 | (decf lo #.(expt 2 30)) 232 | (decf hi #.(expt 2 30)) 233 | (decf val #.(expt 2 30))) 234 | (t 235 | (return))) 236 | (psetf lo (mask32 (ash lo 1)) 237 | hi (mask32 (1+ (ash hi 1))) 238 | val (mask32 (+ (ash val 1) 239 | (if (< off len) 240 | (aref vec off) 241 | 0))) 242 | off (1+ off))))) 243 | rez)) 244 | 245 | (deftest compression () 246 | (rtl:with (((dict1 dict2) 247 | (mapcar (lambda (d) 248 | (let ((dict (make-hash-table))) 249 | (loop :for (k v) :on d :by #'cddr 250 | :do (rtl:sethash k dict v)) 251 | dict)) 252 | '((#\e 1/14 253 | #\a 1/14 254 | #\h 1/14 255 | #\i 2/14 256 | #\s 3/14 257 | #\t 3/14 258 | #\Space 3/14) 259 | (#\e (0 1/14) 260 | #\a (1/14 1/7) 261 | #\h (1/7 3/14) 262 | #\i (3/14 5/14) 263 | #\s (5/14 4/7) 264 | #\t (4/7 11/14) 265 | #\Space (11/14 1)))))) 266 | (should be equal #*100110110100001110000001 267 | (arithm-encode dict1 "this is a test")) 268 | (should be equal #*10011011010000111000001101010110010101 269 | (arithm-encode-correct dict2 "this is a test")) 270 | (should be string= "this is a test" 271 | (arithm-decode dict2 (arithm-encode-correct dict2 "this is a test") 272 | 14)))) 273 | -------------------------------------------------------------------------------- /ch15-synchronization.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | 4 | ;; code protoypes 5 | 6 | (defstruct lf-queue 7 | (head (error "No HEAD.") :type cons) 8 | (tail (error "No TAIL.") :type cons)) 9 | 10 | (defconstant +dummy+ '.dummy.) 11 | 12 | (defun lf-enqueue (value queue) 13 | (let ((new (cons value nil))) 14 | (loop (when (eq nil (sb-ext:compare-and-swap 15 | (cdr (lf-queue-tail queue)) 16 | nil new)) 17 | (setf (lf-queue-tail queue) new) 18 | (return value))))) 19 | 20 | (defun lf-dequeue (queue) 21 | (loop (rtl:with ((head (lf-queue-head queue)) 22 | (next (cdr head))) 23 | (typecase next 24 | ;; the queue always has at least one element: 25 | ;; a +dummy+ node, thus a non-empty queue 26 | ;; will have at least two elements, 27 | ;; so a null NEXT means that the queue was empty 28 | (null (return (values nil 29 | nil))) 30 | (cons (when (eq head (sb-ext:compare-and-swap 31 | (lf-queue-head queue) 32 | head next)) 33 | (let ((value (car next))) 34 | (setf (car next) +dummy+) 35 | (return (values value 36 | t))))))))) 37 | 38 | (defun mapreduce-merge-sort (list n &key (pred '<)) 39 | (lparallel:pmap-reduce 40 | (lambda (x) (merge-sort x pred)) ; map step: solve a sub-problem 41 | (lambda (x y) (merge (type-of x) x y pred)) ; reduce step: combine solutions 42 | (group (ceiling (length list) n) list))) ; divide data into sub-problems 43 | 44 | (defmacro cas (place old new) 45 | `(when (eql ,place ,old) 46 | (setf ,place ,new))) 47 | 48 | (defmacro atomic-incf (place &optional i) 49 | (let ((cur (gensym "CUR")) 50 | (rez (gensym "REZ"))) 51 | `(loop :for ,rez := (let ((,cur ,place)) 52 | (cas ,place ,cur (+ ,cur ,i))) 53 | :when ,rez :do (return ,rez)))) 54 | 55 | (defparameter *interest* (rtl:vec nil nil)) 56 | (defparameter *turn* nil) 57 | 58 | (defun peterson-call (i fn) 59 | (let ((other (abs (1- i)))) 60 | (setf (aref *interest* i) t 61 | *turn* other) 62 | ;; busy waiting 63 | (loop :while (and (aref *interest* other) 64 | (= *turn* other))) 65 | ;; critical section start 66 | (funcall fn) 67 | ;; critical section end 68 | (setf (aref *interest* i) nil))) 69 | 70 | (defstruct (g-counter (:conc-name nil)) 71 | ccs) 72 | 73 | (defun make-gcc (n) 74 | (make-g-counter :ccs (make-array n))) 75 | 76 | (defun gcc-val (gcc) 77 | (reduce '+ (ccs gcc))) 78 | 79 | (defun gcc-merge (gcc1 gcc2) 80 | (rtl:map* 'max gcc1 gcc2)) 81 | -------------------------------------------------------------------------------- /ch4-data-structures.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | 4 | (defstruct point-v0 5 | parent) ; if the parent is null the point is the root 6 | 7 | (defun uf-union-v0 (point1 point2) 8 | "Join the subsets of POINT1 and POINT2." 9 | (setf (point-v0-parent point1) (or (point-v0-parent point2) 10 | point2))) 11 | 12 | (defun uf-find-v0 (point) 13 | "Determine the id of the subset that a POINT belongs to." 14 | (let ((parent (point-v0-parent point))) 15 | (if parent 16 | (uf-find-v0 parent) 17 | point))) 18 | 19 | (defstruct point 20 | parent 21 | (size 1)) 22 | 23 | (defun uf-find (point) 24 | (let ((parent (point-parent point))) 25 | (if parent 26 | ;; here, we use the fact that the assignment will also return 27 | ;; the value to perform both path compression and find 28 | (setf (point-parent point) (uf-find parent)) 29 | point))) 30 | 31 | (defun uf-union (point1 point2) 32 | (rtl:with ((root1 (uf-find point1)) 33 | (root2 (uf-find point2)) 34 | (major minor (if (> (point-size root1) 35 | (point-size root2)) 36 | (values root1 root2) 37 | (values root2 root1)))) 38 | (incf (point-size major) (point-size minor)) 39 | (setf (point-parent minor) major))) 40 | 41 | (defun uf-disjoint (points) 42 | "Return true if all of the POINTS belong to different subsets." 43 | (let ((roots (list))) 44 | (dolist (point points) 45 | (let ((root (uf-find point))) 46 | (when (member root roots) 47 | (return-from uf-disjoint nil)) 48 | (push root roots)))) 49 | t) 50 | 51 | ;; TODO: add tests for Union-Find 52 | -------------------------------------------------------------------------------- /ch5-arrays.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | 4 | (defun map-vec (fn vec) 5 | "Map function FN over each element of VEC 6 | and return the new vector with the results." 7 | (let ((rez (make-array (length vec)))) 8 | (dotimes (i (length vec)) 9 | (setf (aref rez i) (funcall fn (aref vec i)))) 10 | rez)) 11 | 12 | (deftest map-vec () 13 | (should be equalp #(2 3 4) (map-vec '1+ #(1 2 3)))) 14 | 15 | (defun clumsy-filter-vec (pred vec) 16 | "Return the vector with only those elements of VEC 17 | for which calling pred returns true." 18 | (let ((rez (make-array (length vec) :fill-pointer 0))) 19 | (dotimes (i (length vec)) 20 | (when (funcall pred (aref vec i)) 21 | (vector-push (aref vec i) rez))) 22 | rez)) 23 | 24 | (deftest clumsy-filter-vec () 25 | (should be equalp #(1 3) (clumsy-filter-vec 'oddp #(1 2 3)))) 26 | 27 | (defun m* (m1 m2) 28 | (rtl:with ((n (array-dimension m1 1)) 29 | (n1 (array-dimension m1 0)) 30 | (n2 (array-dimension m2 1)) 31 | (rez (make-array (list n1 n2)))) 32 | (assert (= n (array-dimension m2 0))) 33 | (dotimes (i n1) 34 | (dotimes (j n2) 35 | (let ((acc 0)) 36 | (dotimes (k n) 37 | (incf acc (* (aref m1 i k) 38 | (aref m2 k j)))) 39 | (setf (aref rez i j) acc)))) 40 | rez)) 41 | 42 | (deftest m* () 43 | (should be equalp #2A((1)) 44 | (m* #2A((1)) #2A((1)))) 45 | (should be equalp #2A((1 2) (3 4)) 46 | (m* #2A((1 2) 47 | (3 4)) 48 | #2A((1 0) 49 | (0 1))))) 50 | 51 | (defun bin-search-v0 (val vec &optional (pos 0)) 52 | (if (> (length vec) 1) 53 | (rtl:with ((mid (floor (length vec) 2)) 54 | (cur (aref vec mid))) 55 | (cond ((< cur val) (bin-search-v0 val 56 | (rtl:slice vec mid) 57 | (+ pos mid))) 58 | ((> cur val) (bin-search-v0 val 59 | (rtl:slice vec 0 mid) 60 | pos)) 61 | (t (+ pos mid)))) 62 | (when (= (aref vec 0) val) 63 | pos))) 64 | 65 | (defun bin-search (val vec &key (less '<) (test '=) (key 'identity)) 66 | (when (plusp (length vec)) 67 | (let ((beg 0) 68 | (end (1- (length vec)))) 69 | (do () 70 | ((= beg end)) 71 | (let ((mid (+ beg (floor (- end beg) 2)))) 72 | (if (funcall less (funcall key (aref vec mid)) val) 73 | (setf beg (1+ mid)) 74 | (setf end mid)))) 75 | (values (aref vec beg) 76 | beg 77 | (funcall test (funcall key (aref vec beg)) val))))) 78 | 79 | #+prototype 80 | (defun bogosort (vec comp) 81 | (dolist (variant (all-permutations vec)) 82 | (dotimes (i (1- (length variant)) 83 | ;; this is the 3rd optional argument of dotimes header 84 | ;; that is evaluated only after the loop finishes normally 85 | ;; if it does we have found a completely sorted permutation! 86 | (return-from bogosort variant)) 87 | (when (funcall comp (aref variant (1+ i)) (aref variant i)) 88 | (return))))) ; current variant is not sorted, skip it 89 | 90 | (defun selection-sort (vec comp) 91 | (dotimes (i (1- (length vec))) 92 | (let ((best (aref vec i)) 93 | (idx i)) 94 | (dotimes (j (- (length vec) i 1)) 95 | (when (funcall comp (aref vec (+ i j 1)) best) 96 | (setf best (aref vec (+ i j 1)) 97 | idx (+ i j 1)))) 98 | (rotatef (aref vec i) (aref vec idx)))) ; this is the Lisp swap operator 99 | vec) 100 | 101 | (defun insertion-sort (vec comp) 102 | (dotimes (i (1- (length vec))) 103 | (do ((j i (1- j))) 104 | ((minusp j)) 105 | (if (funcall comp (aref vec (1+ j)) (aref vec j)) 106 | (rotatef (aref vec (1+ j)) (aref vec j)) 107 | (return)))) 108 | vec) 109 | 110 | (defun quicksort (vec comp) 111 | (when (> (length vec) 1) 112 | (rtl:with ((pivot-i 0) 113 | (pivot (aref vec (1- (length vec))))) 114 | (dotimes (i (1- (length vec))) 115 | (when (funcall comp (aref vec i) pivot) 116 | (rotatef (aref vec i) 117 | (aref vec pivot-i)) 118 | (incf pivot-i))) 119 | ;; swap the pivot (last element) in its proper place 120 | (rotatef (aref vec (1- (length vec))) 121 | (aref vec pivot-i)) 122 | (quicksort (rtl:slice vec 0 pivot-i) comp) 123 | (quicksort (rtl:slice vec (1+ pivot-i)) comp))) 124 | vec) 125 | 126 | (defun 3-medians (vec comp) 127 | (rtl:with ((len (length vec)) 128 | (lt (aref vec 0)) 129 | (md (aref vec (floor len 2))) 130 | (rt (aref vec (1- len)))) 131 | (rtl:switch ((elt (sort (rtl:vec lt md rt) comp) 1)) 132 | (lt 0) 133 | (rt (1- len)) 134 | (md (floor len 2))))) 135 | 136 | (deftest 3-medians () 137 | (should be = 1 (3-medians #(1 2 3) '<)) 138 | (should be = 0 (3-medians #(2 1 3) '<)) 139 | (should be = 2 (3-medians #(1 3 2) '<))) 140 | 141 | (defun prod-sort (vec comp &optional (eq 'eql)) 142 | (cond ((< (length vec) 2) 143 | vec) 144 | ((< (length vec) 10) 145 | (insertion-sort vec comp)) 146 | (t 147 | (rotatef (aref vec (1- (length vec))) 148 | (aref vec (3-medians vec comp))) 149 | (rtl:with ((pivot-i 0) 150 | (pivot-count 1) 151 | (last-i (1- (length vec))) 152 | (pivot (aref vec last-i))) 153 | (do ((i 0 (1+ i))) 154 | ((> i (- last-i pivot-count))) 155 | (cond ((funcall comp (aref vec i) pivot) 156 | (rotatef (aref vec i) 157 | (aref vec pivot-i)) 158 | (incf pivot-i)) 159 | ((funcall eq (aref vec i) pivot) 160 | (rotatef (aref vec i) 161 | (aref vec (- last-i pivot-count))) 162 | (incf pivot-count) 163 | (decf i)))) ; decrement i to reprocess newly swapped point 164 | (dotimes (i pivot-count) 165 | (rotatef (aref vec (+ pivot-i i)) 166 | (aref vec (- last-i i)))) 167 | (prod-sort (rtl:slice vec 0 pivot-i) comp eq) 168 | (prod-sort (rtl:slice vec (+ pivot-i pivot-count)) comp eq)))) 169 | vec) 170 | 171 | (defun test-sort-vec (fn) 172 | (should be equalp #(1 2 3 4 5) 173 | (funcall fn #(1 2 3 4 5) '<)) 174 | (should be equalp #(1 2 3 4 5) 175 | (funcall fn #(2 1 3 5 4) '<)) 176 | (should be equalp #(1 2 3 4 5) 177 | (funcall fn #(5 4 3 2 1) '<))) 178 | 179 | (deftest sorting () 180 | (test-sort-vec 'selection-sort) 181 | (test-sort-vec 'insertion-sort) 182 | (test-sort-vec 'quicksort) 183 | (test-sort-vec 'prod-sort)) 184 | 185 | (defun random-vec (size) 186 | (let ((vec (make-array size))) 187 | (dotimes (i size) 188 | (setf (aref vec i) (random size))) 189 | vec)) 190 | 191 | (defun print-sort-timings (sort-name sort-fn vec) 192 | ;; we'll use in-place modification of the input vector VEC 193 | ;; so we need to copy it to preserve the original for future use 194 | (let ((vec (copy-seq vec)) 195 | (len (length vec))) 196 | (format t "= ~Asort of random vector (length=~A) =~%" 197 | sort-name len) 198 | (time (funcall sort-fn vec '<)) 199 | (format t "= ~Asort of sorted vector (length=~A) =~%" 200 | sort-name len) 201 | (time (funcall sort-fn vec '<)) 202 | (format t "= ~Asort of reverse sorted vector (length=~A) =~%" 203 | sort-name len) 204 | (time (funcall sort-fn vec '>)))) 205 | -------------------------------------------------------------------------------- /ch6-lists.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | (defun dwim-map (fn seq &rest seqs) 4 | "A thin wrapper over MAP that uses the type of the first SEQ for the result." 5 | (apply 'map (type-of seq) fn seqs)) 6 | 7 | (defun simple-mapcar-v1 (fn list) 8 | (let ((rez (list))) 9 | (dolist (item list) 10 | (setf rez (cons (funcall fn item) rez))) 11 | (reverse rez))) 12 | 13 | (defun simple-mapcar-v2 (fn list) 14 | (let ((rez (list))) 15 | (dolist (item list) 16 | (push (funcall fn item) rez)) 17 | (reverse rez))) 18 | 19 | 20 | (defstruct list-cell 21 | data 22 | next) 23 | 24 | (defstruct our-own-list 25 | (head nil :type (or list-cell null)) 26 | (tail nil :type (or list-cell null)) 27 | (size 0 :type (integer 0))) 28 | 29 | (defstruct (list-cell2 (:include list-cell)) 30 | prev) 31 | 32 | (defun our-cons2 (data list) 33 | (when (null list) (setf list (make-our-own-list))) 34 | (let ((new-head (make-list-cell2 35 | :data data 36 | :next (rtl:? list 'head)))) 37 | (when (rtl:? list 'head) 38 | (setf (rtl:? list 'head 'prev) new-head)) 39 | (make-our-own-list 40 | :head new-head 41 | :tail (rtl:? list 'tail) 42 | :size (1+ (rtl:? list 'size))))) 43 | 44 | (defstruct queue 45 | head 46 | tail) 47 | 48 | (defun enqueue (item queue) 49 | (push item (rtl:? queue 'head))) 50 | 51 | (defun dequeue (queue) 52 | ;; Here and in the next condition, we use the property that an empty list 53 | ;; is also logically false. This is discouraged by many Lisp style-guides, 54 | ;; but in many cases such code is not only more compact but also more clear. 55 | (unless (rtl:? queue 'tail) 56 | (do () 57 | ;; this loop continues until the head becomes empty 58 | ((null (rtl:? queue 'head))) 59 | (push (pop (rtl:? queue 'head)) (rtl:? queue 'tail)))) 60 | ;; By pushing all the items from the head to the tail, 61 | ;; we reverse their order — this is the second reversing 62 | ;; that cancels the reversing performed when we push the items 63 | ;; onto the head, so it restores the original order. 64 | (when (rtl:? queue 'tail) 65 | (values (pop (rtl:? queue 'tail)) 66 | t))) ; this second value is used to indicate 67 | ; that the queue was not empty 68 | 69 | (deftest queue () 70 | (let ((q (make-queue))) 71 | (should be equalp (read-from-string "#S(QUEUE :HEAD NIL :TAIL NIL)") 72 | q) 73 | (enqueue 1 q) 74 | (enqueue 2 q) 75 | (enqueue 3 q) 76 | (should be equalp (read-from-string "#S(QUEUE :HEAD (3 2 1) :TAIL NIL)") 77 | q) 78 | (dequeue q) 79 | (should be equalp (read-from-string "#S(QUEUE :HEAD NIL :TAIL (2 3))") 80 | q) 81 | (enqueue 4 q) 82 | (should be equalp (read-from-string "#S(QUEUE :HEAD (4) :TAIL (2 3))") 83 | q) 84 | (dequeue q) 85 | (should be equalp (read-from-string "#S(QUEUE :HEAD (4) :TAIL (3))") 86 | q) 87 | (dequeue q) 88 | (should be equalp (read-from-string "#S(QUEUE :HEAD (4) :TAIL NIL)") 89 | q) 90 | (dequeue q) 91 | (should be equalp (read-from-string "#S(QUEUE :HEAD NIL :TAIL NIL)") 92 | q))) 93 | 94 | (defun arith-eval (expr) 95 | "EXPR is a list of symbols that may include: 96 | square brackets, arithmetic operations, and numbers." 97 | (let ((ops ()) 98 | (vals ()) 99 | (op nil) 100 | (val nil)) 101 | (dolist (item expr) 102 | (case item 103 | ([ ) ; do nothing 104 | ((+ - * /) (push item ops)) 105 | (] (setf op (pop ops) 106 | val (pop vals)) 107 | (case op 108 | (+ (incf val (pop vals))) 109 | (- (decf val (pop vals))) 110 | (* (setf val (* val (pop vals)))) 111 | (/ (setf val (/ val (pop vals))))) 112 | (push val vals)) 113 | (otherwise (push item vals)))) 114 | (pop vals))) 115 | 116 | (deftest arith-eval () 117 | (should be = 101 (arith-eval '([ 1 + [ [ 2 + 3 ] * [ 4 * 5 ] ] ] ])))) 118 | 119 | (defun sorted-union (s1 s2) 120 | (let ((rez ())) 121 | (do () 122 | ((and (null s1) (null s2))) 123 | (let ((i1 (first s1)) 124 | (i2 (first s2))) 125 | (cond ((null i1) (dolist (i2 s2) 126 | (push i2 rez)) 127 | (return)) 128 | ((null i2) (dolist (i1 s1) 129 | (push i1 rez)) 130 | (return)) 131 | ((= i1 i2) (push i1 rez) 132 | (setf s1 (rest s1) 133 | s2 (rest s2))) 134 | ((< i1 i2) (push i1 rez) 135 | (setf s1 (rest s1))) 136 | ;; just T may be used instead 137 | ;; of the following condition 138 | ((> i1 i2) (push i2 rez) 139 | (setf s2 (rest s2)))))) 140 | (reverse rez))) 141 | 142 | (deftest sorted-union () 143 | (should be equal '(0 1 2 3 5 6) 144 | (sorted-union '(1 2 3) 145 | '(0 1 5 6)))) 146 | 147 | (defun merge-sort (list comp) 148 | (if (null (rest list)) 149 | list 150 | (let ((half (floor (length list) 2))) 151 | (merge-lists (merge-sort (subseq list 0 half) comp) 152 | (merge-sort (subseq list half) comp) 153 | comp)))) 154 | 155 | (defun merge-lists (l1 l2 comp) 156 | (let ((rez ())) 157 | (do () 158 | ((and (null l1) (null l2))) 159 | (let ((i1 (first l1)) 160 | (i2 (first l2))) 161 | (cond ((null i1) (dolist (i l2) 162 | (push i rez)) 163 | (return)) 164 | ((null i2) (dolist (i l1) 165 | (push i rez)) 166 | (return)) 167 | ((funcall comp i1 i2) (push i1 rez) 168 | (setf l1 (rest l1))) 169 | (t (push i2 rez) 170 | (setf l2 (rest l2)))))) 171 | (reverse rez))) 172 | 173 | (defun generic-merge-sort (seq comp) 174 | (if (or (null seq) ; avoid expensive length calculation 175 | (<= (length seq) 1)) 176 | seq 177 | (let ((half (floor (length seq) 2))) 178 | (merge (type-of seq) 179 | (merge-sort (subseq seq 0 half) comp) 180 | (merge-sort (subseq seq half) comp) 181 | comp)))) 182 | 183 | (defun parallel-merge-sort (seq comp) 184 | (if (or (null seq) (<= (length seq) 1)) 185 | seq 186 | (rtl:with ((half (floor (length seq) 2)) 187 | (thread1 (eager-future2:pexec 188 | (merge-sort (subseq seq 0 half) comp))) 189 | (thread2 (eager-future2:pexec 190 | (merge-sort (subseq seq half) comp)))) 191 | (merge (type-of seq) 192 | (eager-future2:yield thread1) 193 | (eager-future2:yield thread2) 194 | comp)))) 195 | 196 | (defun test-sort-list (fn) 197 | (should be equalp '(1 2 3 4 5) 198 | (funcall fn '(1 2 3 4 5) '<)) 199 | (should be equalp '(1 2 3 4 5) 200 | (funcall fn '(2 1 3 5 4) '<)) 201 | (should be equalp '(1 2 3 4 5) 202 | (funcall fn '(5 4 3 2 1) '<))) 203 | 204 | (deftest merge-sort () 205 | (test-sort-list 'merge-sort) 206 | (test-sort-list 'generic-merge-sort) 207 | (test-sort-list 'parallel-merge-sort)) 208 | -------------------------------------------------------------------------------- /ch7-kvs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | (defun alist-del (key alist) 4 | (loop :for tail := alist :then (rest tail) :while tail 5 | :for prev := alist :then tail 6 | ;; a more general version of the fuction will take 7 | ;; an additional :test argument instead of hardcoding EQL 8 | :when (eql key (car (first tail))) 9 | :do (return (if (eql prev alist) 10 | ;; special case of the first item 11 | (rest alist) 12 | (progn (setf (rest prev) (rest tail)) 13 | alist))) 14 | :finally (return alist))) 15 | 16 | (deftest alist-del () 17 | (should be null (alist-del :foo (list (cons :foo 42)))) 18 | (should be equal '((:bar . :baz)) 19 | (alist-del :foo (list (cons :foo 42) (cons :bar :baz))))) 20 | 21 | (defun start-memoizing (fn) 22 | (stop-memoizing fn) 23 | (setf (symbol-function fn) 24 | (let ((table (make-hash-table :test 'equal)) 25 | (vanilla-fn (symbol-function fn))) 26 | (setf (get fn :cache) table 27 | (get fn :fn) vanilla-fn) 28 | (lambda (&rest args) 29 | (rtl:getsethash (format nil "~{~A~^|~}" args) 30 | table 31 | (apply vanilla-fn args)))))) 32 | 33 | (defun stop-memoizing (fn) 34 | ;; WHEN-IT is a so called anaphoric macro, from RUTILS, that assigns 35 | ;; the value of its first argument to an implicitly created variable IT 36 | ;; and evaluates the body when IT isn't null 37 | (rtl:when-it (get fn :fn) 38 | (setf (symbol-function fn) rtl:it 39 | (get fn :fn) nil))) 40 | 41 | ;; TODO: add memoization tests 42 | 43 | (defun find-candidate-second-chance (bitmap) 44 | (declare (type bit-vector bitmap)) 45 | (position 0 bitmap)) 46 | 47 | (let ((i 0)) 48 | (defun find-candidate-clock (bitmap) 49 | (declare (type (vector bit) bitmap)) 50 | (loop :with len := (length bitmap) 51 | :until (zerop (aref bitmap i)) 52 | :do (setf (aref bitmap i) 0) 53 | (setf i (mod (1+ i) len))) 54 | i)) 55 | 56 | ;; TODO: add cache eviction code & tests 57 | -------------------------------------------------------------------------------- /ch8-hash-tables.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | (defun birthday-collision-prob (n) 4 | (let ((rez 1)) 5 | (dotimes (i n) 6 | (setf rez (* rez (/ (- 365 i) 365)))) 7 | ;; don't forget that we want the complement of the probability 8 | ;; of no collisions, hence (- 1.0 ...) 9 | (- 1.0 rez))) 10 | 11 | (defun hash-collision-prob (n size) 12 | (let ((rez 1)) 13 | (dotimes (i n) 14 | (setf rez (* rez (/ (- size i) size)))) 15 | (- 1.0 rez))) 16 | 17 | (deftest collision-probs () 18 | (should be = 0.4114384 (birthday-collision-prob 20)) 19 | (should be = 0.9996371 (hash-collision-prob 10 10)) 20 | (should be = 0.9345271 (hash-collision-prob 10 20)) 21 | (should be = 0.37184352 (hash-collision-prob 10 100)) 22 | (should be = 0.004491329 (hash-collision-prob 10 10000)) 23 | (should be approx= 0.63 (hash-collision-prob 20 200))) 24 | 25 | (defstruct ht 26 | array 27 | (count 0)) 28 | 29 | (defun ht (&rest kvs) 30 | (let ((rez (make-ht :array (make-array 16 :initial-element (list))))) 31 | (loop :for (k v) :in kvs :do 32 | (add-ht k v rez)) 33 | rez)) 34 | 35 | (defun ht-get (key ht) 36 | (rtl:with ((size (length (rtl:? ht 'array))) 37 | (start (rem (hash key) size))) 38 | (do ((count 0 (1+ count)) 39 | (i start (rem (1+ i) size)) 40 | (item (rtl:? ht 'array start) 41 | (rtl:? ht 'array i))) 42 | ((or (null item) 43 | (= count size))) 44 | (when (eql key (car item)) 45 | (return 46 | (values (cdr item) 47 | ;; the second value is an index, at which the item was found 48 | ;; (also used to distinguish the value nil from not found, 49 | ;; which is also represented by nil but with no second value) 50 | i)))))) 51 | 52 | (defun ht-add (key val ht) 53 | (rtl:with ((array (ht-array ht)) 54 | (size (length array))) 55 | ;; flet defines a local function that has access 56 | ;; to the local variables defined in HT-ADD 57 | (flet ((add-item (k v) 58 | (do ((i (rem (hash k) size) 59 | (rem (1+ i) size))) 60 | ((null (rtl:? ht 'array i)) 61 | (setf (rtl:? ht 'array i) (cons k v))) 62 | ;; this do-loop doesn't have a body 63 | ))) 64 | (when (= (hash-table-count ht) size) 65 | ;; when the backing array is full 66 | ;; expand it to have the length equal to the next power of 2 67 | (setf size (expt 2 (ceiling (log (1+ count) 2))) 68 | (rtl:? ht 'array) (make-array size :initial-element nil)) 69 | ;; and re-add its contents 70 | (rtl:dovec (item array) 71 | (add-item (car item) (cdr item))) 72 | ;; finally, add the new item 73 | (incf (rtl:? ht 'count)) 74 | (add-item key val))))) 75 | 76 | (defun ht-rem (key ht) 77 | ;; here, we use the index of the item returned as the 2nd value of HT-GET 78 | (rtl:when-it (nth-value 1 (ht-get key ht)) 79 | (setf (rtl:? ht 'array rtl:it) nil) 80 | ;; return the index to indicate that the item was found 81 | rtl:it)) 82 | 83 | ;; TODO add ht tests 84 | 85 | 86 | (defparameter *fnv-primes* 87 | '((32 . 16777619) 88 | (64 . 1099511628211) 89 | (128 . 309485009821345068724781371) 90 | (256 . 374144419156711147060143317175368453031918731002211))) 91 | 92 | (defparameter *fnv-offsets* 93 | '((32 . 2166136261) 94 | (64 . 14695981039346656037) 95 | (128 . 144066263297769815596495629667062367629) 96 | (256 . 100029257958052580907070968620625704837092796014241193945225284501741471925557))) 97 | 98 | (defun fnv-1a (x &key (bits 32)) 99 | (assert (member bits '(32 64 128 256))) 100 | (let ((rez (rtl:assoc1 bits *fnv-offsets*)) 101 | (prime (rtl:assoc1 bits *fnv-primes*))) 102 | (dotimes (i (/ bits 8)) 103 | (setf rez (ldb (byte bits 0) 104 | (* (logxor rez (ldb (byte 8 (* i 8)) x)) 105 | prime)))) 106 | rez)) 107 | 108 | (defun fnv-1a-str (str) 109 | (let ((rez (rtl:assoc1 32 *fnv-offsets*)) 110 | (prime (rtl:assoc1 32 *fnv-primes*))) 111 | (rtl:dovec (char str) 112 | (setf rez (ldb (byte 32 0) 113 | (* (logxor rez (char-code char)) 114 | prime)))) 115 | rez)) 116 | 117 | (defun djb2-str (str) 118 | (let ((rez 5381)) ; a DJB2 prime number 119 | (rtl:dovec (char str) 120 | (setf rez (ldb (byte 32 0) 121 | (+ (char-code char) 122 | (ldb (byte 32 0) 123 | (+ (ash rez 5) 124 | rez)))))) 125 | rez)) 126 | 127 | (deftest hash-functions () 128 | ) 129 | 130 | (defstruct default-hash-table 131 | (table (make-hash-table)) 132 | default-value) 133 | 134 | (defun gethash-default (key ht) 135 | (gethash key (rtl:? ht 'table) (rtl:? ht 'default-value))) 136 | 137 | (defmethod generic-elt ((kv default-hash-table) key &rest keys) 138 | (gethash-default key kv)) 139 | 140 | (deftest default-hash-table () 141 | (should be = 42 142 | (gethash-default :foo (make-default-hash-table :default-value 42)))) 143 | 144 | (defstruct linked-hash-table-item 145 | key 146 | val 147 | next) 148 | 149 | (defstruct linked-hash-table 150 | (table (make-hash-table)) 151 | head 152 | tail) 153 | 154 | (defun gethash-linked (key ht) 155 | ;; we use GETHASH instead of a shorter (rtl:? ht 'table key 'val) 156 | ;; to preserve the second return value 157 | (gethash key (rtl:? ht 'table))) 158 | 159 | (defun sethash-linked (key ht val) 160 | ;; The initial order of items is the order of addition. 161 | ;; If we'd like to impose a different order, we'll have to perform reordering 162 | ;; after each addition or implement a custom sethash function. 163 | (with-slots (table head tail) ht 164 | (rtl:if-it (gethash key table) 165 | (setf (rtl:? rtl:it 'val) val) 166 | (let ((new (make-linked-hash-table-item 167 | :key key :val val))) 168 | (rtl:sethash key table new) 169 | (when (null head) 170 | (setf (rtl:? ht 'head) new)) 171 | (setf (rtl:? ht 'tail) 172 | (if tail 173 | (setf (rtl:? ht 'tail 'next) new) 174 | new)))))) 175 | 176 | (deftest linked-ht () 177 | (let ((ht (make-linked-hash-table))) 178 | (sethash-linked :foo ht 42) 179 | (sethash-linked :bar ht 43) 180 | (sethash-linked :baz ht 44) 181 | (should be equal '(42 43 44) 182 | (loop :for cur := (linked-hash-table-head ht) 183 | :then (linked-hash-table-item-next cur) 184 | :collect (linked-hash-table-item-val cur) 185 | :until (eql cur (linked-hash-table-tail ht)))))) 186 | 187 | (defmethod mapkv (fn (ht linked-hash-table)) 188 | (let ((rez (make-linked-hash-table 189 | :table (make-hash-table 190 | :test (hash-table-test (rtl:? ht 'table)))))) 191 | (do ((item (rtl:? ht 'head) (rtl:? item 'next))) 192 | ((null item)) 193 | (let ((k (rtl:? item 'key))) 194 | (sethash-linked k rez (funcall fn k (rtl:? item 'val))))) 195 | rez)) 196 | 197 | (defun content-address (object) 198 | (sha1:sha1-hex (with-output-to-string (out) 199 | (format out "~A:" (class-of object)) 200 | (print-object object out)))) 201 | 202 | (defun ca-get-object (address repo) 203 | (gethash address repo)) 204 | 205 | (defun ca-add-object (object repo) 206 | (let ((addr (content-address object))) 207 | (values (rtl:set# addr repo object) 208 | addr))) 209 | 210 | (defun ca-rem-object (object repo) 211 | (remhash (content-address object) repo)) 212 | 213 | (defun content-address2 (object) 214 | ;; here, we use SHA1-DIGEST to get the numeric 215 | ;; value (as a sequence of bytes) of the hash 216 | ;; instead of its string representation 217 | ;; that was previously obtained from SHA1-HEX 218 | (let ((hash (sha1:sha1-digest 219 | (with-output-to-string (out) 220 | (format out "~A:" (class-of object)) 221 | (print-object object out))))) 222 | (rtl:pair (elt hash 0) 223 | ;; the cryptic format ~{~2,'0X~} is used 224 | ;; to print numbers in hex (X) with a fixed length 225 | ;; of 2 chars padded by zeroes from the left 226 | (format nil "~{~2,'0X~}" (subseq hash 1))))) 227 | 228 | (defun ca-get-object2 (address2 repo) 229 | (apply 'rtl:? repo address2)) 230 | 231 | (defun ca-add-object2 (object repo) 232 | (rtl:with (((top addr) (content-address2 object)) 233 | (subrepo (rtl:getset# top repo 234 | (make-hash-table :test 'equal)))) 235 | (values (rtl:set# addr subrepo object) 236 | (rtl:pair top addr)))) 237 | 238 | (defun ca-rem-object2 (object repo) 239 | (rtl:with (((top addr) (content-address2 object))) 240 | (rtl:when-it (gethash top repo) 241 | (remhash addr rtl:it)))) 242 | 243 | (deftest content-adressing () 244 | (let ((repo (make-hash-table :test 'equal)) 245 | (repo2 (make-hash-table :test 'equal))) 246 | (should be string= "test" "514BE1254CC9825EE125651650B5F9F6CF5C55D9" 247 | (ca-add-object "test" repo)) 248 | (should be string= "test" 249 | (gethash "514BE1254CC9825EE125651650B5F9F6CF5C55D9" repo)) 250 | (ca-add-object2 "foo" repo2) 251 | (ca-add-object2 "bar" repo2) 252 | (should be string= "foo" 253 | (gethash "8AB31BA5528396616249FCA3879C734FF3440D" (gethash 138 repo2))) 254 | (should be string= "bar" 255 | (gethash "F50F210FA56B285C6DA1B09C72782791BBB15A" (gethash 195 repo2))))) 256 | -------------------------------------------------------------------------------- /ch9-trees.lisp: -------------------------------------------------------------------------------- 1 | (in-package :progalgs) 2 | 3 | 4 | (defstruct (tree-node (:conc-name nil)) 5 | key 6 | children) ; instead of linked list's next 7 | 8 | (defun dfs-node (fn root) 9 | (funcall fn (key root)) 10 | (dolist (child (children root)) 11 | (dfs-node fn child))) 12 | 13 | (defmacro dotree-dfs ((value root) &body body) 14 | (let ((node (gensym))) ; GENSYM is a fresh symbol 15 | ; used to prevent possible symbol 16 | ; collisions for NODE 17 | `(dfs-node (lambda (,node) 18 | (let ((,value (key ,node))) 19 | ,@body)) 20 | ,root))) 21 | 22 | (defun rank (node) 23 | (let ((size 0)) 24 | (dotree-dfs (_ node) 25 | (incf size)) 26 | (log size 2))) 27 | 28 | (defun dfs-list (fn tree) 29 | ;; we need to handle both subtrees (lists) and 30 | ;; leaves (atoms) — so, we'll just convert 31 | ;; everything to a list 32 | (let ((tree (rtl:mklist tree))) 33 | (funcall fn (first tree)) 34 | (dolist (child (rest tree)) 35 | (dfs-list fn child)))) 36 | 37 | (defun post-dfs (fn node) 38 | (dolist (child (children node)) 39 | (post-dfs fn child)) 40 | (funcall fn (key node))) 41 | 42 | (deftest dfs () 43 | (let ((tree (rtl:with ((f (make-tree-node :key "f")) 44 | (e (make-tree-node :key "e")) 45 | (d (make-tree-node :key "d")) 46 | (c (make-tree-node :key "c" :children (list f))) 47 | (b (make-tree-node :key "b" :children (list d e)))) 48 | (make-tree-node :key "a" 49 | :children (list b c))))) 50 | (should print-to *standard-output* " 51 | \"a\" 52 | \"b\" 53 | \"d\" 54 | \"e\" 55 | \"c\" 56 | \"f\" " (dfs-node 'print tree)) 57 | (should print-to *standard-output* " 58 | DEFUN 59 | FOO 60 | BAR 61 | \"Foo function.\" 62 | BAZ 63 | BAR " (dfs-list 'print '(defun foo (bar) 64 | "Foo function." 65 | (baz bar)))) 66 | (should print-to *standard-output* " 67 | \"d\" 68 | \"e\" 69 | \"b\" 70 | \"f\" 71 | \"c\" 72 | \"a\" " (post-dfs 'print tree)))) 73 | 74 | 75 | (defun bfs (fn nodes) 76 | (let ((next-level (list))) 77 | (dolist (node (rtl:mklist nodes)) 78 | (funcall fn (key node)) 79 | (dolist (child (children node)) 80 | (push child next-level))) 81 | (when next-level 82 | (bfs fn (reverse next-level))))) 83 | 84 | (deftest bfs () 85 | (let ((tree (rtl:with ((f (make-tree-node :key "f")) 86 | (e (make-tree-node :key "e")) 87 | (d (make-tree-node :key "d")) 88 | (c (make-tree-node :key "c" :children (list f))) 89 | (b (make-tree-node :key "b" :children (list d e)))) 90 | (make-tree-node :key "a" 91 | :children (list b c))))) 92 | (should print-to *standard-output* " 93 | \"a\" 94 | \"b\" 95 | \"c\" 96 | \"d\" 97 | \"e\" 98 | \"f\" " (bfs 'print tree)))) 99 | 100 | (defstruct (bst-node (:conc-name nil) 101 | (:print-object (lambda (node out) 102 | (format out "[~a-~@[~a~]-~@[~a~]]" 103 | (key node) 104 | (lt node) 105 | (rt node))))) 106 | key 107 | val ; we won't use this slot in the examples, 108 | ; but without it, in real-world use cases, 109 | ; such a tree doesn't have any value ;) 110 | lt ; left child 111 | rt) ; right child 112 | 113 | (defun tree-rotate (node parent grandparent) 114 | (cond 115 | ((eql node (lt parent)) (setf (lt parent) (rt node) 116 | (rt node) parent)) 117 | ((eql node (rt parent)) (setf (rt parent) (lt node) 118 | (lt node) parent)) 119 | (t (error "NODE (~A) is not the child of PARENT (~A)" 120 | node parent))) 121 | (cond 122 | ((null grandparent) (return-from tree-rotate node)) 123 | ((eql parent (lt grandparent)) (setf (lt grandparent) node)) 124 | ((eql parent (rt grandparent)) (setf (rt grandparent) node)) 125 | (t (error "PARENT (~A) is not the child of GRANDPARENT (~A)" 126 | parent grandparent)))) 127 | 128 | (defun splay (node &rest chain) 129 | (loop :for (parent grandparent) :on chain :do 130 | (tree-rotate node parent grandparent)) 131 | node) 132 | 133 | (defun node-chain (item root &optional chain) 134 | "Return as the values the node equal to ITEM or the closest one to it 135 | and the chain of nodes leading to it, in the splay tree based in ROOT." 136 | (if root 137 | (with-slots (key lt rt) root 138 | (let ((chain (cons root chain))) 139 | (cond ((= item key) (values root 140 | chain)) 141 | ((< item key) (node-chain item lt chain)) 142 | ((> item key) (node-chain item rt chain))))) 143 | (values nil 144 | chain))) 145 | 146 | (defun st-search (item root) 147 | (rtl:with ((node chain (node-chain item root))) 148 | (values (when node (apply 'splay chain)) 149 | chain))) 150 | 151 | (defun st-insert (item root) 152 | (assert root nil "Can't insert item into a null tree") 153 | (rtl:with ((node chain (st-search item root))) 154 | (unless node 155 | (let ((parent (first chain))) 156 | ;; here, we use the property of the := expression 157 | ;; that it returns the item being set 158 | (push (setf (rtl:? parent (if (> (key parent) item) 159 | 'lt 160 | 'rt)) 161 | (make-bst-node :key item)) 162 | chain))) 163 | (apply 'splay chain))) 164 | 165 | (defun idir (dir) 166 | (case dir 167 | (rtl:lt 'rt) 168 | (rtl:rt 'lt))) 169 | 170 | (defun closest-child (node) 171 | (dolist (dir '(lt rt)) 172 | (let ((parent nil) 173 | (current nil)) 174 | (do ((child (funcall dir node) (funcall (idir dir) child))) 175 | ((null child) (when current 176 | (return-from closest-child 177 | (values dir 178 | current 179 | parent)))) 180 | (setf parent current 181 | current child))))) 182 | 183 | (defun st-delete (item root) 184 | (rtl:with ((node chain (st-search item root)) 185 | (parent (second chain))) 186 | (if (null node) 187 | root ; ITEM was not found 188 | (rtl:with ((dir child child-parent (closest-child node)) 189 | (idir (idir dir))) 190 | (when parent 191 | (setf (rtl:? parent (if (eql (lt parent) node) 192 | 'lt 193 | 'rt)) 194 | child)) 195 | (when child 196 | (setf (rtl:? child idir) (rtl:? node idir)) 197 | (when child-parent 198 | (setf (rtl:? child-parent idir) (rtl:? child dir)))) 199 | (if parent 200 | (apply 'splay (rest chain)) 201 | child))))) 202 | 203 | (defun st-update (old new root) 204 | (st-insert new (st-delete old root))) 205 | 206 | (defun pprint-bst (node &optional (level 0) (skip-levels (make-hash-table))) 207 | (when (= 0 level) 208 | (format t "~A~%" (key node))) 209 | (let ((term (make-bst-node :key #\.))) 210 | (when (or (lt node) (rt node)) 211 | (rtl:doindex (i child (remove nil (list (or (lt node) term) 212 | (or (rt node) term)))) 213 | (let ((last-child-p (= 1 i))) 214 | (dotimes (j level) 215 | (format t "~C " (if (gethash j skip-levels) #\Space #\│))) 216 | (format t "~C── ~A~%" 217 | (if last-child-p #\└ #\├) 218 | (key child)) 219 | (:= (gethash level skip-levels) last-child-p) 220 | (unless (eql child term) 221 | (pprint-bst child 222 | (1+ level) 223 | skip-levels))))))) 224 | 225 | (deftest splay-tree () 226 | (let ((st (make-bst-node :key 5))) 227 | (should print-to *standard-output* " 228 | [5--] " 229 | (print st)) 230 | (setf st (st-insert 1 st)) 231 | (should print-to *standard-output* "1 232 | ├── . 233 | └── 5 234 | " (pprint-bst st)) 235 | (setf st (st-insert 10 st)) 236 | (should print-to *standard-output* "10 237 | ├── 1 238 | │ ├── . 239 | │ └── 5 240 | └── . 241 | " (pprint-bst st)) 242 | (setf st (st-insert 3 st)) 243 | (should print-to *standard-output* "3 244 | ├── 1 245 | └── 10 246 | ├── 5 247 | └── . 248 | " (pprint-bst st)) 249 | (setf st (st-insert 7 st)) 250 | (should print-to *standard-output* "7 251 | ├── 3 252 | │ ├── 1 253 | │ └── 5 254 | └── 10 255 | " (pprint-bst st)) 256 | (setf st (st-insert 8 st)) 257 | (should print-to *standard-output* "8 258 | ├── 7 259 | │ ├── 3 260 | │ │ ├── 1 261 | │ │ └── 5 262 | │ └── . 263 | └── 10 264 | "(pprint-bst st)) 265 | (setf st (st-insert 2 st)) 266 | (should print-to *standard-output* "2 267 | ├── 1 268 | └── 8 269 | ├── 7 270 | │ ├── 3 271 | │ │ ├── . 272 | │ │ └── 5 273 | │ └── . 274 | └── 10 275 | "(pprint-bst st)) 276 | (setf st (st-insert 4 st)) 277 | (should print-to *standard-output* "4 278 | ├── 2 279 | │ ├── 1 280 | │ └── 3 281 | └── 8 282 | ├── 7 283 | │ ├── 5 284 | │ └── . 285 | └── 10 286 | "(pprint-bst st)) 287 | (should print-to *standard-output* " 288 | [4-[2-[1--]-[3--]]-[8-[7-[5--]-]-[10--]]] " 289 | (print st)) 290 | (should print-to *standard-output* "5 291 | ├── 4 292 | │ ├── 2 293 | │ │ ├── 1 294 | │ │ └── 3 295 | │ └── . 296 | └── 8 297 | ├── 7 298 | └── 10 299 | " (pprint-bst (st-search 5 st))))) 300 | 301 | 302 | (defun hparent (i) 303 | "Calculate the index of the parent of the heap element with an index I." 304 | (floor (- i 1) 2)) 305 | 306 | (defun hrt (i) 307 | "Calculate the index of the right child of the heap element with an index I." 308 | (* (+ i 1) 2)) 309 | 310 | (defun hlt (i) 311 | "Calculate the index of the left child of the heap element with an index I." 312 | (- (hrt i) 1)) 313 | 314 | (defun heapify (vec) 315 | (let ((mid (floor (length vec) 2))) 316 | (dotimes (i mid) 317 | (heap-down vec (- mid i 1)))) 318 | vec) 319 | 320 | (defun heap-down (vec beg &optional (end (length vec))) 321 | (let ((l (hlt beg)) 322 | (r (hrt beg))) 323 | (when (< l end) 324 | (let ((child (if (or (>= r end) 325 | (> (aref vec l) 326 | (aref vec r))) 327 | l r))) 328 | (when (> (aref vec child) 329 | (aref vec beg)) 330 | (rotatef (aref vec beg) 331 | (aref vec child)) 332 | (heap-down vec child end))))) 333 | vec) 334 | 335 | (defun heap-up (vec i) 336 | (when (> (aref vec i) 337 | (aref vec (hparent i))) 338 | (rotatef (aref vec i) 339 | (aref vec (hparent i))) 340 | (heap-up vec (hparent i))) 341 | vec) 342 | 343 | (defun draw-heap (vec) 344 | (format t "~%") 345 | (rtl:with ((size (length vec)) 346 | (h (+ 1 (floor (log size 2))))) 347 | (dotimes (i h) 348 | (let ((spaces (make-list (- (expt 2 (- h i)) 1) 349 | :initial-element #\Space))) 350 | (dotimes (j (expt 2 i)) 351 | (let ((k (+ (expt 2 i) j -1))) 352 | (when (= k size) (return)) 353 | (format t "~{~C~}~2D~{~C~}" 354 | spaces (aref vec k) spaces))) 355 | (format t "~%")))) 356 | (format t "~%") 357 | vec) 358 | 359 | (defun check-heap (vec) 360 | (dotimes (i (floor (length vec) 2)) 361 | (when (= (hlt i) (length vec)) (return)) 362 | (assert (not (> (aref vec (hlt i)) (aref vec i))) 363 | () "Left child (~A) is > parent at position ~A (~A)." 364 | (aref vec (hlt i)) i (aref vec i)) 365 | (when (= (hrt i) (length vec)) (return)) 366 | (assert (not (> (aref vec (hrt i)) (aref vec i))) 367 | () "Right child (~A) is > than parent at position ~A (~A)." 368 | (aref vec (hrt i)) i (aref vec i))) 369 | vec) 370 | 371 | (defun heap-push (node vec) 372 | (vector-push-extend node vec) 373 | (heap-up vec (1- (length vec)))) 374 | 375 | (defun heap-pop (vec) 376 | (rotatef (aref vec 0) (aref vec (- (length vec) 1))) 377 | ;; PROG1 is used to return the result of the first form 378 | ;; instead of the last, like it happens with PROGN 379 | (prog1 (vector-pop vec) 380 | (heap-down vec 0))) 381 | 382 | (defun heapsort (vec) 383 | (heapify vec) 384 | (dotimes (i (length vec)) 385 | (let ((last (- (length vec) i 1))) 386 | (rotatef (aref vec 0) 387 | (aref vec last)) 388 | (heap-down vec 0 last))) 389 | vec) 390 | 391 | (deftest heap () 392 | (should signal simple-error 393 | (check-heap #(10 5 8 2 3 7 1 9))) 394 | (should be equalp #(22 13 10 9 3 7 8 5 7 1) 395 | (check-heap (heapify #(1 22 10 5 3 7 8 9 7 13)))) 396 | (should be equalp #(1 3 5 7 7 8 9 10 13 22) 397 | (heapsort #(1 22 10 5 3 7 8 9 7 13)))) 398 | 399 | (defstruct (tr-node (:conc-name nil)) 400 | val 401 | (children (list))) 402 | 403 | (defun tr-lookup (key root) 404 | (rtl:dovec (ch key 405 | ;; when iteration terminates normally 406 | ;; we have found the node we were looking for 407 | (val root)) 408 | (rtl:if-it (rtl:assoc1 ch (children root)) 409 | (setf root rtl:it) 410 | (return)))) 411 | 412 | (defun tr-add (key val root) 413 | (let ((i 0)) 414 | (rtl:dovec (ch key) 415 | (rtl:if-it (rtl:assoc1 ch (children root)) 416 | (setf root rtl:it 417 | i (1+ i)) 418 | (return))) 419 | (if (= i (length key)) 420 | ;; something has already being stored at key - 421 | ;; so we signal a continuable error that 422 | ;; gives the user two options: overwrite or abort 423 | (cerror "Assign a new value" 424 | "There was already a value at key: ~A" (val root)) 425 | (rtl:dovec (ch (rtl:slice key i)) 426 | (let ((child (make-tr-node))) 427 | (push (cons ch child) (children root)) 428 | (setf root child)))) 429 | (setf (val root) val))) 430 | 431 | (deftest trie () 432 | (let ((trie (make-tr-node))) 433 | (should be equalp trie 434 | (read-from-string "#S(TR-NODE :VAL NIL :CHILDREN NIL)")) 435 | (should be null (tr-lookup "word" trie)) 436 | (should be = 42 (tr-add "word" 42 trie)) 437 | (should be eql #\w (caar (children trie))) 438 | (should be eql #\o (caar (children (cdar (children trie))))) 439 | (should be eql #\r (caar (children (cdar (children 440 | (cdar (children trie))))))) 441 | (should be eql #\d (caar (children (cdar (children 442 | (cdar (children 443 | (cdar (children trie))))))))) 444 | (should be = 42 (tr-lookup "word" trie)) 445 | (should signal simple-error (tr-add "word" :foo trie)) 446 | (should be eql :baz (tr-add "we" :baz trie)) 447 | (should be = 2 (length (children (cdar (children trie))))))) 448 | 449 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage #:progalgs 4 | (:use :common-lisp #:should-test) 5 | (:export)) 6 | 7 | 8 | (in-package #:progalgs) 9 | 10 | (defun approx= (x y) 11 | (< (/ (abs (- x y)) 12 | (+ x y)) 13 | 0.1)) 14 | -------------------------------------------------------------------------------- /progalgs.asd: -------------------------------------------------------------------------------- 1 | (in-package #:asdf-user) 2 | 3 | (defsystem #:progalgs 4 | :version "1.1" 5 | :description "Code for the book 'Programming Algorithms in Lisp'" 6 | :author "Vsevolod Dyomkin " 7 | :maintainer "Vsevolod Dyomkin " 8 | :depends-on (#:rutils #:eager-future2 #:sha1 #:lparallel #:should-test) 9 | :serial t 10 | :components ((:file "package") 11 | (:file "ch1-complexity") 12 | (:file "ch4-data-structures") 13 | (:file "ch5-arrays") 14 | (:file "ch6-lists") 15 | (:file "ch7-kvs") 16 | (:file "ch8-hash-tables") 17 | (:file "ch9-trees") 18 | (:file "ch10-graphs") 19 | (:file "ch11-strings") 20 | (:file "ch12-dynamic-programming") 21 | (:file "ch13-approximation") 22 | (:file "ch14-compression") 23 | (:file "ch15-synchronization"))) 24 | --------------------------------------------------------------------------------