Merge branch 'master' of git://factorcode.org/git/factor

2009-04-03 09:22:47 -05:00 · 2009-04-03 09:22:47 -05:00 · 038509f652
parent 1731b57249 7e0f271cf3
commit 038509f652
17 changed files with 145 additions and 43 deletions
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces sequences
-strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary combinators.short-circuit ;
+USING: accessors arrays classes.tuple combinators combinators.short-circuit
+    kernel locals math math.functions math.order namespaces sequences strings
+    summary system threads vocabs.loader ;
 IN: calendar

 HOOK: gmt-offset os ( -- hours minutes seconds )
@ -136,7 +136,7 @@ CONSTANT: day-abbreviations3
 GENERIC: leap-year? ( obj -- ? )

 M: integer leap-year? ( year -- ? )
-    dup 100 mod zero? 400 4 ? mod zero? ;
+    dup 100 divisor? 400 4 ? divisor? ;

 M: timestamp leap-year? ( timestamp -- ? )
    year>> leap-year? ;
@ -348,7 +348,7 @@ M: duration time-
    #! good for any date since October 15, 1582
    [
        dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
-        [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
+        [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
        [ 1+ 3 * 5 /i + ] keep 2 * +
    ] dip 1+ + 7 mod ;

--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@ -60,7 +60,7 @@ M: topic url-of topic>filename ;
 : help>html ( topic -- xml )
    [ article-title ]
    [ drop help-stylesheet ]
-    [ [ help ] with-html-writer ]
+    [ [ print-topic ] with-html-writer ]
    tri simple-page ;
          
 : generate-help-file ( topic -- )
--- a/basis/math/functions/functions-docs.factor
+++ b/basis/math/functions/functions-docs.factor
@ -13,7 +13,8 @@ ARTICLE: "integer-functions" "Integer functions"
 "Tests:"
 { $subsection power-of-2? }
 { $subsection even? }
-{ $subsection odd? } ;
+{ $subsection odd? }
+{ $subsection divisor? } ;

 ARTICLE: "arithmetic-functions" "Arithmetic functions"
 "Computing additive and multiplicative inverses:"
@ -269,6 +270,11 @@ HELP: gcd
 { $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
 { $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ;

+HELP: divisor?
+{ $values { "m" integer } { "n" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "n" } " is a divisor of " { $snippet "m" } ". This is the same thing as asking if " { $snippet "m" } " is divisible by " { $snippet "n" } "." }
+{ $notes "Returns t for both negative and positive divisors, as well as for trivial and non-trivial divisors." } ;
+
 HELP: mod-inv
 { $values { "x" integer } { "n" integer } { "y" integer } }
 { $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." }
--- a/basis/math/functions/functions-tests.factor
+++ b/basis/math/functions/functions-tests.factor
@ -32,13 +32,13 @@ IN: math.functions.tests

 [ 1.0 ] [ 0 cosh ] unit-test
 [ 0.0 ] [ 1 acosh ] unit-test
-            
+
 [ 1.0 ] [ 0 cos ] unit-test
 [ 0.0 ] [ 1 acos ] unit-test
-            
+
 [ 0.0 ] [ 0 sinh ] unit-test
 [ 0.0 ] [ 0 asinh ] unit-test
-            
+
 [ 0.0 ] [ 0 sin ] unit-test
 [ 0.0 ] [ 0 asin ] unit-test

@ -97,11 +97,17 @@ IN: math.functions.tests

 : verify-gcd ( a b -- ? )
    2dup gcd
-    [ rot * swap rem ] dip = ; 
+    [ rot * swap rem ] dip = ;

 [ t ] [ 123 124 verify-gcd ] unit-test
 [ t ] [ 50 120 verify-gcd ] unit-test

+[ t ] [ 0 42 divisor? ] unit-test
+[ t ] [ 42 7 divisor? ] unit-test
+[ t ] [ 42 -7 divisor? ] unit-test
+[ t ] [ 42 42 divisor? ] unit-test
+[ f ] [ 42 16 divisor? ] unit-test
+
 [ 3 ] [ 5 7 mod-inv ] unit-test
 [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test

@ -150,4 +156,4 @@ IN: math.functions.tests
    1067811677921310779
    2135623355842621559
    [ >bignum ] tri@ ^mod
-] unit-test
+] unit-test
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@ -111,6 +111,9 @@ PRIVATE>
 : lcm ( a b -- c )
    [ * ] 2keep gcd nip /i ; foldable

+: divisor? ( m n -- ? )
+    mod 0 = ;
+
 : mod-inv ( x n -- y )
    [ nip ] [ gcd 1 = ] 2bi
    [ dup 0 < [ + ] [ nip ] if ]
@ -198,7 +201,7 @@ M: real sin fsin ;

 GENERIC: sinh ( x -- y ) foldable

-M: complex sinh 
+M: complex sinh
    >float-rect
    [ [ fsinh ] [ fcos ] bi* * ]
    [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
--- a/basis/math/primes/factors/factors.factor
+++ b/basis/math/primes/factors/factors.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.primes sequences ;
+USING: arrays combinators kernel make math math.functions math.primes sequences ;
 IN: math.primes.factors

 <PRIVATE
@ -11,7 +11,7 @@ IN: math.primes.factors
    swap ;

 : write-factor ( n d -- n' d' )
-    2dup mod zero? [
+    2dup divisor? [
        [ [ count-factor ] keep swap 2array , ] keep
        ! If the remainder is a prime number, increase d so that
        ! the caller stops looking for factors.
--- a/extra/project-euler/001/001-tests.factor
+++ b/extra/project-euler/001/001-tests.factor
@ -4,3 +4,4 @@ IN: project-euler.001.tests
 [ 233168 ] [ euler001 ] unit-test
 [ 233168 ] [ euler001a ] unit-test
 [ 233168 ] [ euler001b ] unit-test
+[ 233168 ] [ euler001c ] unit-test
--- a/extra/project-euler/001/001.factor
+++ b/extra/project-euler/001/001.factor
@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.ranges sequences project-euler.common ;
 IN: project-euler.001

 ! http://projecteuler.net/index.php?section=problems&id=1
@ -51,4 +51,11 @@ PRIVATE>
 ! [ euler001b ] 100 ave-time
 ! 0 ms run / 0 ms GC ave time - 100 trials

+
+: euler001c ( -- answer )
+    1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+
+! [ euler001c ] 100 ave-time
+! 0 ms ave run time - 0.06 SD (100 trials)
+
 SOLUTION: euler001
--- a/extra/project-euler/004/004.factor
+++ b/extra/project-euler/004/004.factor
@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.ranges project-euler.common sequences
-    sorting sets ;
+USING: hashtables kernel math math.functions math.ranges project-euler.common
+    sequences sorting sets ;
 IN: project-euler.004

 ! http://projecteuler.net/index.php?section=problems&id=4
@ -21,7 +21,7 @@ IN: project-euler.004
 <PRIVATE

 : source-004 ( -- seq )
-    100 999 [a,b] [ 10 mod 0 = not ] filter ;
+    100 999 [a,b] [ 10 divisor? not ] filter ;

 : max-palindrome ( seq -- palindrome )
    natural-sort [ palindrome? ] find-last nip ;
--- a/extra/project-euler/014/014.factor
+++ b/extra/project-euler/014/014.factor
@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel make math math.ranges
-sequences project-euler.common ;
+USING: combinators.short-circuit kernel make math math.functions math.ranges
+    sequences project-euler.common ;
 IN: project-euler.014

 ! http://projecteuler.net/index.php?section=problems&id=14
@ -59,7 +59,7 @@ PRIVATE>
 <PRIVATE

 : worth-calculating? ( n -- ? )
-    1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
+    1- 3 { [ divisor? ] [ / even? ] } 2&& ;

 PRIVATE>

--- a/extra/project-euler/033/033.factor
+++ b/extra/project-euler/033/033.factor
@ -33,7 +33,7 @@ IN: project-euler.033
    10 99 [a,b] dup cartesian-product [ first2 < ] filter ;

 : safe? ( ax xb -- ? )
-    [ 10 /mod ] bi@ -roll = rot zero? not and nip ;
+    [ 10 /mod ] bi@ [ = ] dip zero? not and nip ;

 : ax/xb ( ax xb -- z/f )
    2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ;
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math math.combinatorics math.parser
-    math.ranges project-euler.common sequences sets sorting ;
+USING: combinators.short-circuit kernel math math.functions math.combinatorics
+    math.parser math.ranges project-euler.common sequences sets sorting ;
 IN: project-euler.043

 ! http://projecteuler.net/index.php?section=problems&id=43
@ -36,7 +36,7 @@ IN: project-euler.043
 <PRIVATE

 : subseq-divisible? ( n index seq -- ? )
-    [ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ;
+    [ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ;

 : interesting? ( seq -- ? )
    {
--- a/extra/project-euler/049/049-tests.factor
+++ b/extra/project-euler/049/049-tests.factor
@ -0,0 +1,4 @@
+USING: project-euler.049 tools.test ;
+IN: project-euler.049.tests
+
+[ 296962999629 ] [ euler049 ] unit-test
--- a/extra/project-euler/049/049.factor
+++ b/extra/project-euler/049/049.factor
@ -0,0 +1,74 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays fry hints kernel math math.combinatorics
+    math.functions math.parser math.primes project-euler.common sequences sets ;
+IN: project-euler.049
+
+! http://projecteuler.net/index.php?section=problems&id=49
+
+! DESCRIPTION
+! -----------
+
+! The arithmetic sequence, 1487, 4817, 8147, in which each of the terms
+! increases by 3330, is unusual in two ways: (i) each of the three terms are
+! prime, and, (ii) each of the 4-digit numbers are permutations of one another.
+
+! There are no arithmetic sequences made up of three 1-, 2-, or 3-digit primes,
+! exhibiting this property, but there is one other 4-digit increasing sequence.
+
+! What 12-digit number do you form by concatenating the three terms in this
+! sequence?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: count-digits ( n -- byte-array )
+    10 <byte-array> [
+        '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop
+    ] keep ;
+
+HINTS: count-digits fixnum ;
+
+: permutations? ( n m -- ? )
+    [ count-digits ] bi@ = ;
+
+: collect-permutations ( seq -- seq )
+    [ V{ } clone ] [ dup ] bi* [
+        dupd '[ _ permutations? ] filter
+        [ diff ] keep pick push
+    ] each drop ;
+
+: potential-sequences ( -- seq )
+    1000 9999 primes-between
+    collect-permutations [ length 3 >= ] filter ;
+
+: arithmetic-terms ( m n -- seq )
+    2dup [ swap - ] keep + 3array ;
+
+: (find-unusual-terms) ( n seq -- seq/f )
+    [ [ arithmetic-terms ] with map ] keep
+    '[ _ [ peek ] dip member? ] find nip ;
+
+: find-unusual-terms ( seq -- seq/? )
+    unclip-slice over (find-unusual-terms) [
+        nip
+    ] [
+        dup length 3 >= [ find-unusual-terms ] [ drop f ] if
+    ] if* ;
+
+: 4digit-concat ( seq -- str )
+    0 [ [ 10000 * ] dip + ] reduce ;
+
+PRIVATE>
+
+: euler049 ( -- answer )
+    potential-sequences [ find-unusual-terms ] map sift
+    [ { 1487 4817 8147 } = not ] find nip 4digit-concat ;
+
+! [ euler049 ] 100 ave-time
+! 206 ms ave run time - 10.25 SD (100 trials)
+
+SOLUTION: euler049
--- a/extra/project-euler/052/052.factor
+++ b/extra/project-euler/052/052.factor
@ -1,8 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math
-    project-euler.common sequences sorting
-    grouping ;
+USING: combinators.short-circuit kernel math math.functions
+    project-euler.common sequences sorting grouping ;
 IN: project-euler.052

 ! http://projecteuler.net/index.php?section=problems&id=52
@ -31,7 +30,7 @@ IN: project-euler.052
    [ number>digits natural-sort ] map all-equal? ;

 : candidate? ( n -- ? )
-    { [ odd? ] [ 3 mod 0 = ] } 1&& ;
+    { [ odd? ] [ 3 divisor? ] } 1&& ;

 : next-all-same ( x n -- n )
    dup candidate? [
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@ -44,7 +44,7 @@ IN: project-euler.common

 : (sum-divisors) ( n -- sum )
    dup sqrt >integer [1,b] [
-        [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
+        [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
        dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
    ] { } make sum ;

@ -57,7 +57,7 @@ PRIVATE>
    >lower [ CHAR: a - 1+ ] sigma ;

 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
-    swap [ swap [ 2array ] with map ] with map concat ;
+    [ [ 2array ] with map ] curry map concat ;

 : log10 ( m -- n )
    log 10 log / ;
@ -75,6 +75,9 @@ PRIVATE>
 : number>digits ( n -- seq )
    [ dup 0 = not ] [ 10 /mod ] produce reverse nip ;

+: number-length ( n -- m )
+    log10 floor 1+ >integer ;
+
 : nth-triangle ( n -- n )
    dup 1+ * 2 / ;

@ -117,7 +120,7 @@ PRIVATE>
    factor-2s dup [ 1+ ]
    [ perfect-square? -1 0 ? ]
    [ dup sqrt >fixnum [1,b] ] tri* [
-        dupd mod 0 = [ [ 2 + ] dip ] when
+        dupd divisor? [ [ 2 + ] dip ] when
    ] each drop * ;

 ! These transforms are for generating primitive Pythagorean triples
@ -134,4 +137,3 @@ SYNTAX: SOLUTION:
    [ drop in get vocab (>>main) ]
    [ [ . ] swap prefix (( -- )) define-declared ]
    2bi ;
-
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@ -14,14 +14,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser
    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.052 project-euler.053 project-euler.055 project-euler.056
-    project-euler.057 project-euler.059 project-euler.067 project-euler.071
-    project-euler.073 project-euler.075 project-euler.076 project-euler.079
-    project-euler.092 project-euler.097 project-euler.099 project-euler.100
-    project-euler.116 project-euler.117 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.190
-    project-euler.203 project-euler.215 ;
+    project-euler.049 project-euler.052 project-euler.053 project-euler.055
+    project-euler.056 project-euler.057 project-euler.059 project-euler.067
+    project-euler.071 project-euler.073 project-euler.075 project-euler.076
+    project-euler.079 project-euler.092 project-euler.097 project-euler.099
+    project-euler.100 project-euler.116 project-euler.117 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.190 project-euler.203 project-euler.215 ;
 IN: project-euler

 <PRIVATE