diff --git a/extra/digraphs/authors.txt b/extra/digraphs/authors.txt new file mode 100644 index 0000000000..e9c193bac7 --- /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 index 0000000000..b113c18ca7 --- /dev/null +++ b/extra/digraphs/digraphs-tests.factor @@ -0,0 +1,9 @@ +USING: digraphs kernel sequences tools.test ; +IN: digraphs.tests + +: test-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 index 0000000000..87dc766a29 --- /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 construct-empty H{ } clone over set-delegate ; + +: ( value -- vertex ) + V{ } clone vertex construct-boa ; + +: add-vertex ( key value digraph -- ) + >r 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 index 0000000000..78e5a53313 --- /dev/null +++ b/extra/digraphs/summary.txt @@ -0,0 +1 @@ +Simple directed graph implementation for topological sorting