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 ALIAS: start first\r
  12 ALIAS: end second\r
  13 ALIAS: value third\r
  14 \r
  15 : find-interval ( key interval-map -- interval-node )\r
  16     array>> [ start <=> ] with search nip ;\r
  17 \r
  18 : interval-contains? ( key interval-node -- ? )\r
  19     [ start ] [ end ] bi between? ;\r
  20 \r
  21 : all-intervals ( sequence -- intervals )\r
  22     [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;\r
  23 \r
  24 : disjoint? ( node1 node2 -- ? )\r
  25     [ end ] [ start ] bi* < ;\r
  26 \r
  27 : ensure-disjoint ( intervals -- intervals )\r
  28     dup [ disjoint? ] monotonic?\r
  29     [ "Intervals are not disjoint" throw ] unless ;\r
  30 \r
  31 : >intervals ( specification -- intervals )\r
  32     [ suffix ] { } assoc>map concat 3 <groups> ;\r
  33 \r
  34 PRIVATE>\r
  35 \r
  36 : interval-at* ( key map -- value ? )\r
  37     [ drop ] [ find-interval ] 2bi\r
  38     [ nip ] [ interval-contains? ] 2bi\r
  39     [ value t ] [ drop f f ] if ;\r
  40 \r
  41 : interval-at ( key map -- value ) interval-at* drop ;\r
  42 \r
  43 : interval-key? ( key map -- ? ) interval-at* nip ;\r
  44 \r
  45 : interval-values ( map -- values )\r
  46     array>> [ value ] map ;\r
  47 \r
  48 : <interval-map> ( specification -- map )\r
  49     all-intervals [ first second ] sort-with\r
  50     >intervals ensure-disjoint interval-map boa ;\r
  51 \r
  52 : <interval-set> ( specification -- map )\r
  53     dup zip <interval-map> ;\r
  54 \r
  55 :: coalesce ( alist -- specification )\r
  56     ! Only works with integer keys, because they're discrete\r
  57     ! Makes 2array keys\r
  58     [\r
  59         alist sort-keys unclip swap [ [ first dup ] [ second ] bi ] dip\r
  60         [| oldkey oldval key val | ! Underneath is start\r
  61             oldkey 1 + key =\r
  62             oldval val = and\r
  63             [ oldkey 2array oldval 2array , key ] unless\r
  64             key val\r
  65         ] assoc-each [ 2array ] bi@ ,\r
  66     ] { } make ;\r