diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index 4449968642..b9375b7d1e 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -19,11 +19,15 @@ IN: project-euler.002 ! SOLUTION ! -------- -: last2 ( seq -- elt last ) - 2 tail* first2 ; +r add dup 2 tail* sum r> (fib-upto) ] [ 2drop ] if ; + +PRIVATE> : fib-upto ( n -- seq ) - { 0 } 1 [ pick dupd < ] [ add dup last2 + ] [ ] while drop nip ; + { 0 } 1 rot (fib-upto) ; : euler002 ( -- answer ) 1000000 fib-upto [ even? ] subset sum ; diff --git a/extra/project-euler/003/003.factor b/extra/project-euler/003/003.factor index 2b229aa11b..afc4069aee 100644 --- a/extra/project-euler/003/003.factor +++ b/extra/project-euler/003/003.factor @@ -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 diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor index dadde25411..0db0c6f2cb 100644 --- a/extra/project-euler/004/004.factor +++ b/extra/project-euler/004/004.factor @@ -26,14 +26,16 @@ IN: project-euler.004 : 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 diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor index ff627e4a0e..0d8f11f243 100644 --- a/extra/project-euler/005/005.factor +++ b/extra/project-euler/005/005.factor @@ -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 diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor index 12f06972a9..93754b69d1 100644 --- a/extra/project-euler/007/007.factor +++ b/extra/project-euler/007/007.factor @@ -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 diff --git a/extra/project-euler/008/008.factor b/extra/project-euler/008/008.factor index d76f344279..8b32d5651e 100644 --- a/extra/project-euler/008/008.factor +++ b/extra/project-euler/008/008.factor @@ -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 diff --git a/extra/project-euler/009/009.factor b/extra/project-euler/009/009.factor index 44569149d5..f09643d290 100644 --- a/extra/project-euler/009/009.factor +++ b/extra/project-euler/009/009.factor @@ -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 ; diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor index 1baf9500a1..172bb9d290 100644 --- a/extra/project-euler/010/010.factor +++ b/extra/project-euler/010/010.factor @@ -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 diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor index 0d0d4161e4..3d59549e69 100644 --- a/extra/project-euler/012/012.factor +++ b/extra/project-euler/012/012.factor @@ -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 diff --git a/extra/project-euler/013/013.factor b/extra/project-euler/013/013.factor index be968fc346..907029cfb2 100644 --- a/extra/project-euler/013/013.factor +++ b/extra/project-euler/013/013.factor @@ -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 diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor index 7c1f0d41f9..02c5dbb9d3 100644 --- a/extra/project-euler/014/014.factor +++ b/extra/project-euler/014/014.factor @@ -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> @@ -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 diff --git a/extra/project-euler/016/016.factor b/extra/project-euler/016/016.factor index 866b0ed522..00747a9317 100644 --- a/extra/project-euler/016/016.factor +++ b/extra/project-euler/016/016.factor @@ -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 diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor index 1fdb6c5484..aa47f0cda0 100644 --- a/extra/project-euler/017/017.factor +++ b/extra/project-euler/017/017.factor @@ -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 sequences strings ; IN: project-euler.017 ! http://projecteuler.net/index.php?section=problems&id=17 @@ -23,55 +22,10 @@ IN: project-euler.017 ! SOLUTION ! -------- - - -: >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 diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor index 2dc05db1b1..eb2df5e0da 100644 --- a/extra/project-euler/018/018.factor +++ b/extra/project-euler/018/018.factor @@ -50,39 +50,28 @@ IN: project-euler.018 -! 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 ! ------------------- - - : 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 diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor index f811b98e10..58a2dc9668 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -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 diff --git a/extra/project-euler/020/020.factor b/extra/project-euler/020/020.factor index 498aad16ad..8ac75bd9ff 100644 --- a/extra/project-euler/020/020.factor +++ b/extra/project-euler/020/020.factor @@ -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 diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 5d33a8e50c..b4910e5885 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -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 @@ -32,7 +32,7 @@ IN: project-euler.022 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 ; diff --git a/extra/project-euler/024/024.factor b/extra/project-euler/024/024.factor index d06f8a702d..44434b4a88 100644 --- a/extra/project-euler/024/024.factor +++ b/extra/project-euler/024/024.factor @@ -27,11 +27,11 @@ IN: project-euler.024 : (>permutation) ( seq n -- seq ) [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ; +PRIVATE> + : >permutation ( factoradic -- permutation ) reverse 1 cut [ (>permutation) ] each ; -PRIVATE> - : factoradic ( k order -- factoradic ) [ [1,b] [ 2dup mod , /i ] each ] { } make reverse nip ; diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor index 8d75ef5493..2819e210a7 100644 --- a/extra/project-euler/025/025.factor +++ b/extra/project-euler/025/025.factor @@ -1,7 +1,7 @@ ! 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 - sequences ; + project-euler.common sequences ; IN: project-euler.025 ! http://projecteuler.net/index.php?section=problems&id=25 @@ -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- dup fib swap 1- fib + ] when ; lines [ " " split [ string>number ] map ] map ; + file-lines [ " " split [ string>number ] map ] map ; PRIVATE> @@ -57,7 +56,7 @@ PRIVATE> 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-067 [ max-path ] curry 100 ave-time ! 3 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index 55f8a8dab8..fb7fdebd51 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -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 + + : 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 diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor index 959715e4f9..61645bf50b 100644 --- a/extra/project-euler/169/169.factor +++ b/extra/project-euler/169/169.factor @@ -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 diff --git a/extra/project-euler/173/173.factor b/extra/project-euler/173/173.factor index 4eef3ec3e2..9f2984d37d 100644 --- a/extra/project-euler/173/173.factor +++ b/extra/project-euler/173/173.factor @@ -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 ; + : euler173 ( -- answer ) - 1000000 laminaes ; + 1000000 laminae ; ! [ euler173 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/175/175.factor b/extra/project-euler/175/175.factor index db1760c017..e6b4acc8c0 100644 --- a/extra/project-euler/175/175.factor +++ b/extra/project-euler/175/175.factor @@ -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 ! -------- +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 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 2e18d744fc..6279606481 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -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? ; + 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 * ;