Added extra/graph-theory
William Schlieper
parent
482f1d4c36
commit
fa2cd6a709
|
|
@ -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." } ;
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
! 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 ] 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 ;
|
||||
|
||||
<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) @ ]
|
||||
[ 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 ;
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
! 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? ;
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! 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 ;
|
||||
Loading…
Reference in New Issue