Plaster

;;;; Implementation taken from <https://algs4.cs.princeton.edu/41graph/> (defpackage #:org.euouae.package-generator.graph.undirected (:use #:cl) (:local-nicknames (#:interface #:org.euouae.package-generator.graph.interface))) (in-package #:org.euouae.package-generator.graph.undirected) (defclass undirected-graph (interface:graph) ((adjacency-list :initform nil :documentation "The adjacency list representing the graph. A list of lists. An example of a graph with four vertices and four edges: ((a b c d) ; represents the edges a--b, a--c, a--d (b a c) ; represents the edges b--a, b--c (c a b) ; represents the edges c--a, c--b (d a)) ; represents the edge d--a"))) (import 'undirected-graph :interface) (export 'undirected-graph :interface) (defmethod vertices ((graph undirected-graph)) (mapcar #'first (slot-value graph 'adjacency-list))) (defun equal-edge (edge1 edge2) "True if EDGE1 equals EDGE2." (or (equal edge1 edge2) (equal edge1 (cons (cdr edge2) (car edge2))))) (defun to-cons-list (graph vertex) "Transform the adjacency row into a list of (source . target) cells." (let ((row (adjacency-row graph vertex))) (mapcar (lambda (x) (cons (first row) x)) (rest row)))) (defmethod edges ((graph undirected-graph)) (delete-duplicates (loop for (source . targets) in (slot-value graph 'adjacency-list) append (to-cons-list graph source)) :test #'equal-edge)) (defmethod adjacency-row ((graph undirected-graph) vertex) "Return the list corresponding to VERTEX from the adjacency list of GRAPH." (find vertex (slot-value graph 'adjacency-list) :key #'first)) (defmethod neighbors ((graph undirected-graph) vertex) (let ((row (adjacency-row graph vertex))) (if row (rest row)))) (defmethod vertexp ((graph undirected-graph) vertex) (and (adjacency-row graph vertex) t)) (defmethod add-vertex ((graph undirected-graph) vertex) (unless (vertexp graph vertex) (let ((row (list vertex))) (push row (slot-value graph 'adjacency-list)) row))) (defun add-to-row (x row) "Add a vertex to an adjacency row. If the row is (a b c) then (add-to-row x row) results in (a x b c)." (setf (cdr row) (cons x (cdr row)))) (defmethod add-edge ((graph undirected-graph) u v) (let ((u-row (adjacency-row graph u)) (v-row (adjacency-row graph v))) (unless u-row (setf u-row (add-vertex graph u))) (unless v-row (setf v-row (add-vertex graph v))) (add-to-row v u-row) (add-to-row u v-row))) (defmethod edgep ((graph undirected-graph) u v) (find v (adjacency-row graph u))) (defmethod depth-first-search ((graph undirected-graph) function vertex) (when (vertexp graph vertex) (funcall function nil vertex) (let ((pending (to-cons-list graph vertex)) (visited (list vertex))) (flet ((seen (x) "X has been visited already." (find x visited))) (loop while pending for (source . target) = (pop pending) unless (seen target) do (funcall function source target) (push target visited) (setf pending (append (remove-if #'seen (to-cons-list graph target) :key #'cdr) pending))))))) (defmethod breadth-first-search ((graph undirected-graph) function vertex) (when (vertexp graph vertex) (funcall function nil vertex) (let ((pending (to-cons-list graph vertex)) (visited (list vertex))) (flet ((seen (x) "X has been visited already." (find x visited))) (loop while pending for next = (loop for (source . target) in pending append (unless (seen target) (funcall function source target) (push target visited) (to-cons-list graph target))) do (setf pending (remove-if #'seen next :key #'cdr))))))) (defun extract-path (edges) "Find a path from a list EDGES with noise. Basically, in a list of edges of the form ((x1 . x2) (x3 . x4) ...) start with (x1 . x2) and then find the next cell whose `cdr' is x1, and collect it. Continue in this manner, ignoring all other cells. This function is useful for forming a path from a breadth first search. This function can be deleted and instead the lambda passed to breadth first search can keep track of a tree of visited vertices." (let ((seen '())) (remove-if-not (lambda (x) (if seen (and (equal seen (cdr x)) (setf seen (car x))) (setf seen (car x)))) edges))) (defmethod path ((graph undirected-graph) u v) (let* ((path '()) (result (block done (breadth-first-search graph (lambda (source target) (when source (push (cons source target) path) (when (equal target v) (return-from done (reverse (extract-path path)))))) u)))) (when result ;; Switch from list of edges to list of vertices. (cons (caar result) (mapcar #'cdr result))))) (defmethod components ((graph undirected-graph)) (do* ((remaining (vertices graph) (set-difference remaining last-seen)) (components '() (cons last-seen components)) (last-seen '() '())) ((null remaining) components) ;; A component is created by recording all the targets in a ;; depth-first search. (depth-first-search graph (lambda (_ x) (declare (ignore _)) (push x last-seen)) ;; Start the component discovery at any vertex from the remaining. (first remaining)))) (defmethod cycle ((graph undirected-graph)) (block done ;; Search every component for a cycle. start at a random vertex. (loop for (vertex . _) in (components graph) for path = '() ; visited vertices so far do (depth-first-search graph (lambda (source target) (setf path (member source path)) ; Backtrack path if necessary. (push target path) (let ((cycle (find-if (lambda (x) (find x (neighbors graph target))) ;; We don't want to search in the last two ;; recorded vertices in the path since those ;; are SOURCE and TARGET. (cddr path)))) (if cycle (return-from done path)))) vertex)))) (defmethod span ((graph undirected-graph) vertices) (let ((spanned-graph (make-instance 'undirected-graph))) (setf (slot-value spanned-graph 'adjacency-list) (remove-if-not (lambda (row) (find (first row) vertices)) (slot-value graph 'adjacency-list))) spanned-graph))