core/ranges/ranges.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays classes.algebra classes.tuple kernel
   4 math math.order parser sequences sequences.private sets sorting ;
   5 IN: ranges
   6
   7 TUPLE: range
   8 { from number read-only }
   9 { length integer read-only }
  10 { step number read-only } ;
  11
  12 <PRIVATE
  13
  14 : sign/mod ( x y -- z w )
  15     [ [ /i ] 2keep pick * - ] keep 0 < [ neg ] when ; inline
  16
  17 PRIVATE>
  18
  19 : <range> ( a b step -- range )
  20     [ over - ] dip
  21     [ sign/mod 0 < [ 1 + ] unless 0 max ] keep
  22     range boa ; inline
  23
  24 M: range length length>> ; inline
  25
  26 M: range nth-unsafe
  27     [ step>> * ] keep from>> + ; inline
  28
  29 ! We want M\ tuple hashcode, not M\ sequence hashcode here!
  30 ! sequences hashcode is O(n) in number of elements
  31 M: range hashcode* tuple-hashcode ;
  32
  33 INSTANCE: range immutable-sequence
  34
  35 M: range sum
  36     dup length
  37     [ drop 0 ]
  38     [ swap [ first-unsafe ] [ last-unsafe ] bi + * 2 / ] if-zero ;
  39
  40 M: range minimum
  41     dup step>> 0 > [ first ] [ last ] if ;
  42
  43 M: range maximum
  44     dup step>> 0 > [ last ] [ first ] if ;
  45
  46 <PRIVATE
  47
  48 : twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
  49
  50 : (a.. ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
  51
  52 : ..b) ( a b step -- a' b' step )
  53     2over - over mod zero? [ dup [ - ] curry dip ] when ; inline
  54
  55 PRIVATE>
  56
  57 : [a..b] ( a b -- range ) twiddle <range> ; inline
  58
  59 : (a..b] ( a b -- range ) twiddle (a.. <range> ; inline
  60
  61 : [a..b) ( a b -- range ) twiddle ..b) <range> ; inline
  62
  63 : (a..b) ( a b -- range ) twiddle (a.. ..b) <range> ; inline
  64
  65 : [0..b] ( b -- range ) 0 swap [a..b] ; inline
  66
  67 : [1..b] ( b -- range ) 1 swap [a..b] ; inline
  68
  69 : [0..b) ( b -- range ) 0 swap [a..b) ; inline
  70
  71 : [1..b) ( b -- range ) 1 swap [a..b) ; inline
  72
  73 ! Some methods can be much faster for ranges
  74
  75 <PRIVATE
  76
  77 : >range< ( range -- start stop step )
  78     [ from>> ] [ length>> ] [ step>> ] tri [ swap 1 - * over + ] keep ;
  79
  80 : >forward-range< ( range -- start stop step )
  81     >range< dup neg? [ abs swapd ] when ;
  82
  83 : forward-range ( range -- range' )
  84     >forward-range< <range> ; inline
  85
  86 CONSTANT: empty-range T{ range f 1 0 1 }
  87
  88 :: intersect-range ( range1 range2 -- range3 )
  89     range1 empty? range2 empty? or [ empty-range ] [
  90         range1 >forward-range< :> ( start1 stop1 step1 )
  91         range2 >forward-range< :> ( start2 stop2 step2 )
  92         step1 step2 gcd :> ( x g )
  93         start1 start2 - g /mod :> ( z y )
  94         y zero? not [ empty-range ] [
  95             start1 x z step1 * * - :> b
  96             step1 step2 lcm :> a
  97             start1 start2 [ b over - a rem + ] bi@ max :> m
  98             stop1  stop2  [  dup b - a rem - ] bi@ min :> n
  99             m n a <range>
 100         ] if
 101     ] if ;
 102
 103 PRIVATE>
 104
 105 M: range in?
 106     over number? [
 107         >forward-range< [ 3dup between? ] dip swap
 108         [ nip 3dup [ - ] dip /i * + = ] [ 4drop f ] if
 109     ] [ 2drop f ] if ;
 110
 111 M: range cardinality length>> ;
 112
 113 M: range all-unique? drop t ;
 114
 115 M: range duplicates drop f ;
 116
 117 M: range members >array ; ! XXX: just return a T{ range } ? ;
 118
 119 M: range intersect
 120     over range? [ intersect-range ] [ call-next-method ] if ;
 121
 122 M: range intersects?
 123     over range?
 124     [ intersect-range length>> zero? not ]
 125     [ call-next-method ] if ;
 126
 127 M: range set=
 128     over range?
 129     [ [ [ empty-range ] [ forward-range ] if-empty ] bi@ = ]
 130     [ call-next-method ] if ;
 131
 132 M: range subset?
 133     over range?
 134     [ over empty? [ 2drop t ] [ dupd intersect-range = ] if ]
 135     [ call-next-method ] if ;
 136
 137 SYNTAX: ..= dup pop scan-object [a..b] suffix! ;
 138
 139 SYNTAX: ..< dup pop scan-object [a..b) suffix! ;