|#
-(in-package metabang.graph)
+(in-package #:metabang.graph)
;;; ---------------------------------------------------------------------------
;;; classes
;;; ---------------------------------------------------------------------------
-#+COPYING
-(defcopy-methods basic-vertex :copy-all t)
-
-;;; ---------------------------------------------------------------------------
-
(defmethod initialize-instance :after ((object basic-vertex) &key graph vertex-id)
(when (and graph (not vertex-id))
(setf (slot-value object 'vertex-id)
(color nil ia "The `color` is used by some algorithms for bookkeeping. [?? Should probably be in a mixin]"))
(:export-p t)
(:export-slots edge-id element tag color)
- #+COPYING :copy-slots
(:make-load-form-p t)
(:documentation "This is the root class for all edges in CL-Graph."))
;;; ---------------------------------------------------------------------------
-(defclass* directed-edge-mixin (#+COPYING copyable-mixin) ()
+(defclass* directed-edge-mixin () ()
(:export-p t)
(:documentation "This mixin class is used to indicate that an edge is directed."))
;;; ---------------------------------------------------------------------------
-(defclass* weighted-edge-mixin (#+COPYING copyable-mixin)
+(defclass* weighted-edge-mixin ()
((weight 1d0 ia "The value of the weight of this edge. Defaults to 1.0d0"))
- #+COPYING :copy-slots
:export-slots
(:export-p t)
(:documentation "This mixin class adds a `weight` slot to an edge."))
;;; ---------------------------------------------------------------------------
-(defclass* basic-graph (#+COPYING copyable-mixin)
+(defclass* basic-graph ()
((graph-vertexes :unbound ir)
(graph-edges :unbound ir)
(largest-vertex-id 0 r)
;;; internals
;;; ---------------------------------------------------------------------------
-(defmethod add-vertex ((graph basic-graph) (value basic-vertex) &key if-duplicate-do)
+(defmethod add-vertex
+ ((graph basic-graph) (value basic-vertex) &key if-duplicate-do)
(declare (ignore if-duplicate-do))
(values value))
&allow-other-keys)
(remf args :edge-class)
(remf args :edge-type)
-
- #| I removed 'em, gwk
-
- ;;; I added these - jjm
- (remf args :vertex-test)
- (remf args :vertex-key)
- (remf args :edge-key)
- (remf args :edge-test)
- (remf args :force-new?)
-
-|#
-
(assert (or (null edge-type)
(eq edge-type :directed)
(eq edge-type :undirected)) nil
:graph graph
:vertex-1 vertex-1 :vertex-2 vertex-2 args))
-
;;; ---------------------------------------------------------------------------
(defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys)
(apply #'make-instance graph-type args))
;;; ---------------------------------------------------------------------------
-
-(defmethod make-graph ((classes list) &rest args)
- (let ((name (find-or-create-class 'basic-graph classes)))
- (apply #'make-instance name args)))
-
-;;; ---------------------------------------------------------------------------
;;; generic implementation
;;; ---------------------------------------------------------------------------
;;; ---------------------------------------------------------------------------
-(defmethod find-edge-between-vertexes ((graph basic-graph) (value-1 t) (value-2 t)
- &key (error-if-not-found? t))
- (let ((v1 (find-vertex graph value-1 error-if-not-found?))
- (v2 (find-vertex graph value-2 error-if-not-found?)))
- (aif (and v1 v2 (find-edge-between-vertexes graph v1 v2))
- it
- (when error-if-not-found?
- (error 'graph-edge-not-found-error :vertex-1 v1 :vertex-2 v2)))))
+(defmethod find-edge-between-vertexes
+ ((graph basic-graph) (value-1 t) (value-2 t)
+ &key (error-if-not-found? t))
+ (let* ((v1 (find-vertex graph value-1 error-if-not-found?))
+ (v2 (find-vertex graph value-2 error-if-not-found?)))
+ (or (and v1 v2 (find-edge-between-vertexes graph v1 v2))
+ (when error-if-not-found?
+ (error 'graph-edge-not-found-error
+ :graph graph :vertex-1 v1 :vertex-2 v2)))))
;;; ---------------------------------------------------------------------------
(delete-item (graph-edges graph) edge)
edge)
+
+(defmethod delete-all-edges :after ((graph basic-graph))
+ (empty! (graph-edges graph))
+ graph)
+
;;; ---------------------------------------------------------------------------
(defmethod delete-vertex ((graph basic-graph) value-or-vertex)
(defmethod find-vertex ((graph basic-graph) (value t)
&optional (error-if-not-found? t))
- (aif (find-item (graph-vertexes graph) (funcall (vertex-key graph) value))
- it
- (when error-if-not-found?
- (error 'graph-vertex-not-found-error :vertex value :graph graph))))
+ (or (find-item (graph-vertexes graph) (funcall (vertex-key graph) value))
+ (when error-if-not-found?
+ (error 'graph-vertex-not-found-error :vertex value :graph graph))))
-;;; ---------------------------------------------------------------------------
+(defmethod find-vertex ((graph basic-graph) (vertex basic-vertex)
+ &optional (error-if-not-found? t))
+ (cond ((eq graph (graph vertex))
+ vertex)
+ (t
+ (when error-if-not-found?
+ (error 'graph-vertex-not-found-error
+ :vertex vertex :graph graph)))))
(defmethod find-vertex ((edge basic-edge) (value t)
&optional (error-if-not-found? t))
(when error-if-not-found?
(error 'graph-vertex-not-found-in-edge-error :vertex value :edge edge)))
-;;; ---------------------------------------------------------------------------
-
-(defmethod search-for-vertex ((graph basic-graph) (value t)
- &key (key (vertex-key graph)) (test 'equal)
- (error-if-not-found? t))
- (aif (search-for-node graph value :test test :key key)
- it
- (when error-if-not-found?
- (error "~S not found in ~A using key ~S and test ~S" value graph key
- test))))
-
-;;; ---------------------------------------------------------------------------
(defmethod search-for-vertex ((graph basic-graph) (vertex basic-vertex)
&key (key (vertex-key graph)) (test 'equal)
(error-if-not-found? t))
- (aif (search-for-node (graph-vertexes graph) vertex :test test :key key)
- it
- (when error-if-not-found?
- (error "~A not found in ~A" vertex graph))))
+ (or (search-for-node (graph-vertexes graph) vertex :test test :key key)
+ (when error-if-not-found?
+ (error "~A not found in ~A" vertex graph))))
-;;; ---------------------------------------------------------------------------
-;; TODO !!! dispatch is the same as the second method above
(defmethod search-for-vertex ((graph basic-graph) (vertex t)
&key (key (vertex-key graph)) (test 'equal)
(error-if-not-found? t))
- (aif (search-for-element (graph-vertexes graph) vertex :test test :key key)
- it
- (when error-if-not-found?
- (error "~A not found in ~A" vertex graph))))
-
-;;; ---------------------------------------------------------------------------
+ (or (search-for-element (graph-vertexes graph) vertex :test test :key key)
+ (when error-if-not-found?
+ (error "~A not found in ~A" vertex graph))))
(defmethod iterate-elements ((graph basic-graph) fn)
(iterate-elements (graph-vertexes graph)
;;; ---------------------------------------------------------------------------
-#+COPYING
-(defmethod generate-directed-free-tree ((graph basic-graph) (root basic-vertex))
- (let ((new-graph (copy-top-level graph)))
- (empty! new-graph)
- (nilf (contains-undirected-edge-p new-graph))
- (neighbors-to-children new-graph root)
- (values new-graph)))
-
-;;; ---------------------------------------------------------------------------
-
(defmethod generate-directed-free-tree ((graph basic-graph) root)
(generate-directed-free-tree graph (find-vertex graph root)))
(defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :depth)) marker fn)
(when (eq (tag thing) marker)
- (nilf (tag thing))
+ (setf (tag thing) nil)
(iterate-children
thing
(lambda (vertex)
(defmethod traverse-elements-helper ((thing basic-vertex) (style (eql :breadth)) marker fn)
(when (eq (tag thing) marker)
- (nilf (tag thing))
+ (setf (tag thing) nil)
(funcall fn thing))
(iterate-neighbors
thing
(lambda (vertex)
(when (eq (tag vertex) marker)
- (nilf (tag vertex))
+ (setf (tag vertex) nil)
(traverse-elements-helper vertex style marker fn)))))
;;; ---------------------------------------------------------------------------
+;; also in metatilites
+(defun graph-search-for-cl-graph (states goal-p successors combiner
+ &key (state= #'eql) old-states
+ (new-state-fn #'new-states))
+ "Find a state that satisfies goal-p. Start with states,
+ and search according to successors and combiner.
+ Don't try the same state twice."
+ (cond ((null states) nil)
+ ((funcall goal-p (first states)) (first states))
+ (t (graph-search-for-cl-graph
+ (funcall
+ combiner
+ (funcall new-state-fn states successors state= old-states)
+ (rest states))
+ goal-p successors combiner
+ :state= state=
+ :old-states (adjoin (first states) old-states
+ :test state=)
+ :new-state-fn new-state-fn))))
+
(defmethod in-cycle-p ((graph basic-graph) (start-vertex basic-vertex))
(let ((first-time? t))
(not (null
- (graph-search
+ (graph-search-for-cl-graph
(list start-vertex)
(lambda (v)
(if first-time?
- (nilf first-time?)
+ (setf first-time? nil)
(eq (find-vertex graph v) start-vertex)))
(lambda (v)
(child-vertexes v))
&optional (marked (make-container 'simple-associative-container))
(previous nil))
(block do-it
- (tf (item-at-1 marked current))
+ (setf (item-at-1 marked current) t)
(iterate-children current
(lambda (child)
(cond
(collect-transitive-closure vertex-list vertex-list depth)))
;;; ---------------------------------------------------------------------------
-;;; make-filtered-graph
-;;; ---------------------------------------------------------------------------
-
-(defmethod complete-links ((new-graph basic-graph)
- (old-graph basic-graph))
- ;; Copy links from old-graph ONLY for nodes already in new-graph
- (iterate-vertexes
- new-graph
- (lambda (vertex)
- (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
- (iterate-edges
- old-graph-vertex
- (lambda (old-edge)
- (let* ((old-other-vertex (other-vertex old-edge old-graph-vertex))
- (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil)))
- (when (and new-other-vertex
- (< (vertex-id vertex) (vertex-id new-other-vertex)))
- (let* ((new-edge (copy-template old-edge)))
- (if (eq old-graph-vertex (vertex-1 old-edge))
- (setf (slot-value new-edge 'vertex-1) vertex
- (slot-value new-edge 'vertex-2) new-other-vertex)
- (setf (slot-value new-edge 'vertex-2) vertex
- (slot-value new-edge 'vertex-1) new-other-vertex))
- (add-edge new-graph new-edge))))))))))
-
-#+Old
-(defmethod complete-links ((new-graph basic-graph)
- (old-graph basic-graph))
- ;; Copy links from old-graph ONLY for nodes already in new-graph
- (iterate-vertexes
- new-graph
- (lambda (vertex)
- (let ((old-graph-vertex (find-vertex old-graph (value vertex))))
- (iterate-edges
- old-graph-vertex
- (lambda (edge)
- (let* ((old-other-vertex (other-vertex edge old-graph-vertex))
- (new-other-vertex (find-vertex new-graph (value old-other-vertex) nil))
- (edge-type (if (directed-edge-p edge)
- :directed :undirected)))
- (when new-other-vertex
- (if (and (directed-edge-p edge)
- (eq old-graph-vertex (target-vertex edge)))
- (add-edge-between-vertexes new-graph new-other-vertex vertex
- :value (value edge)
- :edge-type edge-type)
- (add-edge-between-vertexes new-graph vertex new-other-vertex
- :value (value edge)
- :edge-type edge-type))))))))))
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod make-filtered-graph ((old-graph basic-graph)
- test-fn
- &optional
- (graph-completion-method nil)
- (depth nil))
- (let ((new-graph
- (copy-template old-graph)))
- (ecase graph-completion-method
- ((nil
- :complete-links)
- (iterate-vertexes old-graph
- (lambda (vertex)
- (when (funcall test-fn vertex)
- (add-vertex new-graph (value vertex))))))
- ((:complete-closure-nodes-only
- :complete-closure-with-links)
- (let* ((old-graph-vertexes (collect-items old-graph :filter test-fn))
- (closure-vertexes
- (get-transitive-closure old-graph-vertexes depth)))
- (dolist (vertex closure-vertexes)
- (add-vertex new-graph (copy-template vertex))))))
-
- (ecase graph-completion-method
- ((nil :complete-closure-nodes-only) nil)
- ((:complete-links
- :complete-closure-with-links)
- (complete-links new-graph old-graph)))
-
- new-graph))
-
-;;; ---------------------------------------------------------------------------
-
-(defmethod subgraph-containing ((graph basic-graph) (vertex basic-vertex)
- &optional (depth nil))
- (make-filtered-graph graph
- #'(lambda (v)
- (equal v vertex))
- :complete-closure-with-links
- depth))
-
-;;; ---------------------------------------------------------------------------
(defmethod edge-count ((graph basic-graph))
- (length (edges graph)))
+ (count-using #'iterate-edges nil graph))
;;; ---------------------------------------------------------------------------
(assign-level graph 0)
(let ((depth 0))
(iterate-vertexes graph (lambda (vertex)
- (maxf depth (depth-level vertex))))
+ (when (> (depth-level vertex) depth)
+ (setf depth (depth-level vertex)))))
depth))
;;; ---------------------------------------------------------------------------
;;; ---------------------------------------------------------------------------
-(defun map-shortest-paths (graph start-vertex depth fn &key (filter (constantly t)))
+(defun map-shortest-paths
+ (graph start-vertex depth fn &key (filter (constantly t)))
"Apply fn to each shortest path starting at `start-vertex` of depth `depth`. The `filter` predicate is used to remove vertexes from consideration."
(bind ((visited (make-container 'simple-associative-container
:test #'equal)))
projects / cl-graph.git / blobdiff