├── .gitattributes ├── 9781484264270.jpg ├── package.lisp ├── errata.md ├── ch1-complexity.lisp ├── README.md ├── Contributing.md ├── progalgs.asd ├── LICENSE.txt ├── ch4-data-structures.lisp ├── ch7-kvs.lisp ├── ch15-synchronization.lisp ├── ch6-lists.lisp ├── ch5-arrays.lisp ├── ch13-approximation.lisp ├── ch8-hash-tables.lisp ├── ch12-dynamic-programming.lisp ├── ch14-compression.lisp ├── ch11-strings.lisp ├── ch10-graphs.lisp └── ch9-trees.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /9781484264270.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/programming-algorithms-lisp/HEAD/9781484264270.jpg -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /errata.md: -------------------------------------------------------------------------------- 1 | # Errata for *Programming Algorithms in Lisp* 2 | 3 | On **page xx** [Summary of error]: 4 | 5 | Details of error here. Highlight key pieces in **bold**. 6 | 7 | *** 8 | 9 | On **page xx** [Summary of error]: 10 | 11 | Details of error here. Highlight key pieces in **bold**. 12 | 13 | *** -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Apress Source Code 2 | 3 | This repository accompanies [*Programming Algorithms in Lisp*](https://www.apress.com/9781484264270) by Vsevolod Domkin (Apress, 2021). 4 | 5 | [comment]: #cover 6 | ![Cover image](9781484264270.jpg) 7 | 8 | Download the files as a zip using the green button, or clone the repository to your machine using Git. 9 | 10 | ## Releases 11 | 12 | Release v1.0 corresponds to the code in the published book, without corrections or updates. 13 | 14 | ## Contributions 15 | 16 | See the file Contributing.md for more information on how you can contribute to this repository. -------------------------------------------------------------------------------- /Contributing.md: -------------------------------------------------------------------------------- 1 | # Contributing to Apress Source Code 2 | 3 | Copyright for Apress source code belongs to the author(s). However, under fair use you are encouraged to fork and contribute minor corrections and updates for the benefit of the author(s) and other readers. 4 | 5 | ## How to Contribute 6 | 7 | 1. Make sure you have a GitHub account. 8 | 2. Fork the repository for the relevant book. 9 | 3. Create a new branch on which to make your change, e.g. 10 | `git checkout -b my_code_contribution` 11 | 4. Commit your change. Include a commit message describing the correction. Please note that if your commit message is not clear, the correction will not be accepted. 12 | 5. Submit a pull request. 13 | 14 | Thank you for your contribution! -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Freeware License, some rights reserved 2 | 3 | Copyright (c) 2021 Vsevolod Domkin 4 | 5 | Permission is hereby granted, free of charge, to anyone obtaining a copy 6 | of this software and associated documentation files (the "Software"), 7 | to work with the Software within the limits of freeware distribution and fair use. 8 | This includes the rights to use, copy, and modify the Software for personal use. 9 | Users are also allowed and encouraged to submit corrections and modifications 10 | to the Software for the benefit of other users. 11 | 12 | It is not allowed to reuse, modify, or redistribute the Software for 13 | commercial use in any way, or for a user’s educational materials such as books 14 | or blog articles without prior permission from the copyright holder. 15 | 16 | The above copyright notice and this permission notice need to be included 17 | in all copies or substantial portions of the software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS OR APRESS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | SOFTWARE. 26 | 27 | 28 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | --------------------------------------------------------------------------------