extra/digraphs/digraphs.factor

   1 USING: accessors assocs kernel new-slots sequences vectors ;
   2 IN: digraphs
   3
   4 TUPLE: digraph ;
   5 TUPLE: vertex value edges ;
   6
   7 : <digraph> ( -- digraph )
   8     digraph construct-empty H{ } clone over set-delegate ;
   9
  10 : <vertex> ( value -- vertex )
  11     V{ } clone vertex construct-boa ;
  12
  13 : add-vertex ( key value digraph -- )
  14     >r <vertex> swap r> set-at ;
  15
  16 : children ( key digraph -- seq )
  17     at edges>> ;
  18
  19 : @edges ( from to digraph -- to edges ) swapd at edges>> ;
  20 : add-edge ( from to digraph -- ) @edges push ;
  21 : delete-edge ( from to digraph -- ) @edges delete ;
  22
  23 : delete-to-edges ( to digraph -- )
  24     [ nip dupd edges>> delete ] assoc-each drop ;
  25
  26 : delete-vertex ( key digraph -- )
  27     2dup delete-at delete-to-edges ;
  28
  29 : unvisited? ( unvisited key -- ? ) swap key? ;
  30 : visited ( unvisited key -- ) swap delete-at ;
  31
  32 DEFER: (topological-sort)
  33 : visit-children ( seq unvisited key -- seq unvisited )
  34     over children [ (topological-sort) ] each ;
  35
  36 : (topological-sort) ( seq unvisited key -- seq unvisited )
  37     2dup unvisited? [
  38         [ visit-children ] keep 2dup visited pick push
  39     ] [
  40         drop
  41     ] if ;
  42
  43 : topological-sort ( digraph -- seq )
  44     dup clone V{ } clone spin
  45     [ drop (topological-sort) ] assoc-each drop reverse ;