X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=dev%2Fgraph.lisp;h=d71ab6ce0d27437d457784501804948b9e33ae23;hb=e95dd49b959e672614b7eb2c109c2d842b6f4a23;hp=8a17dc1387c6a032bfe24442273dcfd52a6a6501;hpb=53ce4bea57e2710f2296878d79fe00ca31fec9fb;p=cl-graph.git diff --git a/dev/graph.lisp b/dev/graph.lisp index 8a17dc1..d71ab6c 100644 --- a/dev/graph.lisp +++ b/dev/graph.lisp @@ -14,7 +14,7 @@ something is putting something on the vertexes plist's |# -(in-package metabang.graph) +(in-package #:metabang.graph) ;;; --------------------------------------------------------------------------- ;;; classes @@ -87,11 +87,6 @@ something is putting something on the vertexes plist's ;;; --------------------------------------------------------------------------- -#+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) @@ -116,7 +111,6 @@ something is putting something on the vertexes plist's (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.")) @@ -136,15 +130,14 @@ something is putting something on the vertexes plist's ;;; --------------------------------------------------------------------------- -(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.")) @@ -155,7 +148,7 @@ something is putting something on the vertexes plist's ;;; --------------------------------------------------------------------------- -(defclass* basic-graph (#+COPYING copyable-mixin) +(defclass* basic-graph () ((graph-vertexes :unbound ir) (graph-edges :unbound ir) (largest-vertex-id 0 r) @@ -198,7 +191,7 @@ something is putting something on the vertexes plist's (defmethod print-object ((graph basic-graph) stream) (print-unreadable-object (graph stream :type t :identity t) - (format stream "~A" (size graph)))) + (format stream "[~A,~A]" (size graph) (edge-count graph)))) ;;; --------------------------------------------------------------------------- @@ -229,18 +222,6 @@ something is putting something on the vertexes plist's &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 @@ -263,7 +244,6 @@ something is putting something on the vertexes plist's :graph graph :vertex-1 vertex-1 :vertex-2 vertex-2 args)) - ;;; --------------------------------------------------------------------------- (defmethod make-graph ((graph-type symbol) &rest args &key &allow-other-keys) @@ -272,7 +252,7 @@ something is putting something on the vertexes plist's ;;; --------------------------------------------------------------------------- (defmethod make-graph ((classes list) &rest args) - (let ((name (find-or-create-class 'basic-graph classes))) + (let ((name (dynamic-classes:find-or-create-class 'basic-graph classes))) (apply #'make-instance name args))) ;;; --------------------------------------------------------------------------- @@ -476,14 +456,14 @@ something is putting something on the vertexes plist's ;;; --------------------------------------------------------------------------- -(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 :vertex-1 v1 :vertex-2 v2)))) ;;; --------------------------------------------------------------------------- @@ -501,6 +481,11 @@ something is putting something on the vertexes plist's (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) @@ -632,12 +617,18 @@ something is putting something on the vertexes plist's (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)) @@ -650,38 +641,20 @@ something is putting something on the vertexes plist's (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)))) (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) @@ -811,16 +784,6 @@ something is putting something on the vertexes plist's ;;; --------------------------------------------------------------------------- -#+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))) @@ -854,7 +817,7 @@ something is putting something on the vertexes plist's (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) @@ -866,7 +829,7 @@ something is putting something on the vertexes plist's (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 @@ -879,19 +842,39 @@ something is putting something on the vertexes plist's 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)) @@ -914,7 +897,7 @@ something is putting something on the vertexes plist's &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 @@ -1031,48 +1014,48 @@ nil gathers the entire closure(s)." (defmethod make-filtered-graph ((old-graph basic-graph) test-fn - &optional + &key (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 + (depth nil) + (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)) + 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)) + &rest args &key (depth nil) (new-graph nil)) + (declare (ignore depth new-graph)) + (apply #'make-filtered-graph + graph + #'(lambda (v) + (equal v vertex)) + :graph-completion-method :complete-closure-with-links + args)) ;;; --------------------------------------------------------------------------- (defmethod edge-count ((graph basic-graph)) - (length (edges graph))) + (count-using #'iterate-edges nil graph)) ;;; --------------------------------------------------------------------------- @@ -1106,7 +1089,8 @@ nil gathers the entire closure(s)." (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)) ;;; ---------------------------------------------------------------------------