Difference between revisions of "Euler problems/121 to 130"

From HaskellWiki
Jump to: navigation, search
m (Corrected the links to the Euler project)
m
 
(16 intermediate revisions by 6 users not shown)
Line 1: Line 1:
−
[[Category:Programming exercise spoilers]]
  
  +
== [http://projecteuler.net/index.php?section=problems&id=121 Problem 121] ==
−
== [http://projecteuler.net/index.php?section=view&id=121 Problem 121] ==
  
 
Investigate the game of chance involving coloured discs.
  
Investigate the game of chance involving coloured discs.
   
 
Solution:
  
Solution:
 
<haskell>
  
<haskell>
−
problem_121 = undefined
  
  +
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>
  
</haskell>
   
−
== [http://projecteuler.net/index.php?section=view&id=122 Problem 122] ==
 +
== [http://projecteuler.net/index.php?section=problems&id=122 Problem 122] ==
 
Finding the most efficient exponentiation method.
  
Finding the most efficient exponentiation method.
   
−
Solution:
  
  +
Solution using a depth first search, pretty fast :
 
<haskell>
  
<haskell>
−
problem_122 = undefined
  
  +
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>
  
</haskell>
   
−
== [http://projecteuler.net/index.php?section=view&id=123 Problem 123] ==
 +
== [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.
  
Determining the remainder when (pn − 1)n + (pn + 1)n is divided by pn2.
   
 
Solution:
  
Solution:
 
<haskell>
  
<haskell>
−
problem_123 = undefined
 +
problem_123 =
  +
fst . head . dropWhile (\(n,p) -> (2 + 2*n*p) < 10^10) $
  +
zip [1..] primes
 
</haskell>
  
</haskell>
   
−
== [http://projecteuler.net/index.php?section=view&id=124 Problem 124] ==
 +
== [http://projecteuler.net/index.php?section=problems&id=124 Problem 124] ==
 
Determining the kth element of the sorted radical function.
  
Determining the kth element of the sorted radical function.
   
 
Solution:
  
Solution:
 
<haskell>
  
<haskell>
−
problem_124 = undefined
  
  +
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>
  
</haskell>
   
−
== [http://projecteuler.net/index.php?section=view&id=125 Problem 125] ==
 +
== [http://projecteuler.net/index.php?section=problems&id=125 Problem 125] ==
 
Finding square sums that are palindromic.
  
Finding square sums that are palindromic.
   
 
Solution:
  
Solution:
 
<haskell>
  
<haskell>
−
problem_125 = undefined
  
  +
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>
  
</haskell>
   
−
== [http://projecteuler.net/index.php?section=view&id=126 Problem 126] ==
 +
== [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.
  
Exploring the number of cubes required to cover every visible face on a cuboid.
   
 
Solution:
  
Solution:
 
<haskell>
  
<haskell>
−
problem_126 = undefined
  
  +
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>
  
</haskell>
   
−
== [http://projecteuler.net/index.php?section=view&id=127 Problem 127] ==
 +
== [http://projecteuler.net/index.php?section=problems&id=127 Problem 127] ==
 
Investigating the number of abc-hits below a given limit.
  
Investigating the number of abc-hits below a given limit.
   
 
Solution:
  
Solution:
 
<haskell>
  
<haskell>
−
problem_127 = undefined
  
  +
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>
  
</haskell>
   
−
== [http://projecteuler.net/index.php?section=view&id=128 Problem 128] ==
 +
== [http://projecteuler.net/index.php?section=problems&id=128 Problem 128] ==
 
Which tiles in the hexagonal arrangement have prime differences with neighbours?
  
Which tiles in the hexagonal arrangement have prime differences with neighbours?
   
 
Solution:
  
Solution:
 
<haskell>
  
<haskell>
−
problem_128 = undefined
  
  +
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>
  
</haskell>
   
−
== [http://projecteuler.net/index.php?section=view&id=129 Problem 129] ==
 +
== [http://projecteuler.net/index.php?section=problems&id=129 Problem 129] ==
 
Investigating minimal repunits that divide by n.
  
Investigating minimal repunits that divide by n.
   
 
Solution:
  
Solution:
 
<haskell>
  
<haskell>
−
problem_129 = undefined
  
  +
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>
  
</haskell>
   
−
== [http://projecteuler.net/index.php?section=view&id=130 Problem 130] ==
 +
== [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.
  
Finding composite values, n, for which n−1 is divisible by the length of the smallest repunits that divide it.
   
 
Solution:
  
Solution:
 
<haskell>
  
<haskell>
−
problem_130 = undefined
  
  +
--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>
  
</haskell>
−  
−
[[Category:Tutorials]]
  
−
[[Category:Code]]
  

Latest revision as of 18:29, 21 February 2010

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
       ]

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

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

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

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]

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

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

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]

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)

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]
Retrieved from "https://wiki.haskell.org/index.php?title=Euler_problems/121_to_130&oldid=33764"