Add set methods to ranges

[factor.git] / core / ranges / ranges.factor

diff --git a/core/ranges/ranges.factor b/core/ranges/ranges.factor
index 3f1e3d0bb69611bd04ef86b38155ca17703a709b..9f58e81a8281091f87f2c0d846ef5a1d18ef2d70 100644 (file)
--- a/core/ranges/ranges.factor
+++ b/core/ranges/ranges.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: accessors classes.tuple kernel math math.order sequences
-sequences.private ;
+USING: accessors classes.algebra classes.tuple kernel locals
+math math.order sequences sequences.private sets sorting ;
 IN: ranges
 
 TUPLE: range
@@ -62,3 +62,74 @@ PRIVATE>
 : [0..b) ( b -- range ) 0 swap [a..b) ; inline
 
 : [1..b) ( b -- range ) 1 swap [a..b) ; inline
+
+
+! Some methods can be much faster for ranges
+M: range in?
+    over number?
+    [ [ from>> ] [ step>> ] [ length>> 1 - ] tri
+        [ * over + sort-pair between? ] 4keep
+        drop 3dup [ - ] dip /i * + = and
+    ] [ 2drop f ] if ;
+
+M: range cardinality length>> ;
+
+M: range all-unique? drop t ;
+
+M: range duplicates drop f ;
+
+<PRIVATE
+
+: start-stop-step>> ( range -- start stop step )
+    [ from>> ] [ step>> ]
+    [ length>> 1 - 2over swapd * + ] tri swap ;
+
+: rev-range ( range -- range' )
+    start-stop-step>> neg swapd <range> ;
+
+: abs-step ( range -- range' )
+    dup step>> neg? [ rev-range ] when ; inline
+
+: empty-range ( -- range ) 1 0 1 <range> ;
+
+! https://github.com/JuliaLang/julia/blob/8e14322b5aa344639dd86bf9eabb84afe831fcba/base/range.jl#L1185
+:: (intersect) ( range1 range2 -- range' )
+    range1 empty? range2 empty? or [ empty-range ] [
+        
+        range1 abs-step start-stop-step>> :> ( start1 stop1 step1 )
+        range2 abs-step start-stop-step>> :> ( start2 stop2 step2 )
+
+        step1 step2 [ * ] 2keep simple-gcd /i :> a
+        step1 step2 gcd :> ( x g )
+
+        start1 start2 - g /mod :> ( z y )
+
+        y zero? not [ empty-range ] [
+        
+        start1 x z step1 * * - :> b
+
+        start1 start2 [ b over - a rem + ] bi@ max :> m
+        stop1  stop2  [  dup b - a rem - ] bi@ min :> n
+
+        m n a <range>
+    ] if ] if ;
+    
+PRIVATE>
+
+M: range intersect
+    over range? [ (intersect) ] [ call-next-method ] if ;
+
+M: range intersects?
+    over range?
+    [ intersect length>> zero? not ]
+    [ call-next-method ] if ;
+
+M: range set=
+    over range?
+    [ [ [ empty-range ] [ abs-step ] if-empty ] bi@ = ]
+    [ call-next-method ] if ;
+
+M: range subset?
+    swap [ drop t ] [ swap over range?
+        [ dupd (intersect) = ] [ call-next-method ] if
+    ] if-empty ;
\ No newline at end of file