basis/interval-maps/interval-maps.factor

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