USING: accessors arrays assocs base64 byte-arrays calendar
calendar.format calendar.parser combinators endian io
io.encodings.binary io.encodings.string io.encodings.utf8
-io.streams.byte-array io.streams.string kernel math math.bitwise
+io.streams.byte-array io.streams.string kernel math
math.floats.half present sequences strings urls ;
IN: cbor
{ "json.reader" { "json" "0.99" } }
{ "json.writer" { "json" "0.99" } }
{ "math.trig" { "math.functions" "0.100" } }
+ { "math.functions.integer-logs" { "math.functions" "0.100" } }
}
CONSTANT: word-renames {
{ "assoc-all-key?" { "all-keys?" "0.100" } }
{ "assoc-all-value?" { "all-values?" "0.100" } }
{ "assoc-any-key?" { "any-key?" "0.100" } }
- { "assoc-any-value?" { "any-value?" "0.100" } }
+ { "assoc-any-value?" { "any-value?" "0.100" } }
}
: compute-assoc-fixups ( continuation name assoc -- seq )
! See https://factorcode.org/license.txt for BSD license
USING: accessors arrays assocs calendar calendar.english
calendar.private combinators combinators.smart generalizations
-io io.streams.string kernel math math.functions
-math.functions.integer-logs math.parser multiline namespaces
-peg.ebnf present prettyprint quotations sequences
-sequences.generalizations splitting strings unicode ;
+io io.streams.string kernel math math.functions math.parser
+multiline namespaces peg.ebnf present prettyprint quotations
+sequences sequences.generalizations splitting strings unicode ;
FROM: math.parser.private => format-float ;
IN: formatting
M: object bit-count
binary-object uchar <c-direct-array> byte-array-bit-count ;
-: bit-length ( x -- n )
- dup 0 < [ non-negative-number-expected ] [
- dup 1 > [ log2 1 + ] when
- ] if ;
-
: even-parity? ( obj -- ? ) bit-count even? ;
: odd-parity? ( obj -- ? ) bit-count odd? ;
even?
odd?
divisor?
+}
+"Function variants:"
+{ $subsections
+ integer-log2
+ integer-log10
+ integer-sqrt
} ;
ARTICLE: "arithmetic-functions" "Arithmetic functions"
HELP: copysign
{ $values { "x" number } { "y" number } { "x'" number } }
{ $description "Returns " { $snippet "x" } " with the sign of " { $snippet "y" } ", as a " { $link float } "." } ;
+
+HELP: integer-sqrt
+{ $values
+ { "x" "a non-negative rational number" }
+ { "n" integer }
+}
+{ $description "Outputs the largest integer that is less than or equal to the " { $link sqrt } " of " { $snippet "m" } "." }
+{ $errors "Throws an error if " { $snippet "m" } " is negative." }
+{ $examples
+ { $example
+ "USING: prettyprint math.functions ;"
+ "15 integer-sqrt ."
+ "3"
+ }
+} ;
+
+HELP: integer-log10
+{ $values
+ { "x" "a positive rational number" }
+ { "n" integer }
+}
+{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "10^n" } " is less than or equal to " { $snippet "x" } "." }
+{ $errors "Throws an error if " { $snippet "x" } " is zero or negative." }
+{ $examples
+ { $example
+ "USING: prettyprint math.functions sequences ;"
+ "{"
+ " 5 99 100 101 100000000000000000000"
+ " 100+1/2 1/100"
+ "} [ integer-log10 ] map ."
+ "{ 0 1 2 2 20 2 -2 }"
+ }
+} ;
+
+HELP: integer-log2
+{ $values
+ { "x" "a positive rational number" }
+ { "n" integer }
+}
+{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than or equal to " { $snippet "x" } "." }
+{ $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ;
{ -1.0 } [ -1 -0.0 copysign ] unit-test
{ 1.5 } [ -1.5 2 copysign ] unit-test
{ -1.5 } [ -1.5 -2 copysign ] unit-test
+
+[ -1 integer-sqrt ] must-fail
+{ 0 } [ 0 integer-sqrt ] unit-test
+{ 3 } [ 12 integer-sqrt ] unit-test
+{ 4 } [ 16 integer-sqrt ] unit-test
+{ 44 } [ 2019 integer-sqrt ] unit-test
+
+[ -576460752303423489 integer-log10 ] [ positive-number-expected? ] must-fail-with
+[ -123124 integer-log10 ] [ positive-number-expected? ] must-fail-with
+[ -1/2 integer-log10 ] [ positive-number-expected? ] must-fail-with
+[ 0 integer-log10 ] [ positive-number-expected? ] must-fail-with
+
+{ 0 } [ 1 integer-log10 ] unit-test
+{ 0 } [ 5 integer-log10 ] unit-test
+{ 0 } [ 9 integer-log10 ] unit-test
+{ 1 } [ 10 integer-log10 ] unit-test
+{ 1 } [ 99 integer-log10 ] unit-test
+{ 2 } [ 100 integer-log10 ] unit-test
+{ 2 } [ 101 integer-log10 ] unit-test
+{ 2 } [ 101 integer-log10 ] unit-test
+{ 8 } [ 134217726 integer-log10 ] unit-test
+{ 8 } [ 134217727 integer-log10 ] unit-test
+{ 8 } [ 134217728 integer-log10 ] unit-test
+{ 8 } [ 134217729 integer-log10 ] unit-test
+{ 8 } [ 999999999 integer-log10 ] unit-test
+{ 9 } [ 1000000000 integer-log10 ] unit-test
+{ 9 } [ 1000000001 integer-log10 ] unit-test
+{ 17 } [ 576460752303423486 integer-log10 ] unit-test
+{ 17 } [ 576460752303423487 integer-log10 ] unit-test
+{ 17 } [ 576460752303423488 integer-log10 ] unit-test
+{ 17 } [ 576460752303423489 integer-log10 ] unit-test
+{ 17 } [ 999999999999999999 integer-log10 ] unit-test
+{ 18 } [ 1000000000000000000 integer-log10 ] unit-test
+{ 18 } [ 1000000000000000001 integer-log10 ] unit-test
+{ 999 } [ 1000 10^ 1 - integer-log10 ] unit-test
+{ 1000 } [ 1000 10^ integer-log10 ] unit-test
+{ 1000 } [ 1000 10^ 1 + integer-log10 ] unit-test
+
+{ 0 } [ 9+1/2 integer-log10 ] unit-test
+{ 1 } [ 10 integer-log10 ] unit-test
+{ 1 } [ 10+1/2 integer-log10 ] unit-test
+{ 999 } [ 1000 10^ 1/2 - integer-log10 ] unit-test
+{ 1000 } [ 1000 10^ integer-log10 ] unit-test
+{ 1000 } [ 1000 10^ 1/2 + integer-log10 ] unit-test
+{ -1000 } [ 1000 10^ 1/2 - recip integer-log10 ] unit-test
+{ -1000 } [ 1000 10^ recip integer-log10 ] unit-test
+{ -1001 } [ 1000 10^ 1/2 + recip integer-log10 ] unit-test
+{ -1 } [ 8/10 integer-log10 ] unit-test
+{ -1 } [ 4/10 integer-log10 ] unit-test
+{ -1 } [ 1/10 integer-log10 ] unit-test
+{ -2 } [ 1/11 integer-log10 ] unit-test
+
+{ 99 } [ 100 2^ 1/2 - integer-log2 ] unit-test
+{ 100 } [ 100 2^ integer-log2 ] unit-test
+{ 100 } [ 100 2^ 1/2 + integer-log2 ] unit-test
+{ -100 } [ 100 2^ 1/2 - recip integer-log2 ] unit-test
+{ -100 } [ 100 2^ recip integer-log2 ] unit-test
+{ -101 } [ 100 2^ 1/2 + recip integer-log2 ] unit-test
+{ -1 } [ 8/10 integer-log2 ] unit-test
+{ -2 } [ 4/10 integer-log2 ] unit-test
+{ -3 } [ 2/10 integer-log2 ] unit-test
+{ -4 } [ 1/10 integer-log2 ] unit-test
! Copyright (C) 2004, 2010 Slava Pestov.
! See https://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.bits math.constants
-math.libm math.order sequences ;
+USING: combinators kernel kernel.private math math.bits
+math.constants math.libm math.order math.private sequences
+sequences.private ;
IN: math.functions
GENERIC: sqrt ( x -- y ) foldable
[ double>bits ] [ fp-sign ] bi*
[ 63 2^ bitor ] [ 63 2^ bitnot bitand ] if
bits>double ;
+
+:: integer-sqrt ( x -- n )
+ x [ 0 ] [
+ assert-non-negative
+ bit-length 1 - 2 /i :> c
+ 1 :> a!
+ 0 :> d!
+ c bit-length <iota> <reversed> [| s |
+ d :> e
+ c s neg shift d!
+ a d e - 1 - shift
+ x 2 c * e - d - 1 + neg shift a /i + a!
+ ] each
+ a a sq x > [ 1 - ] when
+ ] if-zero ;
+
+<PRIVATE
+
+GENERIC: (integer-log10) ( x -- n ) foldable
+
+! For 32 bits systems, we could reduce
+! this to the first 27 elements..
+CONSTANT: log10-guesses {
+ 0 0 0 0 1 1 1 2 2 2 3 3 3 3
+ 4 4 4 5 5 5 6 6 6 6 7 7 7 8
+ 8 8 9 9 9 9 10 10 10 11 11 11
+ 12 12 12 12 13 13 13 14 14 14
+ 15 15 15 15 16 16 16 17 17
+}
+
+! This table will hold a few unused bignums on 32 bits systems...
+! It could be reduced to the first 8 elements
+! Note that even though the 64 bits most-positive-fixnum
+! is hardcoded here this table also works (by chance) for 32bit systems.
+! This is because there is only one power of 2 greater than the
+! greatest power of 10 for 27 bit unsigned integers so we don't
+! need to hardcode the 32 bits most-positive-fixnum. See the
+! table below for powers of 2 and powers of 10 around the
+! most-positive-fixnum.
+!
+! 67108864 2^26 | 72057594037927936 2^56
+! 99999999 10^8 | 99999999999999999 10^17
+! 134217727 2^27-1 | 144115188075855872 2^57
+! | 288230376151711744 2^58
+! | 576460752303423487 2^59-1
+CONSTANT: log10-thresholds {
+ 9 99 999 9999 99999 999999
+ 9999999 99999999 999999999
+ 9999999999 99999999999
+ 999999999999 9999999999999
+ 99999999999999 999999999999999
+ 9999999999999999 99999999999999999
+ 576460752303423487
+}
+
+: fixnum-integer-log10 ( n -- x )
+ dup (log2) { array-capacity } declare
+ log10-guesses nth-unsafe { array-capacity } declare
+ dup log10-thresholds nth-unsafe { fixnum } declare
+ rot < [ 1 + ] when ; inline
+
+! bignum-integer-log10-find-down and bignum-integer-log10-find-up
+! work with very bad guesses, but in practice they will never loop
+! more than once.
+: bignum-integer-log10-find-down ( guess 10^guess n -- log10 )
+ [ 2dup > ] [ [ [ 1 - ] [ 10 / ] bi* ] dip ] do while 2drop ;
+
+: bignum-integer-log10-find-up ( guess 10^guess n -- log10 )
+ [ 10 * ] dip
+ [ 2dup <= ] [ [ [ 1 + ] [ 10 * ] bi* ] dip ] while 2drop ;
+
+: bignum-integer-log10-guess ( n -- guess 10^guess )
+ (log2) >integer log10-2 * >integer dup 10^ ;
+
+: bignum-integer-log10 ( n -- x )
+ [ bignum-integer-log10-guess ] keep 2dup >
+ [ bignum-integer-log10-find-down ]
+ [ bignum-integer-log10-find-up ] if ; inline
+
+M: fixnum (integer-log10) fixnum-integer-log10 { fixnum } declare ; inline
+
+M: bignum (integer-log10) bignum-integer-log10 ; inline
+
+PRIVATE>
+
+<PRIVATE
+
+GENERIC: (integer-log2) ( x -- n ) foldable
+
+M: integer (integer-log2) (log2) ; inline
+
+: ((ratio-integer-log)) ( ratio quot -- log )
+ [ >integer ] dip call ; inline
+
+: (ratio-integer-log) ( ratio quot base -- log )
+ pick 1 >=
+ [ drop ((ratio-integer-log)) ] [
+ [ recip ] 2dip
+ [ drop ((ratio-integer-log)) ] [ nip pick ^ = ] 3bi
+ [ 1 + ] unless neg
+ ] if ; inline
+
+M: ratio (integer-log2) [ (integer-log2) ] 2 (ratio-integer-log) ;
+
+M: ratio (integer-log10) [ (integer-log10) ] 10 (ratio-integer-log) ;
+
+PRIVATE>
+
+: integer-log10 ( x -- n )
+ assert-positive (integer-log10) ; inline
+
+: integer-log2 ( x -- n )
+ assert-positive (integer-log2) ; inline
+++ /dev/null
-! Copyright (C) 2017 Jon Harper.
-! See https://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel math quotations ;
-IN: math.functions.integer-logs
-
-HELP: integer-log10
-{ $values
- { "x" "a positive rational number" }
- { "n" integer }
-}
-{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "10^n" } " is less than or equal to " { $snippet "x" } "." }
-{ $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ;
-
-HELP: integer-log2
-{ $values
- { "x" "a positive rational number" }
- { "n" integer }
-}
-{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than or equal to " { $snippet "x" } "." }
-{ $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ;
-
-ARTICLE: "integer-logs" "Integer logarithms"
-"The " { $vocab-link "math.functions.integer-logs" } " vocabulary provides exact integer logarithms for all rational numbers:"
-{ $subsections integer-log2 integer-log10 }
-{ $examples
- { $example
- "USING: prettyprint math.functions.integer-logs sequences ;"
- "{"
- " 5 99 100 101 100000000000000000000"
- " 100+1/2 1/100"
- "} [ integer-log10 ] map ."
- "{ 0 1 2 2 20 2 -2 }"
- }
-} ;
-
-ABOUT: "integer-logs"
+++ /dev/null
-! Copyright (C) 2016 Jon Harper.
-! See https://factorcode.org/license.txt for BSD license.
-USING: tools.test math math.functions math.functions.integer-logs ;
-IN: math.functions.integer-logs.tests
-
-[ -576460752303423489 integer-log10 ] [ positive-number-expected? ] must-fail-with
-[ -123124 integer-log10 ] [ positive-number-expected? ] must-fail-with
-[ -1/2 integer-log10 ] [ positive-number-expected? ] must-fail-with
-[ 0 integer-log10 ] [ positive-number-expected? ] must-fail-with
-
-{ 0 } [ 1 integer-log10 ] unit-test
-{ 0 } [ 5 integer-log10 ] unit-test
-{ 0 } [ 9 integer-log10 ] unit-test
-{ 1 } [ 10 integer-log10 ] unit-test
-{ 1 } [ 99 integer-log10 ] unit-test
-{ 2 } [ 100 integer-log10 ] unit-test
-{ 2 } [ 101 integer-log10 ] unit-test
-{ 2 } [ 101 integer-log10 ] unit-test
-{ 8 } [ 134217726 integer-log10 ] unit-test
-{ 8 } [ 134217727 integer-log10 ] unit-test
-{ 8 } [ 134217728 integer-log10 ] unit-test
-{ 8 } [ 134217729 integer-log10 ] unit-test
-{ 8 } [ 999999999 integer-log10 ] unit-test
-{ 9 } [ 1000000000 integer-log10 ] unit-test
-{ 9 } [ 1000000001 integer-log10 ] unit-test
-{ 17 } [ 576460752303423486 integer-log10 ] unit-test
-{ 17 } [ 576460752303423487 integer-log10 ] unit-test
-{ 17 } [ 576460752303423488 integer-log10 ] unit-test
-{ 17 } [ 576460752303423489 integer-log10 ] unit-test
-{ 17 } [ 999999999999999999 integer-log10 ] unit-test
-{ 18 } [ 1000000000000000000 integer-log10 ] unit-test
-{ 18 } [ 1000000000000000001 integer-log10 ] unit-test
-{ 999 } [ 1000 10^ 1 - integer-log10 ] unit-test
-{ 1000 } [ 1000 10^ integer-log10 ] unit-test
-{ 1000 } [ 1000 10^ 1 + integer-log10 ] unit-test
-
-{ 0 } [ 9+1/2 integer-log10 ] unit-test
-{ 1 } [ 10 integer-log10 ] unit-test
-{ 1 } [ 10+1/2 integer-log10 ] unit-test
-{ 999 } [ 1000 10^ 1/2 - integer-log10 ] unit-test
-{ 1000 } [ 1000 10^ integer-log10 ] unit-test
-{ 1000 } [ 1000 10^ 1/2 + integer-log10 ] unit-test
-{ -1000 } [ 1000 10^ 1/2 - recip integer-log10 ] unit-test
-{ -1000 } [ 1000 10^ recip integer-log10 ] unit-test
-{ -1001 } [ 1000 10^ 1/2 + recip integer-log10 ] unit-test
-{ -1 } [ 8/10 integer-log10 ] unit-test
-{ -1 } [ 4/10 integer-log10 ] unit-test
-{ -1 } [ 1/10 integer-log10 ] unit-test
-{ -2 } [ 1/11 integer-log10 ] unit-test
-
-{ 99 } [ 100 2^ 1/2 - integer-log2 ] unit-test
-{ 100 } [ 100 2^ integer-log2 ] unit-test
-{ 100 } [ 100 2^ 1/2 + integer-log2 ] unit-test
-{ -100 } [ 100 2^ 1/2 - recip integer-log2 ] unit-test
-{ -100 } [ 100 2^ recip integer-log2 ] unit-test
-{ -101 } [ 100 2^ 1/2 + recip integer-log2 ] unit-test
-{ -1 } [ 8/10 integer-log2 ] unit-test
-{ -2 } [ 4/10 integer-log2 ] unit-test
-{ -3 } [ 2/10 integer-log2 ] unit-test
-{ -4 } [ 1/10 integer-log2 ] unit-test
+++ /dev/null
-! Copyright (C) 2017 Jon Harper.
-! See https://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private math math.functions
-math.functions.private math.private sequences.private ;
-IN: math.functions.integer-logs
-
-<PRIVATE
-
-GENERIC: (integer-log10) ( x -- n ) foldable
-
-! For 32 bits systems, we could reduce
-! this to the first 27 elements..
-CONSTANT: log10-guesses {
- 0 0 0 0 1 1 1 2 2 2 3 3 3 3
- 4 4 4 5 5 5 6 6 6 6 7 7 7 8
- 8 8 9 9 9 9 10 10 10 11 11 11
- 12 12 12 12 13 13 13 14 14 14
- 15 15 15 15 16 16 16 17 17
-}
-
-! This table will hold a few unused bignums on 32 bits systems...
-! It could be reduced to the first 8 elements
-! Note that even though the 64 bits most-positive-fixnum
-! is hardcoded here this table also works (by chance) for 32bit systems.
-! This is because there is only one power of 2 greater than the
-! greatest power of 10 for 27 bit unsigned integers so we don't
-! need to hardcode the 32 bits most-positive-fixnum. See the
-! table below for powers of 2 and powers of 10 around the
-! most-positive-fixnum.
-!
-! 67108864 2^26 | 72057594037927936 2^56
-! 99999999 10^8 | 99999999999999999 10^17
-! 134217727 2^27-1 | 144115188075855872 2^57
-! | 288230376151711744 2^58
-! | 576460752303423487 2^59-1
-CONSTANT: log10-thresholds {
- 9 99 999 9999 99999 999999
- 9999999 99999999 999999999
- 9999999999 99999999999
- 999999999999 9999999999999
- 99999999999999 999999999999999
- 9999999999999999 99999999999999999
- 576460752303423487
-}
-
-: fixnum-integer-log10 ( n -- x )
- dup (log2) { array-capacity } declare
- log10-guesses nth-unsafe { array-capacity } declare
- dup log10-thresholds nth-unsafe { fixnum } declare
- rot < [ 1 + ] when ; inline
-
-! bignum-integer-log10-find-down and bignum-integer-log10-find-up
-! work with very bad guesses, but in practice they will never loop
-! more than once.
-: bignum-integer-log10-find-down ( guess 10^guess n -- log10 )
- [ 2dup > ] [ [ [ 1 - ] [ 10 / ] bi* ] dip ] do while 2drop ;
-
-: bignum-integer-log10-find-up ( guess 10^guess n -- log10 )
- [ 10 * ] dip
- [ 2dup <= ] [ [ [ 1 + ] [ 10 * ] bi* ] dip ] while 2drop ;
-
-: bignum-integer-log10-guess ( n -- guess 10^guess )
- (log2) >integer log10-2 * >integer dup 10^ ;
-
-: bignum-integer-log10 ( n -- x )
- [ bignum-integer-log10-guess ] keep 2dup >
- [ bignum-integer-log10-find-down ]
- [ bignum-integer-log10-find-up ] if ; inline
-
-M: fixnum (integer-log10) fixnum-integer-log10 { fixnum } declare ; inline
-
-M: bignum (integer-log10) bignum-integer-log10 ; inline
-
-PRIVATE>
-
-<PRIVATE
-
-GENERIC: (integer-log2) ( x -- n ) foldable
-
-M: integer (integer-log2) (log2) ; inline
-
-: ((ratio-integer-log)) ( ratio quot -- log )
- [ >integer ] dip call ; inline
-
-: (ratio-integer-log) ( ratio quot base -- log )
- pick 1 >=
- [ drop ((ratio-integer-log)) ] [
- [ recip ] 2dip
- [ drop ((ratio-integer-log)) ] [ nip pick ^ = ] 3bi
- [ 1 + ] unless neg
- ] if ; inline
-
-M: ratio (integer-log2) [ (integer-log2) ] 2 (ratio-integer-log) ;
-
-M: ratio (integer-log10) [ (integer-log10) ] 10 (ratio-integer-log) ;
-
-PRIVATE>
-
-: integer-log10 ( x -- n )
- assert-positive (integer-log10) ; inline
-
-: integer-log2 ( x -- n )
- assert-positive (integer-log2) ; inline
: even? ( n -- ? ) 1 bitand zero? ; inline
: odd? ( n -- ? ) 1 bitand 1 number= ; inline
+: bit-length ( x -- n )
+ assert-non-negative dup 1 > [ log2 1 + ] when ;
+
GENERIC: neg? ( x -- ? )
: if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
{ 0 } [ 1/2 1 kelly ] unit-test
{ -1/5 } [ 2/5 1 kelly ] unit-test
-[ -1 integer-sqrt ] must-fail
-{ 0 } [ 0 integer-sqrt ] unit-test
-{ 3 } [ 12 integer-sqrt ] unit-test
-{ 4 } [ 16 integer-sqrt ] unit-test
-{ 44 } [ 2019 integer-sqrt ] unit-test
-
{ 1 } [ 11 13 stein ] unit-test
{ 2 } [ 14 52 stein ] unit-test
{ 7 } [ 14 7 stein ] unit-test
: kelly ( winning-probability odds -- fraction )
[ 1 + * 1 - ] [ / ] bi ;
-:: integer-sqrt ( m -- n )
- m [ 0 ] [
- assert-non-negative
- bit-length 1 - 2 /i :> c
- 1 :> a!
- 0 :> d!
- c bit-length <iota> <reversed> [| s |
- d :> e
- c s neg shift d!
- a d e - 1 - shift
- m 2 c * e - d - 1 + neg shift a /i + a!
- ] each
- a a sq m > [ 1 - ] when
- ] if-zero ;
-
<PRIVATE
: reduce-evens ( value u v -- value' u' v' )
projects / factor.git / commitdiff