diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index d0a1b71ff5..e00f8ed791 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 diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index bb1e657710..87028ea93f 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -1,6 +1,6 @@ -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 { 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 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 diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index a12b1d6e2f..f36b659b3b 100644 --- a/basis/math/intervals/intervals.factor +++ b/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 < ; + + [ 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? - [ - [ interval>points [ first ] bi@ ] bi@ - 4array supremum 0 swap >integer next-power-of-2 [a,b] - ] [ 2drop [-inf,inf] ] if + { { [ 2dup [ interval-nonnegative? ] both? ] + ! 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] ] + } 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 ; 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 ; diff --git a/extra/spelling/spelling.factor b/extra/spelling/spelling.factor index 80b1b399b1..1b054caac6 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 ) [