+++ /dev/null
-William Schlieper
+++ /dev/null
-! 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 " { $snippet "from" } " and " { $snippet "to" } "."
- $nl
- "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
-
-HELP: add-edge
-{ $values
- { "u" "The index of a vertex" }
- { "v" "The index of another vertex" }
- { "graph" "A graph" } }
-{ $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
- $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." } ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! 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 ] sigma ] 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 ;
-
-<PRIVATE
-
-: search-wrap ( quot graph -- ? )
- [ [ graph set ] [ vertices [ f 2array ] map >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) @ ]
- while 2drop ] 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{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
- [ drop f ] if ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! 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? ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! 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> ( -- 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 ;
+++ /dev/null
-Graph-theoretic algorithms
+++ /dev/null
-collections
--- /dev/null
+William Schlieper
--- /dev/null
+! 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 " { $snippet "from" } " and " { $snippet "to" } "."
+ $nl
+ "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
+
+HELP: add-edge
+{ $values
+ { "u" "The index of a vertex" }
+ { "v" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
+ $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." } ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! 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 ] sigma ] 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 ;
+
+<PRIVATE
+
+: search-wrap ( quot graph -- ? )
+ [ [ graph set ] [ vertices [ f 2array ] map >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) @ ]
+ while 2drop ] 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{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
+ [ drop f ] if ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! 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? ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! 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> ( -- 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 ;
--- /dev/null
+Graph-theoretic algorithms
--- /dev/null
+collections
projects / factor.git / commitdiff