Personal tools

Euler problems/131 to 140

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 3: Line 3:
  
 
Solution:
 
Solution:
<haskell>
 
primes=sieve [2..]
 
sieve (x:xs)=x:sieve [y|y<-xs,mod y x>0]
 
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
 
 
isPrime n = case (primeFactors n) of
 
                (_:_:_)  -> False
 
                _        -> True
 
problem_131 =
 
    length $ takeWhile (<1000000)
 
    [x|
 
    a<-[1 .. ],
 
    let x=(3*a*(a+1)+1),
 
    isPrime x]
 
</haskell>
 
  
 
== [http://projecteuler.net/index.php?section=view&id=132 Problem 132] ==
 
== [http://projecteuler.net/index.php?section=view&id=132 Problem 132] ==
Line 28: Line 8:
  
 
Solution:
 
Solution:
<haskell>
 
-- primes powMod in problem_133
 
fun x =
 
    (powMod x 10 n)==1
 
    where
 
    n=10^9
 
--add 3
 
p132 =sum$take 41 [a|a<-primes,fun a]
 
problem_132 =p132-3
 
</haskell>
 
  
 
== [http://projecteuler.net/index.php?section=view&id=133 Problem 133] ==
 
== [http://projecteuler.net/index.php?section=view&id=133 Problem 133] ==
Line 43: Line 13:
  
 
Solution:
 
Solution:
<haskell>
 
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)
 
 
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..]]
 
fact25 m 
 
    | m `mod` 2 == 0 = 2 : fact25 (m `div` 2)
 
    | m `mod` 5 == 0 = 5 : fact25 (m `div` 5)
 
    | otherwise      = []
 
fun x
 
    |n==x-1=True
 
    |otherwise= (powMod x 10 n)==1
 
    where
 
    n=product$fact25 (x-1)
 
--miss 2 3 5
 
test =sum$takeWhile (<100)[a|a<-primes,not$fun a]
 
p133 =sum$takeWhile (<100000)[a|a<-primes,not$fun a]
 
problem_133 = p133+2+3+5
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=view&id=134 Problem 134] ==
 
== [http://projecteuler.net/index.php?section=view&id=134 Problem 134] ==
 
Finding the smallest positive integer related to any pair of consecutive primes.
 
Finding the smallest positive integer related to any pair of consecutive primes.
  
 
Solution:
 
Solution:
<haskell>
 
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..]]
 
 
problem_134 :: Integer
 
problem_134 = sum xs
 
          where
 
            ps = drop 2 primes
 
            ds = takeWhile ((< 10^6) . fst) $ zip ps (tail ps)
 
            xs = map (uncurry func) ds
 
 
 
expo :: Integer -> Int
 
expo = length . show
 
 
find :: Integer -> Integer -> (Integer, Integer)
 
find a b = findStep a 1 0 b 0 1
 
 
findStep :: Integer -> Integer -> Integer -> Integer -> Integer
 
                            -> Integer -> (Integer, Integer)
 
findStep a x1 x2 b y1 y2 =
 
  case divMod a b of
 
        (q,0) -> (x2, y2)
 
        (q,r) -> findStep b x2 (x1-q*x2) r  y2 (y1-q*y2)
 
 
checkL :: Integer -> Integer -> (Integer,Integer)
 
checkL 0 _ = (-1,1)
 
checkL n d
 
    = let (u,v) = find n d
 
      in if u <= 0 then (n-v,d+u) else (-v,u)
 
 
func :: Integer -> Integer -> Integer
 
func p1 p2
 
    = n*p2
 
      where
 
        md = 10^(expo p1)
 
        (_,h) = checkL p2 md
 
        n = p1*h `mod` md
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=view&id=135 Problem 135] ==
 
== [http://projecteuler.net/index.php?section=view&id=135 Problem 135] ==
 
Determining the number of solutions of the equation x2 − y2 − z2 = n.
 
Determining the number of solutions of the equation x2 − y2 − z2 = n.
  
 
Solution:
 
Solution:
<haskell>
 
import Control.Monad
 
import Data.List
 
import Data.Array.ST
 
import Control.Monad.ST
 
import Control.Monad.Cont
 
 
--  ghc -package mtl p135.hs
 
p135 m = runST (do
 
  counts <- newArray (1,m-1) 0 :: ST s (STUArray s Int Int)
 
 
  forM_ [1 .. m - 1] $ \ x ->
 
    forM_' [x `div` 3 + 1 .. div m 2] $ \ break n ->
 
 
        let t = (n + x) * (3 * n - x)
 
        in if t < m
 
            then lift $ incArray counts t
 
            else break ()
 
 
  xs <- getElems counts
 
  return $ length $ filter (==10) xs)
 
 
  where
 
    forM_' xs f = flip runContT return $ callCC $ forM_ xs . f
 
 
    incArray arr index = do
 
      v <- readArray arr index
 
      writeArray arr index (v + 1)
 
main=appendFile "p135.log"$show $p135 (10^6)
 
problem_135=main
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=view&id=136 Problem 136] ==
 
== [http://projecteuler.net/index.php?section=view&id=136 Problem 136] ==
 
Discover when the equation x2 − y2 − z2 = n has a unique solution.
 
Discover when the equation x2 − y2 − z2 = n has a unique solution.
  
 
Solution:
 
Solution:
<haskell>
 
import List
 
find2km :: Integral a => a -> (a,a)
 
find2km n = f 0 n
 
    where
 
        f k m
 
            | r == 1 = (k,m)
 
            | otherwise = f (k+1) q
 
            where (q,r) = quotRem m 2       
 
 
millerRabinPrimality :: Integer -> Integer -> Bool
 
millerRabinPrimality n a
 
    | a <= 1 || a >= n-1 =
 
        error $ "millerRabinPrimality: a out of range ("
 
              ++ show a ++ " for "++ show n ++ ")"
 
    | n < 2 = False
 
    | even n = False
 
    | b0 == 1 || b0 == n' = True
 
    | otherwise = iter (tail b)
 
    where
 
        n' = n-1
 
        (k,m) = find2km n'
 
        b0 = powMod n a m
 
        b = take (fromIntegral k) $ iterate (squareMod n) b0
 
        iter [] = False
 
        iter (x:xs)
 
            | x == 1 = False
 
            | x == n' = True
 
            | otherwise = iter xs
 
 
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
 
 
mulMod :: Integral a => a -> a -> a -> a
 
mulMod a b c = (b * c) `mod` a
 
squareMod :: Integral a => a -> a -> a
 
squareMod a b = (b * b) `rem` a
 
powMod :: Integral a => a -> a -> a -> a
 
powMod m = pow' (mulMod m) (squareMod m)
 
isPrime x=foldl  (&& )True [millerRabinPrimality x y|y<-[2,3,7,61]]
 
nextPrime x=head [a|a<-[(x+1)..],isPrime a]
 
lazyPrimeSieve :: [Integer] -> [Integer]
 
lazyPrimeSieve [] = []
 
lazyPrimeSieve (x:xs) = x : (lazyPrimeSieve $ filter (\y -> y `rem` x /= 0) xs)
 
 
oddPrimes :: [Integer]
 
oddPrimes = lazyPrimeSieve [3,5..]
 
fun =2+sum[testPrime a|a<-takeWhile (<100) oddPrimes]
 
limit=50000000
 
groups=1000000
 
fillmap num total rlimit=do
 
    let a=nextPrime num
 
    if a>rlimit then
 
        return  total
 
        else do
 
            let b=testPrime a
 
            fillmap (a+1) (total+b) rlimit
 
testPrime p =p1+p2+p3
 
    where
 
    p1=if mod p 4==3 then 1 else 0
 
    p2=if p*4<limit then 1 else 0
 
    p3=if p*16<limit then 1 else 0
 
problem_136 b=fillmap ming 0 maxg
 
    where
 
    ming=b*groups
 
    maxg=(b+1)*groups
 
google num
 
-- write file to change bignum to small num
 
  =if (num>49)
 
      then return()
 
      else do t1<-problem_136 num
 
              appendFile "file.log" $show t1  ++ "\n"
 
              google (num+1)
 
main=do
 
    appendFile "file.log" $show fun  ++ "\n"
 
    k<-fillmap 100 0 groups
 
    appendFile "file.log" $show k  ++ "\n"
 
    google 1
 
sToInt =(+0).read
 
problem_136a=do
 
    s<-readFile "file.log"
 
    print$sum$map sToInt$lines s
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=view&id=137 Problem 137] ==
 
== [http://projecteuler.net/index.php?section=view&id=137 Problem 137] ==
 
Determining the value of infinite polynomial series for which the coefficients are Fibonacci numbers.
 
Determining the value of infinite polynomial series for which the coefficients are Fibonacci numbers.
  
 
Solution:
 
Solution:
<haskell>
 
-- afx=x/(1-x-x^2)=n
 
--  ->5*n^2+2*n+1=d^2
 
--  ->let k=10*n+2
 
--  ->20*d^2=k^2+16
 
--  ->5*d^2=k^2+4
 
--  ->let d k is even
 
--  ->5*d^2=k^2+1
 
--  ->let d k is odd
 
--  ->5*d^2=k^2+4
 
 
import Data.List
 
findmin d =
 
    d:head [[n,m]|
 
    m<-[1..10],
 
    n<-[1..10],
 
    n*n==d*m*m+1
 
    ]
 
findmin_s d =
 
    d:head [[n,m]|
 
    m<-[1..10],
 
    n<-[1..10],
 
    n*n==d*m*m-1
 
    ]
 
findmu d y=
 
    d:head [[n,m]|
 
    m<-[1..10],
 
    n<-[1..10],
 
    n*n==d-y*m
 
    ]
 
mux2 [d,a, b]=[d,a,-b]
 
mult [d,a, b] [_,a1, b1]=
 
    d:[a*a1+d*b*b1,a*b1+b*a1]
 
pow 1 x=x
 
pow n x =mult x $pow (n-1) x
 
    where
 
    mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1]
 
fun =[c|
 
    a<-[1..20],
 
    [_,b,_]<-powmu a,
 
    let bb=abs(b),
 
    mod bb 5==1,
 
    let c=div bb 5
 
    ]
 
powmu n =
 
    [a,b]
 
    where
 
    c=pow n $findmin 5
 
    x1=findmu 5 4
 
    x2=mux2 x1
 
    a=mult c x1
 
    b=mult c x2
 
fun2=[c|
 
    a<-[1..20],
 
    let[_,b,_]=pow a $findmin_s 5,
 
    let bb=b*2,mod bb 5==1,
 
    let c=div bb 5
 
    ]
 
problem_137 =(!!14)$sort $(++fun)$fun2
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=view&id=138 Problem 138] ==
 
== [http://projecteuler.net/index.php?section=view&id=138 Problem 138] ==
 
Investigating isosceles triangle for which the height and base length differ by one.
 
Investigating isosceles triangle for which the height and base length differ by one.
  
 
Solution:
 
Solution:
<haskell>
 
{-
 
- 4*m^2-16*m*n-4*n^2+1=0
 
- 4*m^2-16*m*n-4*n^2-1=0
 
- (m-2*n)^2-5*n^2=1
 
- (m-2*n)^2-5*n^2=-1
 
-}
 
import Data.List
 
mult [d,a, b] [_,a1, b1]=
 
    d:[a*a1+d*b*b1,a*b1+b*a1]
 
pow 1 x=x
 
pow n x =mult x $pow (n-1) x
 
    where
 
    mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1]
 
-- 2^2-5*1^2=-1
 
-- so [5,2,1]
 
fun =
 
    [d^2+c^2|
 
    a<-[1..20],
 
    let [_,b,c]=pow a [5,2,1],
 
    let d=2*c+b
 
    ]
 
-- 9^2-5*4^2=1
 
-- so [5,9,4]
 
fun2 =
 
    [d^2+c^2|
 
    a<-[1..20],
 
    let [_,b,c]=pow a [5,9,4],
 
    let d=2*c+b
 
    ]
 
problem_138 =sum$take 12 $nub$sort (fun++fun2)
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=view&id=139 Problem 139] ==
 
== [http://projecteuler.net/index.php?section=view&id=139 Problem 139] ==
 
Finding Pythagorean triangles which allow the square on the hypotenuse square to be tiled.
 
Finding Pythagorean triangles which allow the square on the hypotenuse square to be tiled.
  
 
Solution:
 
Solution:
<haskell>
 
{-
 
-                              2                        2
 
-                    (n - 1) y  - 2 n x y + (- n - 1) x  = 0
 
--->
 
-                                          2      2      2
 
-                          ((n - 1) y - n x)  = (2 n  - 1) x
 
--->
 
-                      2        2
 
-                    2 n  - 1 = k
 
-
 
-}
 
import Data.List
 
mult [d,a, b] [_,a1, b1]=
 
    d:[a*a1+d*b*b1,a*b1+b*a1]
 
pow 1 x=x
 
pow n x =mult x $pow (n-1) x
 
div2 [x,y,z]
 
    |mod x 2==0 && mod y 2==0 && mod z 2==0=
 
        [div x 2,div y 2,div z 2]
 
    |otherwise=[x,y,z]
 
-- 1^2-2*1^2=-1
 
-- so [2,1,1]
 
fun =map div2 [
 
    side
 
    |a<-[3,5..40],
 
    let [_,k,n]=pow a [2,1,1],
 
    let m=lcm (n+k) (n-1),
 
    let x=div m (n+k),
 
    let y=div m (n-1),
 
    let side=[y^2-x^2, 2*x*y, y^2+x^2]
 
    ]
 
limit=100000000
 
problem_139=sum [div limit$sum a|a<-fun,  sum a<limit]
 
</haskell>
 
 
 
== [http://projecteuler.net/index.php?section=view&id=140 Problem 140] ==
 
== [http://projecteuler.net/index.php?section=view&id=140 Problem 140] ==
 
Investigating the value of infinite polynomial series for which the coefficients are a linear second order recurrence relation.
 
Investigating the value of infinite polynomial series for which the coefficients are a linear second order recurrence relation.
  
 
Solution:
 
Solution:
<haskell>
 
{-
 
                                      2
 
                                  3 x  + x
 
                            agx= ------------
 
                                    2
 
                                - x  - x + 1
 
--->
 
                                  2            2
 
                                5 n  + 14 n + 1=d
 
 
--->                          k = 10 n + 14
 
--->                          20*d^2=k^2-176
 
--->                          k = 5 n + 2
 
--->                          5*d^2=k^2-44
 
-}
 
import Data.List
 
findmin d =
 
    d:head [[n,m]|
 
    m<-[1..10],
 
    n<-[1..10],
 
    n*n==d*m*m+1
 
    ]
 
findmin_s d =
 
    d:head [[n,m]|
 
    m<-[1..10],
 
    n<-[1..10],
 
    n*n==d*m*m+1
 
    ]
 
findmu d y=
 
    d:head [[n,m]|
 
    m<-[1..10],
 
    n<-[1..10],
 
    n*n==d+y*m
 
    ]
 
mux2 [d,a, b]=[d,a,-b]
 
mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1]
 
div2 [d,a, b] =d:[div a 2,div b 2]
 
pow 1 x=x
 
pow n x =mult x $pow (n-1) x
 
fun =
 
    [c|
 
    a<-[1..20],
 
    [_,b,_]<-powmu a,
 
    let bb=abs(b),
 
    mod bb 5==2,
 
    let c=div bb 5
 
    ]
 
fun2=
 
    [c|
 
    a<-[1..20],
 
    [_,b,_]<-powmu1 a ,
 
    let bb=(abs b)*2,
 
    mod bb 5==2,
 
    let c=div bb 5
 
    ]
 
powmu n =
 
    [a,b,a1,a2,b1,b2]
 
    where
 
    c=pow n $findmin 5
 
    x1=findmu 5 44
 
    x2=mux2 x1
 
    a=mult c x1
 
    b=mult c x2
 
    a1=div2$mult a [5,3, -1]
 
    a2=div2$mult a [5,3, 1]
 
    b1=div2$mult b [5,3, -1]
 
    b2=div2$mult b [5,3, 1]
 
powmu1 n =
 
    [a,b]
 
    where
 
    c=pow n $findmin_s 5
 
    x1=findmu 5 11
 
    x2=mux2 x1
 
    a=mult c x1
 
    b=mult c x2
 
problem_140 =sum $take 30 [a-1|a<-nub$sort (fun++fun2)]
 
</haskell>
 

Revision as of 21:35, 29 January 2008

Contents

1 Problem 131

Determining primes, p, for which n3 + n2p is a perfect cube.

Solution:

2 Problem 132

Determining the first forty prime factors of a very large repunit.

Solution:

3 Problem 133

Investigating which primes will never divide a repunit containing 10n digits.

Solution:

4 Problem 134

Finding the smallest positive integer related to any pair of consecutive primes.

Solution:

5 Problem 135

Determining the number of solutions of the equation x2 − y2 − z2 = n.

Solution:

6 Problem 136

Discover when the equation x2 − y2 − z2 = n has a unique solution.

Solution:

7 Problem 137

Determining the value of infinite polynomial series for which the coefficients are Fibonacci numbers.

Solution:

8 Problem 138

Investigating isosceles triangle for which the height and base length differ by one.

Solution:

9 Problem 139

Finding Pythagorean triangles which allow the square on the hypotenuse square to be tiled.

Solution:

10 Problem 140

Investigating the value of infinite polynomial series for which the coefficients are a linear second order recurrence relation.

Solution: