Initial commit

Author: Mark Powers

.gitattributes

@@ -0,0 +1,2 @@
+# Auto detect text files and perform LF normalization
+* text=auto

9781484264270.jpg

@@ -0,0 +1,14 @@
+# Contributing to Apress Source Code
+
+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.
+
+## How to Contribute
+
+1. Make sure you have a GitHub account.
+2. Fork the repository for the relevant book.
+3. Create a new branch on which to make your change, e.g. 
+`git checkout -b my_code_contribution`
+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.
+5. Submit a pull request.
+
+Thank you for your contribution!

Contributing.md

@@ -0,0 +1,27 @@
+Freeware License, some rights reserved
+
+Copyright (c) 2021 Vsevolod Domkin
+
+Permission is hereby granted, free of charge, to anyone obtaining a copy 
+of this software and associated documentation files (the "Software"), 
+to work with the Software within the limits of freeware distribution and fair use. 
+This includes the rights to use, copy, and modify the Software for personal use. 
+Users are also allowed and encouraged to submit corrections and modifications 
+to the Software for the benefit of other users.
+
+It is not allowed to reuse,  modify, or redistribute the Software for 
+commercial use in any way, or for a user’s educational materials such as books 
+or blog articles without prior permission from the copyright holder. 
+
+The above copyright notice and this permission notice need to be included 
+in all copies or substantial portions of the software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS OR APRESS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+
+

LICENSE.txt

@@ -0,0 +1,16 @@
+# Apress Source Code
+
+This repository accompanies [*Programming Algorithms in Lisp*](https://www.apress.com/9781484264270) by Vsevolod Domkin (Apress, 2021).
+
+[comment]: #cover
+![Cover image](9781484264270.jpg)
+
+Download the files as a zip using the green button, or clone the repository to your machine using Git.
+
+## Releases
+
+Release v1.0 corresponds to the code in the published book, without corrections or updates.
+
+## Contributions
+
+See the file Contributing.md for more information on how you can contribute to this repository.

README.md

@@ -0,0 +1,16 @@
+(in-package :progalgs)
+
+
+(defun mat-max (mat)
+  (let (max)
+    (dotimes (i (array-dimension mat 0))
+      (dotimes (j (array-dimension mat 1))
+        (when (or (null max)
+                  (> (aref mat i j) max))
+          (setf max (aref mat i j)))))
+    max))
+
+(deftest mat-max ()
+  (should be null (mat-max #2A()))
+  (shoould be = 42 (mat-max #2A((42))))
+  (should be = 6 (mat-max #2A((1 2 3) (4 5 6)))))

ch1-complexity.lisp

@@ -0,0 +1,306 @@
+(in-package :progalgs)
+
+
+(defstruct node
+  id edges)
+
+(defstruct edge
+  src dst label)
+
+(defstruct (graph (:conc-name nil) (:print-object pprint-graph))
+  (nodes (make-hash-table)))  ; mapping of node ids to nodes
+
+(defun pprint-graph (graph stream)
+  (let ((ids (sort (rtl:keys (nodes graph)) '<)))
+    (format stream "~{    ~A~}~%" ids)  ; here, Tab is used for space
+    (dolist (id1 ids)
+      (let ((node (rtl:? graph 'nodes id1)))
+        (format stream "~A" id1)
+        (dolist (id2 ids)
+          (format stream "    ~:[~;x~]"   ; here, Tab as well
+                  (find id2 (rtl:? node 'edges) :key 'edge-dst)))
+        (terpri stream)))))
+
+(defun init-graph (edges)
+  (rtl:with ((rez (make-graph))
+             (nodes (nodes rez)))
+            (loop :for (src dst) :in edges :do
+              (let ((src-node (rtl:getsethash src nodes (make-node :id src))))
+                (rtl:getset# dst nodes (make-node :id dst))
+                (push (make-edge :src src :dst dst)
+                      (rtl:? src-node 'edges))))
+            rez))
+
+;; TODO (deftest graph ()
+;; CL-USER> (init-graph '((7 8)
+;;                        (1 3)
+;;                        (1 2)
+;;                        (3 4)
+;;                        (3 5)
+;;                        (2 4)
+;;                        (2 5)
+;;                        (5 4)
+;;                        (5 6)
+;;                        (4 6)))
+
+(defun topo-sort (graph)
+  (let ((nodes (nodes graph))
+        (visited (make-hash-table))
+        (rez (rtl:vec)))
+    (rtl:dokv (id node nodes)
+              (unless (gethash id visited)
+                (visit node nodes visited rez)))
+    rez))
+
+(defun visit (node nodes visited rez)
+  (dolist (edge (node-edges node))
+    (rtl:with ((id (edge-dst edge))
+               (child (elt nodes id)))
+              (unless (find id rez)
+                (assert (not (gethash id visited)) nil
+                        "The graph isn't acyclic for vertex: ~A" id)
+                (setf (gethash id visited) t)
+                (visit child nodes visited rez))))
+  (vector-push-extend (node-id node) rez)
+  rez)
+
+(deftest topo-sort ()
+  (should be equalp #(8 7 6 4 5 2 3 1)
+          (topo-sort (init-graph '((7 8)
+                                   (1 3)
+                                   (1 2)
+                                   (3 4)
+                                   (3 5)
+                                   (2 4)
+                                   (2 5)
+                                   (5 4)
+                                   (5 6)
+                                   (4 6))))))
+
+(defvar *heap-indices*)
+
+(defun prim-mst (graph)
+  (let ((initial-weights (list))
+        (mst (list))
+        (total 0)
+        (*heap-indices* (make-hash-table))
+        weights
+        edges
+        cur)
+    (rtl:dokv (id node (nodes graph))
+              (if cur
+                  (push (rtl:pair id (or (elt edges id)
+                                         ;; a standard constant that is
+                                         ;; a good enough substitute for infinity
+                                         most-positive-fixnum))
+                        initial-weights)
+                  (setf cur id
+                        edges (node-edges node))))
+    (setf weights (heapify initial-weights))
+    (loop
+      (rtl:with (((id weight) (heap-pop weights)))
+                (unless id (return))
+                (when (elt edges id)
+                  ;; if not, we have moved to the new connected component
+                  ;; so there's no edge connecting it to the previous one
+                  (push (rtl:pair cur id) mst)
+                  (incf total weight))
+                (rtl:dokv (id w edges)
+                          (when (< w weight)
+                            (heap-decrease-key weights id w)))
+                (setf cur id
+                      edges (rtl:? graph 'nodes id 'edges))))
+    (values mst
+            total)))
+
+(defun heap-down (vec beg &optional (end (length vec)))
+  (let ((l (hlt beg))
+        (r (hrt beg)))
+    (when (< l end)
+      (let ((child (if (or (>= r end)
+                           (> (aref vec l)
+                              (aref vec r)))
+                       l r)))
+        (when (> (aref vec child)
+                 (aref vec beg))
+          (rotatef (gethash (aref vec beg) *heap-indices*)
+                   (gethash (aref vec child) *heap-indices*))
+          (rotatef (aref vec beg)
+                   (aref vec child))
+          (heap-down vec child end)))))
+  vec)
+
+(defun heap-decrease-key (vec key decrement)
+  (let ((i (pop (gethash key *heap-indices*))))
+    (unless i (error "No key ~A found in the heap: ~A" key vec))
+    (when (null (gethash key *heap-indices*))
+      (remhash key *heap-indices*))
+    (push i (gethash (- key decrement) *heap-indices*))
+    (decf (aref vec i) decrement)
+    (heap-up vec i)))
+
+(defun heap-up (vec i)
+  (rtl:with ((i-key (aref vec i))
+             (parent (hparent i))
+             (parent-key (aref vec parent)))
+    (when (> i-key parent-key)
+      (rtl:removef i (gethash i-key *heap-indices*))
+      (rtl:removef parent (gethash parent-key *heap-indices*))
+      (push i (gethash parent-key *heap-indices*))
+      (push parent (gethash i-key *heap-indices*))
+      (rotatef (aref vec i)
+               (aref vec parent))
+      (heap-up vec parent)))
+  vec)
+
+(defun heap-up-correct (vec i)
+  (let ((parent (hparent i)))
+    (when (> (aref vec i)
+             (aref vec parent))
+      (rotatef (gethash (aref vec i) *heap-indices*)
+               (gethash (aref vec parent) *heap-indices*)))
+    (rotatef (aref vec i)
+             (aref vec parent))
+    (heap-up vec parent))
+  vec)
+
+  (defun heap-decrease-key-correct (vec key decrement)
+  (let ((i (gethash key *heap-indices*)))
+    (unless i (error "No key ~A found in the heap: ~A" key vec))
+    (remhash key *heap-indices*)
+    (setf (gethash (- key decrement) *heap-indices*) i)
+    (decf (aref vec i) decrement)
+    (heap-up vec i)))
+
+(defstruct heap-item
+  key val)
+
+(defun heap-up (vec i)
+  (rtl:with ((i-key (heap-item-key (aref vec i)))
+             (parent (hparent i))
+             (parent-key (heap-item-key (aref vec parent)))) 
+    (when (> i-key parent-kea)
+      (rtl:removef i (gethash i-key *heap-indices*))
+      (rtl:removef parent (gethash parent-key *heap-indices*))
+      (push i (gethash parent-key *heap-indices*))
+      (push parent (gethash i-key *heap-indices*))
+      (rotatef (aref vec i)
+               (aref vec parent))
+      (heap-up vec parent)))
+  vec)
+
+;; TODO (deftest heap2 ()
+
+(defstruct (spf-node (:include node))
+  (weight most-positive-fixnum)
+  (path (list)))
+
+(defun spf (graph src dst)
+  (rtl:with ((nodes (graph-nodes graph))
+             (spf (list))
+             ;; the following code should express initialize the heap
+             ;; with a single node of weight 0 and all other nodes
+             ;; of weight MOST-POSITIVE-FIXNUM
+             ;; (instead of running a O(n*log n) HEAPIFY)
+             (weights (init-weights-heap nodes src)))
+    (loop
+      (rtl:with (((id weight) (heap-pop weights)))
+        (cond ((eql id dst)
+               (let ((dst (elt nodes dst)))
+                 ;; we return two values: the path and its length
+                 (return (values (cons dst (spf-node-path dst))
+                                 (spf-node-weight dst)))))
+              ((= most-positive-fixnum weight)
+               (return)))       ; no path exists
+        (dolist (edge (rtl:? nodes id 'edges))
+          (rtl:with ((cur (edge-dst edge))
+                     (node (elt nodes cur))
+                     (w (+ weight (spf-node-weight cur))))
+            (when (< w (spf-node-weight node))
+              (heap-decrease-key weights cur w) 
+              (setf (spf-node-weight node) w
+                    (spf-node-path node) (cons (rtl:? nodes id)
+                                               (rtl:? nodes id 'path))))))))))
+
+;; TODO (deftest spf ()
+
+(defstruct mf-edge
+  beg end capacity)
+
+(defun max-flow (g)
+  (let ((rg (copy-array g))             ; residual graph
+        (rez 0))
+    (loop :for path := (aug-path rg) :while path :do
+      (let ((flow most-positive-fixnum))
+        ;; the flow along the path is the residual capacity of the thinnest edge
+        (dolist (edge path)
+          (let ((cap (mf-edge-capacity edge)))
+            (when (< (abs cap) flow)
+              (setf flow (abs cap)))))
+        (dolist (edge path)
+          (with-slots (beg end) edge
+            (decf (aref rg beg end) flow)
+            (incf (aref rg end beg) flow)))
+        (incf rez flow)))
+    rez))
+
+(defun aug-path (g)
+  (rtl:with ((sink (1- (array-dimension g 0)))
+             (visited (make-array (1+ sink) :initial-element nil)))
+            (labels ((dfs (g i)
+                       (if (zerop (aref g i sink))
+                           (dotimes (j sink)
+                             (unless (or (zerop (aref g i j))
+                                         (aref visited j))
+                               (rtl:when-it (dfs g j)
+                                            (setf (aref visited j) t)
+                                            (return (cons (make-mf-edge
+                                                           :beg i :end j
+                                                           :capacity (aref g i j))
+                                                          rtl:it)))))
+                           (list (make-mf-edge
+                                  :beg i :end sink
+                                  :capacity (aref g i sink))))))
+              (dfs g 0))))
+
+(deftest max-flow ()
+  (should be = 7 (max-flow #2A((0 4 4 0 0 0)
+                               (0 0 0 4 2 0)
+                               (0 0 0 1 2 0)
+                               (0 0 0 0 0 3)
+                               (0 0 0 0 0 5)))))
+
+;; code prototypes
+
+(defun pagerank (g &key (d 0.85) (repeat 100))
+  (rtl:with ((n (length (nodes g)))
+             (pr (make-arrray n :initial-element (/ 1 n))))
+    (loop :repeat repeat :do
+      (let ((pr2 (map 'vector (lambda (x) (- 1 (/ d n)))
+                      pr)))
+        (rtl:dokv (i node nodes)
+          (let ((p (aref pr i))
+                (m (length (node-children node))))
+            (rtl:dokv (j child (node-children node)))
+            (incf (aref pr2 j) (* d (/ p m)))))
+        (setf pr pr2)))
+    pr))
+
+(defun pr1 (node n p &key (d 0.85))
+  (let ((pr (make-arrray n :initial-element 0))
+        (m (hash-table-count (node-children node))))
+    (rtl:dokv (j child (node-children node))
+      (setf (aref pr j) (* d (/ p m))))
+    pr))
+
+(defun pagerank-mr (g &key (d 0.85) (repeat 100))
+  (rtl:with ((n (length (nodes g)))
+             (pr (make-arrray n :initial-element (/ 1 n))))
+    (loop :repeat repeat :do
+      (setf pr (map 'vector (lambda (x)
+                              (- 1 (/ d n)))
+                    (reduce 'vec+ (map 'vector (lambda (node p)
+                                                 (pr1 node n p :d d))
+                                       (nodes g)
+                                       pr)))))
+    pr))