extra/digraphs/digraphs.factor

   1 ! Copyright (C) 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs kernel new-slots sequences vectors ;
   4 IN: digraphs
   5
   6 TUPLE: digraph ;
   7 TUPLE: vertex value edges ;
   8
   9 : <digraph> ( -- digraph )
  10     digraph construct-empty H{ } clone over set-delegate ;
  11
  12 : <vertex> ( value -- vertex )
  13     V{ } clone vertex construct-boa ;
  14
  15 : add-vertex ( key value digraph -- )
  16     >r <vertex> swap r> set-at ;
  17
  18 : children ( key digraph -- seq )
  19     at edges>> ;
  20
  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 ;
  24
  25 : delete-to-edges ( to digraph -- )
  26     [ nip dupd edges>> delete ] assoc-each drop ;
  27
  28 : delete-vertex ( key digraph -- )
  29     2dup delete-at delete-to-edges ;
  30
  31 : unvisited? ( unvisited key -- ? ) swap key? ;
  32 : visited ( unvisited key -- ) swap delete-at ;
  33
  34 DEFER: (topological-sort)
  35 : visit-children ( seq unvisited key -- seq unvisited )
  36     over children [ (topological-sort) ] each ;
  37
  38 : (topological-sort) ( seq unvisited key -- seq unvisited )
  39     2dup unvisited? [
  40         [ visit-children ] keep 2dup visited pick push
  41     ] [
  42         drop
  43     ] if ;
  44
  45 : topological-sort ( digraph -- seq )
  46     dup clone V{ } clone spin
  47     [ drop (topological-sort) ] assoc-each drop reverse ;
  48
  49 : topological-sorted-values ( digraph -- seq )
  50     dup topological-sort swap [ at value>> ] curry map ;