Merge remote-tracking branch 'origin/master' into modern-harvey3
Doug Coleman
commit
b049b0919c
|
|
@ -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 <displaced-alien> restricts the output type
|
||||
|
|
|
|||
|
|
@ -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 <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
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
[
|
||||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 <iota> ] 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 <iota> ] keep '[
|
||||
ALPHABET [
|
||||
swap _ clone [ set-nth-unsafe ] keep
|
||||
] with { } map-as
|
||||
] map concat ;
|
||||
[ length <iota> ] 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 )
|
||||
[
|
||||
|
|
|
|||
Loading…
Reference in New Issue