adding digraphs

diff --git a/extra/digraphs/authors.txt b/extra/digraphs/authors.txt
new file mode 100644 (file)
index 0000000..e9c193b
--- /dev/null
+++ b/extra/digraphs/authors.txt
@@ -0,0 +1 @@
+Alex Chapman

diff --git a/extra/digraphs/digraphs-tests.factor b/extra/digraphs/digraphs-tests.factor
new file mode 100644 (file)
index 0000000..b113c18
--- /dev/null
+++ b/extra/digraphs/digraphs-tests.factor
@@ -0,0 +1,9 @@
+USING: digraphs kernel sequences tools.test ;
+IN: digraphs.tests
+
+: test-digraph ( -- digraph )
+    <digraph>
+    { { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each
+    { { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ;
+
+[ 5 ] [ test-digraph topological-sort length ] unit-test

diff --git a/extra/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor
new file mode 100644 (file)
index 0000000..87dc766
--- /dev/null
+++ b/extra/digraphs/digraphs.factor
@@ -0,0 +1,45 @@
+USING: accessors assocs kernel new-slots sequences vectors ;
+IN: digraphs
+
+TUPLE: digraph ;
+TUPLE: vertex value edges ;
+
+: <digraph> ( -- digraph )
+    digraph construct-empty H{ } clone over set-delegate ;
+
+: <vertex> ( value -- vertex )
+    V{ } clone vertex construct-boa ;
+
+: add-vertex ( key value digraph -- )
+    >r <vertex> swap r> set-at ;
+
+: children ( key digraph -- seq )
+    at edges>> ;
+
+: @edges ( from to digraph -- to edges ) swapd at edges>> ;
+: add-edge ( from to digraph -- ) @edges push ;
+: delete-edge ( from to digraph -- ) @edges delete ;
+
+: delete-to-edges ( to digraph -- )
+    [ nip dupd edges>> delete ] assoc-each drop ;
+
+: delete-vertex ( key digraph -- )
+    2dup delete-at delete-to-edges ;
+
+: unvisited? ( unvisited key -- ? ) swap key? ;
+: visited ( unvisited key -- ) swap delete-at ;
+
+DEFER: (topological-sort)
+: visit-children ( seq unvisited key -- seq unvisited )
+    over children [ (topological-sort) ] each ;
+
+: (topological-sort) ( seq unvisited key -- seq unvisited )
+    2dup unvisited? [
+        [ visit-children ] keep 2dup visited pick push
+    ] [
+        drop
+    ] if ;
+
+: topological-sort ( digraph -- seq )
+    dup clone V{ } clone spin
+    [ drop (topological-sort) ] assoc-each drop reverse ;

diff --git a/extra/digraphs/summary.txt b/extra/digraphs/summary.txt
new file mode 100644 (file)
index 0000000..78e5a53
--- /dev/null
+++ b/extra/digraphs/summary.txt
@@ -0,0 +1 @@
+Simple directed graph implementation for topological sorting