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