diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index fe94c7301b..985a47e256 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -229,6 +229,6 @@ SYMBOL: interactive-vocabs ] with-interactive-vocabs ; : listener-main ( -- ) - version-info print flush listener ; + "q" get [ version-info print flush ] unless listener ; MAIN: listener-main diff --git a/basis/math/floats/half/half-tests.factor b/basis/math/floats/half/half-tests.factor index 082557f8a7..88e21b1779 100644 --- a/basis/math/floats/half/half-tests.factor +++ b/basis/math/floats/half/half-tests.factor @@ -1,5 +1,6 @@ -USING: accessors alien.c-types alien.syntax math.floats.half kernel -math tools.test specialized-arrays alien.data classes.struct ; +USING: accessors alien.c-types alien.data classes.struct kernel +math math.floats.half math.order sequences specialized-arrays +tools.test ; SPECIALIZED-ARRAY: half IN: math.floats.half.tests @@ -46,3 +47,12 @@ STRUCT: halves { half-array{ 1.0 2.0 3.0 1/0. -1/0. } } [ { 1.0 2.0 3.0 1/0. -1/0. } half >c-array ] unit-test + +{ 0x1.0p-24 } [ 1 bits>half ] unit-test + +{ t } [ + 65536 + [ 0x7c01 0x7dff between? ] reject + [ 0xfc01 0xfdff between? ] reject + [ dup bits>half half>bits = ] all? +] unit-test diff --git a/basis/math/floats/half/half.factor b/basis/math/floats/half/half.factor index bcb37879d2..35fd7adbf8 100644 --- a/basis/math/floats/half/half.factor +++ b/basis/math/floats/half/half.factor @@ -1,30 +1,35 @@ ! Copyright (C) 2009 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.accessors alien.c-types alien.data -alien.syntax kernel math math.order ; +USING: accessors alien.accessors alien.c-types combinators +kernel math ; FROM: math => float ; IN: math.floats.half : half>bits ( float -- bits ) float>bits - [ -31 shift 15 shift ] [ - 0x7fffffff bitand - dup zero? [ - dup 0x7f800000 >= [ -13 shift 0x7fff bitand ] [ - -13 shift - 112 10 shift - - 0 0x7c00 clamp - ] if - ] unless - ] bi bitor ; + [ -16 shift 0x8000 bitand ] keep + [ 0x7fffff bitand ] keep + -23 shift 0xff bitand 127 - { + { [ dup -24 < ] [ 2drop 0 ] } + { [ dup -14 < ] [ [ 1 + shift ] [ 24 + 2^ ] bi bitor ] } + { [ dup 15 <= ] [ [ -13 shift ] [ 15 + 10 shift ] bi* bitor ] } + { [ dup 128 < ] [ 2drop 0x7c00 ] } + [ drop -13 shift 0x7c00 bitor ] + } cond bitor ; : bits>half ( bits -- float ) [ -15 shift 31 shift ] [ 0x7fff bitand dup zero? [ dup 0x7c00 >= [ 13 shift 0x7f800000 bitor ] [ - 13 shift - 112 23 shift + + dup 0x0400 < [ + dup log2 + [ nip 103 + 23 shift ] + [ 23 swap - shift 0x7fffff bitand ] 2bi bitor + ] [ + 13 shift + 112 23 shift + + ] if ] if ] unless ] bi bitor bits>float ; diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 460bdc0dcf..430d2918c0 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -96,6 +96,28 @@ CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11 { e 1.e-10 } [ 1 e^ ] unit-test~ { 1.0 1.e-10 } [ -1 e^ e * ] unit-test~ +{ 0.0 } [ 0.0 e^-1 ] unit-test +{ -0.0 } [ -0.0 e^-1 ] unit-test +{ 1/0. } [ 1/0. e^-1 ] unit-test +{ -1.0 } [ -1/0. e^-1 ] unit-test +{ -1.0 } [ -1/0. e^-1 ] unit-test +{ t } [ NAN: 8000000000000 dup e^-1 [ fp-nan-payload ] same? ] unit-test +{ 5e-324 } [ 5e-324 e^-1 ] unit-test +{ 1e-20 } [ 1e-20 e^-1 ] unit-test +{ -5e-324 } [ -5e-324 e^-1 ] unit-test +{ -1e-20 } [ -1e-20 e^-1 ] unit-test +{ 1.0000000000500000e-10 } [ 1e-10 e^-1 ] unit-test +{ 22025.465794806718 } [ 10.0 e^-1 ] unit-test +{ -9.999999999500001e-11 } [ -1e-10 e^-1 ] unit-test +{ -0.9999546000702375 } [ -10.0 e^-1 ] unit-test +{ -1.0 } [ -38.0 e^-1 ] unit-test +{ -1.0 } [ -1e50 e^-1 ] unit-test +{ 1.9424263952412558e+130 } [ 300 e^-1 ] unit-test +{ 1.7976931346824240e+308 } [ 709.78271289328393 e^-1 ] unit-test +{ 1/0. } [ 1000.0 e^-1 ] unit-test +{ 1/0. } [ 1e50 e^-1 ] unit-test +{ 1/0. } [ 1.79e308 e^-1 ] unit-test + { 1.0 } [ 0 cosh ] unit-test { 1.0 } [ 0.0 cosh ] unit-test { 0.0 } [ 1 acosh ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 693de75055..dcc1a0e9a4 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -239,6 +239,19 @@ M: complex log10 log 10 log / ; inline M: bignum log10 [ log10 ] log10-2 (bignum-log) ; +GENERIC: e^-1 ( x -- e^x-1 ) + +M: float e^-1 + dup abs 0.7 < [ + dup e^ dup 1.0 = [ + drop + ] [ + [ 1.0 - * ] [ log / ] bi + ] if + ] [ e^ 1.0 - ] if ; inline + +M: real e^-1 >float e^-1 ; inline + GENERIC: cos ( x -- y ) foldable M: complex cos diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 045c34a3e0..e39e838524 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -59,7 +59,7 @@ PRIVATE> [ factors [ number>string ] map " " join print ] bi* ] [ "factor: `" "' is not a valid positive integer" surround print - ] if* ; + ] if* flush ; : run-unix-factor ( -- ) command-line get [ diff --git a/basis/system-info/linux/linux-tests.factor b/basis/system-info/linux/linux-tests.factor index afe2207a54..c17241c2d3 100644 --- a/basis/system-info/linux/linux-tests.factor +++ b/basis/system-info/linux/linux-tests.factor @@ -11,5 +11,5 @@ tools.test kernel ; [ t ] [ domainname string? ] unit-test { t } [ - release "." split1 drop { "2" "3" "4" } member? + release "." split1 drop { "2" "3" "4" "5" } member? ] unit-test diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 7a4fdbc0c3..569010bd8b 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -28,6 +28,9 @@ T{ error-type-holder { quot [ test-failures get ] } } define-error-type +SYMBOL: silent-tests? +f silent-tests? set-global + SYMBOL: verbose-tests? t verbose-tests? set-global @@ -157,7 +160,7 @@ M: must-fail-with-experiment experiment. ( experiment -- ) :: experiment ( word: ( -- error/f failed? tested? ) line-number -- ) word :> e - e experiment. + silent-tests? get [ e experiment. ] unless word execute [ [ current-test-file get [ diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 5d86de9683..bc3e3a5fbb 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -35,8 +35,9 @@ SINGLETONS: vocab-completion color-completion char-completion path-completion history-completion ; UNION: definition-completion word-completion vocab-word-completion vocab-completion ; -UNION: listener-completion definition-completion -color-completion char-completion path-completion history-completion ; +UNION: code-completion definition-completion +color-completion char-completion path-completion ; +UNION: listener-completion code-completion history-completion ; GENERIC: completion-quot ( interactor completion-mode -- quot ) @@ -196,3 +197,13 @@ M: completion-popup handle-gesture ( gesture completion -- ? ) 2dup completion-gesture [ [ nip hide-glass ] [ invoke-command ] 2bi* f ] [ drop call-next-method ] if* ; + +: ?check-popup ( interactor -- interactor ) + dup popup>> [ + gadget-child dup completion-popup? [ + completion-mode>> dup code-completion? [ + over completion-mode = + [ dup popup>> hide-glass ] unless + ] [ drop ] if + ] [ drop ] if + ] when* ; diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index f201ad61d8..b7eab054a5 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -376,7 +376,7 @@ M: interactor stream-read-quot ( stream -- quot/f ) M: interactor handle-gesture { { [ over key-gesture? not ] [ call-next-method ] } - { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] } + { [ dup popup>> ] [ ?check-popup { [ pass-to-popup ] [ call-next-method ] } 2&& ] } { [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index e7a0acf955..2482a72149 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -3,7 +3,7 @@ USING: accessors assocs classes classes.algebra classes.algebra.private classes.builtin classes.private combinators definitions kernel kernel.private math math.private -quotations sequences sets words ; +quotations sequences sets sorting words ; IN: classes.union PREDICATE: union-class < class @@ -21,20 +21,28 @@ M: union-class union-of-builtins? M: class union-of-builtins? drop f ; -: fast-union-mask ( class -- n ) - flatten-class 0 [ class>type 2^ bitor ] reduce ; - : empty-union-predicate-quot ( class -- quot ) drop [ drop f ] ; -: fast-union-predicate-quot ( class -- quot ) +: fast-union-mask ( class/builtin-classes -- n ) + dup sequence? [ flatten-class ] unless + 0 [ class>type 2^ bitor ] reduce ; + +: fast-union-predicate-quot ( class/builtin-classes -- quot ) fast-union-mask 1quotation [ tag 1 swap fixnum-shift-fast ] [ fixnum-bitand 0 eq? not ] surround ; : slow-union-predicate-quot ( class -- quot ) - class-members [ predicate-def ] map unclip swap + class-members + dup [ builtin-class? ] count 1 > [ + [ builtin-class? ] partition + [ predicate-def ] map swap + [ fast-union-predicate-quot suffix ] unless-empty + ] [ + [ predicate-def ] map + ] if unclip swap [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ; : union-predicate-quot ( class -- quot ) diff --git a/core/command-line/command-line-docs.factor b/core/command-line/command-line-docs.factor index a15411b66f..b2c55e1ef1 100644 --- a/core/command-line/command-line-docs.factor +++ b/core/command-line/command-line-docs.factor @@ -91,6 +91,7 @@ $nl ARTICLE: "standard-cli-args" "Command line switches for general usage" "The following command line switches can be passed to a bootstrapped Factor image:" { $table + { { $snippet "-help" } { "Show help for the command line switches." } } { { $snippet "-e=" { $emphasis "code" } } { "This specifies a code snippet to evaluate and then exit Factor." } } { { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link \ \MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } " or " { $vocab-link "ui.tools" } "." } } { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } } diff --git a/core/command-line/startup/startup.factor b/core/command-line/startup/startup.factor index e8977cd700..3f976028a9 100644 --- a/core/command-line/startup/startup.factor +++ b/core/command-line/startup/startup.factor @@ -1,14 +1,19 @@ ! Copyright (C) 2011 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: command-line eval io io.pathnames kernel namespaces -system vocabs.loader ; +USING: combinators command-line eval io io.pathnames kernel +namespaces system vocabs.loader ; IN: command-line.startup -: cli-usage ( -- ) +: help? ( -- ? ) + "help" get "h" get or + os windows? [ script get "/?" = or ] when ; + +: help. ( -- ) "Usage: " write vm-path file-name write " [Factor arguments] [script] [script arguments] Factor arguments: -help print this message and exit + -version print the Factor version and exit -i= load Factor image file (default " write vm-path file-stem write ".image) -run= run the MAIN: entry point of -run=listener run terminal listener @@ -35,22 +40,25 @@ from within Factor for more information. " write ; -: help? ( -- ? ) - "help" get "h" get or - os windows? [ script get "/?" = or ] when ; +: version? ( -- ? ) "version" get ; + +: version. ( -- ) "Factor " write vm-version print ; : command-line-startup ( -- ) - (command-line) parse-command-line - help? [ cli-usage ] [ - load-vocab-roots - run-user-init - "e" get script get or [ - "e" get [ eval( -- ) ] when* - script get [ run-script ] when* - ] [ - "run" get run - ] if - ] if + (command-line) parse-command-line { + { [ help? ] [ help. ] } + { [ version? ] [ version. ] } + [ + load-vocab-roots + run-user-init + "e" get script get or [ + "e" get [ eval( -- ) ] when* + script get [ run-script ] when* + ] [ + "run" get run + ] if + ] + } cond output-stream get [ stream-flush ] when* 0 exit ; diff --git a/extra/benchmark/cuckoo-filters/cuckoo-filters.factor b/extra/benchmark/cuckoo-filters/cuckoo-filters.factor new file mode 100644 index 0000000000..95e92d95c7 --- /dev/null +++ b/extra/benchmark/cuckoo-filters/cuckoo-filters.factor @@ -0,0 +1,17 @@ +USING: cuckoo-filters fry io.binary kernel math sequences ; +IN: benchmark.cuckoo-filters + +: insert-data ( cuckoo-filter -- cuckoo-filter ) + 2,000 [ 4 >le ] map + 10 swap '[ _ [ over cuckoo-insert drop ] each ] times ; + +: test-hit ( cuckoo-filter -- cuckoo-filter ) + 10,000 100 4 >le '[ _ over cuckoo-lookup drop ] times ; + +: test-miss ( cuckoo-filter -- cuckoo-filter ) + 100,000 12345 4 >le '[ _ over cuckoo-lookup drop ] times ; + +: cuckoo-filters-benchmark ( -- ) + 2000 insert-data test-hit test-miss drop ; + +MAIN: cuckoo-filters-benchmark diff --git a/extra/help/lint/coverage/coverage-docs.factor b/extra/help/lint/coverage/coverage-docs.factor index c30640470f..a914fb1c92 100644 --- a/extra/help/lint/coverage/coverage-docs.factor +++ b/extra/help/lint/coverage/coverage-docs.factor @@ -10,7 +10,7 @@ PRIVATE> ABOUT: "help.lint.coverage" ARTICLE: "help.lint.coverage" "Help coverage linting" -"The " { $vocab-link "help.lint.coverage" } " vocabulary implements a very picky documentation completeness checker." +"The " { $vocab-link "help.lint.coverage" } " vocabulary implements a very pedantic documentation completeness checker." $nl "The documentation coverage linter requires most words to have " { $link postpone: \HELP: } " declarations defining some of the " { $links $values $description $error-description $class-description $examples } " sections (see " { $links "element-types" } ")." diff --git a/extra/help/lint/coverage/coverage-tests.factor b/extra/help/lint/coverage/coverage-tests.factor index ada199ab67..1996931e48 100644 --- a/extra/help/lint/coverage/coverage-tests.factor +++ b/extra/help/lint/coverage/coverage-tests.factor @@ -5,22 +5,22 @@ tools.test vocabs ; IN: help.lint.coverage.tests -{ t } [ \ empty empty-examples? ] unit-test -{ f } [ \ nonexistent empty-examples? ] unit-test -{ f } [ \ defined empty-examples? ] unit-test +{ t } [ \ an-empty-word-with-a-unique-name empty-examples? ] unit-test +{ f } [ \ a-nonexistent-word empty-examples? ] unit-test +{ f } [ \ a-defined-word empty-examples? ] unit-test { f } [ \ keep empty-examples? ] unit-test -{ { $description $values } } [ \ empty missing-sections natural-sort ] unit-test -{ { $description $values } } [ \ defined missing-sections natural-sort ] unit-test +{ { $description $values } } [ \ an-empty-word-with-a-unique-name missing-sections natural-sort ] unit-test +{ { $description $values } } [ \ a-defined-word missing-sections natural-sort ] unit-test { { } } [ \ keep missing-sections ] unit-test { { "a.b" "a.b.c" } } [ { "a.b" "a.b.private" "a.b.c.private" "a.b.c" } filter-private ] unit-test @@ -29,13 +29,13 @@ PRIVATE> { "section" } [ 1 "section" ?pluralize ] unit-test { "sections" } [ 10 "section" ?pluralize ] unit-test -{ { $examples } } [ \ empty word-defines-sections ] unit-test -{ { $examples } } [ \ defined word-defines-sections ] unit-test -{ { } } [ \ nonexistent word-defines-sections ] unit-test +{ { $examples } } [ \ an-empty-word-with-a-unique-name word-defines-sections ] unit-test +{ { $examples } } [ \ a-defined-word word-defines-sections ] unit-test +{ { } } [ \ a-nonexistent-word word-defines-sections ] unit-test { { $values $description $examples } } [ \ keep word-defines-sections ] unit-test { { $values $contract $examples } } [ \ word-defines-sections ] unit-test -{ empty } [ "empty" find-word ] unit-test +{ an-empty-word-with-a-unique-name } [ "an-empty-word-with-a-unique-name" find-word ] unit-test { V{ "[" { $[ "math" dup lookup-vocab ] } "] " { "zero?" zero? } ": " } @@ -101,8 +101,8 @@ PRIVATE> USING: definitions compiler.units ; IN: help.lint.coverage.tests.private [ - \ empty forget - \ nonexistent forget - \ defined forget + \ an-empty-word-with-a-unique-name forget + \ a-nonexistent-word forget + \ a-defined-word forget ] with-compilation-unit ]] eval( -- ) diff --git a/extra/llvm/ffi/ffi.factor b/extra/llvm/ffi/ffi.factor index 9bf9af5bdd..5e11cc1d4b 100644 --- a/extra/llvm/ffi/ffi.factor +++ b/extra/llvm/ffi/ffi.factor @@ -144,6 +144,10 @@ FUNCTION: LLVMValueRef LLVMBuildSub ( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, c-string Name ) +FUNCTION: LLVMValueRef LLVMBuildMul ( LLVMBuilderRef Builder, + LLVMValueRef LHS, + LLVMValueRef RHS, + c-string Name ) FUNCTION: LLVMValueRef LLVMBuildRet ( LLVMBuilderRef Builder, LLVMValueRef V ) diff --git a/extra/math/extras/extras-tests.factor b/extra/math/extras/extras-tests.factor index fb4d0159f8..72b4da6367 100644 --- a/extra/math/extras/extras-tests.factor +++ b/extra/math/extras/extras-tests.factor @@ -130,6 +130,9 @@ tools.test ; { { 0 1 2 3 0 0 1 } } [ { 1 2 3 3 2 1 2 } [ <= ] monotonic-count ] unit-test { 4 } [ { 1 2 3 1 2 3 4 5 } [ < ] max-monotonic-count ] unit-test +{ 4.0 } [ { 1e-30 1 3 -1e-30 } sum-floats ] unit-test +{ 1.0000000000000002e16 } [ { 1e-16 1 1e16 } sum-floats ] unit-test + { 2470 } [ 20 sum-squares ] unit-test { 2470 } [ 20 >array sum-squares ] unit-test @@ -148,3 +151,9 @@ tools.test ; { 1/5 } [ 3/5 1 kelly ] unit-test { 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 diff --git a/extra/math/extras/extras.factor b/extra/math/extras/extras.factor index 7e99b35364..47698cee8a 100644 --- a/extra/math/extras/extras.factor +++ b/extra/math/extras/extras.factor @@ -3,11 +3,11 @@ USING: accessors arrays assocs assocs.extras byte-arrays combinators combinators.short-circuit compression.zlib fry -grouping kernel locals math math.combinatorics math.constants -math.functions math.order math.primes math.primes.factors -math.ranges math.ranges.private math.statistics math.vectors -memoize parser random sequences sequences.extras -sequences.private sets sorting sorting.extras ; +grouping kernel locals math math.bitwise math.combinatorics +math.constants math.functions math.order math.primes +math.primes.factors math.ranges math.ranges.private +math.statistics math.vectors memoize parser random sequences +sequences.extras sequences.private sets sorting sorting.extras ; IN: math.extras @@ -173,8 +173,8 @@ PRIVATE> seq natural-sort :> sorted seq length :> len sorted 0 [ + ] cum-reduce :> ( a b ) - b len a * / :> B - 1 len recip + 2 B * - ; + b len a * / :> c + 1 len recip + 2 c * - ; PRIVATE> @@ -202,7 +202,8 @@ PRIVATE> unzip cum-sum [ last random ] [ bisect-left ] bi swap nth ; : unique-indices ( seq -- unique indices ) - [ members ] keep over dup length H{ } zip-as '[ _ at ] map ; + [ members ] keep over dup length + H{ } zip-as '[ _ at ] map ; : digitize] ( seq bins -- seq' ) '[ _ bisect-left ] map ; @@ -290,6 +291,53 @@ PRIVATE> [ 0.0 0.0 ] 2dip [ 2dip rot kahan+ ] curry [ -rot ] prepose each nip ; inline + yr y yr - ; inline + +:: partial-sums ( seq -- seq' ) + V{ } clone :> partials + seq [ + 0 partials [ + swapd sort-partial partial+ swapd + [ over partials set-nth 1 + ] unless-zero + ] each :> i + i partials shorten + [ i partials set-nth ] unless-zero + ] each partials ; + +:: sum-exact ( partials -- n ) + partials [ 0.0 ] [ + ! sum from the top, stop when sum becomes inexact + [ 0.0 0.0 ] dip [ + nip partial+ dup 0.0 = not + ] find-last drop :> ( lo n ) + + ! make half-even rounding work across multiple partials + n [ 0 > ] [ f ] if* [ + n 1 - partials nth + [ 0.0 < lo 0.0 < and ] + [ 0.0 > lo 0.0 > and ] bi or [ + lo 2.0 * :> y + dup y + :> x + x over - :> yr + y yr = [ drop x ] when + ] when + ] when + ] if-empty ; + +PRIVATE> + +: sum-floats ( seq -- n ) + partial-sums sum-exact ; + ! SYNTAX: .. dup pop scan-object [a,b) suffix! ; ! SYNTAX: ... dup pop scan-object [a,b] suffix! ; @@ -310,3 +358,18 @@ M: iota sum-cubes sum sq ; : kelly ( winning-probability odds -- fraction ) [ 1 + * 1 - ] [ / ] bi ; + +:: integer-sqrt ( m -- n ) + m [ 0 ] [ + dup 0 < [ non-negative-integer-expected ] when + bit-length 1 - 2 /i :> c + 1 :> a! + 0 :> d! + c bit-length [| 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 ; diff --git a/extra/project-euler/064/064.factor b/extra/project-euler/064/064.factor index 3ead2c409a..eae8824803 100644 --- a/extra/project-euler/064/064.factor +++ b/extra/project-euler/064/064.factor @@ -1,7 +1,59 @@ -USING: accessors arrays classes.tuple io kernel locals math math.functions - math.ranges prettyprint project-euler.common sequences ; +USING: accessors arrays classes.tuple io kernel locals math +math.functions math.ranges prettyprint project-euler.common +sequences ; IN: project-euler.064 +! http://projecteuler.net/index.php?section=problems&id=64 + +! DESCRIPTION +! ----------- + +! All square roots are periodic when written as continued +! fractions and can be written in the form: + +! √N=a0+1/(a1+1/(a2+1/a3+...)) + +! For example, let us consider √23: + +! √23=4+√(23)−4=4+1/(1/(√23−4)=4+1/(1+((√23−3)/7) + +! If we continue we would get the following expansion: + +! √23=4+1/(1+1/(3+1/(1+1/(8+...)))) + +! The process can be summarised as follows: + +! a0=4, 1/(√23−4) = (√23+4)/7 = 1+(√23−3)/7 +! a1=1, 7/(√23−3) = 7*(√23+3)/14 = 3+(√23−3)/2 +! a2=3, 2/(√23−3) = 2*(√23+3)/14 = 1+(√23−4)/7 +! a3=1, 7/(√23−4) = 7*(√23+4)/7 = 8+√23−4 +! a4=8, 1/(√23−4) = (√23+4)/7 = 1+(√23−3)/7 +! a5=1, 7/(√23−3) = 7*(√23+3)/14 = 3+(√23−3)/2 +! a6=3, 2/(√23−3) = 2*(√23+3)/14 = 1+(√23−4)/7 +! a7=1, 7/(√23−4) = 7*(√23+4)/7 = 8+√23−4 + +! It can be seen that the sequence is repeating. For +! conciseness, we use the notation √23=[4;(1,3,1,8)], to +! indicate that the block (1,3,1,8) repeats indefinitely. + +! The first ten continued fraction representations of +! (irrational) square roots are: + +! √2=[1;(2)] , period=1 +! √3=[1;(1,2)], period=2 +! √5=[2;(4)], period=1 +! √6=[2;(2,4)], period=2 +! √7=[2;(1,1,1,4)], period=4 +! √8=[2;(1,4)], period=2 +! √10=[3;(6)], period=1 +! √11=[3;(3,6)], period=2 +! √12=[3;(2,6)], period=2 +! √13=[3;(1,1,1,1,6)], period=5 + +! Exactly four continued fractions, for N <= 13, have an odd period. + +! How many continued fractions for N <= 10000 have an odd period? + cont-frac dup tuple>array rest cont-frac slots>tuple ; : create-cont-frac ( n -- n cont-frac ) - dup sqrt >fixnum - [let :> root - root - root - 1 - ] ; + dup sqrt >fixnum dup 1 ; : step ( n cont-frac -- n cont-frac ) swap dup @@ -54,13 +101,10 @@ C: cont-frac drop new-whole new-num-const new-denom ] ; -: loop ( c l n cont-frac -- c l n cont-frac ) - [let :> cf :> n :> l :> c - n cf step - :> new-cf drop - c 1 + l n new-cf - l new-cf = [ ] [ loop ] if - ] ; +:: loop ( c l n cf -- c l n cf ) + n cf step :> new-cf drop + c 1 + l n new-cf + l new-cf = [ loop ] unless ; : find-period ( n -- period ) 0 swap @@ -70,7 +114,8 @@ C: cont-frac loop drop drop drop ; -: try-all ( -- n ) 2 10000 [a,b] +: try-all ( -- n ) + 2 10000 [a,b] [ perfect-square? not ] filter [ find-period ] map [ odd? ] filter @@ -81,52 +126,51 @@ PRIVATE> : euler064a ( -- n ) try-all ; cfrac +: >cfrac< ( fr -- n a b ) + [ n>> ] [ a>> ] [ b>> ] tri ; + ! (√n + a) / b = 1 / (k + (√n + a') / b') ! ! b / (√n + a) = b (√n - a) / (n - a^2) = (√n - a) / ((n - a^2) / b) :: reciprocal ( fr -- fr' ) - fr n>> - fr a>> neg - fr n>> fr a>> sq - fr b>> / - - ; + fr >cfrac< :> ( n a b ) + n + a neg + n a sq - b / + ; :: split ( fr -- k fr' ) - fr n>> sqrt fr a>> + fr b>> / >integer - dup fr n>> swap - fr b>> * fr a>> swap - - fr b>> - - ; + fr >cfrac< :> ( n a b ) + n sqrt a + b / >integer + dup n swap + b * a swap - + b + ; : pure ( n -- fr ) - 0 1 - ; + 0 1 ; : next ( fr -- fr' ) - reciprocal split nip - ; + reciprocal split nip ; -:: period ( n -- per ) - n pure split nip :> start - n sqrt >integer sq n = - [ 0 ] - [ 1 start next - [ dup start = not ] - [ next [ 1 + ] dip ] - while - drop - ] if - ; +:: period ( n -- period ) + n sqrt >integer sq n = [ 0 ] [ + n pure split nip :> start + 1 start next + [ dup start = not ] + [ next [ 1 + ] dip ] + while drop + ] if ; PRIVATE> : euler064b ( -- ct ) - 1 10000 [a,b] - [ period odd? ] count - ; + 10000 [1,b] [ period odd? ] count ; + +SOLUTION: euler064b diff --git a/extra/project-euler/087/087.factor b/extra/project-euler/087/087.factor index c20498415c..0367e7a5a3 100644 --- a/extra/project-euler/087/087.factor +++ b/extra/project-euler/087/087.factor @@ -1,29 +1,53 @@ -USING: locals math math.primes sequences math.functions sets kernel ; +USING: locals math math.functions math.primes +project-euler.common sequences sets ; + IN: project-euler.087 -> O((n / log n)^(13/12)) ! -! When n = 50000000, the first equation is approximately 10 million and -! the second is approximately 2 billion. +! When n = 50,000,000, the first equation is approximately 10 +! million and the second is approximately 2 billion. :: prime-triples ( n -- answer ) n sqrt primes-upto :> primes @@ -32,9 +56,11 @@ IN: project-euler.087 primes 4 n prime-powers-less-than :> primes^4 primes^2 primes^3 [ + ] cartesian-map concat primes^4 [ + ] cartesian-map concat - [ n <= ] filter remove-duplicates length ; + [ n <= ] filter members length ; PRIVATE> :: euler087 ( -- answer ) - 50000000 prime-triples ; + 50,000,000 prime-triples ; + +SOLUTION: euler087 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 2db0cf4d35..5024a73d76 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,11 +1,11 @@ ! Copyright (c) 2007-2010 Aaron Schaefer. ! The contents of this file are licensed under the Simplified BSD License ! A copy of the license is available at http://factorcode.org/license.txt -USING: accessors arrays byte-arrays fry hints kernel lists make math - math.functions math.matrices math.order math.parser math.primes.factors - math.primes.lists math.primes.miller-rabin math.ranges math.ratios - math.vectors namespaces parser prettyprint quotations sequences sorting - strings unicode vocabs vocabs.parser words ; +USING: accessors arrays byte-arrays fry hints kernel lists make +math math.functions math.matrices math.order math.parser +math.primes.factors math.primes.lists math.ranges math.ratios +math.vectors parser prettyprint sequences sorting strings +unicode vocabs.parser words ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -38,31 +38,17 @@ IN: project-euler.common : perfect-square? ( n -- ? ) dup sqrt mod zero? ; +: alpha-value ( str -- n ) + >lower [ char: a - 1 + ] map-sum ; + +: mediant ( a/c b/d -- (a+b)/(c+d) ) + 2>fraction [ + ] 2bi@ / ; + [ - '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop - ] keep ; - -HINTS: count-digits fixnum ; - : max-children ( seq -- seq ) [ dup length 1 - [ nth-pair max , ] with each ] { } make ; -! Propagate one row into the upper one -: propagate ( bottom top -- newtop ) - [ over rest rot first2 max rot + ] map nip ; - -: (sum-divisors) ( n -- sum ) - dup sqrt >integer [1,b] [ - [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each - dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if - ] { } make sum ; - -: transform ( triple matrix -- new-triple ) - [ 1array ] dip m. first ; - PRIVATE> : alpha-value ( str -- n ) @@ -113,6 +99,14 @@ PRIVATE> : penultimate ( seq -- elt ) dup length 2 - swap nth ; + + ! Not strictly needed, but it is nice to be able to dump the ! triangle after the propagation : propagate-all ( triangle -- new-triangle ) @@ -120,9 +114,30 @@ PRIVATE> [ propagate dup ] map nip reverse swap suffix ; + [ + '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop + ] keep ; + +HINTS: count-digits fixnum ; + +PRIVATE> + : permutations? ( n m -- ? ) [ count-digits ] same? ; +integer [1,b] [ + [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each + dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if + ] { } make sum ; + +PRIVATE> + : sum-divisors ( n -- sum ) dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ; @@ -150,6 +165,13 @@ PRIVATE> dupd divisor? [ [ 2 + ] dip ] when ] each drop * ; + + ! These transforms are for generating primitive Pythagorean triples : u-transform ( triple -- new-triple ) { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index d33264a435..e3304283b2 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,46 +1,20 @@ ! Copyright (c) 2007-2010 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: definitions io io.files io.pathnames kernel math math.parser - prettyprint project-euler.ave-time sequences vocabs vocabs.loader - project-euler.001 project-euler.002 project-euler.003 project-euler.004 - project-euler.005 project-euler.006 project-euler.007 project-euler.008 - project-euler.009 project-euler.010 project-euler.011 project-euler.012 - project-euler.013 project-euler.014 project-euler.015 project-euler.016 - project-euler.017 project-euler.018 project-euler.019 project-euler.020 - project-euler.021 project-euler.022 project-euler.023 project-euler.024 - project-euler.025 project-euler.026 project-euler.027 project-euler.028 - project-euler.029 project-euler.030 project-euler.031 project-euler.032 - project-euler.033 project-euler.034 project-euler.035 project-euler.036 - project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.043 project-euler.044 - project-euler.045 project-euler.046 project-euler.047 project-euler.048 - project-euler.049 project-euler.050 project-euler.051 project-euler.052 - project-euler.053 project-euler.054 project-euler.055 project-euler.056 - project-euler.057 project-euler.058 project-euler.059 project-euler.062 - project-euler.063 project-euler.065 project-euler.067 project-euler.069 - project-euler.070 project-euler.071 project-euler.072 project-euler.073 - project-euler.074 project-euler.075 project-euler.076 project-euler.079 - project-euler.081 project-euler.085 project-euler.089 project-euler.092 - project-euler.097 project-euler.099 project-euler.100 project-euler.102 - project-euler.112 project-euler.116 project-euler.117 project-euler.124 - project-euler.134 project-euler.148 project-euler.150 project-euler.151 - project-euler.164 project-euler.169 project-euler.173 project-euler.175 - project-euler.186 project-euler.188 project-euler.190 project-euler.203 - project-euler.206 project-euler.215 project-euler.255 project-euler.265 ; +USING: io kernel math.parser prettyprint sequences +vocabs.loader ; IN: project-euler number ; + print flush readln string>number ; : number>euler ( n -- str ) number>string 3 char: 0 pad-head ; : solution-path ( n -- str/f ) - number>euler "project-euler." prepend - lookup-vocab where dup [ first ] when ; + number>euler "project-euler." prepend vocab-source-path ; PRIVATE>