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

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

14
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
2dup * , ! a = p * q
[ 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

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

@ -50,39 +50,28 @@ IN: project-euler.018
<PRIVATE
: pyramid ( -- seq )
{
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
}
15 [ 1+ cut swap ] map nip ;
: source-018 ( -- 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
} 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

30
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,34 +9,40 @@ 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
! power of 10 above p1)
: s ( p1 p2 -- s )
over 0 2array rot next-power-of-10 rot 2array chinese-remainder ;
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

21
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,18 +22,19 @@ USING: combinators kernel math math.functions memoize ;
! What is f(1025)?
! SOLUTION
! --------
MEMO: fn ( n -- x )
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
{ [ t ] [ 2/ [ fn ] keep 1- fn + ] }
} cond ;
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
{ [ t ] [ 2/ [ fn ] keep 1- fn + ] }
} cond ;
: euler169 ( -- result )
10 25 ^ fn ;
10 25 ^ fn ;
! [ euler169 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials

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

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

@ -8,45 +8,49 @@ 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
] [
pick length 1 bitand = [ over pop + ] when swap push
] if ;
over zero? [
3drop
] [
pick length 1 bitand = [ over pop + ] when swap push
] if ;
: compute ( vec ratio -- )
{
{ [ dup integer? ] [ 1- 0 add-bits ] }
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
{ [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
} cond ;
{
{ [ dup integer? ] [ 1- 0 add-bits ] }
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
{ [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
} cond ;
PRIVATE>
: euler175 ( -- result )
V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ;
V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ;
! [ euler175 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials

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