projects
/
cl-graph.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
tweak website style sheets (thanks to Robert Goldman!)
[cl-graph.git]
/
dev
/
graph-algorithms.lisp
diff --git
a/dev/graph-algorithms.lisp
b/dev/graph-algorithms.lisp
index
bd52fca
..
d84a799
100644
(file)
--- a/
dev/graph-algorithms.lisp
+++ b/
dev/graph-algorithms.lisp
@@
-1,15
+1,12
@@
(in-package #:metabang.graph)
(in-package #:metabang.graph)
-;;; ---------------------------------------------------------------------------
;;;
;;;
-;;; ---------------------------------------------------------------------------
(defstruct (vertex-datum (:conc-name node-) (:type list))
(color nil)
(depth most-positive-fixnum)
(parent nil))
(defstruct (vertex-datum (:conc-name node-) (:type list))
(color nil)
(depth most-positive-fixnum)
(parent nil))
-;;; ---------------------------------------------------------------------------
(defmethod initialize-vertex-data ((graph basic-graph))
(let ((vertex-data (make-container 'simple-associative-container)))
(defmethod initialize-vertex-data ((graph basic-graph))
(let ((vertex-data (make-container 'simple-associative-container)))
@@
-18,14
+15,11
@@
(make-vertex-datum :color :white))))
(values vertex-data)))
(make-vertex-datum :color :white))))
(values vertex-data)))
-;;; ---------------------------------------------------------------------------
;;; breadth-first-search by GWK
;;; breadth-first-search by GWK
-;;; ---------------------------------------------------------------------------
(defmethod breadth-first-visitor ((graph basic-graph) (source t) fn)
(breadth-first-visitor graph (find-vertex graph source) fn))
(defmethod breadth-first-visitor ((graph basic-graph) (source t) fn)
(breadth-first-visitor graph (find-vertex graph source) fn))
-;;; ---------------------------------------------------------------------------
(defmethod breadth-first-visitor ((graph basic-graph) (source basic-vertex) fn)
;; initialize
(defmethod breadth-first-visitor ((graph basic-graph) (source basic-vertex) fn)
;; initialize
@@
-57,12
+51,10
@@
vertex-data)))
vertex-data)))
-;;; ---------------------------------------------------------------------------
(defmethod breadth-first-search-graph ((graph basic-graph) (source t))
(breadth-first-search-graph graph (find-vertex graph source)))
(defmethod breadth-first-search-graph ((graph basic-graph) (source t))
(breadth-first-search-graph graph (find-vertex graph source)))
-;;; ---------------------------------------------------------------------------
(defmethod breadth-first-search-graph ((graph basic-graph) (source basic-vertex))
;; initialize
(defmethod breadth-first-search-graph ((graph basic-graph) (source basic-vertex))
;; initialize
@@
-93,9
+85,7
@@
vertex-data)))
vertex-data)))
-;;; ---------------------------------------------------------------------------
;;; single-source-shortest-paths - gwk
;;; single-source-shortest-paths - gwk
-;;; ---------------------------------------------------------------------------
#+NotYet
(defmethod single-source-shortest-paths ((graph basic-graph))
#+NotYet
(defmethod single-source-shortest-paths ((graph basic-graph))
@@
-105,9
+95,7
@@
(setf (node-depth source-datum) 0))
))
(setf (node-depth source-datum) 0))
))
-;;; ---------------------------------------------------------------------------
;;; connected-components - gwk
;;; connected-components - gwk
-;;; ---------------------------------------------------------------------------
(defmethod connected-components ((graph basic-graph))
(let ((union (make-container 'union-find-container)))
(defmethod connected-components ((graph basic-graph))
(let ((union (make-container 'union-find-container)))
@@
-124,7
+112,6
@@
(iterate-elements union 'find-set)
union))
(iterate-elements union 'find-set)
union))
-;;; ---------------------------------------------------------------------------
(defmethod connected-component-count ((graph basic-graph))
;;?? Gary King 2005-11-28: Super ugh
(defmethod connected-component-count ((graph basic-graph))
;;?? Gary King 2005-11-28: Super ugh
@@
-159,8
+146,7
@@
(let ((element (element (parent component))))
(unless (item-at found-elements element)
(setf (item-at found-elements element) t)
(let ((element (element (parent component))))
(unless (item-at found-elements element)
(setf (item-at found-elements element) t)
-
- (push (subgraph-containing graph (element component)
+ (push (subgraph-containing graph (element component)
most-positive-fixnum)
result)))))
most-positive-fixnum)
result)))))
@@
-168,9
+154,7
@@
-;;; ---------------------------------------------------------------------------
;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm
;;; minimum-spanning-tree based on kruskal's algorithm detailed in clrs2 -jjm
-;;; ---------------------------------------------------------------------------
(defmethod mst-find-set ((vertex basic-vertex))
#+ignore
(defmethod mst-find-set ((vertex basic-vertex))
#+ignore
@@
-180,18
+164,15
@@
(setf (previous-node vertex) (mst-find-set (previous-node vertex))))
(previous-node vertex))
(setf (previous-node vertex) (mst-find-set (previous-node vertex))))
(previous-node vertex))
-;;; ---------------------------------------------------------------------------
(defmethod mst-make-set ((vertex basic-vertex))
(setf (previous-node vertex) vertex
(rank vertex) 0))
(defmethod mst-make-set ((vertex basic-vertex))
(setf (previous-node vertex) vertex
(rank vertex) 0))
-;;; ---------------------------------------------------------------------------
(defmethod mst-tree-union ((v1 basic-vertex) (v2 basic-vertex))
(mst-link (mst-find-set v1) (mst-find-set v2)))
(defmethod mst-tree-union ((v1 basic-vertex) (v2 basic-vertex))
(mst-link (mst-find-set v1) (mst-find-set v2)))
-;;; ---------------------------------------------------------------------------
(defmethod mst-link ((v1 basic-vertex) (v2 basic-vertex))
(cond ((> (rank v1) (rank v2))
(defmethod mst-link ((v1 basic-vertex) (v2 basic-vertex))
(cond ((> (rank v1) (rank v2))
@@
-200,19
+181,17
@@
(when (= (rank v1) (rank v2))
(incf (rank v2))))))
(when (= (rank v1) (rank v2))
(incf (rank v2))))))
-;;; ---------------------------------------------------------------------------
;;; jjm's implementation of mst depends on this
;;; todo - figure out some what to add and edge we create to a graph rather
;;; than always using add-edge-between-vertexes interface
;;; jjm's implementation of mst depends on this
;;; todo - figure out some what to add and edge we create to a graph rather
;;; than always using add-edge-between-vertexes interface
-;;; ---------------------------------------------------------------------------
(defmethod add-edges-to-graph ((graph basic-graph) (edges list)
&key (if-duplicate-do :ignore))
(iterate-elements
edges
(lambda (edge)
(defmethod add-edges-to-graph ((graph basic-graph) (edges list)
&key (if-duplicate-do :ignore))
(iterate-elements
edges
(lambda (edge)
- (bind ((v1 (element (source-vertex edge)))
- (v2 (element (target-vertex edge))))
+ (let ((v1 (element (source-vertex edge)))
+ (v2 (element (target-vertex edge))))
(add-edge-between-vertexes
graph v1 v2 :edge-class (type-of edge)
:edge-type (if (directed-edge-p edge)
(add-edge-between-vertexes
graph v1 v2 :edge-class (type-of edge)
:edge-type (if (directed-edge-p edge)
@@
-227,27
+206,24
@@
:if-duplicate-do if-duplicate-do))))
graph)
:if-duplicate-do if-duplicate-do))))
graph)
-;;; ---------------------------------------------------------------------------
(defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
(< (weight e1) (weight e2)))
(defmethod edge-lessp-by-weight ((e1 basic-edge) (e2 basic-edge))
(< (weight e1) (weight e2)))
-;;; ---------------------------------------------------------------------------
;;; minumum spanning tree
;;; minumum spanning tree
-;;; ---------------------------------------------------------------------------
(defmethod minimum-spanning-tree ((graph basic-graph)
&key
(edge-sorter #'edge-lessp-by-weight))
(defmethod minimum-spanning-tree ((graph basic-graph)
&key
(edge-sorter #'edge-lessp-by-weight))
- (bind ((result nil))
+ (let ((result nil))
(iterate-vertexes
graph
(lambda (v)
(mst-make-set v)))
(loop for edge in (sort (edges graph) edge-sorter) do
(iterate-vertexes
graph
(lambda (v)
(mst-make-set v)))
(loop for edge in (sort (edges graph) edge-sorter) do
- (bind ((v1 (source-vertex edge))
+ (let ((v1 (source-vertex edge))
(v2 (target-vertex edge)))
(unless (eq (mst-find-set v1)
(v2 (target-vertex edge)))
(unless (eq (mst-find-set v1)
@@
-260,13
+236,12
@@
(values t result))
(t (values nil result)))))))
(values t result))
(t (values nil result)))))))
-;;; ---------------------------------------------------------------------------
#+ignore ;;; shoot
(defmethod minimum-spanning-tree ((vertex-list list)
&key
(edge-sorter #'edge-lessp-by-weight))
#+ignore ;;; shoot
(defmethod minimum-spanning-tree ((vertex-list list)
&key
(edge-sorter #'edge-lessp-by-weight))
- (bind ((result nil)
+ (let ((result nil)
(v-edges (remove-duplicates
(flatten (mapcar #'edges vertex-list)) :test #'eq)))
(v-edges (remove-duplicates
(flatten (mapcar #'edges vertex-list)) :test #'eq)))
@@
-276,10
+251,10
@@
(mst-make-set v)))
(loop for edge in (sort v-edges edge-sorter) do
(mst-make-set v)))
(loop for edge in (sort v-edges edge-sorter) do
- (bind ((v1 (source-vertex edge))
- (v2 (target-vertex edge))
- (v1-set (mst-find-set v1))
- (v2-set (mst-find-set v2)))
+ (let ((v1 (source-vertex edge))
+ (v2 (target-vertex edge))
+ (v1-set (mst-find-set v1))
+ (v2-set (mst-find-set v2)))
(when (or (not v1-set)
(not v2-set))
(when (or (not v1-set)
(not v2-set))
@@
-296,19
+271,16
@@
(values t result))
(t (values nil result)))))))
(values t result))
(t (values nil result)))))))
-;;; ---------------------------------------------------------------------------
;;; uses mst to determine if the graph is connected
;;; uses mst to determine if the graph is connected
-;;; ---------------------------------------------------------------------------
(defmethod connected-graph-p ((graph basic-graph) &key
(edge-sorter 'edge-lessp-by-weight))
(minimum-spanning-tree graph :edge-sorter edge-sorter))
(defmethod connected-graph-p ((graph basic-graph) &key
(edge-sorter 'edge-lessp-by-weight))
(minimum-spanning-tree graph :edge-sorter edge-sorter))
-;;; ---------------------------------------------------------------------------
#+test
#+test
-(bind ((g (make-container 'graph-container)))
+(let ((g (make-container 'graph-container)))
(add-edge-between-vertexes g :v :y :edge-type :directed)
(add-edge-between-vertexes g :u :x :edge-type :directed)
(add-edge-between-vertexes g :x :v :edge-type :directed)
(add-edge-between-vertexes g :v :y :edge-type :directed)
(add-edge-between-vertexes g :u :x :edge-type :directed)
(add-edge-between-vertexes g :x :v :edge-type :directed)
@@
-320,11
+292,9
@@
:if-duplicate-do :force)
(minimum-spanning-tree g))
:if-duplicate-do :force)
(minimum-spanning-tree g))
-;;; ---------------------------------------------------------------------------
;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
;;; a tree (still faster even if it does). Will decide later if which to use
;;; ignoring for now -jjm
;;; GWK's implementation of kruskal's - slightly faster, but it doesn't return
;;; a tree (still faster even if it does). Will decide later if which to use
;;; ignoring for now -jjm
-;;; ---------------------------------------------------------------------------
#+not-yet
(defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
#+not-yet
(defmethod minimum-spanning-tree ((graph basic-graph) &key (weight 'weight))
@@
-342,7
+312,6
@@
(values a)))
(values a)))
-;;; ---------------------------------------------------------------------------
#+test
(loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
#+test
(loop for f in '(mst-kruskal minimum-spanning-tree-kruskal) do
@@
-361,26
+330,18
@@
(declare (ignore a b))
0)))))))
(declare (ignore a b))
0)))))))
-;;; ---------------------------------------------------------------------------
;;; end minimum spanning tree
;;; end minimum spanning tree
-;;; ---------------------------------------------------------------------------
-;;; ---------------------------------------------------------------------------
;;; depth-first-search - clrs2
;;; todo - figure out how to name this depth-first-search, which is already
;;; defined in search.lisp
;;; depth-first-search - clrs2
;;; todo - figure out how to name this depth-first-search, which is already
;;; defined in search.lisp
-;;; ---------------------------------------------------------------------------
-;;; ---------------------------------------------------------------------------
;;; should probably make this special
;;; should probably make this special
-;;; ---------------------------------------------------------------------------
(defparameter *depth-first-search-timer* -1)
(defparameter *depth-first-search-timer* -1)
-;;; ---------------------------------------------------------------------------
;;; undirected edges are less than edges that are directed
;;; undirected edges are less than edges that are directed
-;;; ---------------------------------------------------------------------------
#+ignore ;;; incorrect, methinks - jjm
(defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
#+ignore ;;; incorrect, methinks - jjm
(defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
@@
-394,7
+355,6
@@
(defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
(and (undirected-edge-p e1) (directed-edge-p e2)))
(defmethod edge-lessp-by-direction ((e1 basic-edge) (e2 basic-edge))
(and (undirected-edge-p e1) (directed-edge-p e2)))
-;;; ---------------------------------------------------------------------------
(defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
(cond ((and (directed-edge-p edge)
(defmethod out-edge-for-vertex-p ((edge basic-edge) (vertex basic-vertex))
(cond ((and (directed-edge-p edge)
@@
-406,15
+366,12
@@
t)
(t nil)))
t)
(t nil)))
-;;; ---------------------------------------------------------------------------
;;; depth-first-search
;;; depth-first-search
-;;; ---------------------------------------------------------------------------
(defmethod dfs ((graph basic-graph) (root t) fn &key
(out-edge-sorter #'edge-lessp-by-direction))
(dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
(defmethod dfs ((graph basic-graph) (root t) fn &key
(out-edge-sorter #'edge-lessp-by-direction))
(dfs graph (find-vertex graph root) fn :out-edge-sorter out-edge-sorter))
-;;; ---------------------------------------------------------------------------
(defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
(out-edge-sorter #'edge-lessp-by-direction))
(defmethod dfs ((graph basic-graph) (root basic-vertex) fn &key
(out-edge-sorter #'edge-lessp-by-direction))
@@
-442,7
+399,6
@@
(sort (copy-list (vertexes graph)) #'< :key #'finish-time)
graph))
(sort (copy-list (vertexes graph)) #'< :key #'finish-time)
graph))
-;;; ---------------------------------------------------------------------------
(defmethod dfs-visit ((graph graph-container) (u basic-vertex)
fn sorter)
(defmethod dfs-visit ((graph graph-container) (u basic-vertex)
fn sorter)
@@
-457,7
+413,7
@@
(edges u)
:filter (lambda (e)
(out-edge-for-vertex-p e u))) sorter) do
(edges u)
:filter (lambda (e)
(out-edge-for-vertex-p e u))) sorter) do
- (bind ((v (other-vertex edge u)))
+ (let ((v (other-vertex edge u)))
(unless (color edge)
(setf (color edge) (color v)))
(unless (color edge)
(setf (color edge) (color v)))
@@
-472,12
+428,10
@@
(setf (color u) :black
(finish-time u) *depth-first-search-timer*))
(setf (color u) :black
(finish-time u) *depth-first-search-timer*))
-;;; ---------------------------------------------------------------------------
;;; from clrs2
;;; from clrs2
-;;; ---------------------------------------------------------------------------
#+test
#+test
-(bind ((g (make-container 'graph-container)))
+(let ((g (make-container 'graph-container)))
(add-edge-between-vertexes g :v :y :edge-type :directed)
(add-edge-between-vertexes g :u :x :edge-type :directed)
(add-edge-between-vertexes g :x :v :edge-type :directed)
(add-edge-between-vertexes g :v :y :edge-type :directed)
(add-edge-between-vertexes g :u :x :edge-type :directed)
(add-edge-between-vertexes g :x :v :edge-type :directed)
@@
-490,19
+444,15
@@
(assert (equal '(:X :Y :V :U :Z :W)
(mapcar #'element (dfs g :u #'identity)))))
(assert (equal '(:X :Y :V :U :Z :W)
(mapcar #'element (dfs g :u #'identity)))))
-;;; ---------------------------------------------------------------------------
(defmethod dfs-tree-edge-p ((edge graph-container-edge))
(eql (color edge) :white))
(defmethod dfs-tree-edge-p ((edge graph-container-edge))
(eql (color edge) :white))
-;;; ---------------------------------------------------------------------------
(defmethod dfs-back-edge-p ((edge graph-container-edge))
(eql (color edge) :gray))
(defmethod dfs-back-edge-p ((edge graph-container-edge))
(eql (color edge) :gray))
-;;; ---------------------------------------------------------------------------
;;; not correct - has to look at combination of discovery-time and finish-time
;;; not correct - has to look at combination of discovery-time and finish-time
-;;; ---------------------------------------------------------------------------
(defmethod dfs-forward-edge-p ((edge graph-container-edge))
(warn "implementation is not correct.")
(defmethod dfs-forward-edge-p ((edge graph-container-edge))
(warn "implementation is not correct.")
@@
-511,9
+461,7
@@
(< (discovery-time (source-vertex edge))
(discovery-time (target-vertex edge)))))
(< (discovery-time (source-vertex edge))
(discovery-time (target-vertex edge)))))
-;;; ---------------------------------------------------------------------------
;;; not correct - has to look at combination of discovery-time and finish-time
;;; not correct - has to look at combination of discovery-time and finish-time
-;;; ---------------------------------------------------------------------------
(defmethod dfs-cross-edge-p ((edge graph-container-edge))
(warn "implementation is not correct.")
(defmethod dfs-cross-edge-p ((edge graph-container-edge))
(warn "implementation is not correct.")
@@
-522,7
+470,6
@@
(> (discovery-time (source-vertex edge))
(discovery-time (target-vertex edge)))))
(> (discovery-time (source-vertex edge))
(discovery-time (target-vertex edge)))))
-;;; ---------------------------------------------------------------------------
(defmethod dfs-edge-type ((edge graph-container-edge))
(cond ((dfs-tree-edge-p edge)
(defmethod dfs-edge-type ((edge graph-container-edge))
(cond ((dfs-tree-edge-p edge)
@@
-535,20
+482,14
@@
:cross)
(t nil)))
:cross)
(t nil)))
-;;; ---------------------------------------------------------------------------
;;; end dfs
;;; end dfs
-;;; ---------------------------------------------------------------------------
-;;; ---------------------------------------------------------------------------
;;; mapping functions
;;; mapping functions
-;;; ---------------------------------------------------------------------------
-;;; ---------------------------------------------------------------------------
;;; over vertexes
;;; over vertexes
-;;; ---------------------------------------------------------------------------
(defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
(defmethod map-over-all-combinations-of-k-vertexes ((graph basic-graph) k fn)
- (bind ((vertex-count (size graph))
+ (let* ((vertex-count (size graph))
(symbols (make-list k :initial-element vertex-count))
(vertexes (vertexes graph)))
(iterate-over-indexes
(symbols (make-list k :initial-element vertex-count))
(vertexes (vertexes graph)))
(iterate-over-indexes
@@
-559,10
+500,9
@@
(nth-element vertexes vertex-index))
vertex-indexes)))))))
(nth-element vertexes vertex-index))
vertex-indexes)))))))
-;;; ---------------------------------------------------------------------------
#+test
#+test
-(bind ((result nil)
+(let ((result nil)
(g (make-container 'graph-container)))
(add-edge-between-vertexes g :u :v :edge-type :directed)
(add-edge-between-vertexes g :u :x :edge-type :directed)
(g (make-container 'graph-container)))
(add-edge-between-vertexes g :u :v :edge-type :directed)
(add-edge-between-vertexes g :u :x :edge-type :directed)
@@
-576,18
+516,16
@@
g
4
(lambda (vertex-list)
g
4
(lambda (vertex-list)
- (bind ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
+ (let ((graph-from-vertexes (make-graph-from-vertexes vertex-list)))
(when (mst-kruskal graph-from-vertexes #'identity-sorter)
(push graph-from-vertexes result)))))
result)
(when (mst-kruskal graph-from-vertexes #'identity-sorter)
(push graph-from-vertexes result)))))
result)
-;;; ---------------------------------------------------------------------------
;;; over edges
;;; todo: merge these two defs
;;; over edges
;;; todo: merge these two defs
-;;; ---------------------------------------------------------------------------
(defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
(defmethod map-over-all-combinations-of-k-edges ((graph basic-graph) k fn)
- (bind ((edge-count (edge-count graph))
+ (let* ((edge-count (edge-count graph))
(symbols (make-list k :initial-element edge-count))
(edges (edges graph)))
(print symbols)
(symbols (make-list k :initial-element edge-count))
(edges (edges graph)))
(print symbols)
@@
-599,13
+537,12
@@
(nth-element edges edge-index))
edge-indexes)))))))
(nth-element edges edge-index))
edge-indexes)))))))
-;;; ---------------------------------------------------------------------------
(defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
(defmethod map-over-all-combinations-of-k-edges ((vertex basic-vertex) k fn)
- (bind ((edge-count (edge-count vertex))
- (symbols (make-list k :initial-element edge-count))
- (edges (edges vertex)))
- (print symbols)
+ (let* ((edge-count (edge-count vertex))
+ (symbols (make-list k :initial-element edge-count))
+ (edges (edges vertex)))
+ ;(print symbols)
(iterate-over-indexes
symbols
(lambda (edge-indexes)
(iterate-over-indexes
symbols
(lambda (edge-indexes)
@@
-613,7
+550,6
@@
(funcall fn (mapcar (lambda (edge-index)
(nth-element edges edge-index))
edge-indexes)))))))
(funcall fn (mapcar (lambda (edge-index)
(nth-element edges edge-index))
edge-indexes)))))))
-;;; ---------------------------------------------------------------------------
#+test
(map-over-all-combinations-of-k-edges
#+test
(map-over-all-combinations-of-k-edges