Solution to Project Euler problem 75

extra/project-euler/039/039.factor

@@ -1,7 +1,7 @@
 ! 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
+USING: arrays combinators.lib kernel math math.ranges namespaces
-    sequences ;
+    project-euler.common sequences ;
 IN: project-euler.039
 
 ! http://projecteuler.net/index.php?section=problems&id=39
@@ -21,6 +21,7 @@ IN: project-euler.039
 ! --------
 
 ! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
+! Identical implementation as problem #75
 
 ! Basically, this makes an array of 1000 zeros, recursively creates primitive
 ! triples using the three transforms and then increments the array at index
@@ -39,18 +40,6 @@ SYMBOL: p-count
     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

extra/project-euler/075/075.factor

@@ -0,0 +1,78 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.lib kernel math math.ranges namespaces
+    project-euler.common sequences ;
+IN: project-euler.075
+
+! http://projecteuler.net/index.php?section=problems&id=75
+
+! DESCRIPTION
+! -----------
+
+! It turns out that 12 cm is the smallest length of wire can be bent to form a
+! right angle triangle in exactly one way, but there are many more examples.
+
+!     12 cm: (3,4,5)
+!     24 cm: (6,8,10)
+!     30 cm: (5,12,13)
+!     36 cm: (9,12,15)
+!     40 cm: (8,15,17)
+!     48 cm: (12,16,20)
+
+! In contrast, some lengths of wire, like 20 cm, cannot be bent to form a right
+! angle triangle, and other lengths allow more than one solution to be found;
+! for example, using 120 cm it is possible to form exactly three different
+! right angle triangles.
+
+!     120 cm: (30,40,50), (20,48,52), (24,45,51)
+
+! Given that L is the length of the wire, for how many values of L ≤ 1,000,000
+! can exactly one right angle triangle be formed?
+
+
+! SOLUTION
+! --------
+
+! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
+! Identical implementation as problem #39
+
+! Basically, this makes an array of 1000000 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 1000000
+! (to account for non-primitive triples). The answer is just the number of
+! indexes that equal one.
+
+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 ;
+
+: (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>
+
+: euler075 ( -- answer )
+    [
+        1000000 count-perimeters p-count get [ 1 = ] count
+    ] with-scope ;
+
+! [ euler075 ] 100 ave-time
+! 1873 ms run / 123 ms GC ave time - 100 trials
+
+MAIN: euler075

extra/project-euler/common/common.factor

@@ -1,5 +1,6 @@
 USING: arrays combinators.lib kernel math math.functions math.miller-rabin
-    math.parser math.primes.factors math.ranges namespaces sequences sorting ;
+    math.matrices math.parser math.primes.factors math.ranges namespaces
+    sequences sorting ;
 IN: project-euler.common
 
 ! A collection of words used by more than one Project Euler solution
@@ -16,6 +17,7 @@ IN: project-euler.common
 ! propagate-all - #18, #67
 ! sum-proper-divisors - #21
 ! tau* - #12
+! [uad]-transform - #39, #75
 
 
 : nth-pair ( n seq -- nth next )
@@ -45,6 +47,9 @@ IN: project-euler.common
         dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
     ] { } make sum ;
 
+: transform ( triple matrix -- new-triple )
+    [ 1array ] dip m. first ;
+
 PRIVATE>
 
 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
@@ -101,3 +106,12 @@ PRIVATE>
     dup sqrt >fixnum [1,b] [
         dupd mod zero? [ [ 2 + ] dip ] when
     ] each drop * ;
+
+! These transforms are for generating primitive Pythagorean triples
+: 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 ;
+

extra/project-euler/project-euler.factor

@@ -12,7 +12,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
     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.039 project-euler.067
-    project-euler.134 project-euler.169 project-euler.173 project-euler.175 ;
+    project-euler.075 project-euler.134 project-euler.169 project-euler.173
+    project-euler.175 ;
 IN: project-euler
 
 <PRIVATE