extra/digraphs/digraphs.factor

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