Merge remote-tracking branch 'origin/master' into modern-harvey3

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

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 <iota>
+    [ 0x7c01 0x7dff between? ] reject
+    [ 0xfc01 0xfdff between? ] reject
+    [ dup bits>half half>bits = ] all?
+] unit-test

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 ;

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

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

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 [

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

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 <experiment> :> e
-    e experiment.
+    silent-tests? get [ e experiment. ] unless
     word execute [
         [
             current-test-file get [

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* ;

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&& ]

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 )

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" } "." } }

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=<image>          load Factor image file <image> (default " write vm-path file-stem write ".image)
     -run=<vocab>        run the MAIN: entry point of <vocab>
         -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 ;

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 <iota> [ 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 <cuckoo-filter> insert-data test-hit test-miss drop ;
+
+MAIN: cuckoo-filters-benchmark

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" } ")."

extra/help/lint/coverage/coverage-tests.factor

@@ -5,22 +5,22 @@ tools.test vocabs ;
 IN: help.lint.coverage.tests
 
 <PRIVATE
-: empty ( a v -- x y ) ;
-: nonexistent ( a v -- x y ) ;
-: defined ( x -- x ) ;
+: an-empty-word-with-a-unique-name ( a v -- x y ) ;
+: a-nonexistent-word ( a v -- x y ) ;
+: a-defined-word ( x -- x ) ;
 
-HELP: empty { $examples } ;
-HELP: nonexistent ;
-HELP: defined { $examples { $example "USING: prettyprint ; " "1 ." "1" } } ;
+HELP: an-empty-word-with-a-unique-name { $examples } ;
+HELP: a-nonexistent-word ;
+HELP: a-defined-word { $examples { $example "USING: prettyprint ; " "1 ." "1" } } ;
 PRIVATE>
 
-{ 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-help-coverage> 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( -- )

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 )
 

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 <iota> sum-squares ] unit-test
 { 2470 } [ 20 <iota> >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

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 <iota> H{ } zip-as '[ _ at ] map ;
+    [ members ] keep over dup length <iota>
+    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
 
+<PRIVATE
+
+! Adaptive Precision Floating-Point Arithmetic and Fast Robust Geometric Predicates
+! www-2.cs.cmu.edu/afs/cs/project/quake/public/papers/robust-arithmetic.ps
+
+: sort-partial ( x y -- x' y' )
+    2dup [ abs ] bi@ < [ swap ] when ; inline
+
+:: partial+ ( x y -- hi lo )
+    x y + dup x - :> 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 <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 ;

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?
+
 <PRIVATE
 
 TUPLE: cont-frac
@@ -15,12 +67,7 @@ C: <cont-frac> 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
-    ] <cont-frac> ;
+    dup sqrt >fixnum dup 1 <cont-frac> ;
 
 : step ( n cont-frac -- n cont-frac )
     swap dup
@@ -54,13 +101,10 @@ C: <cont-frac> cont-frac
         drop new-whole new-num-const new-denom <cont-frac>
     ] ;
 
-: 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> 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 ;
 
 <PRIVATE
+
 ! (√n + a)/b
 TUPLE: cfrac n a b ;
 
 C: <cfrac> 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>> /
-    <cfrac>
-    ;
+    fr >cfrac< :> ( n a b )
+    n
+    a neg
+    n a sq - b /
+    <cfrac> ;
 
 :: split ( fr -- k fr' )
-    fr n>> sqrt fr a>> + fr b>> / >integer
-    dup fr n>> swap
-    fr b>> * fr a>> swap -
-    fr b>>
-    <cfrac>
-    ;
+    fr >cfrac< :> ( n a b )
+    n sqrt a + b / >integer
+    dup n swap
+    b * a swap -
+    b
+    <cfrac> ;
 
 : pure ( n -- fr )
-    0 1 <cfrac>
-    ;
+    0 1 <cfrac> ;
 
 : 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

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
 
-<PRIVATE
+! https://projecteuler.net/index.php?section=problems&id=87
 
-: remove-duplicates ( seq -- seq' )
-    dup intersect ;
+! DESCRIPTION
+! -----------
+
+! The smallest number expressible as the sum of a prime square,
+! prime cube, and prime fourth power is 28. In fact, there are
+! exactly four numbers below fifty that can be expressed in such
+! a way:
+
+! 28 = 2^2 + 2^3 + 2^4
+! 33 = 3^2 + 2^3 + 2^4
+! 49 = 5^2 + 2^3 + 2^4
+! 47 = 2^2 + 3^3 + 2^4
+
+! How many numbers below fifty million can be expressed as the
+! sum of a prime square, prime cube, and prime fourth power?
+
+<PRIVATE
 
 :: prime-powers-less-than ( primes pow n -- prime-powers )
     primes [ pow ^ ] map [ n <= ] filter ;
 
-! You may think to make a set of all possible sums of a prime square and cube 
-! and then subtract prime fourths from numbers ranging from 1 to 'n' to find 
-! this. As n grows large, this is actually more inefficient!
+! You may think to make a set of all possible sums of a prime
+! square and cube and then subtract prime fourths from numbers
+! ranging from 1 to 'n' to find this. As n grows large, this is
+! actually more inefficient!
+!
 ! Prime numbers grow ~ n / log n
+!
 ! Thus there are (n / log n)^(1/2) prime squares <= n,
 !                (n / log n)^(1/3) prime cubes   <= n,
 !            and (n / log n)^(1/4) prime fourths <= n.
-! If we compute the cartesian product of these, this takes 
+!
+! If we compute the cartesian product of these, this takes
 ! O((n / log n)^(13/12)).
-! If we instead precompute sums of squares and cubes, and iterate up to n,
-! checking each fourth power against it, this takes
+!
+! If we instead precompute sums of squares and cubes, and
+! iterate up to n, checking each fourth power against it, this
+! takes:
+!
 ! O(n * (n / log n)^(1/4)) = O(n^(5/4)/(log n)^(1/4)) >> 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

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@ / ;
+
 <PRIVATE
 
-: count-digits ( n -- byte-array )
-    10 <byte-array> [
-        '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
-    ] keep ;
-
-HINTS: count-digits fixnum ;
-
 : max-children ( seq -- seq )
     [ dup length 1 - <iota> [ 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 ;
 
+<PRIVATE
+
+! Propagate one row into the upper one
+: propagate ( bottom top -- newtop )
+    [ over rest rot first2 max rot + ] map nip ;
+
+PRIVATE>
+
 ! 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 ;
 
+<PRIVATE
+
+: count-digits ( n -- byte-array )
+    10 <byte-array> [
+        '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
+    ] keep ;
+
+HINTS: count-digits fixnum ;
+
+PRIVATE>
+
 : permutations? ( n m -- ? )
     [ count-digits ] same? ;
 
+<PRIVATE
+
+: (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 ;
+
+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 * ;
 
+<PRIVATE
+
+: transform ( triple matrix -- new-triple )
+    [ 1array ] dip m. first ;
+
+PRIVATE>
+
 ! These transforms are for generating primitive Pythagorean triples
 : u-transform ( triple -- new-triple )
     { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;

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
 
 <PRIVATE
 
 : problem-prompt ( -- n )
     "Which problem number from Project Euler would you like to solve?"
-    print readln string>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 <pathname> ] when ;
+    number>euler "project-euler." prepend vocab-source-path ;
 
 PRIVATE>