├── .gitignore ├── README.md ├── cl-directed-graph.asd ├── package.lisp ├── LICENSE └── src.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.lisp~ 2 | *.asd~ -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | CL-DIRECTED-GRAPH 2 | ================= 3 | 4 | CL-DIRECTED-GRAPH is a simple implementation of the directed graph data structure in Common Lisp. -------------------------------------------------------------------------------- /cl-directed-graph.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:cl-directed-graph 2 | :name "cl-directed-graph" 3 | :version "20161106" 4 | :author "Hunter Chandler " 5 | :license "MIT" 6 | :description "Directed graph data structure" 7 | :serial t 8 | :components ((:file "package") 9 | (:file "src")) 10 | :depends-on (serapeum)) 11 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | (defpackage #:cl-directed-graph 4 | (:use #:cl) 5 | (:import-from #:serapeum #:lret) 6 | (:export #:make-graph 7 | #:adjacent 8 | #:neighbors 9 | #:add-vertex 10 | #:remove-vertex 11 | #:add-edge 12 | #:remove-edge 13 | #:graph 14 | ;; traversal functions 15 | #:map-vertices 16 | #:map-edges 17 | #:map-depth-first 18 | #:map-breadth-first)) 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Hunter Chandler 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /src.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-directed-graph) 2 | 3 | (defclass graph () 4 | ((vertices :accessor vertices :initarg :vertices) 5 | (edges :accessor edges :initarg :edges))) 6 | 7 | (defmethod print-object ((object graph) stream) 8 | (print-unreadable-object (object stream) 9 | (format stream "DIRECTED GRAPH ~:S" (vertices object)))) 10 | 11 | (defun adjacent (graph x y) 12 | "Tests whether GRAPH contains an edge from X to Y." 13 | (if (member y (gethash x (edges graph)) :test #'equal) 14 | t nil)) 15 | 16 | (defun neighbors (graph vertex) 17 | "Returns a list of all vertices in GRAPH where there is an edge from VERTEX." 18 | (values (gethash vertex (edges graph)))) 19 | 20 | (defun add-vertex (graph vertex) 21 | "Adds VERTEX to GRAPH." 22 | (pushnew vertex (vertices graph) :test #'equal) 23 | graph) 24 | 25 | (defun remove-vertex (graph vertex) 26 | "Removes VERTEX from GRAPH." 27 | (setf (vertices graph) (remove vertex (vertices graph) :test #'equal)) 28 | (let ((edges (edges graph))) 29 | (maphash (lambda (k v) 30 | (cond ((equal k vertex) (remhash k (edges graph))) 31 | ((member vertex v :test #'equal) 32 | (setf (gethash k edges) (remove vertex v :test #'equal))) 33 | (t))) 34 | edges)) 35 | graph) 36 | 37 | (defun add-edge (graph x y) 38 | "Adds an edge from X to Y in GRAPH." 39 | (pushnew y (gethash x (edges graph)) :test #'equal) 40 | graph) 41 | 42 | (defun remove-edge (graph x y) 43 | "Removes the edge from X to Y in GRAPH." 44 | (setf (gethash x (edges graph)) 45 | (remove y (gethash x (edges graph)) :test #'equal)) 46 | graph) 47 | #| TODO 48 | (macrolet ((get-vertex-value () 49 | '(value-of-vertex (assoc-value vertex (vertices graph))))) 50 | 51 | (defun vertex-value (graph vertex) 52 | "Returns the value associated with VERTEX in GRAPH." 53 | (get-vertex-value)) 54 | 55 | (defun (setf vertex-value) (graph vertex value) 56 | (setf (get-vertex-value) value))) 57 | 58 | (macrolet ((get-edge-value () 59 | '(value-of-edge (assoc-value (edges graph) (cons x y) 60 | :test #'equal)))) 61 | 62 | (defun edge-value (graph x y) 63 | "Returns the value associated with the edge from X to Y in GRAPH." 64 | (get-edge-value)) 65 | 66 | (defun (setf edge-value) (graph x y value) 67 | (setf (get-edge-value) value))) 68 | |# 69 | (defun make-graph (&key vertices edges) 70 | "Creates a new directed graph object. VERTICES should be a list of vertices 71 | unique under EQUAL. EDGES should be a hash table whose keys are objects in 72 | VERTICES and whose values are lists of vertices." 73 | (when edges 74 | (maphash (lambda (k v) 75 | (assert (and (member k vertices :test #'equal) 76 | (mapc (lambda (x) (member x vertices :test #'equal)) 77 | v)))) 78 | edges)) 79 | (make-instance 'graph :vertices vertices 80 | :edges (if edges edges (make-hash-table :test #'equal)))) 81 | 82 | ;;; TRAVERSAL 83 | 84 | (defun map-vertices (function graph) 85 | "Returns a list of the results of calling FUNCTION on each vertex of GRAPH." 86 | (mapcar function (vertices graph))) 87 | 88 | (defun map-edges (function graph) 89 | "Returns a list of the results of calling FUNCTION on each edge of GRAPH. 90 | FUNCTION should take 2 arguments: the starting and ending vertices of an edge." 91 | (let ((result (list))) 92 | (maphash (lambda (k v) 93 | (mapc (lambda (x) 94 | (push (funcall function k x) result)) 95 | v)) 96 | (edges graph)) 97 | result)) 98 | ;;; BUG: ordered mapping causes an infinite loop on cycles 99 | (defmacro traverse (&body body) 100 | `(progn (cond ((member vertex seen :test #'equal)) 101 | (t (push vertex seen) 102 | (push (funcall function vertex) result))) 103 | (dolist (x (neighbors graph vertex)) 104 | ,@body))) 105 | 106 | (defun map-depth-first (function graph) 107 | "Returns a list of the results of calling FUNCTION on each vertex of GRAPH 108 | in depth-first traversal order." 109 | (lret ((seen (list)) 110 | (result (list))) 111 | (labels ((trav (vertex) 112 | (traverse (trav x)))) 113 | (map-vertices #'trav graph)))) 114 | 115 | (defun map-breadth-first (function graph) 116 | "Returns a list of the results of calling FUNCTION on each vertex of GRAPH 117 | in breadth-first traversal order." 118 | (lret ((seen (list)) 119 | (result (list))) 120 | (flet ((trav (vertex) 121 | (traverse (push x seen) 122 | (push (funcall function x) result)))) 123 | (map-vertices #'trav graph)))) 124 | --------------------------------------------------------------------------------