1 ! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel combinators fry continuations sequences arrays
4 vectors assocs hashtables heaps namespaces ;
11 GENERIC: vertices ( graph -- seq ) flushable
13 GENERIC: num-vertices ( graph -- n ) flushable
15 GENERIC: num-edges ( graph -- n ) flushable
17 GENERIC: adjlist ( from graph -- seq ) flushable
19 GENERIC: adj? ( from to graph -- ? ) flushable
21 GENERIC: add-blank-vertex ( index graph -- )
23 GENERIC: delete-blank-vertex ( index graph -- )
25 GENERIC: add-edge* ( from to graph -- )
27 GENERIC: add-edge ( u v graph -- )
29 GENERIC: delete-edge* ( from to graph -- )
31 GENERIC: delete-edge ( u v graph -- )
37 [ vertices ] [ '[ _ adjlist length ] map-sum ] bi ;
40 [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
43 swapd adjlist index >boolean ;
46 [ add-edge* ] [ swapd add-edge* ] 3bi ;
49 [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
51 : add-blank-vertices ( seq graph -- )
52 '[ _ add-blank-vertex ] each ;
54 : delete-vertex ( index graph -- )
56 [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
57 [ delete-blank-vertex ] 2tri ;
61 : search-wrap ( quot graph -- ? )
62 [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
63 [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
65 : (depth-first) ( v pre post -- )
66 { [ 2drop visited? get t -rot set-at ]
68 [ [ graph get adjlist ] 2dip
69 '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
70 [ nip call ] } 3cleave ; inline
74 : depth-first ( v graph pre post -- ?list ? )
75 '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
77 : full-depth-first ( graph pre post tail -- ? )
78 '[ [ visited? get [ nip not ] assoc-find ]
79 [ drop _ _ (depth-first) @ ]
80 while 2drop ] swap search-wrap ; inline
83 V{ } clone swap [ 2dup swap push dupd
84 '[ _ swap graph get adj? not ] all?
85 [ end-search ] unless ]
86 [ drop dup pop* ] [ ] full-depth-first nip ;
88 : topological-sort ( graph -- seq/f )
90 [ V{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ]