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