unmaintained/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 USING: kernel combinators fry continuations sequences arrays
   4 vectors assocs hashtables heaps namespaces ;
   5 IN: graph-theory
   6
   7 MIXIN: graph
   8 SYMBOL: visited?
   9 ERROR: end-search ;
  10
  11 GENERIC: vertices ( graph -- seq ) flushable
  12
  13 GENERIC: num-vertices ( graph -- n ) flushable
  14
  15 GENERIC: num-edges ( graph -- n ) flushable
  16
  17 GENERIC: adjlist ( from graph -- seq ) flushable
  18
  19 GENERIC: adj? ( from to graph -- ? ) flushable
  20
  21 GENERIC: add-blank-vertex ( index graph -- )
  22
  23 GENERIC: delete-blank-vertex ( index graph -- )
  24
  25 GENERIC: add-edge* ( from to graph -- )
  26
  27 GENERIC: add-edge ( u v graph -- )
  28
  29 GENERIC: delete-edge* ( from to graph -- )
  30
  31 GENERIC: delete-edge ( u v graph -- )
  32
  33 M: graph num-vertices
  34     vertices length ;
  35
  36 M: graph num-edges
  37    [ vertices ] [ '[ _ adjlist length ] map-sum ] bi ;
  38
  39 M: graph adjlist
  40     [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
  41
  42 M: graph adj?
  43     swapd adjlist index >boolean ;
  44
  45 M: graph add-edge
  46     [ add-edge* ] [ swapd add-edge* ] 3bi ;
  47
  48 M: graph delete-edge
  49     [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
  50
  51 : add-blank-vertices ( seq graph -- )
  52     '[ _ add-blank-vertex ] each ;
  53
  54 : delete-vertex ( index graph -- )
  55     [ adjlist ]
  56     [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
  57     [ delete-blank-vertex ] 2tri ;
  58
  59 <PRIVATE
  60
  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
  64
  65 : (depth-first) ( v pre post -- )
  66     { [ 2drop visited? get t -rot set-at ]
  67       [ drop call ]
  68       [ [ graph get adjlist ] 2dip
  69         '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
  70       [ nip call ] } 3cleave ; inline
  71
  72 PRIVATE>
  73
  74 : depth-first ( v graph pre post -- ?list ? )
  75     '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
  76
  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
  81
  82 : dag? ( graph -- ? )
  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 ;
  87
  88 : topological-sort ( graph -- seq/f )
  89     dup dag?
  90     [ V{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
  91     [ drop f ] if ;