basis/interval-maps/interval-maps.factor

   1 ! Copyright (C) 2008 Daniel Ehrenberg.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: kernel sequences arrays accessors grouping math.order\r
   4 sorting binary-search math assocs locals namespaces make ;\r
   5 IN: interval-maps\r
   6 \r
   7 TUPLE: interval-map array ;\r
   8 \r
   9 <PRIVATE\r
  10 \r
  11 : find-interval ( key interval-map -- interval-node )\r
  12     [ first <=> ] with search nip ;\r
  13 \r
  14 : interval-contains? ( key interval-node -- ? )\r
  15     first2 between? ;\r
  16 \r
  17 : all-intervals ( sequence -- intervals )\r
  18     [ >r dup number? [ dup 2array ] when r> ] { } assoc-map-as ;\r
  19 \r
  20 : disjoint? ( node1 node2 -- ? )\r
  21     [ second ] [ first ] bi* < ;\r
  22 \r
  23 : ensure-disjoint ( intervals -- intervals )\r
  24     dup [ disjoint? ] monotonic?\r
  25     [ "Intervals are not disjoint" throw ] unless ;\r
  26 \r
  27 : >intervals ( specification -- intervals )\r
  28     [ suffix ] { } assoc>map concat 3 <groups> ;\r
  29 \r
  30 PRIVATE>\r
  31 \r
  32 : interval-at* ( key map -- value ? )\r
  33     [ drop ] [ array>> find-interval ] 2bi\r
  34     tuck interval-contains? [ third t ] [ drop f f ] if ;\r
  35 \r
  36 : interval-at ( key map -- value ) interval-at* drop ;\r
  37 \r
  38 : interval-key? ( key map -- ? ) interval-at* nip ;\r
  39 \r
  40 : <interval-map> ( specification -- map )\r
  41     all-intervals [ [ first second ] compare ] sort\r
  42     >intervals ensure-disjoint interval-map boa ;\r
  43 \r
  44 : <interval-set> ( specification -- map )\r
  45     [ dup 2array ] map <interval-map> ;\r
  46 \r
  47 :: coalesce ( alist -- specification )\r
  48     ! Only works with integer keys, because they're discrete\r
  49     ! Makes 2array keys\r
  50     [\r
  51         alist sort-keys unclip first2 dupd roll\r
  52         [| oldkey oldval key val | ! Underneath is start\r
  53             oldkey 1+ key =\r
  54             oldval val = and\r
  55             [ oldkey 2array oldval 2array , key ] unless\r
  56             key val\r
  57         ] assoc-each [ 2array ] bi@ ,\r
  58     ] { } make ;\r