diff --git a/core/math/intervals/intervals-docs.factor b/core/math/intervals/intervals-docs.factor index 59fb0df18e..d6b3935b17 100644 --- a/core/math/intervals/intervals-docs.factor +++ b/core/math/intervals/intervals-docs.factor @@ -14,6 +14,8 @@ ARTICLE: "math-intervals-new" "Creating intervals" { $subsection [-inf,a) } { $subsection [a,inf] } { $subsection (a,inf] } +"The set of all real numbers with infinities:" +{ $subsection [-inf,inf] } "Another constructor:" { $subsection points>interval } ; @@ -24,16 +26,23 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic" { $subsection interval* } { $subsection interval/ } { $subsection interval/i } -{ $subsection interval-shift } +{ $subsection interval-mod } +{ $subsection interval-rem } { $subsection interval-min } { $subsection interval-max } +"Bitwise operations on intervals:" +{ $subsection interval-shift } +{ $subsection interval-bitand } +{ $subsection interval-bitor } +{ $subsection interval-bitxor } "Unary operations on intervals:" { $subsection interval-1+ } { $subsection interval-1- } { $subsection interval-neg } { $subsection interval-bitnot } { $subsection interval-recip } -{ $subsection interval-2/ } ; +{ $subsection interval-2/ } +{ $subsection interval-abs } ; ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals" { $subsection interval-contains? } diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index faf04d305e..f8dce14a06 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -84,9 +84,9 @@ IN: math.intervals.tests 1 0 1 (a,b) interval-contains? ] unit-test -[ f ] [ -1 1 (a,b) -1 1 (a,b) interval/ ] unit-test +[ t ] [ -1 1 (a,b) -1 1 (a,b) interval/ [-inf,inf] = ] unit-test -[ f ] [ -1 1 (a,b) 0 1 (a,b) interval/ ] unit-test +[ t ] [ -1 1 (a,b) 0 1 (a,b) interval/ [-inf,inf] = ] unit-test "math.ratios.private" vocab [ [ t ] [ @@ -156,7 +156,7 @@ IN: math.intervals.tests interval-contains? ] unit-test -[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test +[ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test ! Interval random tester : random-element ( interval -- n ) @@ -177,12 +177,43 @@ IN: math.intervals.tests { 3 [ (a,b] ] } } case ; -: random-op ( -- pair ) +: random-unary-op ( -- pair ) + { + { bitnot interval-bitnot } + { abs interval-abs } + { 2/ interval-2/ } + { 1+ interval-1+ } + { 1- interval-1- } + { neg interval-neg } + } + "math.ratios.private" vocab [ + { recip interval-recip } suffix + ] when + random ; + +: unary-test ( -- ? ) + random-interval random-unary-op ! 2dup . . + 0 pick interval-contains? over first \ recip eq? and [ + 2drop t + ] [ + [ >r random-element ! dup . + r> first execute ] 2keep + second execute interval-contains? + ] if ; + +[ t ] [ 80000 [ drop unary-test ] all? ] unit-test + +: random-binary-op ( -- pair ) { { + interval+ } { - interval- } { * interval* } { /i interval/i } + { mod interval-mod } + { rem interval-rem } + { bitand interval-bitand } + { bitor interval-bitor } + { bitxor interval-bitxor } { shift interval-shift } { min interval-min } { max interval-max } @@ -192,8 +223,8 @@ IN: math.intervals.tests ] when random ; -: interval-test ( -- ? ) - random-interval random-interval random-op ! 3dup . . . +: binary-test ( -- ? ) + random-interval random-interval random-binary-op ! 3dup . . . 0 pick interval-contains? over first { / /i } member? and [ 3drop t ] [ @@ -202,7 +233,7 @@ IN: math.intervals.tests second execute interval-contains? ] if ; -[ t ] [ 40000 [ drop interval-test ] all? ] unit-test +[ t ] [ 80000 [ drop binary-test ] all? ] unit-test : random-comparison ( -- pair ) { @@ -215,11 +246,7 @@ IN: math.intervals.tests : comparison-test ( -- ? ) random-interval random-interval random-comparison [ >r [ random-element ] bi@ r> first execute ] 3keep - second execute dup incomparable eq? [ - 2drop t - ] [ - = - ] if ; + second execute dup incomparable eq? [ 2drop t ] [ = ] if ; [ t ] [ 40000 [ drop comparison-test ] all? ] unit-test diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 9b994b4bbf..66d829e0ae 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -36,6 +36,8 @@ C: interval : (a,inf] ( a -- interval ) 1./0. (a,b] ; inline +: [-inf,inf] ( -- interval ) -1./0. 1./0. [a,b] ; foldable + : compare-endpoints ( p1 p2 quot -- ? ) >r over first over first r> call [ 2drop t @@ -154,7 +156,7 @@ C: interval : interval-shift-safe ( i1 i2 -- i3 ) dup to>> first 100 > [ - 2drop f + 2drop [-inf,inf] ] [ interval-shift ] if ; @@ -172,7 +174,7 @@ C: interval : interval-division-op ( i1 i2 quot -- i3 ) >r 0 over interval-closure interval-contains? - [ 2drop f ] r> if ; inline + [ 2drop [-inf,inf] ] r> if ; inline : interval/ ( i1 i2 -- i3 ) [ [ / ] interval-op ] interval-division-op ; @@ -187,6 +189,25 @@ C: interval [ [ /i ] interval-op ] interval-integer-op ] interval-division-op interval-closure ; +: interval/f ( i1 i2 -- i3 ) + [ [ /f ] interval-op ] interval-division-op ; + +: interval-abs ( i1 -- i2 ) + interval>points [ first2 [ abs ] dip 2array ] bi@ 2array + points>interval ; + +: interval-mod ( i1 i2 -- i3 ) + #! Inaccurate. + [ + nip interval-abs to>> first [ neg ] keep (a,b) + ] interval-division-op ; + +: interval-rem ( i1 i2 -- i3 ) + #! Inaccurate. + [ + nip interval-abs to>> first 0 swap [a,b) + ] interval-division-op ; + : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; : interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ; @@ -194,16 +215,16 @@ C: interval SYMBOL: incomparable : left-endpoint-< ( i1 i2 -- ? ) - [ swap interval-subset? ] 2keep - [ nip interval-singleton? ] 2keep - [ from>> ] bi@ = - and and ; + [ swap interval-subset? ] + [ nip interval-singleton? ] + [ [ from>> ] bi@ = ] + 2tri and and ; : right-endpoint-< ( i1 i2 -- ? ) - [ interval-subset? ] 2keep - [ drop interval-singleton? ] 2keep - [ to>> ] bi@ = - and and ; + [ interval-subset? ] + [ drop interval-singleton? ] + [ [ to>> ] bi@ = ] + 2tri and and ; : (interval<) ( i1 i2 -- i1 i2 ? ) over from>> over from>> endpoint< ; @@ -235,6 +256,27 @@ SYMBOL: incomparable : interval>= ( i1 i2 -- ? ) swap interval<= ; +: interval-bitand ( i1 i2 -- i3 ) + dup 1 [a,a] interval>= [ + 1 [a,a] interval- interval-rem + ] [ + 2drop [-inf,inf] + ] if ; + +: interval-bitor ( i1 i2 -- i3 ) + #! Inaccurate. + 2dup [ 0 [a,a] interval>= ] both? + [ to>> first 0 swap [a,b] interval-intersect ] + [ 2drop [-inf,inf] ] + if ; + +: interval-bitxor ( i1 i2 -- i3 ) + #! Inaccurate. + 2dup [ 0 [a,a] interval>= ] both? + [ nip to>> first 0 swap [a,b] ] + [ 2drop [-inf,inf] ] + if ; + : assume< ( i1 i2 -- i3 ) to>> first [-inf,a) interval-intersect ; diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index f75a63eefc..237438e69a 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -130,38 +130,27 @@ HELP: / { $see-also "division-by-zero" } ; HELP: /i -{ $values { "x" real } { "y" real } { "z" real } } +{ $values { "x" real } { "y" real } { "z" integer } } { $description "Divides " { $snippet "x" } " by " { $snippet "y" } ", truncating the result to an integer." - { $list - "Integer division of fixnums may overflow and yield a bignum." - "Integer division of bignums always yields a bignum." - "Integer division of floats always yields a float." - "Integer division of ratios and complex numbers proceeds using the relevant mathematical rules." - } } { $see-also "division-by-zero" } ; HELP: /f -{ $values { "x" real } { "y" real } { "z" real } } +{ $values { "x" real } { "y" real } { "z" float } } { $description "Divides " { $snippet "x" } " by " { $snippet "y" } ", representing the result as a floating point number." - { $list - "Integer division of fixnums may overflow and yield a bignum." - "Integer division of bignums always yields a bignum." - "Integer division of floats always yields a float." - "Integer division of ratios and complex numbers proceeds using the relevant mathematical rules." - } } { $see-also "division-by-zero" } ; HELP: mod -{ $values { "x" integer } { "y" integer } { "z" integer } } +{ $values { "x" rational } { "y" rational } { "z" rational } } { $description "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative." { $list "Modulus of fixnums always yields a fixnum." - "Modulus of bignums always yields a bignum." + "Modulus of bignums always yields a bignum." + { "Modulus of rationals always yields a rational. In this case, the remainder is computed using the formula " { $snippet "x - (x mod y) * y" } "." } } } { $see-also "division-by-zero" rem } ; @@ -254,12 +243,13 @@ HELP: recip { $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ; HELP: rem -{ $values { "x" integer } { "y" integer } { "z" integer } } +{ $values { "x" rational } { "y" rational } { "z" rational } } { $description "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive." { $list - "Modulus of fixnums always yields a fixnum." - "Modulus of bignums always yields a bignum." + "Given fixnums, always yields a fixnum." + "Given bignums, always yields a bignum." + "Given rationals, always yields a rational." } } { $see-also "division-by-zero" mod } ; diff --git a/core/math/math.factor b/core/math/math.factor index 457dddceeb..4efca0ef2f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -66,7 +66,7 @@ PRIVATE> : ?1+ [ 1+ ] [ 0 ] if* ; inline -: rem ( x y -- z ) tuck mod over + swap mod ; foldable +: rem ( x y -- z ) abs tuck mod over + swap mod ; foldable : 2^ ( n -- 2^n ) 1 swap shift ; inline