extra/project-euler/075/075.factor

   1 ! Copyright (c) 2008 Aaron Schaefer.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel math math.ranges
   4     namespaces project-euler.common sequences ;
   5 IN: project-euler.075
   6
   7 ! http://projecteuler.net/index.php?section=problems&id=75
   8
   9 ! DESCRIPTION
  10 ! -----------
  11
  12 ! It turns out that 12 cm is the smallest length of wire can be bent to form a
  13 ! right angle triangle in exactly one way, but there are many more examples.
  14
  15 !     12 cm: (3,4,5)
  16 !     24 cm: (6,8,10)
  17 !     30 cm: (5,12,13)
  18 !     36 cm: (9,12,15)
  19 !     40 cm: (8,15,17)
  20 !     48 cm: (12,16,20)
  21
  22 ! In contrast, some lengths of wire, like 20 cm, cannot be bent to form a right
  23 ! angle triangle, and other lengths allow more than one solution to be found;
  24 ! for example, using 120 cm it is possible to form exactly three different
  25 ! right angle triangles.
  26
  27 !     120 cm: (30,40,50), (20,48,52), (24,45,51)
  28
  29 ! Given that L is the length of the wire, for how many values of L ≤ 2,000,000
  30 ! can exactly one right angle triangle be formed?
  31
  32
  33 ! SOLUTION
  34 ! --------
  35
  36 ! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
  37 ! Identical implementation as problem #39
  38
  39 ! Basically, this makes an array of 2000000 zeros, recursively creates
  40 ! primitive triples using the three transforms and then increments the array at
  41 ! index [a+b+c] by one for each triple's sum AND its multiples under 2000000
  42 ! (to account for non-primitive triples). The answer is just the total number
  43 ! of indexes that are equal to one.
  44
  45 SYMBOL: p-count
  46
  47 <PRIVATE
  48
  49 : max-p ( -- n )
  50     p-count get length ;
  51
  52 : adjust-p-count ( n -- )
  53     max-p 1 - over <range> p-count get
  54     [ [ 1 + ] change-nth ] curry each ;
  55
  56 : (count-perimeters) ( seq -- )
  57     dup sum max-p < [
  58         dup sum adjust-p-count
  59         [ u-transform ] [ a-transform ] [ d-transform ] tri
  60         [ (count-perimeters) ] tri@
  61     ] [
  62         drop
  63     ] if ;
  64
  65 : count-perimeters ( n -- )
  66     0 <array> p-count set { 3 4 5 } (count-perimeters) ;
  67
  68 PRIVATE>
  69
  70 : euler075 ( -- answer )
  71     [
  72         2000000 count-perimeters p-count get [ 1 = ] count
  73     ] with-scope ;
  74
  75 ! [ euler075 ] 10 ave-time
  76 ! 3341 ms ave run timen - 157.77 SD (10 trials)
  77
  78 SOLUTION: euler075