Difference between revisions of "Euler problems/171 to 180"
m (import) 
m 

(4 intermediate revisions by 4 users not shown)  
Line 2:  Line 2:  
Finding numbers for which the sum of the squares of the digits is a square. 
Finding numbers for which the sum of the squares of the digits is a square. 

−  Solution: 

⚫  
−  this was Antoine Celeriers C code pasted from the Project Euler Forum. 

== [http://projecteuler.net/index.php?section=problems&id=172 Problem 172] == 
== [http://projecteuler.net/index.php?section=problems&id=172 Problem 172] == 

Line 42:  Line 41:  
Counting the number of "hollow" square laminae that can form one, two, three, ... distinct arrangements. 
Counting the number of "hollow" square laminae that can form one, two, three, ... distinct arrangements. 

−  Solution: This was my C++ code, published here without my permission nor any attribution, shame on whoever put it here. [[user:henk263henk263]] 

+  {{sectstub}} 

== [http://projecteuler.net/index.php?section=problems&id=175 Problem 175] == 
== [http://projecteuler.net/index.php?section=problems&id=175 Problem 175] == 

Line 60:  Line 59:  
l=length k 
l=length k 

p175 x y= 
p175 x y= 

−  init$foldl (++) "" [a++"," 

+  concat $ intersperse "," $ 

−  +  map show $reverse $filter (/=0)$findRat x y 

problems_175=p175 123456789 987654321 
problems_175=p175 123456789 987654321 

test=p175 13 17 
test=p175 13 17 

Line 85:  Line 84:  
Integer angled Quadrilaterals. 
Integer angled Quadrilaterals. 

−  Solution: This C++ solution is stolen from balakrishnan. Check out the forum if you want to see his solution to the problem 

+  {{sectstub}} 

== [http://projecteuler.net/index.php?section=problems&id=178 Problem 178] == 
== [http://projecteuler.net/index.php?section=problems&id=178 Problem 178] == 

Line 114:  Line 113:  
== [http://projecteuler.net/index.php?section=problems&id=179 Problem 179] == 
== [http://projecteuler.net/index.php?section=problems&id=179 Problem 179] == 

Consecutive positive divisors. 
Consecutive positive divisors. 

+  See http://en.wikipedia.org/wiki/Divisor_function for a simple 

+  explanation of calculating the number of divisors of an integer, 

+  based on its prime factorization. Then, if you have a lot of 

+  time on your hands, run the following program. You need to load 

+  the Factoring library from David Amos' wonderful Maths library. 

+  See: http://www.polyomino.f2s.com/david/haskell/main.html 

+  
+  <haskell> 

+  import Factoring 

+  import Data.List 

+  
+  nFactors :: Integer > Int 

+  nFactors n = 

+  let a = primePowerFactorsL n 

+  in foldl' (\x y > x * ((snd y)+1) ) 1 a 

+  
+  countConsecutiveInts l = foldl' (\x y > if y then x+1 else x) 0 a 

+  where a = zipWith (==) l (tail l) 

+  
+  problem_179 = countConsecutiveInts $ map nFactors [2..(10^7  1)] 

+  
+  main = print problem_179 

+  
+  </haskell> 

+  
+  This is all well and good, but it runs very slowly. (About 4 

+  minutes on my machine) We have to factor every number between 2 

+  and 10^7, which on a non Quantum CPU takes a while. There is 

+  another way! 

+  
+  We can sieve for the answer. Every number has 1 for a factor. 

+  Every other number has 2 as a factor, and every third number has 

+  3 as a factor. So we run a sieve that counts (increments) 

+  itself for every integer. When we are done, we run through the 

+  resulting array and look at neighboring elements. If they are 

+  equal, we increment a counter. This version runs in about 9 

+  seconds on my machine. HenryLaxen May 14, 2008 

+  
+  <haskell> 

+  {# OPTIONS O2 optcO #} 

+  import Data.Array.ST 

+  import Data.Array.Unboxed 

+  import Control.Monad 

+  import Control.Monad.ST 

+  import Data.List 

+  
+  r1 = (2,(10^71)) 

+  
+  type Sieve s = STUArray s Int Int 

+  
+  incN :: Sieve s > Int > ST s () 

+  incN a n = do 

+  x < readArray a n 

+  writeArray a n (x+1) 

+  
+  incEveryN :: Sieve s > Int > ST s () 

+  incEveryN a n = mapM_ (incN a) [n,n+n..snd r1] 

+  
+  sieve :: Int 

+  sieve = countConsecutiveInts b 

+  where b = runSTUArray $ 

+  do a < newArray r1 1 :: ST s (STUArray s Int Int) 

+  mapM_ (incEveryN a) [fst r1 .. (snd r1) `div` 2] 

+  return a 

+  
+  countConsecutiveInts :: UArray Int Int > Int 

+  countConsecutiveInts a = 

+  let r1 = [fst (bounds a) .. snd (bounds a)  1] 

+  in length $ filter (\y > a ! y == a ! (y+1)) $ r1 

+  
+  main = print sieve 

+  </haskell> 

⚫  
== [http://projecteuler.net/index.php?section=problems&id=180 Problem 180] == 
== [http://projecteuler.net/index.php?section=problems&id=180 Problem 180] == 
Latest revision as of 01:49, 13 February 2010
Contents
Problem 171
Finding numbers for which the sum of the squares of the digits is a square.
Problem 172
Investigating numbers with few repeated digits.
Solution:
factorial n = product [1..toInteger n]
fallingFactorial x n = product [x  fromInteger i  i < [0..toInteger n  1] ]
choose n k = fallingFactorial n k `div` factorial k
 how many numbers can we get having d digits and p positions
p172 0 _ = 0
p172 d p
 p < 4 = d^p
 otherwise =
(p172' p) + p*(p172' (p1)) + (choose p 2)*(p172' (p2)) + (choose p 3)*(p172' (p3))
where
p172' = p172 (d1)
problem_172= (p172 10 18) * 9 `div` 10
Problem 173
Using up to one million tiles how many different "hollow" square laminae can be formed? Solution:
problem_173=
let c=div (10^6) 4
xm=floor$sqrt $fromIntegral c
k=[div c xx<[1..xm]]
in sum k(div (xm*(xm+1)) 2)
Problem 174
Counting the number of "hollow" square laminae that can form one, two, three, ... distinct arrangements.
Problem 175
Fractions involving the number of different ways a number can be expressed as a sum of powers of 2. Solution:
sternTree x 0=[]
sternTree x y=
m:sternTree y n
where
(m,n)=divMod x y
findRat x y
odd l=take (l1) k++[last k1,1]
otherwise=k
where
k=sternTree x y
l=length k
p175 x y=
concat $ intersperse "," $
map show $reverse $filter (/=0)$findRat x y
problems_175=p175 123456789 987654321
test=p175 13 17
Problem 176
Rectangular triangles that share a cathetus. Solution:
k=47547
2*k+1=95095 = 5*7*11*13*19
lst=[5,7,11,13,19]
primes=[2,3,5,7,11]
problem_176 =
product[a^b(a,b)<zip primes (reverse n)]
where
la=div (last lst+1) 2
m=map (\x>div x 2)$init lst
n=m++[la]
Problem 177
Integer angled Quadrilaterals.
Problem 178
Step Numbers
Count pandigital step numbers.
import qualified Data.Map as M
data StepState a = StepState { minDigit :: a
, maxDigit :: a
, lastDigit :: a
} deriving (Show, Eq, Ord)
isSolution (StepState i a _) = i == 0 && a == 9
neighborStates m s@(StepState i a n) = map (\x > (x, M.findWithDefault 0 s m)) $
[StepState (min i (n  1)) a (n  1), StepState i (max a (n + 1)) (n + 1)]
allStates = [StepState i a n  (i, a) < range ((0, 0), (9, 9)), n < range (i, a)]
initialState = M.fromDistinctAscList [(StepState i i i, 1)  i < [1..9]]
stepState m = M.fromListWith (+) $ allStates >>= neighborStates m
numSolutionsInMap = sum . map snd . filter (isSolution . fst) . M.toList
numSolutionsOfSize n = sum . map numSolutionsInMap . take n $ iterate stepState initialState
problem_178 = numSolutionsOfSize 40
Problem 179
Consecutive positive divisors. See http://en.wikipedia.org/wiki/Divisor_function for a simple explanation of calculating the number of divisors of an integer, based on its prime factorization. Then, if you have a lot of time on your hands, run the following program. You need to load the Factoring library from David Amos' wonderful Maths library. See: http://www.polyomino.f2s.com/david/haskell/main.html
import Factoring
import Data.List
nFactors :: Integer > Int
nFactors n =
let a = primePowerFactorsL n
in foldl' (\x y > x * ((snd y)+1) ) 1 a
countConsecutiveInts l = foldl' (\x y > if y then x+1 else x) 0 a
where a = zipWith (==) l (tail l)
problem_179 = countConsecutiveInts $ map nFactors [2..(10^7  1)]
main = print problem_179
This is all well and good, but it runs very slowly. (About 4 minutes on my machine) We have to factor every number between 2 and 10^7, which on a non Quantum CPU takes a while. There is another way!
We can sieve for the answer. Every number has 1 for a factor. Every other number has 2 as a factor, and every third number has 3 as a factor. So we run a sieve that counts (increments) itself for every integer. When we are done, we run through the resulting array and look at neighboring elements. If they are equal, we increment a counter. This version runs in about 9 seconds on my machine. HenryLaxen May 14, 2008
{# OPTIONS O2 optcO #}
import Data.Array.ST
import Data.Array.Unboxed
import Control.Monad
import Control.Monad.ST
import Data.List
r1 = (2,(10^71))
type Sieve s = STUArray s Int Int
incN :: Sieve s > Int > ST s ()
incN a n = do
x < readArray a n
writeArray a n (x+1)
incEveryN :: Sieve s > Int > ST s ()
incEveryN a n = mapM_ (incN a) [n,n+n..snd r1]
sieve :: Int
sieve = countConsecutiveInts b
where b = runSTUArray $
do a < newArray r1 1 :: ST s (STUArray s Int Int)
mapM_ (incEveryN a) [fst r1 .. (snd r1) `div` 2]
return a
countConsecutiveInts :: UArray Int Int > Int
countConsecutiveInts a =
let r1 = [fst (bounds a) .. snd (bounds a)  1]
in length $ filter (\y > a ! y == a ! (y+1)) $ r1
main = print sieve
Problem 180
Rational zeros of a function of three variables. Solution:
import Data.Ratio
{
After some algebra, we find:
f1 n x y z = x^(n+1) + y^(n+1)  z^(n+1)
f2 n x y z = (x*y + y*z + z*x) * ( x^(n1) + y^(n1)  z^(n1) )
f3 n x y z = x*y*z*( x^(n2) + y^(n2)  z^(n2) )
f n x y z = f1 n x y z + f2 n x y z  f3 n x y z
f n x y z = (x+y+z) * (x^n+y^nz^n)
Now the hard part comes in realizing that n can be negative.
Thanks to Fermat, we only need examine the cases n = [2, 1, 1, 2]
Which leads to:
f(2) z = xy/sqrt(x^2 + y^2)
f(1) z = xy/(x+y)
f(1) z = x+y
f(2) z = sqrt(x^2 + y^2)
}
unique :: Eq(a) => [a] > [a]
unique [] = []
unique (x:xs)  elem x xs = unique xs
 otherwise = x : unique xs
 Not quite correct, but I don't care about the zeros
ratSqrt :: Rational > Rational
ratSqrt x =
let a = floor $ sqrt $ fromIntegral $ numerator x
b = floor $ sqrt $ fromIntegral $ denominator x
c = (a%b) * (a%b)
in if x == c then (a%b) else 0
 Not quite correct, but I don't care about the zeros
reciprocal :: Rational > Rational
reciprocal x
 x == 0 = 0
 otherwise = denominator x % numerator x
problem_180 =
let order = 35
range :: [Rational]
range = unique [ (a%b)  b < [1..order], a < [1..(b1)] ]
fm2,fm1,f1,f2 :: [[Rational]]
fm2 = [[x,y,z]  x<range, y<range,
let z = x*y * reciprocal (ratSqrt(x*x+y*y)), elem z range]
fm1 = [[x,y,z]  x<range, y<range,
let z = x*y * reciprocal (x+y), elem z range]
f1 = [[x,y,z]  x<range, y<range,
let z = (x+y), elem z range]
f2 = [[x,y,z]  x<range, y<range,
let z = ratSqrt(x*x+y*y), elem z range]
result = sum $ unique $ map (\x > sum x) (fm2++fm1++f1++f2)
in (numerator result + denominator result)