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