diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 514c808ee0..7f40969b95 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -1,37 +1,93 @@ -USING: help.markup help.syntax kernel math math.order sequences ; +USING: help.markup help.syntax kernel math math.order multiline sequences ; IN: math.combinatorics HELP: factorial { $values { "n" "a non-negative integer" } { "n!" integer } } { $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "4 factorial ." "24" } +} ; HELP: nPk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } { $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nPk ." "5040" } +} ; HELP: nCk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } { $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nCk ." "210" } +} ; HELP: permutation { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "1 3 permutation ." "{ 0 2 1 }" } + { $example "USING: math.combinatorics prettyprint ;" + "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } +} ; HELP: all-permutations { $values { "seq" sequence } { "seq" sequence } } { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } +} ; + +HELP: each-permutation +{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ; HELP: inverse-permutation { $values { "seq" sequence } { "permutation" sequence } } { $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } { $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } + { $example "USING: math.combinatorics prettyprint ;" + "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } +} ; + +HELP: combination +{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." } +{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." } +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "6 7 iota 4 combination ." "{ 0 1 3 6 }" } + { $example "USING: math.combinatorics prettyprint ;" + "0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" } +} ; + +HELP: all-combinations +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." } +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ." +<" { + { "a" "b" } + { "a" "c" } + { "a" "d" } + { "b" "c" } + { "b" "d" } + { "c" "d" } +}"> } } ; + +HELP: each-combination +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ; IN: math.combinatorics.private diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 5ef435a4e0..1bc4bbc825 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -1,18 +1,6 @@ USING: math.combinatorics math.combinatorics.private tools.test ; IN: math.combinatorics.tests -[ { } ] [ 0 factoradic ] unit-test -[ { 1 0 } ] [ 1 factoradic ] unit-test -[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test - -[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test -[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test - -[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test -[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test - [ 1 ] [ 0 factorial ] unit-test [ 1 ] [ 1 factorial ] unit-test [ 3628800 ] [ 10 factorial ] unit-test @@ -31,6 +19,19 @@ IN: math.combinatorics.tests [ 2598960 ] [ 52 5 nCk ] unit-test [ 2598960 ] [ 52 47 nCk ] unit-test + +[ { } ] [ 0 factoradic ] unit-test +[ { 1 0 } ] [ 1 factoradic ] unit-test +[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test + +[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test +[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test + +[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test +[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test + [ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test @@ -43,3 +44,29 @@ IN: math.combinatorics.tests [ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test [ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test + +[ 2598960 ] [ 52 iota 5 choose ] unit-test + +[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test +[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test +[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test +[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test + +[ 9 ] [ 0 5 iota 3 dual-index ] unit-test +[ 0 ] [ 9 5 iota 3 dual-index ] unit-test +[ 179 ] [ 72 10 iota 5 dual-index ] unit-test + +[ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test +[ { 4 3 2 1 0 } ] [ 10 iota 5 0 combinadic ] unit-test +[ { 8 6 3 1 0 } ] [ 10 iota 5 72 combinadic ] unit-test +[ { 9 8 7 6 5 } ] [ 10 iota 5 251 combinadic ] unit-test + +[ { 0 1 2 } ] [ 0 5 iota 3 combination-indices ] unit-test +[ { 2 3 4 } ] [ 9 5 iota 3 combination-indices ] unit-test + +[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test +[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test + +[ { { "a" "b" } { "a" "c" } + { "a" "d" } { "b" "c" } + { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index afdf4e378e..bc09f9fe0f 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,7 +1,7 @@ -! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. +! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math math.order math.ranges mirrors -namespaces sequences sorting fry ; +USING: accessors assocs binary-search fry kernel locals math math.order + math.ranges mirrors namespaces sequences sorting ; IN: math.combinatorics [ dupd - ] when ; inline -! See this article for explanation of the factoradic-based permutation methodology: -! http://msdn2.microsoft.com/en-us/library/aa302371.aspx +PRIVATE> + +: factorial ( n -- n! ) + 1 [ 1 + * ] reduce ; + +: nPk ( n k -- nPk ) + 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; + +: nCk ( n k -- nCk ) + twiddle [ nPk ] keep factorial / ; + + +! Factoradic-based permutation methodology + + ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ; + 0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ; : (>permutation) ( seq n -- seq ) - [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ; + [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ; : >permutation ( factoradic -- permutation ) reverse 1 cut [ (>permutation) ] each ; @@ -29,27 +42,84 @@ IN: math.combinatorics PRIVATE> -: factorial ( n -- n! ) - 1 [ 1+ * ] reduce ; - -: nPk ( n k -- nPk ) - 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; - -: nCk ( n k -- nCk ) - twiddle [ nPk ] keep factorial / ; - : permutation ( n seq -- seq ) [ permutation-indices ] keep nths ; : all-permutations ( seq -- seq ) - [ length factorial ] keep '[ _ permutation ] map ; + [ length factorial ] keep + '[ _ permutation ] map ; : each-permutation ( seq quot -- ) [ [ length factorial ] keep ] dip '[ _ permutation @ ] each ; inline -: reduce-permutations ( seq initial quot -- result ) +: reduce-permutations ( seq identity quot -- result ) swapd each-permutation ; inline : inverse-permutation ( seq -- permutation ) >alist sort-values keys ; + + +! Combinadic-based combination methodology + + combo + +: choose ( combo -- nCk ) + [ seq>> length ] [ k>> ] bi nCk ; + +: largest-value ( a b x -- v ) + dup 0 = [ + drop 1 - nip + ] [ + [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip + ] if ; + +:: next-values ( a b x -- a' b' x' v ) + a b x largest-value dup :> v ! a' + b 1 - ! b' + x v b nCk - ! x' + v ; ! v == a' + +: dual-index ( m combo -- m' ) + choose 1 - swap - ; + +: initial-values ( combo m -- n k m ) + [ [ seq>> length ] [ k>> ] bi ] dip ; + +: combinadic ( combo m -- combinadic ) + initial-values [ over 0 > ] [ next-values ] produce + [ 3drop ] dip ; + +: combination-indices ( m combo -- seq ) + [ tuck dual-index combinadic ] keep + seq>> length 1 - swap [ - ] with map ; + +: apply-combination ( m combo -- seq ) + [ combination-indices ] keep seq>> nths ; + +PRIVATE> + +: combination ( m seq k -- seq ) + apply-combination ; + +: all-combinations ( seq k -- seq ) + [ choose [0,b) ] keep + '[ _ apply-combination ] map ; + +: each-combination ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] each ; inline + +: map-combinations ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] map ; inline + +: reduce-combinations ( seq k identity quot -- result ) + [ -rot ] dip each-combination ; inline + diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 88c01d5271..991924dfe4 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Doug Coleman. +! Copyright (c) 2008-2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel locals math math.functions math.ranges random sequences sets combinators.short-circuit math.bitwise @@ -27,7 +27,7 @@ IN: math.miller-rabin ] [ r iota [ 2^ s * a swap n ^mod n - -1 = - ] any? not + ] any? not ] if ] any? not ; diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor index 5de5cc5e99..0f8a98e6f9 100644 --- a/extra/benchmark/pidigits/pidigits.factor +++ b/extra/benchmark/pidigits/pidigits.factor @@ -18,7 +18,7 @@ IN: benchmark.pidigits : >matrix ( q s r t -- z ) 4array 2 group ; -: produce ( z n -- z' ) +: produce ( z y -- z' ) [ 10 ] dip -10 * 0 1 >matrix swap m. ; : gen-x ( x -- matrix ) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index 09019a29d7..fef47b859c 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax strings ; IN: poker HELP: -{ $values { "str" string } { "hand" "a new hand" } } +{ $values { "str" string } { "hand" "a new " { $link hand } } } { $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." } { $examples { $example "USING: kernel math.order poker prettyprint ;" @@ -12,8 +12,16 @@ HELP: } { $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ; +HELP: best-hand +{ $values { "str" string } { "hand" "a new " { $link hand } } } +{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } +{ $examples + { $example "USING: kernel poker prettyprint ;" + "\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" } +} ; + HELP: >cards -{ $values { "hand" "a hand" } { "str" string } } +{ $values { "hand" hand } { "str" string } } { $description "Outputs a string representation of a hand's cards." } { $examples { $example "USING: poker prettyprint ;" @@ -21,10 +29,18 @@ HELP: >cards } ; HELP: >value -{ $values { "hand" "a hand" } { "str" string } } +{ $values { "hand" hand } { "str" string } } { $description "Outputs a string representation of a hand's value." } { $examples { $example "USING: poker prettyprint ;" "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; + +HELP: +{ $values { "deck" "a new " { $link deck } } } +{ $description "Creates a standard deck of 52 cards." } ; + +HELP: shuffle +{ $values { "deck" deck } { "deck" "a shuffled " { $link deck } } } +{ $description "Shuffles the cards in " { $snippet "deck" } ", in-place, using the Fisher-Yates algorithm." } ; diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index ad371a6bff..6b05178462 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -1,4 +1,4 @@ -USING: accessors poker poker.private tools.test math.order kernel ; +USING: accessors kernel math.order poker poker.private tools.test ; IN: poker.tests [ 134236965 ] [ "KD" >ckf ] unit-test @@ -26,3 +26,5 @@ IN: poker.tests [ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ = ] unit-test [ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ eq? ] unit-test + +[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index e8e9fa23c5..a5a5a93628 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -1,7 +1,9 @@ -! Copyright (c) 2009 Aaron Schaefer. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors ascii binary-search combinators kernel locals math - math.bitwise math.order poker.arrays sequences splitting ; +! Copyright (c) 2009 Aaron Schaefer. All rights reserved. +! 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 ascii binary-search combinators kernel locals math + math.bitwise math.combinatorics math.order poker.arrays random sequences + sequences.product splitting ; IN: poker ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with @@ -47,19 +49,21 @@ CONSTANT: QUEEN 10 CONSTANT: KING 11 CONSTANT: ACE 12 -CONSTANT: STRAIGHT_FLUSH 1 -CONSTANT: FOUR_OF_A_KIND 2 -CONSTANT: FULL_HOUSE 3 -CONSTANT: FLUSH 4 -CONSTANT: STRAIGHT 5 -CONSTANT: THREE_OF_A_KIND 6 -CONSTANT: TWO_PAIR 7 -CONSTANT: ONE_PAIR 8 -CONSTANT: HIGH_CARD 9 +CONSTANT: STRAIGHT_FLUSH 0 +CONSTANT: FOUR_OF_A_KIND 1 +CONSTANT: FULL_HOUSE 2 +CONSTANT: FLUSH 3 +CONSTANT: STRAIGHT 4 +CONSTANT: THREE_OF_A_KIND 5 +CONSTANT: TWO_PAIR 6 +CONSTANT: ONE_PAIR 7 +CONSTANT: HIGH_CARD 8 + +CONSTANT: SUIT_STR { "C" "D" "H" "S" } CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" } -CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" +CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush" "Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" } : card-rank-prime ( rank -- n ) @@ -108,6 +112,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" #! Cactus Kev Format >upper 1 cut (>ckf) ; +: parse-cards ( str -- seq ) + " " split [ >ckf ] map ; + : flush? ( cards -- ? ) HEX: F000 [ bitand ] reduce 0 = not ; @@ -152,8 +159,8 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" [ drop "S" ] } cond ; -: hand-rank ( hand -- rank ) - value>> { +: hand-rank ( value -- rank ) + { { [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card { [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair { [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair @@ -165,24 +172,38 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" [ drop STRAIGHT_FLUSH ] ! 10 straight-flushes } cond ; +: card>string ( card -- str ) + [ >card-rank ] [ >card-suit ] bi append ; + PRIVATE> TUPLE: hand { cards sequence } - { value integer } ; + { value integer initial: 9999 } ; M: hand <=> [ value>> ] compare ; M: hand equal? over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ; : ( str -- hand ) - " " split [ >ckf ] map - dup hand-value hand boa ; + parse-cards dup hand-value hand boa ; + +: best-hand ( str -- hand ) + parse-cards 5 hand new + [ dup hand-value hand boa min ] reduce-combinations ; : >cards ( hand -- str ) - cards>> [ - [ >card-rank ] [ >card-suit ] bi append - ] map " " join ; + cards>> [ card>string ] map " " join ; : >value ( hand -- str ) - hand-rank VALUE_STR nth ; + value>> hand-rank VALUE_STR nth ; + +TUPLE: deck + { cards sequence } ; + +: ( -- deck ) + RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ; + +: shuffle ( deck -- deck ) + [ randomize ] change-cards ; + diff --git a/extra/poker/summary.txt b/extra/poker/summary.txt index c8efe851c8..8dbbe9bd74 100644 --- a/extra/poker/summary.txt +++ b/extra/poker/summary.txt @@ -1 +1 @@ -5-card poker hand evaluator +Poker hand evaluator diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 0d4f5fb1bd..204527418b 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov. +! Copyright (c) 2007-2009 Aaron Schaefer, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.ranges project-euler.common sequences sets ; @@ -47,14 +47,14 @@ PRIVATE> : euler001b ( -- answer ) - 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; + 1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; ! [ euler001b ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) : euler001c ( -- answer ) - 1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ; + 1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ; ! [ euler001c ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor index 7fef29a6b9..8512bc97fa 100644 --- a/extra/project-euler/005/005.factor +++ b/extra/project-euler/005/005.factor @@ -1,6 +1,6 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2009 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: math math.functions sequences project-euler.common ; +USING: math math.functions math.ranges project-euler.common sequences ; IN: project-euler.005 ! http://projecteuler.net/index.php?section=problems&id=5 @@ -18,7 +18,7 @@ IN: project-euler.005 ! -------- : euler005 ( -- answer ) - 20 1 [ 1+ lcm ] reduce ; + 20 [1,b] 1 [ lcm ] reduce ; ! [ euler005 ] 100 ave-time ! 0 ms ave run time - 0.14 SD (100 trials) diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor index 9c7c4fee74..9189323121 100644 --- a/extra/project-euler/018/018.factor +++ b/extra/project-euler/018/018.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math project-euler.common sequences ; +USING: kernel math math.ranges project-euler.common sequences ; IN: project-euler.018 ! http://projecteuler.net/index.php?section=problems&id=18 @@ -66,7 +66,7 @@ IN: project-euler.018 91 71 52 38 17 14 91 43 58 50 27 29 48 63 66 04 68 89 53 67 30 73 16 69 87 40 31 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23 - } 15 iota [ 1+ cut swap ] map nip ; + } 15 [1,b] [ cut swap ] map nip ; PRIVATE> diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor index 80a933dc63..5dfe7b9f56 100644 --- a/extra/project-euler/025/025.factor +++ b/extra/project-euler/025/025.factor @@ -39,7 +39,7 @@ IN: project-euler.025 ! Memoized brute force MEMO: fib ( m -- n ) - dup 1 > [ 1- dup fib swap 1- fib + ] when ; + dup 1 > [ [ 1 - fib ] [ 2 - fib ] bi + ] when ; : euler030 ( -- answer ) - 325537 [ dup sum-fifth-powers = ] filter sum 1- ; + 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ; ! [ euler030 ] 100 ave-time ! 1700 ms ave run time - 64.84 SD (100 trials) diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 64c9ec445e..814f8a5a63 100755 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -28,7 +28,7 @@ IN: project-euler.032 : source-032 ( -- seq ) 9 factorial iota [ - 9 permutation [ 1+ ] map 10 digits>integer + 9 permutation [ 1 + ] map 10 digits>integer ] map ; : 1and4 ( n -- ? ) diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor index e56b9e9548..640a3a68f6 100644 --- a/extra/project-euler/048/048.factor +++ b/extra/project-euler/048/048.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions sequences project-euler.common ; +USING: kernel math math.functions math.ranges project-euler.common sequences ; IN: project-euler.048 ! http://projecteuler.net/index.php?section=problems&id=48 @@ -17,7 +17,7 @@ IN: project-euler.048 ! -------- : euler048 ( -- answer ) - 1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ; + 1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ; ! [ euler048 ] 100 ave-time ! 276 ms run / 1 ms GC ave time - 100 trials diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor index 43f380b3ba..07525fe6a4 100644 --- a/extra/project-euler/055/055.factor +++ b/extra/project-euler/055/055.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser project-euler.common sequences ; +USING: kernel math math.parser math.ranges project-euler.common sequences ; IN: project-euler.055 ! http://projecteuler.net/index.php?section=problems&id=55 @@ -61,7 +61,7 @@ IN: project-euler.055 PRIVATE> : euler055 ( -- answer ) - 10000 [ lychrel? ] count ; + 10000 [0,b) [ lychrel? ] count ; ! [ euler055 ] 100 ave-time ! 478 ms ave run time - 30.63 SD (100 trials) diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor index 681a17dd9e..97789944fe 100644 --- a/extra/project-euler/057/057.factor +++ b/extra/project-euler/057/057.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Samuel Tardieu ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.parser sequences project-euler.common ; +USING: kernel math math.functions math.parser math.ranges project-euler.common + sequences ; IN: project-euler.057 ! http://projecteuler.net/index.php?section=problems&id=57 @@ -11,14 +12,14 @@ IN: project-euler.057 ! It is possible to show that the square root of two can be expressed ! as an infinite continued fraction. -! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213... +! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213... ! By expanding this for the first four iterations, we get: -! 1 + 1/2 = 3/2 = 1.5 -! 1 + 1/(2 + 1/2) = 7/5 = 1.4 -! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666... -! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379... +! 1 + 1/2 = 3/2 = 1.5 +! 1 + 1/(2 + 1/2) = 7/5 = 1.4 +! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666... +! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379... ! The next three expansions are 99/70, 239/169, and 577/408, but the ! eighth expansion, 1393/985, is the first example where the number of @@ -35,9 +36,9 @@ IN: project-euler.057 >fraction [ number>string length ] bi@ > ; inline : euler057 ( -- answer ) - 0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ; + 0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ; -! [ euler057 ] time -! 3.375118 seconds +! [ euler057 ] 100 ave-time +! 1728 ms ave run time - 80.81 SD (100 trials) SOLUTION: euler057 diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 314698534f..eeb4b0c315 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. -USING: hints kernel locals math math.order sequences sequences.private project-euler.common ; +USING: hints kernel locals math math.order math.ranges project-euler.common + sequences sequences.private ; IN: project-euler.150 ! http://projecteuler.net/index.php?section=problems&id=150 @@ -50,13 +51,13 @@ IN: project-euler.150 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline : sums-triangle ( -- seq ) - 0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ; + 0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ; :: (euler150) ( m -- n ) [let | table [ sums-triangle ] | m [| x | x 1+ [| y | - m x - iota [| z | + m x - [0,b) [| z | x z + table nth-unsafe [ y z + 1+ swap nth-unsafe ] [ y swap nth-unsafe ] bi -