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