extra/graph-theory/graph-theory.factor

   1 ! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: kernel combinators fry continuations sequences arrays vectors assocs hashtables heaps namespaces ;
   5
   6 IN: graph-theory
   7
   8 MIXIN: graph
   9 SYMBOL: visited?
  10 ERROR: end-search ;
  11
  12 GENERIC: vertices ( graph -- seq ) flushable
  13
  14 GENERIC: num-vertices ( graph -- n ) flushable
  15
  16 GENERIC: num-edges ( graph -- n ) flushable
  17
  18 GENERIC: adjlist ( from graph -- seq ) flushable
  19
  20 GENERIC: adj? ( from to graph -- ? ) flushable
  21
  22 GENERIC: add-blank-vertex ( index graph -- )
  23
  24 GENERIC: delete-blank-vertex ( index graph -- )
  25
  26 GENERIC: add-edge* ( from to graph -- )
  27
  28 GENERIC: add-edge ( u v graph -- )
  29
  30 GENERIC: delete-edge* ( from to graph -- )
  31
  32 GENERIC: delete-edge ( u v graph -- )
  33
  34 M: graph num-vertices
  35     vertices length ;
  36
  37 M: graph num-edges
  38    [ vertices ] [ '[ _ adjlist length ] map sum ] bi ;
  39
  40 M: graph adjlist
  41     [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
  42
  43 M: graph adj?
  44     swapd adjlist index >boolean ;
  45
  46 M: graph add-edge
  47     [ add-edge* ] [ swapd add-edge* ] 3bi ;
  48
  49 M: graph delete-edge
  50     [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
  51
  52 : add-blank-vertices ( seq graph -- )
  53     '[ _ add-blank-vertex ] each ;
  54
  55 : delete-vertex ( index graph -- )
  56     [ adjlist ]
  57     [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
  58     [ delete-blank-vertex ] 2tri ;
  59
  60 <PRIVATE
  61
  62 : search-wrap ( quot graph -- ? )
  63     [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
  64       [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
  65
  66 : (depth-first) ( v pre post -- )
  67     { [ 2drop visited? get t -rot set-at ]
  68       [ drop call ]
  69       [ [ graph get adjlist ] 2dip
  70         '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
  71       [ nip call ] } 3cleave ; inline
  72
  73 PRIVATE>
  74
  75 : depth-first ( v graph pre post -- ?list ? )
  76     '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
  77
  78 : full-depth-first ( graph pre post tail -- ? )
  79     '[ [ visited? get [ nip not ] assoc-find ]
  80        [ drop _ _ (depth-first) @ ]
  81        [ 2drop ] while ] swap search-wrap ; inline
  82
  83 : dag? ( graph -- ? )
  84     V{ } clone swap [ 2dup swap push dupd
  85                      '[ _ swap graph get adj? not ] all?
  86                       [ end-search ] unless ]
  87                     [ drop dup pop* ] [ ] full-depth-first nip ;
  88
  89 : topological-sort ( graph -- seq/f )
  90     dup dag?
  91     [ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
  92     [ drop f ] if ;