From 713cfa79f84d2e7abde5428310e483d7bd760c18 Mon Sep 17 00:00:00 2001 From: timor Date: Wed, 28 Aug 2019 11:27:07 +0200 Subject: [PATCH 01/10] math.intervals: more exact interval-bitor operation Addresses #2170 - fixed: `interval-bitor` caused bit-growth - improved: `interval-bitor` more exact about lower bounds The added utility words could be used as a basis to make the other bitwise interval operations more exact also. --- basis/math/intervals/intervals-tests.factor | 46 ++++++++++++++++-- basis/math/intervals/intervals.factor | 53 +++++++++++++++++++-- 2 files changed, 91 insertions(+), 8 deletions(-) diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index bb1e657710..f7ae5dc9c0 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -1,8 +1,10 @@ -USING: math.intervals kernel sequences words math math.order -arrays prettyprint tools.test random vocabs combinators -accessors math.constants fry ; +USING: accessors combinators fry kernel literals math math.intervals +math.intervals.private math.order math.statistics random sequences +sequences.deep tools.test vocabs ; IN: math.intervals.tests +FROM: math.ranges => ; + { empty-interval } [ 2 2 (a,b) ] unit-test { empty-interval } [ 2 2.0 (a,b) ] unit-test @@ -385,7 +387,7 @@ commutative-ops [ ] unit-test ] each -! Test singleton behavior +! test singleton behavior { f } [ full-interval interval-nonnegative? ] unit-test { t } [ empty-interval interval-nonnegative? ] unit-test @@ -397,3 +399,39 @@ 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 bitor + +{ 1/0. } [ 1/0. bit-weight ] unit-test +{ 1/0. } [ -1/0. bit-weight ] unit-test + +{ t } [ + 16 dup [ bitor ] cartesian-map flatten + [ 0 15 [a,b] interval-contains? ] all? +] unit-test + +: cartesian-bounds ( range range quot -- min max ) + cartesian-map flatten minmax ; inline + +{ 0 15 } [ 16 dup [ bitor ] cartesian-bounds ] unit-test +{ 0 15 } [ 16 dup [ bitxor ] cartesian-bounds ] unit-test + +{ -8 7 } [ -8 7 1 dup [ bitor ] cartesian-bounds ] unit-test +{ -8 7 } [ -8 7 1 dup [ bitxor ] cartesian-bounds ] unit-test + +{ 6 15 } [ 5 15 1 6 15 1 [ bitor ] cartesian-bounds ] unit-test + +{ -12 -1 } [ -16 -12 1 -12 -2 1 [ bitor ] cartesian-bounds ] unit-test + +{ -16 15 } [ -16 4 1 -1 15 1 [ bitor ] cartesian-bounds ] unit-test + +{ $[ 0 255 [a,b] ] } [ 0 255 [a,b] dup interval-bitor ] unit-test +{ $[ 0 511 [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 diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index a12b1d6e2f..2d5a02825c 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -384,6 +384,9 @@ SYMBOL: incomparable : interval-nonnegative? ( i -- ? ) from>> first 0 >= ; +: interval-negative? ( interval -- ? ) + to>> first 0 < ; + : interval-bitand ( i1 i2 -- i3 ) ! Inaccurate. [ @@ -400,7 +403,53 @@ SYMBOL: incomparable } cond ] do-empty-interval ; + [ 1 + ] [ neg ] if next-power-of-2 ] if ; + +: bounds ( interval -- lower upper ) + { + { full-interval [ -1/0. 1/0. ] } + [ interval>points [ first ] bi@ ] + } case ; + +: max-lower-bound ( i1 i2 -- n ) + [ from>> first ] bi@ max ; + +: max-upper-bound ( i1 i2 -- n ) + [ to>> first ] bi@ max ; + +: interval-bit-weight ( i1 -- n ) + bounds [ bit-weight ] bi@ max ; +PRIVATE> + +! 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 ) + [ + { { [ 2dup [ interval-nonnegative? ] both? ] + [ [ max-lower-bound ] [ max-upper-bound ] 2bi bit-weight 1 - [a,b] ] } + { [ 2dup [ interval-negative? ] both? ] + [ max-lower-bound -1 [a,b] ] } + [ interval-union interval-bit-weight [ neg ] [ 1 - ] bi [a,b] ] + } cond + ] do-empty-interval ; + +: interval-bitxor ( i1 i2 -- i3 ) ! Inaccurate. [ 2dup [ interval-nonnegative? ] both? @@ -410,10 +459,6 @@ SYMBOL: incomparable ] [ 2drop [-inf,inf] ] if ] do-empty-interval ; -: interval-bitxor ( i1 i2 -- i3 ) - ! Inaccurate. - interval-bitor ; - GENERIC: interval-log2 ( i1 -- i2 ) M: empty-interval interval-log2 ; M: full-interval interval-log2 drop [0,inf] ; From 449224878fc07164230868e73437e47f9a89c3ab Mon Sep 17 00:00:00 2001 From: timor Date: Wed, 28 Aug 2019 12:32:14 +0200 Subject: [PATCH 02/10] math.intervals: more exact interval-bitxor operation - fixed: `interval-bitxor` caused bit-growth - improved: `interval-bitxor` more exact case for negative intervals --- basis/math/intervals/intervals-tests.factor | 24 +++++++++++++++++++-- basis/math/intervals/intervals.factor | 19 ++++++++++------ 2 files changed, 35 insertions(+), 8 deletions(-) diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index f7ae5dc9c0..a1a4fa6e2f 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -414,10 +414,8 @@ commutative-ops [ cartesian-map flatten minmax ; inline { 0 15 } [ 16 dup [ bitor ] cartesian-bounds ] unit-test -{ 0 15 } [ 16 dup [ bitxor ] cartesian-bounds ] unit-test { -8 7 } [ -8 7 1 dup [ bitor ] cartesian-bounds ] unit-test -{ -8 7 } [ -8 7 1 dup [ bitxor ] cartesian-bounds ] unit-test { 6 15 } [ 5 15 1 6 15 1 [ bitor ] cartesian-bounds ] unit-test @@ -435,3 +433,25 @@ commutative-ops [ { $[ 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 15 } [ 16 dup [ bitxor ] cartesian-bounds ] unit-test + +{ -8 7 } [ -8 7 1 dup [ bitxor ] cartesian-bounds ] unit-test + +{ 0 15 } [ -16 -1 1 dup [ bitxor ] cartesian-bounds ] unit-test + +{ -16 15 } [ -16 0 1 dup [ bitxor ] cartesian-bounds ] unit-test + +{ $[ 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 diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 2d5a02825c..e9e6cdf2ee 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -417,6 +417,9 @@ SYMBOL: incomparable [ interval>points [ first ] bi@ ] } case ; +: min-lower-bound ( i1 i2 -- n ) + [ from>> first ] bi@ min ; + : max-lower-bound ( i1 i2 -- n ) [ from>> first ] bi@ max ; @@ -449,14 +452,18 @@ PRIVATE> } 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. [ - 2dup [ interval-nonnegative? ] both? - [ - [ interval>points [ first ] bi@ ] bi@ - 4array supremum 0 swap >integer next-power-of-2 [a,b] - ] [ 2drop [-inf,inf] ] if + { { [ 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 ) From 30f2d6e78f744f1a27b8a9896d79f2ea0e5a7e87 Mon Sep 17 00:00:00 2001 From: timor Date: Thu, 29 Aug 2019 08:19:57 +0200 Subject: [PATCH 03/10] math.intervals.tests: clean up literal syntax --- basis/math/intervals/intervals-tests.factor | 28 ++++++++++----------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index a1a4fa6e2f..15e49caba5 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -423,16 +423,16 @@ commutative-ops [ { -16 15 } [ -16 4 1 -1 15 1 [ bitor ] cartesian-bounds ] unit-test -{ $[ 0 255 [a,b] ] } [ 0 255 [a,b] dup interval-bitor ] unit-test -{ $[ 0 511 [a,b] ] } [ 0 256 [a,b] dup interval-bitor ] unit-test +${ 0 255 [a,b] } [ 0 255 [a,b] dup interval-bitor ] unit-test +${ 0 511 [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 +${ -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 +${ 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 +${ 4 [a,inf] } [ 4 [a,inf] 3 [a,inf] interval-bitor ] unit-test ! interval-bitxor { 0 15 } [ 16 dup [ bitxor ] cartesian-bounds ] unit-test @@ -443,15 +443,15 @@ commutative-ops [ { -16 15 } [ -16 0 1 dup [ bitxor ] cartesian-bounds ] unit-test -{ $[ 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 +${ 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 +${ -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 +${ 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 From 20c4e2feaaf338e4710019a2ebc1d8b108899abc Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 30 Oct 2019 09:47:04 -0700 Subject: [PATCH 04/10] math.intervals: remove extra non-interval tests. --- basis/math/intervals/intervals-tests.factor | 28 ++------------------- 1 file changed, 2 insertions(+), 26 deletions(-) diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 15e49caba5..293f49b69a 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -3,8 +3,6 @@ math.intervals.private math.order math.statistics random sequences sequences.deep tools.test vocabs ; IN: math.intervals.tests -FROM: math.ranges => ; - { empty-interval } [ 2 2 (a,b) ] unit-test { empty-interval } [ 2 2.0 (a,b) ] unit-test @@ -387,7 +385,7 @@ commutative-ops [ ] unit-test ] each -! test singleton behavior +! Test singleton behavior { f } [ full-interval interval-nonnegative? ] unit-test { t } [ empty-interval interval-nonnegative? ] unit-test @@ -401,7 +399,6 @@ commutative-ops [ { t } [ -1/0. 1/0. [ full-interval interval-contains? ] bi@ and ] unit-test ! Interval bitor - { 1/0. } [ 1/0. bit-weight ] unit-test { 1/0. } [ -1/0. bit-weight ] unit-test @@ -410,19 +407,6 @@ commutative-ops [ [ 0 15 [a,b] interval-contains? ] all? ] unit-test -: cartesian-bounds ( range range quot -- min max ) - cartesian-map flatten minmax ; inline - -{ 0 15 } [ 16 dup [ bitor ] cartesian-bounds ] unit-test - -{ -8 7 } [ -8 7 1 dup [ bitor ] cartesian-bounds ] unit-test - -{ 6 15 } [ 5 15 1 6 15 1 [ bitor ] cartesian-bounds ] unit-test - -{ -12 -1 } [ -16 -12 1 -12 -2 1 [ bitor ] cartesian-bounds ] unit-test - -{ -16 15 } [ -16 4 1 -1 15 1 [ bitor ] cartesian-bounds ] unit-test - ${ 0 255 [a,b] } [ 0 255 [a,b] dup interval-bitor ] unit-test ${ 0 511 [a,b] } [ 0 256 [a,b] dup interval-bitor ] unit-test @@ -434,15 +418,7 @@ ${ 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 15 } [ 16 dup [ bitxor ] cartesian-bounds ] unit-test - -{ -8 7 } [ -8 7 1 dup [ bitxor ] cartesian-bounds ] unit-test - -{ 0 15 } [ -16 -1 1 dup [ bitxor ] cartesian-bounds ] unit-test - -{ -16 15 } [ -16 0 1 dup [ bitxor ] cartesian-bounds ] 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 From 29ebfe5129618540ead3ab7e7dbf0fd7009693ca Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 31 Oct 2019 10:03:44 -0700 Subject: [PATCH 05/10] compiler.tree.propagation: fix test for improved interval-bitor. --- basis/compiler/tree/propagation/propagation-tests.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 37460dffc0..75df94f629 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/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^ [a,b] = + [ string-nth ] final-info first interval>> 0 23 2^ 1 - [a,b] = ] unit-test ! Non-zero displacement for restricts the output type From bccdb5419b84c09449fac5f2f1b2adf4f165cbb2 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 31 Oct 2019 10:27:17 -0700 Subject: [PATCH 06/10] math.intervals: improve interval-bitand. --- basis/math/intervals/intervals-tests.factor | 6 ++ basis/math/intervals/intervals.factor | 62 ++++++++++----------- 2 files changed, 37 insertions(+), 31 deletions(-) diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 293f49b69a..73706da340 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -398,6 +398,12 @@ commutative-ops [ { 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 diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index e9e6cdf2ee..8c4c1a8e34 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -374,48 +374,23 @@ 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 < ; -: interval-bitand ( i1 i2 -- i3 ) - ! Inaccurate. - [ - { - { - [ 2dup [ interval-nonnegative? ] both? ] - [ interval-bitand-pos ] - } - { - [ 2dup [ interval-nonnegative? ] either? ] - [ interval-bitand-neg ] - } - [ 2drop [-inf,inf] ] - } cond - ] do-empty-interval ; - [ 1 + ] [ neg ] if next-power-of-2 ] if ; -: bounds ( interval -- lower upper ) - { - { full-interval [ -1/0. 1/0. ] } - [ interval>points [ first ] bi@ ] - } case ; +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 ; @@ -423,13 +398,38 @@ SYMBOL: incomparable : 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 ) - bounds [ bit-weight ] bi@ max ; + interval-bounds [ bit-weight ] bi@ max ; PRIVATE> +: interval-bitand ( i1 i2 -- i3 ) + [ + { + { + [ 2dup [ interval-nonnegative? ] both? ] + [ min-upper-bound 0 swap [a,b] ] + } + { + [ 2dup [ interval-nonnegative? ] either? ] + [ + dup interval-nonnegative? [ nip ] [ drop ] if + to>> first 0 swap [a,b] + ] + } + { + [ 2dup [ interval-negative? ] both? ] + [ [ min-lower-bound bit-weight neg ] [ min-upper-bound ] 2bi [a,b] ] + } + [ [ min-lower-bound bit-weight neg ] [ max-upper-bound ] 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 From 52123559f3fdc1e97c15fa2d454fc855fae1e74e Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 31 Oct 2019 10:27:29 -0700 Subject: [PATCH 07/10] math.partial-dispatch: simplify using fry. --- .../partial-dispatch/partial-dispatch.factor | 40 ++++++------------- 1 file changed, 12 insertions(+), 28 deletions(-) diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index fceee5a75d..851aae4798 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/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 -math.functions math.functions.private sequences parser -namespaces make assocs quotations arrays generic generic.math -hashtables effects compiler.units classes.algebra fry -combinators words ; +USING: accessors arrays assocs classes.algebra combinators +compiler.units fry generic generic.math hashtables kernel make +math math.private namespaces quotations sequences 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 ) - [ - [ over fixnum? ] % - [ '[ _ execute ] , ] [ bignum-fixnum-op-quot , ] bi* \ if , - ] [ ] make ; + bignum-fixnum-op-quot '[ over fixnum? [ _ execute ] _ if ] ; : fixnum-integer-op-quot ( fix-word big-word -- quot ) - [ - [ dup fixnum? ] % - [ '[ _ execute ] , ] [ fixnum-bignum-op-quot , ] bi* \ if , - ] [ ] make ; + fixnum-bignum-op-quot '[ dup fixnum? [ _ execute ] _ if ] ; : integer-bignum-op-quot ( big-word -- quot ) - [ - [ over fixnum? ] % - [ fixnum-bignum-op-quot , ] [ '[ _ execute ] , ] bi \ if , - ] [ ] make ; + [ fixnum-bignum-op-quot ] keep + '[ over fixnum? _ [ _ execute ] if ] ; : integer-integer-op-quot ( fix-word big-word -- quot ) - [ - [ 2dup both-fixnums? ] % - [ '[ _ execute ] , ] - [ - [ - [ dup fixnum? ] % - [ bignum-fixnum-op-quot , ] - [ integer-bignum-op-quot , ] bi \ if , - ] [ ] make , - ] bi* \ if , - ] [ ] make ; + [ bignum-fixnum-op-quot ] [ integer-bignum-op-quot ] bi + '[ + 2dup both-fixnums? + [ _ execute ] [ dup fixnum? _ _ if ] if + ] ; : integer-op-word ( triple -- word ) [ name>> ] map "-" join "math.partial-dispatch" create-word ; From f68df75b84bf3bf7c3e0f170ede15b4ca34b3161 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 31 Oct 2019 10:45:36 -0700 Subject: [PATCH 08/10] math.intervals: simplify interval-bitand. --- basis/math/intervals/intervals.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 8c4c1a8e34..63fa4582fd 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -422,11 +422,13 @@ PRIVATE> to>> first 0 swap [a,b] ] } - { - [ 2dup [ interval-negative? ] both? ] - [ [ min-lower-bound bit-weight neg ] [ min-upper-bound ] 2bi [a,b] ] - } - [ [ min-lower-bound bit-weight neg ] [ max-upper-bound ] 2bi [a,b] ] + [ + [ min-lower-bound bit-weight neg ] + [ + 2dup [ interval-negative? ] both? + [ min-upper-bound ] [ max-upper-bound ] if + ] 2bi [a,b] + ] } cond ] do-empty-interval ; From e256a4ba18fbb7916db2a22ead55cbcbf7cf920d Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 31 Oct 2019 10:45:54 -0700 Subject: [PATCH 09/10] math.intervals: workaround possible compiler bug by widening interval-bitor. IN: scratchpad [ { byte-array } declare [ 0 alien-unsigned-4 32 shift ] [ 4 alien-unsigned-4 ] bi bitor 64 >signed ] optimized. ! working [ dup >R 0 alien-unsigned-4 32 fixnum-shift R> 4 alien-unsigned-4 over tag 0 eq? [ fixnum-bitor ] [ fixnum>bignum bignum-bitor ] if 18446744073709551615 >R >bignum R> bignum-bitand dup 63 bignum-bit? [ 18446744073709551616 bignum- ] [ ] if ] ! broken [ dup >R 0 alien-unsigned-4 32 fixnum-shift R> 4 alien-unsigned-4 over tag 0 eq? [ fixnum-bitor ] [ fixnum>bignum bignum-bitor ] if dup 63 bignum-bit? [ 18446744073709551616 bignum- ] [ ] if ] The second case correctly eliminates the bitand but incorrectly assumes that the item on the stack (which is an integer -- either a fixnum or a bignum), was converted to a bignum. --- basis/math/intervals/intervals-tests.factor | 4 ++-- basis/math/intervals/intervals.factor | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 73706da340..87028ea93f 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -413,8 +413,8 @@ ${ 0 0xff [a,b] } [ -0xff -1 [a,b] 0 0xff [a,b] interval-bitand ] unit-test [ 0 15 [a,b] interval-contains? ] all? ] unit-test -${ 0 255 [a,b] } [ 0 255 [a,b] dup interval-bitor ] unit-test -${ 0 511 [a,b] } [ 0 256 [a,b] dup interval-bitor ] 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 diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 63fa4582fd..f36b659b3b 100644 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -447,7 +447,8 @@ PRIVATE> : interval-bitor ( i1 i2 -- i3 ) [ { { [ 2dup [ interval-nonnegative? ] both? ] - [ [ max-lower-bound ] [ max-upper-bound ] 2bi bit-weight 1 - [a,b] ] } + ! FIXME: this should maybe be bitweight 1 - + [ [ max-lower-bound ] [ max-upper-bound ] 2bi bit-weight [a,b] ] } { [ 2dup [ interval-negative? ] both? ] [ max-lower-bound -1 [a,b] ] } [ interval-union interval-bit-weight [ neg ] [ 1 - ] bi [a,b] ] From 4c48f03fe1b8470915957f3959d5d65f110988a8 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Thu, 31 Oct 2019 14:55:47 -0700 Subject: [PATCH 10/10] spelling: minor cleanup. --- extra/spelling/spelling.factor | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/extra/spelling/spelling.factor b/extra/spelling/spelling.factor index 78e5b20a31..2ade0d1bbe 100644 --- a/extra/spelling/spelling.factor +++ b/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 -sequences sequences.private sets sorting splitting strings urls ; +locals math math.ranges math.statistics memoize sequences +sequences.private sorting splitting urls ; IN: spelling ! http://norvig.com/spell-correct.html @@ -12,23 +14,19 @@ CONSTANT: ALPHABET "abcdefghijklmnopqrstuvwxyz" [ length ] keep '[ _ remove-nth ] map ; : transposes ( word -- edits ) - [ length [1,b) ] keep '[ - dup 1 - _ clone [ exchange-unsafe ] keep - ] map ; + [ length [1,b) ] keep + '[ dup 1 - _ clone [ exchange-unsafe ] keep ] map ; + +: replace1 ( i word -- words ) + [ ALPHABET ] 2dip bounds-check + '[ _ _ clone [ set-nth-unsafe ] keep ] { } map-as ; : replaces ( word -- edits ) - [ length ] keep '[ - ALPHABET [ - swap _ clone [ set-nth-unsafe ] keep - ] with { } map-as - ] map concat ; + [ length ] keep '[ _ replace1 ] map concat ; : inserts ( word -- edits ) - [ length [0,b] ] keep '[ - CHAR: ? over _ insert-nth ALPHABET swap [ - swapd clone [ set-nth-unsafe ] keep - ] curry with { } map-as - ] map concat ; + [ length [0,b] ] keep + '[ CHAR: ? over _ insert-nth replace1 ] map concat ; : edits1 ( word -- edits ) [