Merge remote-tracking branch 'origin/master' into modern-harvey3

basis/compiler/tree/propagation/propagation-tests.factor

@@ -1059,8 +1059,7 @@ M: tuple-with-read-only-slot clone
 ! Output range for string-nth now that string-nth is a library word and
 ! not a primitive
 { t } [
-    ! Should actually be 0 23 2^ 1 - [a,b]
+    [ string-nth ] final-info first interval>> 0 23 2^ 1 - [a,b] =
-    [ string-nth ] final-info first interval>> 0 23 2^ [a,b] =
 ] unit-test
 
 ! Non-zero displacement for <displaced-alien> restricts the output type

basis/math/intervals/intervals-tests.factor

@@ -1,6 +1,6 @@
-USING: math.intervals kernel sequences words math math.order
+USING: accessors combinators fry kernel literals math math.intervals
-arrays prettyprint tools.test random vocabs combinators
+math.intervals.private math.order math.statistics random sequences
-accessors math.constants fry ;
+sequences.deep tools.test vocabs ;
 IN: math.intervals.tests
 
 { empty-interval } [ 2 2 (a,b) ] unit-test
@@ -397,3 +397,43 @@ commutative-ops [
 { f } [ -1/0. 1/0. [ empty-interval interval-contains? ] bi@ or ] unit-test
 
 { t } [ -1/0. 1/0. [ full-interval interval-contains? ] bi@ and ] unit-test
+
+! Interval bitand
+${ 0 0xaf [a,b] } [ 0 0xff [a,b] 0 0xaf [a,b] interval-bitand ] unit-test
+${ -0x100 -10 [a,b] } [ -0xff -1 [a,b] -0xaf -10 [a,b] interval-bitand ] unit-test
+${ -0x100 10 [a,b] } [ -0xff 1 [a,b] -0xaf 10 [a,b] interval-bitand ] unit-test
+${ 0 0xff [a,b] } [ -0xff -1 [a,b] 0 0xff [a,b] interval-bitand ] unit-test
+
+! Interval bitor
+{ 1/0. } [ 1/0. bit-weight ] unit-test
+{ 1/0. } [ -1/0. bit-weight ] unit-test
+
+{ t } [
+    16 <iota> dup [ bitor ] cartesian-map flatten
+    [ 0 15 [a,b] interval-contains? ] all?
+] unit-test
+
+${ 0 256 [a,b] } [ 0 255 [a,b] dup interval-bitor ] unit-test
+${ 0 512 [a,b] } [ 0 256 [a,b] dup interval-bitor ] unit-test
+
+${ -128 127 [a,b] } [ -128 127 [a,b] dup interval-bitor ] unit-test
+${ -256 255 [a,b] } [ -128 128 [a,b] dup interval-bitor ] unit-test
+
+{ full-interval } [ full-interval -128 127 [a,b] interval-bitor ] unit-test
+${ 0 [a,inf] } [ 0 [a,inf] dup interval-bitor ] unit-test
+{ full-interval } [ 0 [-inf,a] dup interval-bitor ] unit-test
+${ 4 [a,inf] } [ 4 [a,inf] 3 [a,inf] interval-bitor ] unit-test
+
+! Interval bitxor
+${ 0 255 [a,b] } [ 0 255 [a,b] dup interval-bitxor ] unit-test
+${ 0 511 [a,b] } [ 0 256 [a,b] dup interval-bitxor ] unit-test
+
+${ -128 127 [a,b] } [ -128 127 [a,b] dup interval-bitxor ] unit-test
+${ -256 255 [a,b] } [ -128 128 [a,b] dup interval-bitxor ] unit-test
+${ 0 127 [a,b] } [ -128 -1 [a,b] dup interval-bitxor ] unit-test
+
+{ full-interval } [ full-interval -128 127 [a,b] interval-bitxor ] unit-test
+${ 0 [a,inf] } [ 0 [a,inf] dup interval-bitxor ] unit-test
+${ 0 [a,inf] } [ -1 [-inf,a] dup interval-bitxor ] unit-test
+${ 0 [a,inf] } [ 4 [a,inf] 3 [a,inf] interval-bitxor ] unit-test
+{ full-interval } [ 4 [a,inf] -3 [a,inf] interval-bitxor ] unit-test

basis/math/intervals/intervals.factor

@@ -374,45 +374,100 @@ SYMBOL: incomparable
         [ nip (rem-range) ]
     } cond ;
 
-: interval-bitand-pos ( i1 i2 -- ? )
-    [ to>> first ] bi@ min 0 swap [a,b] ;
-
-: interval-bitand-neg ( i1 i2 -- ? )
-    dup from>> first 0 < [ drop ] [ nip ] if
-    0 swap to>> first [a,b] ;
-
 : interval-nonnegative? ( i -- ? )
     from>> first 0 >= ;
 
+: interval-negative? ( interval -- ? )
+    to>> first 0 < ;
+
+<PRIVATE
+! Return the weight of the MSB.  For signed numbers, this does
+! not mean the sign bit.
+: bit-weight  ( n -- m )
+    dup [ -1/0. = ] [ 1/0. = ] bi or
+    [ drop 1/0. ]
+    [ dup 0 > [ 1 + ] [ neg ] if next-power-of-2 ] if ;
+
+GENERIC: interval-bounds ( interval -- lower upper )
+M: full-interval interval-bounds drop -1/0. 1/0. ;
+M: interval interval-bounds interval>points [ first ] bi@ ;
+
+: min-lower-bound ( i1 i2 -- n )
+    [ from>> first ] bi@ min ;
+
+: max-lower-bound ( i1 i2 -- n )
+    [ from>> first ] bi@ max ;
+
+: min-upper-bound ( i1 i2 -- n )
+    [ to>> first ] bi@ min ;
+
+: max-upper-bound ( i1 i2 -- n )
+    [ to>> first ] bi@ max ;
+
+: interval-bit-weight ( i1 -- n )
+    interval-bounds [ bit-weight ] bi@ max ;
+PRIVATE>
+
 : interval-bitand ( i1 i2 -- i3 )
-    ! Inaccurate.
     [
         {
             {
                 [ 2dup [ interval-nonnegative? ] both? ]
-                [ interval-bitand-pos ]
+                [ min-upper-bound 0 swap [a,b] ]
             }
             {
                 [ 2dup [ interval-nonnegative? ] either? ]
-                [ interval-bitand-neg ]
+                [
+                    dup interval-nonnegative? [ nip ] [ drop ] if
+                    to>> first 0 swap [a,b]
+                ]
             }
-            [ 2drop [-inf,inf] ]
+            [
+                [ min-lower-bound bit-weight neg ]
+                [
+                    2dup [ interval-negative? ] both?
+                    [ min-upper-bound ] [ max-upper-bound ] if
+                ] 2bi [a,b]
+            ]
         } cond
     ] do-empty-interval ;
 
+! Basic Property of bitor: bits can never be taken away.  For both signed and
+! unsigned integers this means that the number can only grow towards positive
+! infinity.  Also, the significant bit range can never be larger than either of
+! the operands.
+! In case both intervals are positive:
+! lower(i1 bitor i2) = max(lower(i1),lower(i2))
+! upper(i1 bitor i2) = 2 ^ max(bit-length(upper(i1)), bit-length(upper(i2))) - 1
+! In case both intervals are negative:
+! lower(i1 bitor i2) = max(lower(i1),lower(i2))
+! upper(i1 bitor i2) = -1
+! In case one is negative and the other positive, simply assume the whole
+! bit-range.  This case is not accurate though.
 : interval-bitor ( i1 i2 -- i3 )
-    ! Inaccurate.
     [
-        2dup [ interval-nonnegative? ] both?
+        { { [ 2dup [ interval-nonnegative? ] both? ]
-        [
+            ! FIXME: this should maybe be bitweight 1 -
-            [ interval>points [ first ] bi@ ] bi@
+            [ [ max-lower-bound ] [ max-upper-bound ] 2bi bit-weight [a,b] ] }
-            4array supremum 0 swap >integer next-power-of-2 [a,b]
+          { [ 2dup [ interval-negative? ] both? ]
-        ] [ 2drop [-inf,inf] ] if
+            [ max-lower-bound -1 [a,b] ] }
+          [ interval-union interval-bit-weight [ neg ] [ 1 - ] bi [a,b] ]
+        } cond
     ] do-empty-interval ;
 
+! Basic Property of bitxor: can always produce 0,  can never increase
+! significant range
+! If both operands are known to be negative, the sign bit(s) will be zero,
+! always resulting in a positive number
 : interval-bitxor ( i1 i2 -- i3 )
-    ! Inaccurate.
+    [
-    interval-bitor ;
+        { { [ 2dup [ interval-nonnegative? ] both? ]
+            [ max-upper-bound bit-weight 1 - 0 swap [a,b] ] }
+          { [ 2dup [ interval-negative? ] both? ]
+            [ min-lower-bound bit-weight 1 - 0 swap [a,b] ] }
+          [ interval-union interval-bit-weight [ neg ] [ 1 - ] bi [a,b] ]
+        } cond
+    ] do-empty-interval ;
 
 GENERIC: interval-log2 ( i1 -- i2 )
 M: empty-interval interval-log2 ;

basis/math/partial-dispatch/partial-dispatch.factor

@@ -1,10 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel kernel.private math math.private
+USING: accessors arrays assocs classes.algebra combinators
-math.functions math.functions.private sequences parser
+compiler.units fry generic generic.math hashtables kernel make
-namespaces make assocs quotations arrays generic generic.math
+math math.private namespaces quotations sequences words ;
-hashtables effects compiler.units classes.algebra fry
-combinators words ;
 IN: math.partial-dispatch
 
 PREDICATE: math-partial < word
@@ -53,35 +51,21 @@ M: word integer-op-input-classes
     '[ [ fixnum>bignum ] dip _ execute ] ;
 
 : integer-fixnum-op-quot ( fix-word big-word -- quot )
-    [
+    bignum-fixnum-op-quot '[ over fixnum? [ _ execute ] _ if ] ;
-        [ over fixnum? ] %
-        [ '[ _ execute ] , ] [ bignum-fixnum-op-quot , ] bi* \ if ,
-    ] [ ] make ;
 
 : fixnum-integer-op-quot ( fix-word big-word -- quot )
-    [
+    fixnum-bignum-op-quot '[ dup fixnum? [ _ execute ] _ if ] ;
-        [ dup fixnum? ] %
-        [ '[ _ execute ] , ] [ fixnum-bignum-op-quot , ] bi* \ if ,
-    ] [ ] make ;
 
 : integer-bignum-op-quot ( big-word -- quot )
-    [
+    [ fixnum-bignum-op-quot ] keep
-        [ over fixnum? ] %
+    '[ over fixnum? _ [ _ execute ] if ] ;
-        [ fixnum-bignum-op-quot , ] [ '[ _ execute ] , ] bi \ if ,
-    ] [ ] make ;
 
 : integer-integer-op-quot ( fix-word big-word -- quot )
-    [
+    [ bignum-fixnum-op-quot ] [ integer-bignum-op-quot ] bi
-        [ 2dup both-fixnums? ] %
+    '[
-        [ '[ _ execute ] , ]
+        2dup both-fixnums?
-        [
+        [ _ execute ] [ dup fixnum? _ _ if ] if
-            [
+    ] ;
-                [ dup fixnum? ] %
-                [ bignum-fixnum-op-quot , ]
-                [ integer-bignum-op-quot , ] bi \ if ,
-            ] [ ] make ,
-        ] bi* \ if ,
-    ] [ ] make ;
 
 : integer-op-word ( triple -- word )
     [ name>> ] map "-" join "math.partial-dispatch" create-word ;

extra/spelling/spelling.factor

@@ -1,7 +1,9 @@
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
 USING: arrays ascii assocs combinators combinators.smart fry
 http.client io.encodings.ascii io.files io.files.temp kernel
-literals locals math math.ranges math.statistics memoize
+locals math math.ranges math.statistics memoize sequences
-sequences sequences.private sets sorting splitting strings urls ;
+sequences.private sorting splitting urls ;
 IN: spelling
 
 ! http://norvig.com/spell-correct.html
@@ -12,23 +14,19 @@ CONSTANT: ALPHABET "abcdefghijklmnopqrstuvwxyz"
     [ length <iota> ] keep '[ _ remove-nth ] map ;
 
 : transposes ( word -- edits )
-    [ length [1,b) ] keep '[
+    [ length [1,b) ] keep
-        dup 1 - _ clone [ exchange-unsafe ] keep
+    '[ dup 1 - _ clone [ exchange-unsafe ] keep ] map ;
-    ] map ;
+
+: replace1 ( i word -- words )
+    [ ALPHABET ] 2dip bounds-check
+    '[ _ _ clone [ set-nth-unsafe ] keep ] { } map-as ;
 
 : replaces ( word -- edits )
-    [ length <iota> ] keep '[
+    [ length <iota> ] keep '[ _ replace1 ] map concat ;
-        ALPHABET [
-            swap _ clone [ set-nth-unsafe ] keep
-        ] with { } map-as
-    ] map concat ;
 
 : inserts ( word -- edits )
-    [ length [0,b] ] keep '[
+    [ length [0,b] ] keep
-        char: ? over _ insert-nth ALPHABET swap [
+    '[ char: ? over _ insert-nth replace1 ] map concat ;
-            swapd clone [ set-nth-unsafe ] keep
-        ] curry with { } map-as
-    ] map concat ;
 
 : edits1 ( word -- edits )
     [