Plaster

(defpackage #:digraph (:use #:cl) (:export #:add-edge #:edges #:edge-list #:edgep #:graph-list #:make-directed-graph #:source #:target #:vertexp #:with-edge-iterator)) (in-package #:digraph) (defclass directed-graph () ((vertices :initarg :vertices) (edges :initarg :edges)) (:documentation "A directed graph with no multiple edges with the same source and target.")) (defun make-directed-graph () "An empty directed graph." (make-instance 'directed-graph :vertices (make-hash-table :test #'equal) :edges (make-hash-table :test #'equal))) (defmethod edges ((graph directed-graph) source target) "Edges in GRAPH from SOURCE to TARGET. Returns nil if none exist." (gethash (cons source target) (slot-value graph 'edges))) (defmethod add-vertex ((graph directed-graph) vertex) "Add VERTEX to GRAPH." (setf (gethash vertex (slot-value graph 'vertices)) t)) (defmethod vertexp ((graph directed-graph) vertex) "True if VERTEX is a vertex of GRAPH." (and (gethash vertex (slot-value graph 'vertices)) t)) (defun source (edge) "The source vertex of an EDGE." (car edge)) (defun target (edge) "The target vertex of an EDGE." (cdr edge)) (defmethod add-edge ((graph directed-graph) source target) "Add an edge from SOURCE to TARGET in GRAPH." (unless (vertexp graph source) (add-vertex graph source)) (unless (vertexp graph target) (add-vertex graph target)) (setf (gethash (cons source target) (slot-value graph 'edges)) t)) (defmethod edgep ((graph directed-graph) source target) "True if SOURCE -> TARGET is an edge of GRAPH." (and (gethash (cons source target) (slot-value graph 'edges)) t)) (defmacro with-vertex-iterator ((name graph) &body body) "NAME is an iterator for the vertices of GRAPH. When NAME is called within BODY, it returns three values: 1. A generalized boolean that is true if an entry is returned. 2. The vertex. 3. Ignore this value, it is always `t'. The BODY may be prepended with unevaluated declare expressions." `(with-hash-table-iterator (,name (slot-value ,graph 'edges)) ,@body)) (defmethod vertex-list ((graph directed-graph)) "The list of vertices of GRAPH." (loop for vertex being the hash-key of (slot-value graph 'vertices) collect vertex)) (defmacro with-edge-iterator ((name graph) &body body) "NAME is an iterator for the edges of GRAPH. When NAME is called within BODY, it returns three values: 1. A generalized boolean that is true if an entry is returned. 2. The edge. 3. Ignore this value, it is always `t'. The BODY may be prepended with unevaluated declare expressions." `(with-hash-table-iterator (,name (slot-value ,graph 'edges)) ,@body)) (defmethod edge-list ((graph directed-graph)) "The list of directed edges of GRAPH as `cons' cells." (loop for edge being the hash-key of (slot-value graph 'edges) collect edge)) (defmethod acyclicp ((graph directed-graph)) "True when GRAPH is acyclic. It's time complexity is ~ max(|V|, |E|). The algorithm is by Kahn, A.B.: Topological sorting of large networks. Commun. ACM 5, 558–562 (1962)." (and (topological-sorting graph) t)) (defmethod neighbors ((graph directed-graph) vertex) "The neighbors of VERTEX in GRAPH." ;; Slow and inefficient; it may be better to store another hashtable ;; with neighbors (uses more memory), or at least use the iterator. (loop for (source . target) in (edge-list graph) when (equal source vertex) collect target)) #| (defmethod topological-sorting ((graph directed-graph)) "Return a topological ordering of GRAPH or nil if none exist." ;; Slow because it uses lists. (let* ((vertices (vertices graph)) (n (length vertices)) (to-remove (make-array n :fill-pointer 0)) (rest (make-array n :fill-pointer 0)) (sorted (make-array n :fill-pointer 0))) (loop for i below n for vertex = (elt vertices i) for neighbors = (neighbors vertex) when (null neighbors) do (vector-push i to-remove) do (vector-push rest neighbors)) (loop while to-remove for i = 0 then (+1 i) for x = (vector-pop to-remove) do (vector-push x sorted) (loop for w in (neighbors vertex))))) |#