Personal tools

Euler problems/121 to 130

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 153: Line 153:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_127 = undefined
+
import Data.List
  +
import Data.Map(fromList,(!))
  +
rad x= product[a|(a,_)<-fstfac x]
  +
radMap=fromList[(a,fromList [(b,rad(a*1000+b))|b<-[0..999]])|a<-[0..100]]
  +
fastrad x=
  +
radMap!a!b
  +
where
  +
(a,b)=divMod x 1000
  +
maxSingFac x
  +
|not$null ar=last ar
  +
|otherwise=0
  +
where
  +
ar=[a|(a,b)<-x,b==1]
  +
testPrime x p divx= [swap(x,a,b)|
  +
a<-[p2*a1|a1<-[1..n]],
  +
gcd a x==1,
  +
let b=x-a,
  +
gcd b x==1,
  +
gcd b a==1,
  +
fastrad a*fastrad b<divx
  +
]
  +
where
  +
p2=p^2
  +
(n,m)=divMod x p2
  +
swap (a,b,c)
  +
|b<c=[a,b]
  +
|otherwise=[a,c]
  +
test1 x divx
  +
|fastrad (x-1)<divx=[[x,1]]
  +
|otherwise=[]
  +
test x
  +
|(length ff>4)=[]
  +
|(maxSingFac ff>1200)=[]
  +
|otherwise= nub d
  +
where
  +
ra=fastrad x
  +
ff=fstfac x
  +
divx=div x ra
  +
ba=div divx 2
  +
c1=takeWhile (<=ba) primes
  +
d=test1 x divx++[b|p<-c1,b<-testPrime x p divx]
  +
  +
groups=1000
  +
p127 k=[m|a<-[1+k*groups..groups*(k+1)],let t=test a,not$null t,m<-t]
  +
show1 x=foldl (++) "" $map ((++" \n").show2) x
  +
show2 [a,b]=show a++" "++show b
  +
google num
  +
-- write file to change bignum to small num
  +
=if (num>99)
  +
then return()
  +
else do appendFile "p127.log" $(show1$p127 num)
  +
google (num+1)
  +
main=google 0
  +
  +
fstfac x = [(head a ,length a)|a<-group$primeFactors x]
  +
primeFactors :: Integer -> [Integer]
  +
primeFactors n = factor n primes
  +
where
  +
factor _ [] = []
  +
factor m (p:ps) | p*p > m = [m]
  +
| m `mod` p == 0 = p : factor (m `div` p) (p:ps)
  +
| otherwise = factor m ps
  +
merge xs@(x:xt) ys@(y:yt) = case compare x y of
  +
LT -> x : (merge xt ys)
  +
EQ -> x : (merge xt yt)
  +
GT -> y : (merge xs yt)
  +
  +
diff xs@(x:xt) ys@(y:yt) = case compare x y of
  +
LT -> x : (diff xt ys)
  +
EQ -> diff xt yt
  +
GT -> diff xs yt
  +
  +
primes, nonprimes :: [Integer]
  +
primes = [2,3,5] ++ (diff [7,9..] nonprimes)
  +
nonprimes = foldr1 f . map g $ tail primes
  +
where f (x:xt) ys = x : (merge xt ys)
  +
g p = [ n*p | n <- [p,p+2..]]
  +
split :: Char -> String -> [String]
  +
split = unfoldr . split'
  +
  +
split' :: Char -> String -> Maybe (String, String)
  +
split' c l
  +
| null l = Nothing
  +
| otherwise = Just (h, drop 1 t)
  +
where (h, t) = span (/=c) l
  +
  +
sToInt x=((+0).read) $head$split ' ' x
  +
  +
problem_127=do
  +
x<-readFile "p127.log"
  +
let y=sum$map sToInt $lines x
  +
print (y-1-100000)
 
</haskell>
 
</haskell>
   

Revision as of 12:55, 27 December 2007

Contents

1 Problem 121

Investigate the game of chance involving coloured discs.

Solution:

problem_121 = undefined

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

3 Problem 123

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

Solution:

primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
 
primeFactors n = factor n primes
    where
        factor _ [] = []
        factor m (p:ps) | p*p > m        = [m]
                        | m `mod` p == 0 = p : [m `div` p]
                        | otherwise      = factor m ps
 
isPrime :: Integer -> Bool
isPrime 1 = False
isPrime n = case (primeFactors n) of
                (_:_:_)   -> False
                _         -> True
 
problem_123 = 
    head[a+1|a<-[20000,20002..22000],
    let n=2*(a+1)*primes!!(fromInteger a),
    n>10^10
    ]

4 Problem 124

Determining the kth element of the sorted radical function.

Solution:

import List
primes :: [Integer]
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
 
primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
    where
        factor _ [] = []
        factor m (p:ps) | p*p > m        = [m]
                        | m `mod` p == 0 = p : factor (m `div` p) (p:ps)
                        | otherwise      = factor m ps
problem_124=snd$(!!9999)$sort[(product$nub$primeFactors x,x)|x<-[1..100000]]

5 Problem 125

Finding square sums that are palindromic.

Solution:

import Data.List 
import Data.Map(fromList,(!))
 
toFloat = (flip encodeFloat 0) 
digits n 
{-  123->[3,2,1]
 -}
    |n<10=[n]
    |otherwise= y:digits x 
    where
    (x,y)=divMod n 10
 
palind n=foldl dmm 0 (digits n) 
-- 123 ->321
dmm=(\x y->x*10+y)
 
makepalind n=(n*d+p):[c+b*d|b<-[0..9]]
    where
    a=(+1)$floor$logBase 10$fromInteger n
    d=10^a
    p=palind n
    c=n*10*d+p
 
twomakep n=(n*d+p)
    where
    a=(+1)$floor$logBase 10$fromInteger n
    d=10^a
    p=palind n
 
p125=sum[b|a<-[1..999], b<-makepalind a,not$null$ funa b]
p125a=sum[b|a<-[1000..9999], let b=twomakep a,not$null$ funa b]
p125b=sum[a|a<-[1..9], not$null$ funa a]
 
findmap=fromList[(a,2*fill_map a)|a<-[0..737]]
fill_map x
    |odd x=fastsum $div (x-1) 2
    |otherwise=fastsumodd (x-1)
    where
    fastsum  y=div (y*(y+1)*(2*y+1)) 6
    fastsumodd  y=let n=div (y+1) 2 in div (n*(4*n*n-1)) 3
 
funa x=[(a,x)|a<-takeWhile (\a->a*a*a<4*x) [2..],funb a x]
funb x n
    |odd x=d2==0 && 4*d1>=(x+1)^2 && isSq d1
    |otherwise=d4==0 && odd d3 && d3>=(x+1)^2 && isSq d3
    where
    x1=fromInteger x
    (d1,d2)=divMod ((n-findmap! x1)) (x)
    (d3,d4)=divMod ((4*n-findmap!x1)) (x)
isSq x=(floor$sqrt$toFloat x)^2==x
problem_125 = (p125+p125a+p125b)

6 Problem 126

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

Solution:

problem_126 = undefined

7 Problem 127

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

Solution:

import Data.List
import Data.Map(fromList,(!))
rad x= product[a|(a,_)<-fstfac x]
radMap=fromList[(a,fromList [(b,rad(a*1000+b))|b<-[0..999]])|a<-[0..100]]
fastrad x=
    radMap!a!b
    where
    (a,b)=divMod x 1000
maxSingFac x 
    |not$null ar=last ar
    |otherwise=0
    where
    ar=[a|(a,b)<-x,b==1]
testPrime x p divx= [swap(x,a,b)| 
    a<-[p2*a1|a1<-[1..n]],
    gcd a x==1,
    let b=x-a,
    gcd b x==1,
    gcd b a==1,
    fastrad a*fastrad b<divx
    ] 
    where
    p2=p^2
    (n,m)=divMod x p2
swap (a,b,c)
    |b<c=[a,b]
    |otherwise=[a,c]
test1 x divx
    |fastrad (x-1)<divx=[[x,1]]
    |otherwise=[]
test x
    |(length ff>4)=[]
    |(maxSingFac ff>1200)=[]
    |otherwise= nub d 
    where
    ra=fastrad x
    ff=fstfac x
    divx=div x ra
    ba=div divx 2 
    c1=takeWhile (<=ba) primes
    d=test1 x divx++[b|p<-c1,b<-testPrime x p divx]
 
groups=1000
p127 k=[m|a<-[1+k*groups..groups*(k+1)],let t=test a,not$null t,m<-t]
show1 x=foldl (++) "" $map ((++" \n").show2) x
show2 [a,b]=show a++"  "++show b
google num
-- write file to change bignum to small num
  =if (num>99)
      then return()
      else do appendFile "p127.log" $(show1$p127 num)  
              google (num+1)
main=google 0
 
fstfac x = [(head a ,length a)|a<-group$primeFactors x]
primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
    where
        factor _ [] = []
        factor m (p:ps) | p*p > m        = [m]
                        | m `mod` p == 0 = p : factor (m `div` p) (p:ps)
                        | otherwise      = factor m ps
merge xs@(x:xt) ys@(y:yt) = case compare x y of
    LT -> x : (merge xt ys)
    EQ -> x : (merge xt yt)
    GT -> y : (merge xs yt)
 
diff  xs@(x:xt) ys@(y:yt) = case compare x y of
    LT -> x : (diff xt ys)
    EQ -> diff xt yt
    GT -> diff xs yt
 
primes, nonprimes :: [Integer]
primes    = [2,3,5] ++ (diff [7,9..] nonprimes) 
nonprimes = foldr1 f . map g $ tail primes
    where f (x:xt) ys = x : (merge xt ys)
          g p = [ n*p | n <- [p,p+2..]]
split :: Char -> String -> [String]
split = unfoldr . split'
 
split' :: Char -> String -> Maybe (String, String)
split' c l
  | null l = Nothing
  | otherwise = Just (h, drop 1 t)
  where (h, t) = span (/=c) l
 
sToInt x=((+0).read) $head$split ' ' x
 
problem_127=do
    x<-readFile "p127.log"
    let y=sum$map sToInt $lines x
    print  (y-1-100000)

8 Problem 128

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

Solution:

problem_128 = undefined

9 Problem 129

Investigating minimal repunits that divide by n.

Solution:

problem_129 = undefined

10 Problem 130

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

Solution:

import Data.List
mulMod :: Integral a => a -> a -> a -> a
mulMod a b c= (b * c) `rem` a
squareMod :: Integral a => a -> a -> a
squareMod a b = (b * b) `rem` a
pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a
pow' _ _ _ 0 = 1
pow' mul sq x' n' = f x' n' 1
    where
    f x n y
        | n == 1 = x `mul` y
        | r == 0 = f x2 q y
        | otherwise = f x2 q (x `mul` y)
        where
            (q,r) = quotRem n 2
            x2 = sq x
powMod :: Integral a => a -> a -> a -> a
powMod m = pow' (mulMod m) (squareMod m)
 
primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
    where
        factor _ [] = []
        factor m (p:ps) | p*p > m        = [m]
                        | m `mod` p == 0 = p : factor (m `div` p) (p:ps)
                        | otherwise      = factor m ps
 
primes=2:[a|a<-[2..],isPrime a]
isPrime :: Integer -> Bool
isPrime 1 = False
isPrime n = case (primeFactors n) of
                (_:_:_)   -> False
                _         -> True
fstfac x = [(head a ,length a)|a<-group$primeFactors x]
fac [(x,y)]=[x^a|a<-[0..y]]
fac (x:xs)=[a*b|a<-fac [x],b<-fac xs]
factors x=fac$fstfac x
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]