Cleanup of all Project Euler solutions thus far

extra/project-euler/002/002.factor

@@ -19,11 +19,15 @@ IN: project-euler.002
 ! SOLUTION
 ! --------
 
-: last2 ( seq -- elt last )
+<PRIVATE
-    2 tail* first2 ;
+
+: (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 [ pick dupd < ] [ add dup last2 + ] [ ] while drop nip ;
+    { 0 } 1 rot (fib-upto) ;
 
 : euler002 ( -- answer )
     1000000 fib-upto [ even? ] subset sum ;

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
+! [ euler003 ] 100 ave-time
-! 2 ms run / 0 ms GC time
+! 1 ms run / 0 ms GC ave time - 100 trials
 
 MAIN: euler003

extra/project-euler/004/004.factor

@@ -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
+    source-004 dup cartesian-product [ product ] map prune max-palindrome ;
-    cartesian-product [ product ] map prune max-palindrome ;
 
 ! [ euler004 ] 100 ave-time
 ! 1608 ms run / 102 ms GC ave time - 100 trials

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

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
+! [ euler007 ] 100 ave-time
-! 22 ms run / 0 ms GC time
+! 10 ms run / 0 ms GC ave time - 100 trials
 
 MAIN: euler007

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

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 * ,                    ! a = p * q
-        2dup sq swap sq swap - 2 / ,  ! b = (p² - q²) / 2
+        [ sq ] 2apply 2dup - 2 / ,  ! b = (p² - q²) / 2
-        sq swap sq swap + 2 / ,       ! c = (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
+    roll [ swap sum = ] keep -roll
-    [
+    [ next-pq 2dup abc (ptriplet) ] unless ;
-        next-pq 2dup abc (ptriplet)
-    ] unless ;
 
 : ptriplet ( target -- triplet )
    3 1 { 3 4 5 } (ptriplet) abc nip ;

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

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

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

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

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

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
+USING: combinators.lib kernel math.ranges math.text sequences strings ;
-    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

extra/project-euler/018/018.factor

@@ -50,39 +50,28 @@ IN: project-euler.018
 
 <PRIVATE
 
-: pyramid ( -- seq )
+: source-018 ( -- triangle )
-  {
+    {                              75
-                         75
+                                 95  64
-                        95 64
+                               17  47  82
-                      17 47 82
+                             18  35  87  10
-                     18 35 87 10
+                           20  04  82  47  65
-                   20 04 82 47 65
+                         19  01  23  75  03  34
-                  19 01 23 75 03 34
+                       88  02  77  73  07  63  67
-                88 02 77 73 07 63 67
+                     99  65  04  28  06  16  70  92
-               99 65 04 28 06 16 70 92
+                   41  41  26  56  83  40  80  70  33
-             41 41 26 56 83 40 80 70 33
+                 41  48  72  33  47  32  37  16  94  29
-            41 48 72 33 47 32 37 16 94 29
+               53  71  44  65  25  43  91  52  97  51  14
-          53 71 44 65 25 43 91 52 97 51 14
+             70  11  33  28  77  73  17  78  39  68  17  57
-         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
-       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
-      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
-    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

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 )
+: euler019 ( -- answer )
-  1901 2000 [a,b] [ 12 [1,b] [ 1 zeller-congruence ] 1 map-withn ] map concat
+    1901 2000 [a,b] [
-  [ 0 = ] subset length ;
+        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

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

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
+USING: io.files kernel math math.parser namespaces sequences sorting splitting
-    sorting splitting strings system vocabs ;
+    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 ;

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 ;
 

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 ;
 
 <PRIVATE
 
@@ -67,8 +67,6 @@ PRIVATE>
 
 <PRIVATE
 
-FUNCTION: double log10 ( double x ) ;
-
 : phi ( -- phi )
     5 sqrt 1+ 2 / ;
 

extra/project-euler/067/067.factor

@@ -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
+USING: io.files math.parser namespaces project-euler.common sequences splitting ;
-    project-euler.common sequences splitting system vocabs ;
 IN: project-euler.067
 
 ! http://projecteuler.net/index.php?section=problems&id=67
@@ -39,7 +38,7 @@ IN: project-euler.067
 
 : source-067 ( -- seq )
     "extra/project-euler/067/triangle.txt" resource-path
-    <file-reader> 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

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
+! Consider the consecutive primes p1 = 19 and p2 = 23. It can be verified that
-! verified that 1219 is the smallest number such that the last digits
+! 1219 is the smallest number such that the last digits are formed by p1 whilst
-! are formed by p1 whilst also being divisible by p2.
+! 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
+! consecutive primes, p2 p1, there exist values of n for which the last digits
-! digits are formed by p1 and n is divisible by p2. Let S be the
+! are formed by p1 and n is divisible by p2. Let S be the smallest of these
-! smallest of these values of n.
+! 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

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
+! 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
+! expressed as a sum of integer powers of 2 using each power no more than
-! than twice.
+! 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 2 < ]  [ drop 1 ] }
-    { [ dup odd? ] [ 2/ fn ] }
+        { [ dup odd? ] [ 2/ fn ] }
-    { [ t ]        [ 2/ [ fn ] keep 1- fn + ] }
+        { [ t ]        [ 2/ [ fn ] keep 1- fn + ] }
-  } cond ;
+    } cond ;
 
 : euler169 ( -- result )
-  10 25 ^ fn ;
+    10 25 ^ fn ;
 
 ! [ euler169 ] 100 ave-time
 ! 0 ms run / 0 ms GC ave time - 100 trials

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
+! We shall define a square lamina to be a square outline with a square "hole"
-! "hole" so that the shape possesses vertical and horizontal
+! so that the shape possesses vertical and horizontal symmetry. For example,
-! symmetry. For example, using exactly thirty-two square tiles we can
+! using exactly thirty-two square tiles we can form two different square
-! form two different square laminae: [see URL for figure]
+! laminae: [see URL for figure]
 
-! With one-hundred tiles, and not necessarily using all of the tiles at
+! With one-hundred tiles, and not necessarily using all of the tiles at one
-! one time, it is possible to form forty-one different square laminae.
+! 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 )
+<PRIVATE
-  4 / dup sqrt [1,b] 0 rot [ over /mod drop - - ] curry reduce ;
+
+: 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

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
+! It can be shown that for every fraction p/q (p0, q0) there exists at least
-! least one integer n such that f(n)/f(n-1)=p/q.
+! 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
+! 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
+! binary expansion of 241 is 11110001. Reading this binary number from the most
-! the most significant bit to the least significant bit there are 4
+! significant bit to the least significant bit there are 4 one's, 3 zeroes and
-! one's, 3 zeroes and 1 one. We shall call the string 4,3,1 the
+! 1 one. We shall call the string 4,3,1 the Shortened Binary Expansion of 241.
-! 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? [
+    over zero? [
-    3drop
+        3drop
-  ] [
+    ] [
-    pick length 1 bitand = [ over pop + ] when swap push
+        pick length 1 bitand = [ over pop + ] when swap push
-  ] if ;
+    ] if ;
 
 : compute ( vec ratio -- )
-  {
+    {
-    { [ dup integer? ] [ 1- 0 add-bits ] }
+        { [ dup integer? ] [ 1- 0 add-bits ] }
-    { [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
+        { [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
-    { [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
+        { [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
-  } cond ;
+    } 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

extra/project-euler/common/common.factor

@@ -1,31 +1,51 @@
-USING: arrays kernel hashtables math math.functions math.miller-rabin
+USING: kernel math math.functions math.miller-rabin math.parser
-    math.parser math.ranges namespaces sequences combinators.lib ;
+    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 )
+! Propagate one row into the upper one
-    dup prune [
+: propagate ( bottom top -- newtop )
-        [ 2dup [ = ] curry count 2array , ] each
+    [ over 1 tail rot first2 max rot + ] map nip ;
-    ] { } make nip ; inline
 
 : 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 -- ? )
+: log10 ( m -- n )
-    mod zero? ;
+    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 -- ? )
+! Not strictly needed, but it is nice to be able to dump the triangle after the
-    dup sqrt divisor? ;
+! propagation
-
+: propagate-all ( triangle -- newtriangle )
-: prime-factorization ( n -- seq )
+    reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ;
-    [
-        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 ;
 
 : 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 )
+: tau ( m -- n )
-    prime-factorization* flip second 1 [ 1+ * ] reduce ;
+    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 * ;