Personal tools

Euler problems/121 to 130

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
m
 
(4 intermediate revisions by 3 users not shown)
Line 1: Line 1:
Do them on your own!
+
== [http://projecteuler.net/index.php?section=problems&id=121 Problem 121] ==
 +
Investigate the game of chance involving coloured discs.
 +
 
 +
Solution:
 +
<haskell>
 +
import Data.List
 +
problem_121 = possibleGames `div` winningGames
 +
  where
 +
  possibleGames = product [1..16]
 +
  winningGames =
 +
      (1+) $ sum $ map product $ chooseUpTo 7 [1..15]
 +
  chooseUpTo 0    _ = []
 +
  chooseUpTo (n+1) x =
 +
      [y:z |
 +
      (y:ys) <- tails x,
 +
      z <- []: chooseUpTo n ys
 +
      ]
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=122 Problem 122] ==
 +
Finding the most efficient exponentiation method.
 +
 
 +
Solution using a depth first search, pretty fast :
 +
<haskell>
 +
import Data.List
 +
import Data.Array.Diff
 +
import Control.Monad
 +
 
 +
depthAddChain 12 branch mins = mins
 +
depthAddChain d branch mins = foldl' step mins $ nub $ filter (> head branch)
 +
                              $ liftM2 (+) branch branch
 +
    where
 +
      step da e | e > 200 = da
 +
                | otherwise =
 +
                    case compare (da ! e) d of
 +
                      GT -> depthAddChain (d+1) (e:branch) $ da // [(e,d)]
 +
                      EQ -> depthAddChain (d+1) (e:branch) da
 +
                      LT -> da
 +
 
 +
baseBranch = [2,1]
 +
 
 +
baseMins :: DiffUArray Int Int
 +
baseMins = listArray (1,200) $ 0:1: repeat maxBound
 +
 
 +
problem_122 = sum . elems $ depthAddChain 2 baseBranch baseMins
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=123 Problem 123] ==
 +
Determining the remainder when (pn − 1)n + (pn + 1)n is divided by pn2.
 +
 
 +
Solution:
 +
<haskell>
 +
problem_123 =
 +
    fst . head . dropWhile (\(n,p) -> (2 + 2*n*p) < 10^10) $
 +
    zip [1..] primes
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=124 Problem 124] ==
 +
Determining the kth element of the sorted radical function.
 +
 
 +
Solution:
 +
<haskell>
 +
import Data.List
 +
import Data.Ord (comparing)
 +
 
 +
compress = map head . group
 +
 
 +
rad = product . compress . primeFactors
 +
 
 +
radfax = (1,1) : zip [2..] (map rad [2..])
 +
 
 +
sortRadfax n = sortBy (comparing snd) $ take n radfax
 +
problem_124=fst$sortRadfax 100000!!9999
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=125 Problem 125] ==
 +
Finding square sums that are palindromic.
 +
 
 +
Solution:
 +
<haskell>
 +
import Data.List as L
 +
import Data.Set as S
 +
 +
hi = 100000000
 +
 +
ispalindrome n = (show n) == reverse (show n)
 +
 +
-- the "drop 2" ensures all sums use at least two terms
 +
-- by ignoring the 0- and 1-term "sums"
 +
sumsFrom i =
 +
    takeWhile (<hi) .
 +
    drop 2 .
 +
    scanl (\s n -> s + n^2) 0 $ [i..]
 +
 +
limit =
 +
    truncate . sqrt . fromIntegral $ (hi `div` 2)
 +
 
 +
problem_125 =
 +
    fold (+) 0 .
 +
    fromList .
 +
    concat .
 +
    L.map (L.filter ispalindrome . sumsFrom) $ [1 .. limit]
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=126 Problem 126] ==
 +
Exploring the number of cubes required to cover every visible face on a cuboid.
 +
 
 +
Solution:
 +
<haskell>
 +
import Data.Array.ST
 +
import Control.Monad (when)
 +
import Control.Monad.ST
 +
 
 +
limit = 20000
 +
layer x y z n = 4*(x+y+z+n-2)*(n-1) + 2*x*y + 2*x*z + 2*y*z
 +
 
 +
solutions :: STUArray s Int Int -> Int -> ST s ()
 +
solutions a n =
 +
    when (layer 1 1 1 n <= limit) $
 +
            do solutions a (n+1)
 +
                solutions' a 1 n
 +
 
 +
solutions' :: STUArray s Int Int -> Int -> Int -> ST s ()
 +
solutions' a x n =
 +
    when (layer x x x n <= limit) $
 +
            do solutions' a (x+1) n
 +
                solutions'' a x x n
 +
 
 +
solutions'' :: STUArray s Int Int -> Int -> Int -> Int -> ST s ()
 +
solutions'' a x y n =
 +
    when (layer x y y n <= limit) $
 +
            do solutions'' a x (y+1) n
 +
                solutions''' a x y y n
 +
 
 +
solutions''' :: STUArray s Int Int -> Int -> Int -> Int -> Int -> ST s ()
 +
solutions''' a x y z n =
 +
    when (layer x y z n <= limit) $
 +
            do readArray a (layer x y z n) >>= return.(+1) >>= writeArray a (layer x y z n)
 +
                solutions''' a x y (z+1) n
 +
 
 +
findSolution :: STUArray s Int Int -> Int -> ST s (Maybe Int)
 +
findSolution a n
 +
    | n == limit = return Nothing
 +
    | otherwise = do
 +
        v <- readArray a n
 +
        if v == 1000
 +
            then return (Just n)
 +
            else findSolution a (n+1)
 +
 
 +
main :: IO ()
 +
main = print foo
 +
  where foo = runST $
 +
              do cn <- newArray (0,limit+1) 0 :: ST s (STUArray s Int Int)
 +
                solutions cn 1
 +
                findSolution cn 154
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=127 Problem 127] ==
 +
Investigating the number of abc-hits below a given limit.
 +
 
 +
Solution:
 +
<haskell>
 +
import Data.List
 +
import Data.Array.IArray
 +
import Data.Array.Unboxed
 +
 
 +
main = appendFile "p127.log" $show$ solve 99999
 +
 +
rad x = fromIntegral $ product $ map fst $ primePowerFactors $ fromIntegral x
 +
primePowerFactors x = [(head a ,length a)|a<-group$primeFactors x]
 +
solve :: Int -> Int
 +
solve n = sum [ c | (rc,c) <- invrads
 +
                  , 2 * rc < c
 +
                  , (ra, a) <- takeWhile (\(a,_)->(c > 2*rc*a)) invrads
 +
                  , a < c `div` 2
 +
                  , gcd ra rc == 1
 +
                  , ra * rads ! (c - a) < c `div` rc]
 +
    where
 +
    rads :: UArray Int Int
 +
    rads = listArray (1,n) $ map rad [1..n]
 +
    invrads = sort $ map (\(a,b) -> (b, a)) $ assocs rads
 +
problem_127 = main
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=128 Problem 128] ==
 +
Which tiles in the hexagonal arrangement have prime differences with neighbours?
 +
 
 +
Solution:
 +
<haskell>
 +
p128=
 +
    concat[m|a<-[0..70000],let m=middle a++right a,not$null m]
 +
    where
 +
    middle n
 +
        |all isPrime [11+6*n,13+6*n,29+12*n]=[2+3*(n+1)*(n+2)]
 +
        |otherwise=[]
 +
    right n
 +
        |all isPrime [11+6*n,17+6*n,17+12*n]=[1+3*(n+2)*(n+3)]
 +
        |otherwise=[]
 +
problem_128=do
 +
    print(p128!!1997)
 +
isPrime x
 +
    |x<100=isPrime' x
 +
    |otherwise=all (millerRabinPrimality x )[2,7,61]
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=129 Problem 129] ==
 +
Investigating minimal repunits that divide by n.
 +
 
 +
Solution:
 +
<haskell>
 +
import Data.List
 +
factors x=fac$fstfac x
 +
funp (p,1)=
 +
    head[a|
 +
    a<-sort$factors (p-1),
 +
    powMod p 10 a==1
 +
    ]
 +
funp (p,s)=p^(s-1)*funp (p,1)
 +
funn []=1
 +
funn (x:xs) =lcm (funp x) (funn xs)
 +
p129 q=
 +
    head[a|
 +
    a<-[q..],
 +
    gcd a 10==1,
 +
    let s=funn$fstfac$(*9) a,
 +
    s>q,
 +
    s>a
 +
    ]
 +
problem_129 = p129 (10^6)
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=130 Problem 130] ==
 +
Finding composite values, n, for which n−1 is divisible by the length of the smallest repunits that divide it.
 +
 
 +
Solution:
 +
<haskell>
 +
--factors powMod in p129
 +
fun x
 +
    |(not$null a)=head a
 +
    |otherwise=0
 +
    where
 +
    a=take 1 [n|n<-sort$factors (x-1),(powMod x 10 n)==1]
 +
problem_130 =sum$take 25[a|a<-[1..],
 +
    not$isPrime a,
 +
    let b=fun a,
 +
    b/=0,
 +
    mod (a-1) b==0,
 +
    mod a 3 /=0]
 +
</haskell>

Latest revision as of 18:29, 21 February 2010

Contents

[edit] 1 Problem 121

Investigate the game of chance involving coloured discs.

Solution:

import Data.List
problem_121 = possibleGames `div` winningGames
   where
   possibleGames = product [1..16]
   winningGames = 
       (1+) $ sum $ map product $ chooseUpTo 7 [1..15]
   chooseUpTo 0     _ = []
   chooseUpTo (n+1) x = 
       [y:z | 
       (y:ys) <- tails x,
       z <- []: chooseUpTo n ys
       ]

[edit] 2 Problem 122

Finding the most efficient exponentiation method.

Solution using a depth first search, pretty fast :

import Data.List
import Data.Array.Diff
import Control.Monad
 
depthAddChain 12 branch mins = mins
depthAddChain d branch mins = foldl' step mins $ nub $ filter (> head branch)
                               $ liftM2 (+) branch branch
    where
      step da e | e > 200 = da
                | otherwise =
                    case compare (da ! e) d of
                      GT -> depthAddChain (d+1) (e:branch) $ da // [(e,d)]
                      EQ -> depthAddChain (d+1) (e:branch) da
                      LT -> da
 
baseBranch = [2,1]
 
baseMins :: DiffUArray Int Int
baseMins = listArray (1,200) $ 0:1: repeat maxBound
 
problem_122 = sum . elems $ depthAddChain 2 baseBranch baseMins

[edit] 3 Problem 123

Determining the remainder when (pn − 1)n + (pn + 1)n is divided by pn2.

Solution:

problem_123 = 
    fst . head . dropWhile (\(n,p) -> (2 + 2*n*p) < 10^10) $
    zip [1..] primes

[edit] 4 Problem 124

Determining the kth element of the sorted radical function.

Solution:

import Data.List
import Data.Ord (comparing)
 
compress = map head . group
 
rad = product . compress . primeFactors
 
radfax = (1,1) : zip [2..] (map rad [2..])
 
sortRadfax n = sortBy (comparing snd) $ take n radfax
problem_124=fst$sortRadfax 100000!!9999

[edit] 5 Problem 125

Finding square sums that are palindromic.

Solution:

import Data.List as L
import Data.Set as S
 
hi = 100000000
 
ispalindrome n = (show n) == reverse (show n)
 
-- the "drop 2" ensures all sums use at least two terms
-- by ignoring the 0- and 1-term "sums"
sumsFrom i =
    takeWhile (<hi) .
    drop 2 .
    scanl (\s n -> s + n^2) 0 $ [i..]
 
limit =
    truncate . sqrt . fromIntegral $ (hi `div` 2)
 
problem_125 =
    fold (+) 0 .
    fromList .
    concat .
    L.map (L.filter ispalindrome . sumsFrom) $ [1 .. limit]

[edit] 6 Problem 126

Exploring the number of cubes required to cover every visible face on a cuboid.

Solution:

import Data.Array.ST
import Control.Monad (when)
import Control.Monad.ST
 
limit = 20000
layer x y z n = 4*(x+y+z+n-2)*(n-1) + 2*x*y + 2*x*z + 2*y*z
 
solutions :: STUArray s Int Int -> Int -> ST s ()
solutions a n =
    when (layer 1 1 1 n <= limit) $
             do solutions a (n+1)
                solutions' a 1 n
 
solutions' :: STUArray s Int Int -> Int -> Int -> ST s ()
solutions' a x n =
    when (layer x x x n <= limit) $
             do solutions' a (x+1) n
                solutions'' a x x n
 
solutions'' :: STUArray s Int Int -> Int -> Int -> Int -> ST s ()
solutions'' a x y n =
    when (layer x y y n <= limit) $
             do solutions'' a x (y+1) n
                solutions''' a x y y n
 
solutions''' :: STUArray s Int Int -> Int -> Int -> Int -> Int -> ST s ()
solutions''' a x y z n =
    when (layer x y z n <= limit) $
             do readArray a (layer x y z n) >>= return.(+1) >>= writeArray a (layer x y z n)
                solutions''' a x y (z+1) n
 
findSolution :: STUArray s Int Int -> Int -> ST s (Maybe Int)
findSolution a n 
    | n == limit = return Nothing
    | otherwise = do 
        v <- readArray a n
        if v == 1000
            then return (Just n)
            else findSolution a (n+1)
 
main :: IO ()
main = print foo
  where foo = runST $
              do cn <- newArray (0,limit+1) 0 :: ST s (STUArray s Int Int)
                 solutions cn 1
                 findSolution cn 154

[edit] 7 Problem 127

Investigating the number of abc-hits below a given limit.

Solution:

import Data.List
import Data.Array.IArray
import Data.Array.Unboxed
 
main = appendFile "p127.log" $show$ solve 99999
 
rad x = fromIntegral $ product $ map fst $ primePowerFactors $ fromIntegral x
primePowerFactors x = [(head a ,length a)|a<-group$primeFactors x] 
solve :: Int -> Int
solve n = sum [ c | (rc,c) <- invrads
                  , 2 * rc < c
                  , (ra, a) <- takeWhile (\(a,_)->(c > 2*rc*a)) invrads
                  , a < c `div` 2
                  , gcd ra rc == 1
                  , ra * rads ! (c - a) < c `div` rc]
    where
     rads :: UArray Int Int
     rads = listArray (1,n) $ map rad [1..n]
     invrads = sort $ map (\(a,b) -> (b, a)) $ assocs rads
problem_127 = main

[edit] 8 Problem 128

Which tiles in the hexagonal arrangement have prime differences with neighbours?

Solution:

p128=
    concat[m|a<-[0..70000],let m=middle a++right a,not$null m]
    where
    middle n
        |all isPrime [11+6*n,13+6*n,29+12*n]=[2+3*(n+1)*(n+2)]
        |otherwise=[]
    right n
        |all isPrime [11+6*n,17+6*n,17+12*n]=[1+3*(n+2)*(n+3)]
        |otherwise=[]
problem_128=do
    print(p128!!1997)
isPrime x
    |x<100=isPrime' x
    |otherwise=all (millerRabinPrimality x )[2,7,61]

[edit] 9 Problem 129

Investigating minimal repunits that divide by n.

Solution:

import Data.List
factors x=fac$fstfac x
funp (p,1)=
    head[a|
    a<-sort$factors (p-1),
    powMod p 10 a==1
    ]
funp (p,s)=p^(s-1)*funp (p,1)
funn []=1
funn (x:xs) =lcm (funp x) (funn xs)
p129 q=
    head[a|
    a<-[q..],
    gcd a 10==1,
    let s=funn$fstfac$(*9) a,
    s>q,
    s>a
    ]
problem_129 = p129 (10^6)

[edit] 10 Problem 130

Finding composite values, n, for which n−1 is divisible by the length of the smallest repunits that divide it.

Solution:

--factors powMod in p129
fun x 
    |(not$null a)=head a 
    |otherwise=0
    where 
    a=take 1 [n|n<-sort$factors (x-1),(powMod x 10 n)==1]
problem_130 =sum$take 25[a|a<-[1..],
    not$isPrime a,
    let b=fun a, 
    b/=0,
    mod (a-1) b==0,
    mod a 3 /=0]