1 ! Copyright (C) 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs kernel sequences vectors ;
7 TUPLE: vertex value edges ;
9 : <digraph> ( -- digraph )
10 digraph new H{ } clone over set-delegate ;
12 : <vertex> ( value -- vertex )
13 V{ } clone vertex boa ;
15 : add-vertex ( key value digraph -- )
16 >r <vertex> swap r> set-at ;
18 : children ( key digraph -- seq )
21 : @edges ( from to digraph -- to edges ) swapd at edges>> ;
22 : add-edge ( from to digraph -- ) @edges push ;
23 : delete-edge ( from to digraph -- ) @edges delete ;
25 : delete-to-edges ( to digraph -- )
26 [ nip dupd edges>> delete ] assoc-each drop ;
28 : delete-vertex ( key digraph -- )
29 2dup delete-at delete-to-edges ;
31 : unvisited? ( unvisited key -- ? ) swap key? ;
32 : visited ( unvisited key -- ) swap delete-at ;
34 DEFER: (topological-sort)
35 : visit-children ( seq unvisited key -- seq unvisited )
36 over children [ (topological-sort) ] each ;
38 : (topological-sort) ( seq unvisited key -- seq unvisited )
40 [ visit-children ] keep 2dup visited pick push
45 : topological-sort ( digraph -- seq )
46 dup clone V{ } clone spin
47 [ drop (topological-sort) ] assoc-each drop reverse ;
49 : topological-sorted-values ( digraph -- seq )
50 dup topological-sort swap [ at value>> ] curry map ;