steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix conflict

db4
Slava Pestov 2008-01-10 22:57:21 -05:00
parent 7598617119 6385289244
commit afd4732409
33 changed files with 387 additions and 284 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
extra/math/text/authors.txt → extra/math/text/english/authors.txt
View File

2
extra/math/text/text-docs.factor → extra/math/text/english/english-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax math strings ;
IN: math.text
IN: math.text.english
HELP: number>text
{ $values { "n" integer } { "str" string } }

2
extra/math/text/text-tests.factor → extra/math/text/english/english-tests.factor
View File

@ -1,4 +1,4 @@
USING: math.functions math.text tools.test ;
USING: math.functions math.text.english tools.test ;
IN: temporary
[ "Zero" ] [ 0 number>text ] unit-test

8
extra/math/text/text.factor → extra/math/text/english/english.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.parser namespaces
sequences splitting sequences.lib ;
IN: math.text
IN: math.text.english
<PRIVATE
@ -26,10 +26,7 @@ IN: math.text
SYMBOL: and-needed?
: set-conjunction ( seq -- )
first {
[ dup 100 < ]
[ dup 0 > ]
} && and-needed? set drop ;
first { [ dup 100 < ] [ dup 0 > ] } && and-needed? set drop ;
: negative-text ( n -- str )
0 < "Negative " "" ? ;
@ -100,4 +97,3 @@ PRIVATE>
] [
[ (number>text) ] with-scope
] if ;

1
extra/math/text/english/summary.txt Normal file
View File

@ -0,0 +1 @@
Convert integers to English text

1
extra/math/text/summary.txt
View File

@ -1 +0,0 @@
Convert integers to text

14
extra/project-euler/002/002.factor
View File

@ -19,14 +19,18 @@ IN: project-euler.002
! SOLUTION
! --------
: last2 ( seq -- elt last )
reverse first2 swap ;
<PRIVATE
: fib-up-to ( n -- seq )
{ 0 } 1 [ pick dupd < ] [ add dup last2 + ] [ ] while drop nip ;
: (fib-upto) ( seq n limit -- seq )
2dup <= [ >r add dup 2 tail* sum r> (fib-upto) ] [ 2drop ] if ;
PRIVATE>
: fib-upto ( n -- seq )
{ 0 } 1 rot (fib-upto) ;
: euler002 ( -- answer )
1000000 fib-up-to [ even? ] subset sum ;
1000000 fib-upto [ even? ] subset sum ;
! [ euler002 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials

9
extra/project-euler/003/003.factor
View File

@ -16,13 +16,10 @@ IN: project-euler.003
! SOLUTION
! --------
: largest-prime-factor ( n -- factor )
factors supremum ;
: euler003 ( -- answer )
317584931803 largest-prime-factor ;
317584931803 factors supremum ;
! [ euler003 ] time
! 2 ms run / 0 ms GC time
! [ euler003 ] 100 ave-time
! 1 ms run / 0 ms GC ave time - 100 trials
MAIN: euler003

6
extra/project-euler/004/004.factor
View File

@ -26,14 +26,16 @@ IN: project-euler.004
<PRIVATE
: source-004 ( -- seq )
100 999 [a,b] [ 10 mod zero? not ] subset ;
: max-palindrome ( seq -- palindrome )
natural-sort [ palindrome? ] find-last nip ;
PRIVATE>
: euler004 ( -- answer )
100 999 [a,b] [ 10 mod zero? not ] subset dup
cartesian-product [ product ] map prune max-palindrome ;
source-004 dup cartesian-product [ product ] map prune max-palindrome ;
! [ euler004 ] 100 ave-time
! 1608 ms run / 102 ms GC ave time - 100 trials

2
extra/project-euler/005/005.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences ;
USING: math math.functions sequences ;
IN: project-euler.005
! http://projecteuler.net/index.php?section=problems&id=5

6
extra/project-euler/007/007.factor
View File

@ -18,12 +18,12 @@ IN: project-euler.007
! --------
: nth-prime ( n -- n )
1 - lprimes lnth ;
1- lprimes lnth ;
: euler007 ( -- answer )
10001 nth-prime ;
! [ euler007 ] time
! 22 ms run / 0 ms GC time
! [ euler007 ] 100 ave-time
! 10 ms run / 0 ms GC ave time - 100 trials
MAIN: euler007

2
extra/project-euler/008/008.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.parser project-euler.common sequences ;
USING: math.parser project-euler.common sequences ;
IN: project-euler.008
! http://projecteuler.net/index.php?section=problems&id=8

12
extra/project-euler/009/009.factor
View File

@ -26,20 +26,18 @@ IN: project-euler.009
: next-pq ( p1 q1 -- p2 q2 )
! p > q and both are odd integers
dup 1 = [ swap 2 + nip dup 2 - ] [ 2 - ] if ;
dup 1 = [ drop 2 + dup ] when 2 - ;
: abc ( p q -- triplet )
[
2dup * , ! a = p * q
2dup sq swap sq swap - 2 / , ! b = (p² - q²) / 2
sq swap sq swap + 2 / , ! c = (p² + q²) / 2
[ sq ] 2apply 2dup - 2 / , ! b = (p² - q²) / 2
+ 2 / , ! c = (p² + q²) / 2
] { } make natural-sort ;
: (ptriplet) ( target p q triplet -- target p q )
roll dup >r swap sum = r> -roll
[
next-pq 2dup abc (ptriplet)
] unless ;
roll [ swap sum = ] keep -roll
[ next-pq 2dup abc (ptriplet) ] unless ;
: ptriplet ( target -- triplet )
3 1 { 3 4 5 } (ptriplet) abc nip ;

2
extra/project-euler/010/010.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.primes sequences ;
USING: math.primes sequences ;
IN: project-euler.010
! http://projecteuler.net/index.php?section=problems&id=10

2
extra/project-euler/012/012.factor
View File

@ -37,7 +37,7 @@ IN: project-euler.012
dup 1+ * 2 / ;
: euler012 ( -- answer )
2 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ;
8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ;
! [ euler012 ] 10 ave-time
! 5413 ms run / 1 ms GC ave time - 10 trials

2
extra/project-euler/013/013.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.parser sequences ;
USING: math.parser sequences ;
IN: project-euler.013
! http://projecteuler.net/index.php?section=problems&id=13

11
extra/project-euler/014/014.factor
View File

@ -39,7 +39,7 @@ IN: project-euler.014
dup even? [ 2 / ] [ 3 * 1+ ] if ;
: longest ( seq seq -- seq )
2dup length swap length > [ nip ] [ drop ] if ;
2dup [ length ] 2apply > [ drop ] [ nip ] if ;
PRIVATE>
@ -47,7 +47,7 @@ PRIVATE>
[ [ dup 1 > ] [ dup , next-collatz ] [ ] while , ] { } make ;
: euler014 ( -- answer )
1000000 0 [ 1+ collatz longest ] reduce first ;
1000000 [1,b] 0 [ collatz longest ] reduce first ;
! [ euler014 ] time
! 52868 ms run / 483 ms GC time
@ -59,10 +59,7 @@ PRIVATE>
<PRIVATE
: worth-calculating? ( n -- ? )
{
[ dup 1- 3 mod zero? ]
[ dup 1- 3 / even? ]
} && nip ;
{ [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } && nip ;
PRIVATE>
@ -72,7 +69,7 @@ PRIVATE>
] reduce first ;
! [ euler014a ] 10 ave-time
! 5109 ms run / 44 ms GC time
! 4821 ms run / 41 ms GC time
! TODO: try using memoization

2
extra/project-euler/016/016.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.functions math.parser project-euler.common sequences ;
USING: math.functions math.parser project-euler.common sequences ;
IN: project-euler.016
! http://projecteuler.net/index.php?section=problems&id=16

52
extra/project-euler/017/017.factor
View File

@ -1,7 +1,6 @@
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.ranges math.text namespaces sequences
strings ;
USING: combinators.lib kernel math.ranges math.text.english sequences strings ;
IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17
@ -23,55 +22,10 @@ IN: project-euler.017
! SOLUTION
! --------
<PRIVATE
: units ( n -- )
{
"zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
"ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen"
"seventeen" "eighteen" "nineteen"
} nth % ;
: tenths ( n -- )
{
f f "twenty" "thirty" "fourty" "fifty" "sixty" "seventy" "eighty" "ninety"
} nth % ;
DEFER: make-english
: maybe-add ( n sep -- )
over zero? [ 2drop ] [ % make-english ] if ;
: 0-99 ( n -- )
dup 20 < [ units ] [ 10 /mod swap tenths "-" maybe-add ] if ;
: 0-999 ( n -- )
100 /mod swap
dup zero? [ drop 0-99 ] [ units " hundred" % " and " maybe-add ] if ;
: make-english ( n -- )
1000 /mod swap
dup zero? [ drop 0-999 ] [ 0-999 " thousand" % " and " maybe-add ] if ;
PRIVATE>
: >english ( n -- str )
[ make-english ] "" make ;
: euler017 ( -- answer )
1000 [1,b] [ >english [ letter? ] subset length ] map sum ;
! [ euler017 ] 100 ave-time
! 9 ms run / 0 ms GC ave time - 100 trials
! ALTERNATE SOLUTIONS
! -------------------
: euler017a ( -- answer )
1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ Letter? ] count ;
! [ euler017a ] 100 ave-time
! 14 ms run / 1 ms GC ave time - 100 trials
! 14 ms run / 0 ms GC ave time - 100 trials
MAIN: euler017

44
extra/project-euler/018/018.factor
View File

@ -50,9 +50,8 @@ IN: project-euler.018
<PRIVATE
: pyramid ( -- seq )
{
75
: source-018 ( -- triangle )
{ 75
95 64
17 47 82
18 35 87 10
@ -67,22 +66,12 @@ 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 [ 1+ cut swap ] map nip ;
} 15 [ 1+ cut swap ] map nip ;
PRIVATE>
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
[ over 1 tail rot first2 max rot + ] map nip ;
! Not strictly needed, but it is nice to be able to dump the pyramid after
! the propagation
: propagate-all ( pyramid -- newpyramid )
reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ;
: euler018 ( -- answer )
pyramid propagate-all first first ;
source-018 propagate-all first first ;
! [ euler018 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
@ -91,31 +80,10 @@ PRIVATE>
! ALTERNATE SOLUTIONS
! -------------------
<PRIVATE
: source-018a ( -- triangle )
{ { 75 }
{ 95 64 }
{ 17 47 82 }
{ 18 35 87 10 }
{ 20 04 82 47 65 }
{ 19 01 23 75 03 34 }
{ 88 02 77 73 07 63 67 }
{ 99 65 04 28 06 16 70 92 }
{ 41 41 26 56 83 40 80 70 33 }
{ 41 48 72 33 47 32 37 16 94 29 }
{ 53 71 44 65 25 43 91 52 97 51 14 }
{ 70 11 33 28 77 73 17 78 39 68 17 57 }
{ 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 } } ;
PRIVATE>
: euler018a ( -- answer )
source-018a max-path ;
source-018 max-path ;
! [ euler018a ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler018
MAIN: euler018a

7
extra/project-euler/019/019.factor
View File

@ -30,9 +30,10 @@ IN: project-euler.019
! already, as "zeller-congruence ( year month day -- n )" where n is
! the day of the week (Sunday is 0).
: euler019 ( -- count )
1901 2000 [a,b] [ 12 [1,b] [ 1 zeller-congruence ] 1 map-withn ] map concat
[ 0 = ] subset length ;
: euler019 ( -- answer )
1901 2000 [a,b] [
12 [1,b] [ 1 zeller-congruence ] 1 map-withn
] map concat [ zero? ] count ;
! [ euler019 ] 100 ave-time
! 1 ms run / 0 ms GC ave time - 100 trials

2
extra/project-euler/020/020.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.combinatorics math.parser project-euler.common sequences ;
USING: math.combinatorics math.parser project-euler.common sequences ;
IN: project-euler.020
! http://projecteuler.net/index.php?section=problems&id=20

19
extra/project-euler/022/022.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib io io.files kernel math math.parser namespaces sequences
sorting splitting strings system vocabs ;
USING: io.files kernel math math.parser namespaces sequences sorting splitting
strings system vocabs ;
IN: project-euler.022
! http://projecteuler.net/index.php?section=problems&id=22
@ -27,21 +27,12 @@ IN: project-euler.022
<PRIVATE
: (source-022) ( -- path )
[
"project-euler.022" vocab-root ?resource-path %
os "windows" = [
"\\project-euler\\022\\names.txt" %
] [
"/project-euler/022/names.txt" %
] if
] "" make ;
: source-022 ( -- seq )
(source-022) file-contents [ quotable? ] subset "," split ;
"extra/project-euler/022/names.txt" resource-path
file-contents [ quotable? ] subset "," split ;
: alpha-value ( str -- n )
string>digits [ 9 - ] sigma ;
[ string>digits sum ] keep length 9 * - ;
: name-scores ( seq -- seq )
dup length [ 1+ swap alpha-value * ] 2map ;

61
extra/project-euler/023/023.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math math.ranges project-euler.common sequences
sorting ;
IN: project-euler.023
! http://projecteuler.net/index.php?section=problems&id=23
! DESCRIPTION
! -----------
! A perfect number is a number for which the sum of its proper divisors is
! exactly equal to the number. For example, the sum of the proper divisors of
! 28 would be 1 + 2 + 4 + 7 + 14 = 28, which means that 28 is a perfect number.
! A number whose proper divisors are less than the number is called deficient
! and a number whose proper divisors exceed the number is called abundant.
! As 12 is the smallest abundant number, 1 + 2 + 3 + 4 + 6 = 16, the smallest
! number that can be written as the sum of two abundant numbers is 24. By
! mathematical analysis, it can be shown that all integers greater than 28123
! can be written as the sum of two abundant numbers. However, this upper limit
! cannot be reduced any further by analysis even though it is known that the
! greatest number that cannot be expressed as the sum of two abundant numbers
! is less than this limit.
! Find the sum of all the positive integers which cannot be written as the sum
! of two abundant numbers.
! SOLUTION
! --------
! The upper limit can be dropped to 20161 which reduces our search space
! and every even number > 46 can be expressed as a sum of two abundants
<PRIVATE
: source-023 ( -- seq )
46 [1,b] 47 20161 2 <range> append ;
: abundants-upto ( n -- seq )
[1,b] [ abundant? ] subset ;
: possible-sums ( seq -- seq )
dup { } -rot [
dupd [ + ] curry map
rot append prune swap 1 tail
] each drop natural-sort ;
PRIVATE>
: euler023 ( -- answer )
20161 abundants-upto possible-sums source-023 seq-diff sum ;
! TODO: solution is still too slow, although it takes under 1 minute
! [ euler023 ] time
! 52780 ms run / 3839 ms GC
MAIN: euler023

48
extra/project-euler/024/024.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.ranges namespaces sequences ;
IN: project-euler.024
! http://projecteuler.net/index.php?section=problems&id=24
! DESCRIPTION
! -----------
! A permutation is an ordered arrangement of objects. For example, 3124 is one
! possible permutation of the digits 1, 2, 3 and 4. If all of the permutations
! are listed numerically or alphabetically, we call it lexicographic order. The
! lexicographic permutations of 0, 1 and 2 are:
! 012 021 102 120 201 210
! What is the millionth lexicographic permutation of the digits 0, 1, 2, 3, 4,
! 5, 6, 7, 8 and 9?
! SOLUTION
! --------
<PRIVATE
: (>permutation) ( seq n -- seq )
[ [ dupd >= [ 1+ ] when ] curry map ] keep add* ;
PRIVATE>
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
: factoradic ( k order -- factoradic )
[ [1,b] [ 2dup mod , /i ] each ] { } make reverse nip ;
: permutation ( k seq -- seq )
dup length swapd factoradic >permutation
[ [ dupd swap nth , ] each drop ] { } make ;
: euler024 ( -- answer )
999999 10 permutation 10 swap digits>integer ;
! [ euler024 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler024

84
extra/project-euler/025/025.factor Normal file
View File

@ -0,0 +1,84 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel math math.functions math.parser math.ranges memoize
project-euler.common sequences ;
IN: project-euler.025
! http://projecteuler.net/index.php?section=problems&id=25
! DESCRIPTION
! -----------
! The Fibonacci sequence is defined by the recurrence relation:
! Fn = Fn-1 + Fn-2, where F1 = 1 and F2 = 1.
! Hence the first 12 terms will be:
! F1 = 1
! F2 = 1
! F3 = 2
! F4 = 3
! F5 = 5
! F6 = 8
! F7 = 13
! F8 = 21
! F9 = 34
! F10 = 55
! F11 = 89
! F12 = 144
! The 12th term, F12, is the first term to contain three digits.
! What is the first term in the Fibonacci sequence to contain 1000 digits?
! SOLUTION
! --------
! Memoized brute force
MEMO: fib ( m -- n )
dup 1 > [ 1- dup fib swap 1- fib + ] when ;
<PRIVATE
: (digit-fib) ( n term -- term )
2dup fib number>string length > [ 1+ (digit-fib) ] [ nip ] if ;
: digit-fib ( n -- term )
1 (digit-fib) ;
PRIVATE>
: euler025 ( -- answer )
1000 digit-fib ;
! [ euler025 ] 10 ave-time
! 5237 ms run / 72 ms GC ave time - 10 trials
! ALTERNATE SOLUTIONS
! -------------------
! A number containing 1000 digits is the same as saying it's greater than 10**999
! The nth Fibonacci number is Phi**n / sqrt(5) rounded to the nearest integer
! Thus we need we need "Phi**n / sqrt(5) > 10**999", and we just solve for n
<PRIVATE
: phi ( -- phi )
5 sqrt 1+ 2 / ;
: digit-fib* ( n -- term )
1- 5 log10 2 / + phi log10 / ceiling >integer ;
PRIVATE>
: euler025a ( -- answer )
1000 digit-fib* ;
! [ euler025a ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler025a

32
extra/project-euler/067/067.factor
View File

@ -1,7 +1,6 @@
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files kernel math.parser namespaces project-euler.018
project-euler.common sequences splitting system vocabs ;
USING: io.files math.parser namespaces project-euler.common sequences splitting ;
IN: project-euler.067
! http://projecteuler.net/index.php?section=problems&id=67
@ -37,14 +36,14 @@ IN: project-euler.067
<PRIVATE
: pyramid ( -- seq )
"resource:extra/project-euler/067/triangle.txt" ?resource-path
: source-067 ( -- seq )
"extra/project-euler/067/triangle.txt" resource-path
file-lines [ " " split [ string>number ] map ] map ;
PRIVATE>
: euler067 ( -- answer )
pyramid propagate-all first first ;
source-067 propagate-all first first ;
! [ euler067 ] 100 ave-time
! 18 ms run / 0 ms GC time
@ -53,30 +52,13 @@ PRIVATE>
! ALTERNATE SOLUTIONS
! -------------------
<PRIVATE
: (source-067a) ( -- path )
[
"project-euler.067" vocab-root ?resource-path %
os "windows" = [
"\\project-euler\\067\\triangle.txt" %
] [
"/project-euler/067/triangle.txt" %
] if
] "" make ;
: source-067a ( -- triangle )
(source-067a) file-lines [ " " split [ string>number ] map ] map ;
PRIVATE>
: euler067a ( -- answer )
source-067a max-path ;
source-067 max-path ;
! [ euler067a ] 100 ave-time
! 15 ms run / 0 ms GC ave time - 100 trials
! 14 ms run / 0 ms GC ave time - 100 trials
! source-067a [ max-path ] curry 100 ave-time
! source-067 [ max-path ] curry 100 ave-time
! 3 ms run / 0 ms GC ave time - 100 trials
MAIN: euler067a

28
extra/project-euler/134/134.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel lazy-lists math.algebra math math.functions math.primes
math.ranges sequences ;
math.ranges project-euler.common sequences ;
IN: project-euler.134
! http://projecteuler.net/index.php?section=problems&id=134
@ -9,23 +9,26 @@ IN: project-euler.134
! DESCRIPTION
! -----------
! Consider the consecutive primes p1 = 19 and p2 = 23. It can be
! verified that 1219 is the smallest number such that the last digits
! are formed by p1 whilst also being divisible by p2.
! Consider the consecutive primes p1 = 19 and p2 = 23. It can be verified that
! 1219 is the smallest number such that the last digits are formed by p1 whilst
! also being divisible by p2.
! In fact, with the exception of p1 = 3 and p2 = 5, for every pair of
! consecutive primes, p2 p1, there exist values of n for which the last
! digits are formed by p1 and n is divisible by p2. Let S be the
! smallest of these values of n.
! consecutive primes, p2 p1, there exist values of n for which the last digits
! are formed by p1 and n is divisible by p2. Let S be the smallest of these
! values of n.
! Find S for every pair of consecutive primes with 5 p1 1000000.
! SOLUTION
! --------
! Compute the smallest power of 10 greater than m or equal to it
! Compute the smallest power of 10 greater than or equal to m
: next-power-of-10 ( m -- n )
10 swap log 10 log / ceiling >integer ^ ; foldable
10 swap log10 ceiling >integer ^ ; foldable
<PRIVATE
! Compute S for a given pair (p1, p2) -- that is the smallest positive
! number such that X = p1 [npt] and X = 0 [p2] (npt being the smallest
@ -33,10 +36,13 @@ IN: project-euler.134
: s ( p1 p2 -- s )
over 0 2array rot next-power-of-10 rot 2array chinese-remainder ;
PRIVATE>
: euler134 ( -- answer )
0 5 lprimes-from uncons [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ;
0 5 lprimes-from uncons [ 1000000 > ] luntil
[ [ s + ] keep ] leach drop ;
! [ euler134 ] 10 ave-time
! 3797 ms run / 30 ms GC ave time - 10 trials
! 2430 ms run / 36 ms GC ave time - 10 trials
MAIN: euler134

9
extra/project-euler/169/169.factor
View File

@ -8,11 +8,11 @@ USING: combinators kernel math math.functions memoize ;
! DESCRIPTION
! -----------
! Define f(0)=1 and f(n) to be the number of different ways n can be
! expressed as a sum of integer powers of 2 using each power no more
! than twice.
! Define f(0) = 1 and f(n) to be the number of different ways n can be
! expressed as a sum of integer powers of 2 using each power no more than
! twice.
! For example, f(10)=5 since there are five different ways to express 10:
! For example, f(10) = 5 since there are five different ways to express 10:
! 1 + 1 + 8
! 1 + 1 + 4 + 4
@ -22,6 +22,7 @@ USING: combinators kernel math math.functions memoize ;
! What is f(1025)?
! SOLUTION
! --------

28
extra/project-euler/173/173.factor
View File

@ -1,4 +1,4 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.ranges sequences ;
IN: project-euler.173
@ -8,25 +8,29 @@ IN: project-euler.173
! DESCRIPTION
! -----------
! We shall define a square lamina to be a square outline with a square
! "hole" so that the shape possesses vertical and horizontal
! symmetry. For example, using exactly thirty-two square tiles we can
! form two different square laminae: [see URL for figure]
! We shall define a square lamina to be a square outline with a square "hole"
! so that the shape possesses vertical and horizontal symmetry. For example,
! using exactly thirty-two square tiles we can form two different square
! laminae: [see URL for figure]
! With one-hundred tiles, and not necessarily using all of the tiles at
! one time, it is possible to form forty-one different square laminae.
! With one-hundred tiles, and not necessarily using all of the tiles at one
! time, it is possible to form forty-one different square laminae.
! Using up to one million tiles how many different square laminae can be formed?
! Using up to one million tiles how many different square laminae can be
! formed?
! SOLUTION
! --------
: laminaes ( upper -- n )
4 / dup sqrt [1,b] 0 rot [ over /mod drop - - ] curry reduce ;
<PRIVATE
: laminae ( upper -- n )
4 / dup sqrt [1,b] 0 rot [ over /i - - ] curry reduce ;
PRIVATE>
: euler173 ( -- answer )
1000000 laminaes ;
1000000 laminae ;
! [ euler173 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials

24
extra/project-euler/175/175.factor
View File

@ -8,29 +8,31 @@ IN: project-euler.175
! DESCRIPTION
! -----------
! Define f(0)=1 and f(n) to be the number of ways to write n as a sum of
! Define f(0) = 1 and f(n) to be the number of ways to write n as a sum of
! powers of 2 where no power occurs more than twice.
! For example, f(10)=5 since there are five different ways to express
! For example, f(10) = 5 since there are five different ways to express
! 10: 10 = 8+2 = 8+1+1 = 4+4+2 = 4+2+2+1+1 = 4+4+1+1
! It can be shown that for every fraction p/q (p0, q0) there exists at
! least one integer n such that f(n)/f(n-1)=p/q.
! It can be shown that for every fraction p/q (p0, q0) there exists at least
! one integer n such that f(n) / f(n-1) = p/q.
! For instance, the smallest n for which f(n)/f(n-1)=13/17 is 241. The
! binary expansion of 241 is 11110001. Reading this binary number from
! the most significant bit to the least significant bit there are 4
! one's, 3 zeroes and 1 one. We shall call the string 4,3,1 the
! Shortened Binary Expansion of 241.
! For instance, the smallest n for which f(n) / f(n-1) = 13/17 is 241. The
! binary expansion of 241 is 11110001. Reading this binary number from the most
! significant bit to the least significant bit there are 4 one's, 3 zeroes and
! 1 one. We shall call the string 4,3,1 the Shortened Binary Expansion of 241.
! Find the Shortened Binary Expansion of the smallest n for which
! f(n)/f(n-1)=123456789/987654321.
! f(n) / f(n-1) = 123456789/987654321.
! Give your answer as comma separated integers, without any whitespaces.
! SOLUTION
! --------
<PRIVATE
: add-bits ( vec n b -- )
over zero? [
3drop
@ -45,6 +47,8 @@ IN: project-euler.175
{ [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
} cond ;
PRIVATE>
: euler175 ( -- result )
V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ;

77
extra/project-euler/common/common.factor
View File

@ -1,31 +1,51 @@
USING: arrays kernel hashtables math math.functions math.miller-rabin
math.parser math.ranges namespaces sequences combinators.lib ;
USING: kernel math math.functions math.miller-rabin math.parser
math.primes.factors math.ranges namespaces sequences ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution.
! A collection of words used by more than one Project Euler solution
! and/or related words that could be useful for future problems.
! Problems using each public word
! -------------------------------
! collect-consecutive - #8, #11
! log10 - #25, #134
! max-path - #18, #67
! number>digits - #16, #20
! propagate-all - #18, #67
! sum-proper-divisors - #21
! tau* - #12
: nth-pair ( n seq -- nth next )
over 1+ over nth >r nth r> ;
: perfect-square? ( n -- ? )
dup sqrt mod zero? ;
<PRIVATE
: count-shifts ( seq width -- n )
>r length 1+ r> - ;
: shift-3rd ( seq obj obj -- seq obj obj )
rot 1 tail -rot ;
: max-children ( seq -- seq )
[ dup length 1- [ over nth-pair max , ] each ] { } make nip ;
: >multiplicity ( seq -- seq )
dup prune [
[ 2dup [ = ] curry count 2array , ] each
] { } make nip ; inline
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
[ over 1 tail rot first2 max rot + ] map nip ;
: reduce-2s ( n -- r s )
dup even? [ factor-2s >r 1+ r> ] [ 1 swap ] if ;
: shift-3rd ( seq obj obj -- seq obj obj )
rot 1 tail -rot ;
: (sum-divisors) ( n -- sum )
dup sqrt >fixnum [1,b] [
[ 2dup mod zero? [ 2dup / + , ] [ drop ] if ] each
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
] { } make sum ;
PRIVATE>
: collect-consecutive ( seq width -- seq )
@ -33,8 +53,8 @@ PRIVATE>
2dup count-shifts [ 2dup head shift-3rd , ] times
] { } make 2nip ;
: divisor? ( n m -- ? )
mod zero? ;
: log10 ( m -- n )
log 10 log / ;
: max-path ( triangle -- n )
dup length 1 > [
@ -46,27 +66,10 @@ PRIVATE>
: number>digits ( n -- seq )
number>string string>digits ;
: perfect-square? ( n -- ? )
dup sqrt divisor? ;
: prime-factorization ( n -- seq )
[
2 [ over 1 > ]
[ 2dup divisor? [ dup , [ / ] keep ] [ next-prime ] if ]
[ ] while 2drop
] { } make ;
: prime-factorization* ( n -- seq )
prime-factorization >multiplicity ;
: prime-factors ( n -- seq )
prime-factorization prune >array ;
: (sum-divisors) ( n -- sum )
dup sqrt >fixnum [1,b] [
[ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
] { } make sum ;
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
: propagate-all ( triangle -- newtriangle )
reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ;
: sum-divisors ( n -- sum )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
@ -84,12 +87,12 @@ PRIVATE>
dup sum-proper-divisors = ;
! The divisor function, counts the number of divisors
: tau ( n -- n )
prime-factorization* flip second 1 [ 1+ * ] reduce ;
: tau ( m -- n )
count-factors flip second 1 [ 1+ * ] reduce ;
! Optimized brute-force, is often faster than prime factorization
: tau* ( n -- n )
: tau* ( m -- n )
reduce-2s [ perfect-square? -1 0 ? ] keep
dup sqrt >fixnum [1,b] [
dupd divisor? [ >r 2 + r> ] when
dupd mod zero? [ >r 2 + r> ] when
] each drop * ;

4
extra/project-euler/project-euler.factor
View File

@ -7,7 +7,9 @@ USING: definitions io io.files kernel math.parser sequences vocabs
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.067 project-euler.134 ;
project-euler.021 project-euler.022 project-euler.023 project-euler.024
project-euler.025 project-euler.067 project-euler.134 project-euler.169
project-euler.173 project-euler.175 ;
IN: project-euler
<PRIVATE