Difference between revisions of "Euler problems/131 to 140"
Marypoppins (talk | contribs) |
CaleGibbard (talk | contribs) (rv: vandalism) |
||
Line 1: | Line 1: | ||
− | + | == [http://projecteuler.net/index.php?section=view&id=131 Problem 131] == | |
+ | Determining primes, p, for which n3 + n2p is a perfect cube. | ||
+ | |||
+ | 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] == | ||
+ | Determining the first forty prime factors of a very large repunit. | ||
+ | |||
+ | 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] == | ||
+ | Investigating which primes will never divide a repunit containing 10n digits. | ||
+ | |||
+ | 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] == | ||
+ | Finding the smallest positive integer related to any pair of consecutive primes. | ||
+ | |||
+ | 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] == | ||
+ | Determining the number of solutions of the equation x2 − y2 − z2 = n. | ||
+ | |||
+ | 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] == | ||
+ | Discover when the equation x2 − y2 − z2 = n has a unique 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] == | ||
+ | Determining the value of infinite polynomial series for which the coefficients are Fibonacci numbers. | ||
+ | |||
+ | 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] == | ||
+ | Investigating isosceles triangle for which the height and base length differ by one. | ||
+ | |||
+ | 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] == | ||
+ | Finding Pythagorean triangles which allow the square on the hypotenuse square to be tiled. | ||
+ | |||
+ | 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] == | ||
+ | Investigating the value of infinite polynomial series for which the coefficients are a linear second order recurrence relation. | ||
+ | |||
+ | 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 04:59, 30 January 2008
Contents
Problem 131
Determining primes, p, for which n3 + n2p is a perfect cube.
Solution:
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]
Problem 132
Determining the first forty prime factors of a very large repunit.
Solution:
-- 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
Problem 133
Investigating which primes will never divide a repunit containing 10n digits.
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)
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
Problem 134
Finding the smallest positive integer related to any pair of consecutive primes.
Solution:
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
Problem 135
Determining the number of solutions of the equation x2 − y2 − z2 = n.
Solution:
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
Problem 136
Discover when the equation x2 − y2 − z2 = n has a unique solution.
Solution:
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
Problem 137
Determining the value of infinite polynomial series for which the coefficients are Fibonacci numbers.
Solution:
-- 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
Problem 138
Investigating isosceles triangle for which the height and base length differ by one.
Solution:
{-
- 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)
Problem 139
Finding Pythagorean triangles which allow the square on the hypotenuse square to be tiled.
Solution:
{-
- 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]
Problem 140
Investigating the value of infinite polynomial series for which the coefficients are a linear second order recurrence relation.
Solution:
{-
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)]