basis/interval-sets/interval-sets.factor

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