Solution to Project Euler problem 39

extra/project-euler/039/039.factor

@@ -0,0 +1,76 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.lib kernel math math.matrices math.ranges namespaces
+    sequences ;
+IN: project-euler.039
+
+! http://projecteuler.net/index.php?section=problems&id=39
+
+! DESCRIPTION
+! -----------
+
+! If p is the perimeter of a right angle triangle with integral length sides,
+! {a,b,c}, there are exactly three solutions for p = 120.
+
+!     {20,48,52}, {24,45,51}, {30,40,50}
+
+! For which value of p < 1000, is the number of solutions maximised?
+
+
+! SOLUTION
+! --------
+
+! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
+
+! Basically, this makes an array of 1000 zeros, recursively creates primitive
+! triples using the three transforms and then increments the array at index
+! [a+b+c] by one for each triple's sum AND its multiples under 1000 (to account
+! for non-primitive triples). The answer is just the index that has the highest
+! number.
+
+SYMBOL: p-count
+
+<PRIVATE
+
+: max-p ( -- n )
+    p-count get length ;
+
+: adjust-p-count ( n -- )
+    max-p 1- over <range> p-count get
+    [ [ 1+ ] change-nth ] curry each ;
+
+: transform ( triple matrix -- new-triple )
+    [ 1array ] dip m. first ;
+
+: u-transform ( triple -- new-triple )
+    { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ;
+
+: a-transform ( triple -- new-triple )
+    { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ;
+
+: d-transform ( triple -- new-triple )
+    { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ;
+
+: (count-perimeters) ( seq -- )
+    dup sum max-p < [
+        dup sum adjust-p-count
+        [ u-transform ] keep [ a-transform ] keep d-transform
+        [ (count-perimeters) ] 3apply
+    ] [
+        drop
+    ] if ;
+
+: count-perimeters ( n -- )
+    0 <array> p-count set { 3 4 5 } (count-perimeters) ;
+
+PRIVATE>
+
+: euler039 ( -- answer )
+    [
+        1000 count-perimeters p-count get [ supremum ] keep index
+    ] with-scope ;
+
+! [ euler039 ] 100 ave-time
+! 2 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler039

extra/project-euler/project-euler.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: definitions io io.files kernel math.parser sequences vocabs
-    vocabs.loader project-euler.ave-time project-euler.common math
+USING: definitions io io.files kernel math math.parser project-euler.ave-time
+    sequences vocabs vocabs.loader
     project-euler.001 project-euler.002 project-euler.003 project-euler.004
     project-euler.005 project-euler.006 project-euler.007 project-euler.008
     project-euler.009 project-euler.010 project-euler.011 project-euler.012
@@ -11,8 +11,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs
     project-euler.025 project-euler.026 project-euler.027 project-euler.028
     project-euler.029 project-euler.030 project-euler.031 project-euler.032
     project-euler.033 project-euler.034 project-euler.035 project-euler.036
-    project-euler.037 project-euler.038 project-euler.067 project-euler.134
-    project-euler.169 project-euler.173 project-euler.175 ;
+    project-euler.037 project-euler.038 project-euler.039 project-euler.067
+    project-euler.134 project-euler.169 project-euler.173 project-euler.175 ;
 IN: project-euler
 
 <PRIVATE