Euler problems/121 to 130

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
compress [] = []
compress (x:[]) = [x]
compress (x:y:xs) | x == y = compress (y:xs)
                  | otherwise = x : compress (y:xs)
 
rad = product . compress . primeFactors
 
radfax = (1,1) : zip [2..] (map rad [2..])
 
sortRadfax n = sortBy (\ (_,x) (_,y) -> compare x y) $ 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.IO
import Data.Array.Base

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 :: IOUArray Int Int -> Int -> IO ()
solutions a n = do 
    if layer 1 1 1 n <= limit
        then do solutions a (n+1)
                solutions' a 1 n
        else do return ()

solutions' :: IOUArray Int Int -> Int -> Int -> IO ()
solutions' a x n = do 
    if layer x x x n <= limit
        then do solutions' a (x+1) n
                solutions'' a x x n
        else do return ()    

solutions'' :: IOUArray Int Int -> Int -> Int -> Int -> IO ()
solutions'' a x y n = do 
    if layer x y y n <= limit
        then do solutions'' a x (y+1) n
                solutions''' a x y y n
        else do return ()

solutions''' :: IOUArray Int Int -> Int -> Int -> Int -> Int -> IO ()
solutions''' a x y z n = do 
    if layer x y z n <= limit
        then do unsafeRead a (layer x y z n) >>= return.(+1) >>= unsafeWrite a (layer x y z n)
                solutions''' a x y (z+1) n
        else do return ()

findSolution :: IOUArray Int Int -> Int -> IO (Maybe Int)
findSolution a n 
    | n == limit = do return Nothing
    | otherwise = do 
        v <- unsafeRead a n
        if v == 1000
            then do return (Just n)
            else do findSolution a (n+1)

main = do 
    cn <- newArray (0,limit+1) 0 :: IO (IOUArray Int Int)
    solutions cn 1
    findSolution cn 154 >>=print
problem_126 = main

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]