basis/interval-sets/interval-sets.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences binary-search accessors math.order
   4 specialized-arrays.uint make grouping math arrays
   5 sorting assocs locals combinators fry hints ;
   6 IN: interval-sets
   7 ! Sets of positive integers
   8
   9 TUPLE: interval-set { array uint-array read-only } ;
  10
  11 <PRIVATE
  12
  13 ALIAS: start first
  14 ALIAS: end second
  15
  16 : find-interval ( key interval-set -- slice )
  17     array>> 2 <sliced-groups>
  18     [ start <=> ] with search nip ; inline
  19
  20 PRIVATE>
  21
  22 : in? ( key set -- ? )
  23     dupd find-interval
  24     [ [ start ] [ end 1- ] bi between? ]
  25     [ drop f ] if* ;
  26
  27 HINTS: in? { integer interval-set } ;
  28
  29 <PRIVATE
  30
  31 : spec>pairs ( sequence -- intervals )
  32     [ dup number? [ dup 2array ] when ] map ;
  33
  34 : disjoint? ( node1 node2 -- ? )
  35     [ end ] [ start ] bi* < ;
  36
  37 : (delete-redundancies) ( seq -- )
  38     dup length {
  39         { 0 [ drop ] }
  40         { 1 [ % ] }
  41         [
  42             drop dup first2 <
  43             [ unclip-slice , ]
  44             [ 2 tail-slice ] if
  45             (delete-redundancies)
  46         ]
  47     } case ;
  48
  49 : delete-redundancies ( seq -- seq' )
  50     ! If the next element is >= current one, leave out both
  51     [ (delete-redundancies) ] uint-array{ } make ;
  52
  53 : make-intervals ( seq -- interval-set )
  54     uint-array{ } like
  55     delete-redundancies
  56     interval-set boa ;
  57
  58 : >intervals ( seq -- seq' )
  59     [ 1+ ] assoc-map concat ;
  60
  61 PRIVATE>
  62
  63 : <interval-set> ( specification -- interval-set )
  64     spec>pairs sort-keys
  65     >intervals make-intervals ;
  66
  67 <PRIVATE
  68
  69 :: or-step ( set1 set2 -- set1' set2' )
  70     set1 first ,
  71     set1 second set2 first <=
  72     [ set1 0 ] [ set2 2 ] if
  73     [ second , ] [ set2 swap tail-slice ] bi*
  74     set1 2 tail-slice ;
  75
  76 : combine-or ( set1 set2 -- )
  77     {
  78         { [ over empty? ] [ % drop ] }
  79         { [ dup empty? ] [ drop % ] }
  80         [
  81             2dup [ first ] bi@ <=
  82             [ swap ] unless
  83             or-step combine-or
  84         ]
  85     } cond ;
  86
  87 PRIVATE>
  88
  89 : <interval-or> ( set1 set2 -- set )
  90     [ array>> ] bi@
  91     [ combine-or ] uint-array{ } make
  92     make-intervals ;
  93
  94 <PRIVATE
  95
  96 : prefix-0 ( seq -- 0seq )
  97     0 over ?nth zero? [ rest ] [ 0 prefix ] if ;
  98
  99 : interval-max ( interval-set1 interval-set2 -- n )
 100     [ array>> [ 0 ] [ peek ] if-empty ] bi@ max ;
 101
 102 PRIVATE>
 103
 104 : <interval-not> ( set maximum -- set' )
 105     [ array>> prefix-0 ] dip suffix make-intervals ;
 106
 107 : <interval-and> ( set1 set2 -- set )
 108     2dup interval-max
 109     [ '[ _ <interval-not> ] bi@ <interval-or> ] keep
 110     <interval-not> ;