unmaintained: New home for misfit Factor vocabularies.

[factor-unmaintained.git] / graph-theory / graph-theory.factor

diff --git a/graph-theory/graph-theory.factor b/graph-theory/graph-theory.factor
new file mode 100644 (file)
index 0000000..e14ffb4
--- /dev/null
+++ b/graph-theory/graph-theory.factor
@@ -0,0 +1,91 @@
+! 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) @ ] 
+       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 ;