diff --git a/extra/graph-theory/graph-theory-docs.factor b/extra/graph-theory/graph-theory-docs.factor new file mode 100644 index 0000000000..82d8b9adf6 --- /dev/null +++ b/extra/graph-theory/graph-theory-docs.factor @@ -0,0 +1,135 @@ +! See http://factorcode.org/license.txt for BSD licence. +USING: help.markup help.syntax ; + +IN: graph-theory + +ARTICLE: "graph-protocol" "Graph protocol" +"All graphs must be instances of the graph mixin:" +{ $subsection graph } +"All graphs must implement a method on the following generic word:" +{ $subsection vertices } +"At least one of the following two generic words must have a method; the " { $link graph } " mixin has default definitions which are mutually recursive:" +{ $subsection adjlist } +{ $subsection adj? } +"All mutable graphs must implement a method on the following generic word:" +{ $subsection add-blank-vertex } +"All mutable undirected graphs must implement a method on the following generic word:" +{ $subsection add-edge } +"Mutable directed graphs should not implement the above word, as it has a default definition defined in terms of the following generic word:" +{ $subsection add-edge* } +"The following two words have default definitions, but are available as generics to allow implementations to optimize them:" +{ $subsection num-vertices } +{ $subsection num-edges } ; + +HELP: graph +{ $class-description "A mixin class whose instances are graphs. Custom implementations of the graph protocol should be declared as instances of this mixin for all graph functionality to work correctly:" + { $code "INSTANCE: hex-board graph" } +} ; + +{ vertices num-vertices num-edges } related-words + +HELP: vertices +{ $values { "graph" graph } { "seq" "The vertices" } } +{ $description "Returns the vertices of the graph." } ; + +HELP: num-vertices +{ $values { "graph" graph } { "n" "The number of vertices" } } +{ $description "Returns the number of vertices in the graph." } ; + +HELP: num-edges +{ $values { "graph" "A graph" } { "n" "The number of edges" } } +{ $description "Returns the number of edges in the graph." } ; + +{ adjlist adj? } related-words + +HELP: adjlist +{ $values + { "from" "The index of a vertex" } + { "graph" "The graph to be examined" } + { "seq" "The adjacency list" } } +{ $description "Returns a sequence of vertices that this vertex links to" } ; + +HELP: adj? +{ $values + { "from" "The index of a vertex" } + { "to" "The index of a vertex" } + { "graph" "A graph" } + { "?" "A boolean" } } +{ $description "Returns a boolean describing whether there is an edge in the graph between from and to." } ; + +{ add-blank-vertex add-blank-vertices add-edge add-edge* } related-words + +HELP: add-blank-vertex +{ $values + { "index" "A vertex index" } + { "graph" "A graph" } } +{ $description "Adds a vertex to the graph." } ; + +HELP: add-blank-vertices +{ $values + { "seq" "A sequence of vertex indices" } + { "graph" "A graph" } } +{ $description "Adds vertices with indices in seq to the graph." } ; + +HELP: add-edge* +{ $values + { "from" "The index of a vertex" } + { "to" "The index of another vertex" } + { "graph" "A graph" } } +{ $description "Adds a one-way edge to the graph, between from and to." + $nl + "If you want to add a two-way edge, use " { $link add-edge } " instead." } ; + +HELP: add-edge +{ $values + { "m" "The index of a vertex" } + { "n" "The index of another vertex" } + { "graph" "A graph" } } +{ $description "Adds a two-way edge to the graph, between m and n." + $nl + "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ; + +{ depth-first full-depth-first dag? topological-sort } related-words + +HELP: depth-first +{ $values + { "v" "The vertex to start the search at" } + { "graph" "The graph to search" } + { "pre" "A quotation of the form ( n -- )" } + { "post" "A quotation of the form ( n -- )" } + { "?list" "A list of booleans describing the vertices visited in the search" } + { "?" "A boolean describing whether or not the end-search error was thrown" } } +{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } " can be accessed in both quotations." + $nl + "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first." + $nl + "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first." + $nl + { $emphasis "?list" } " is a list of booleans, " { $link t } " for every vertex visted during the search, and " { $link f } " for every vertex not visited." } ; + +HELP: full-depth-first +{ $values + { "graph" "The graph to search" } + { "pre" "A quotation of the form ( n -- )" } + { "post" "A quotation of the form ( n -- )" } + { "tail" "A quotation of the form ( -- )" } + { "?" "A boolean describing whether or not the end-search error was thrown" } } +{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } "can be accessed in both quotations." + $nl + "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first." + $nl + "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first." + $nl + "The " { $emphasis "tail" } " quotation is run after each time the depth-first search runs out of nodes. On an undirected graph this will be each connected subgroup but on a directed graph it can be more complex." } ; + +HELP: dag? +{ $values + { "graph" graph } + { "?" "A boolean indicating if the graph is acyclic" } } +{ $description "Using a depth-first search, determines if the specified directed graph is a directed acyclic graph. An undirected graph will produce a false result, as the algorithm does not eliminate cycles of length 2, which will include any edge that goes both ways." } ; + +HELP: topological-sort +{ $values + { "graph" graph } + { "seq/f" "Either a sequence of values or f" } } +{ $description "Using a depth-first search, topologically sorts the specified directed graph. Returns f if the graph contains any cycles, and a topologically sorted sequence otherwise." } ; diff --git a/extra/graph-theory/graph-theory.factor b/extra/graph-theory/graph-theory.factor new file mode 100644 index 0000000000..322f17d2dd --- /dev/null +++ b/extra/graph-theory/graph-theory.factor @@ -0,0 +1,92 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel combinators fry continuations sequences arrays vectors assocs hashtables heaps namespaces ; + +IN: graph-theory + +MIXIN: graph +SYMBOL: visited? +ERROR: end-search ; + +GENERIC: vertices ( graph -- seq ) flushable + +GENERIC: num-vertices ( graph -- n ) flushable + +GENERIC: num-edges ( graph -- n ) flushable + +GENERIC: adjlist ( from graph -- seq ) flushable + +GENERIC: adj? ( from to graph -- ? ) flushable + +GENERIC: add-blank-vertex ( index graph -- ) + +GENERIC: delete-blank-vertex ( index graph -- ) + +GENERIC: add-edge* ( from to graph -- ) + +GENERIC: add-edge ( u v graph -- ) + +GENERIC: delete-edge* ( from to graph -- ) + +GENERIC: delete-edge ( u v graph -- ) + +M: graph num-vertices + vertices length ; + +M: graph num-edges + [ vertices ] [ '[ , adjlist length ] map sum ] bi ; + +M: graph adjlist + [ vertices ] [ swapd '[ , swap , adj? ] filter ] bi ; + +M: graph adj? + swapd adjlist index >boolean ; + +M: graph add-edge + [ add-edge* ] [ swapd add-edge* ] 3bi ; + +M: graph delete-edge + [ delete-edge* ] [ swapd delete-edge* ] 3bi ; + +: add-blank-vertices ( seq graph -- ) + '[ , add-blank-vertex ] each ; + +: delete-vertex ( index graph -- ) + [ adjlist ] + [ '[ , , 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ] + [ delete-blank-vertex ] 2tri ; + +hashtable visited? set ] bi + [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline + +: (depth-first) ( v pre post -- ) + { [ 2drop visited? get t -rot set-at ] + [ drop call ] + [ [ graph get adjlist ] 2dip + '[ dup visited? get at [ drop ] [ , , (depth-first) ] if ] each ] + [ nip call ] } 3cleave ; inline + +PRIVATE> + +: depth-first ( v graph pre post -- ?list ? ) + '[ , , (depth-first) visited? get ] swap search-wrap ; inline + +: full-depth-first ( graph pre post tail -- ? ) + '[ [ visited? get [ nip not ] assoc-find ] + [ drop , , (depth-first) @ ] + [ 2drop ] while ] swap search-wrap ; inline + +: dag? ( graph -- ? ) + V{ } clone swap [ 2dup swap push dupd + '[ , swap graph get adj? not ] all? + [ end-search ] unless ] + [ drop dup pop* ] [ ] full-depth-first nip ; + +: topological-sort ( graph -- seq/f ) + dup dag? + [ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ] + [ drop f ] if ; diff --git a/extra/graph-theory/reversals/reversals.factor b/extra/graph-theory/reversals/reversals.factor new file mode 100644 index 0000000000..1ea1a3fbf5 --- /dev/null +++ b/extra/graph-theory/reversals/reversals.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors kernel graph-theory ; + +IN: graph-theory.reversals + +TUPLE: reversal graph ; + +GENERIC: reverse-graph ( graph -- reversal ) + +M: graph reverse-graph reversal boa ; + +M: reversal reverse-graph graph>> ; + +INSTANCE: reversal graph + +M: reversal vertices + graph>> vertices ; + +M: reversal adj? + swapd graph>> adj? ; diff --git a/extra/graph-theory/sparse/sparse.factor b/extra/graph-theory/sparse/sparse.factor new file mode 100644 index 0000000000..33c5505f0a --- /dev/null +++ b/extra/graph-theory/sparse/sparse.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors kernel sequences arrays vectors sets assocs hashtables graph-theory namespaces fry ; + +IN: graph-theory.sparse + +TUPLE: sparse-graph alist ; + +: ( -- sparse-graph ) + H{ } clone sparse-graph boa ; + +: >sparse-graph ( graph -- sparse-graph ) + [ vertices ] keep + '[ dup , adjlist 2array ] map >hashtable sparse-graph boa ; + +INSTANCE: sparse-graph graph + +M: sparse-graph vertices + alist>> keys ; + +M: sparse-graph adjlist + alist>> at ; + +M: sparse-graph add-blank-vertex + alist>> V{ } clone -rot set-at ; + +M: sparse-graph delete-blank-vertex + alist>> delete-at ; + +M: sparse-graph add-edge* + alist>> swapd at adjoin ; + +M: sparse-graph delete-edge* + alist>> swapd at delete ;