Euler problems/131 to 140
From HaskellWiki
Contents |
1 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]
2 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
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
4 Problem 134
Finding the smallest positive integer related to any pair of consecutive primes.
Solution:
import List 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..]] dign x=(+1)$floor$logBase 10$fromInteger x euler x1 x2 x3 y1 y2 1=(x3,y2) euler x1 x2 x3 y1 y2 y3 =euler y1 y2 y3 t1 t2 t3 where (k,t3)=divMod x3 y3 t1=x1-k*y1 t2=x2-k*y2 -- find a ,b -- mod (x*a) y = 1 -- mod (y*b) x = 1 congrue x y |x>y=euler 1 0 x 0 1 y |otherwise =(a,b) where (b,a)=congrue y x --fastfun 7=1219 fastfun x |x==1=0 |p1>1000000=0 |otherwise= a*d+p1 where p1=primes!!x p2=primes!!(x+1) dp=p2-p1 d=10^dign p1 dmod=mod d p2 eu=(+p2)$fst$congrue dmod p2 a=mod (eu*dp) p2 groups=1000 funsum k=sum[fastfun a|a<-[1+k*groups..groups*(k+1)]] google num -- write file to change bignum to small num =if (num>79) then return() else do appendFile "file.log" $(show$funsum num) ++" "++(show num) ++"\n" google (num+1) -- first use main to make file.log -- then run problem_134 main=google 0 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_134=do x<-readFile "file.log" let y=sum$map sToInt $lines x print y
5 Problem 135
Determining the number of solutions of the equation x2 − y2 − z2 = n.
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 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 fastfun x |mod x 4==3=[a|a<-factors x,a*a<3*x] |mod x 16==4=[a|let n=div x 4,a<-factors n,a*a<3*n] |mod x 16==12=[a|let n=div x 4,a<-factors n,a*a<3*n] |mod x 16==0=[a|let n=div x 16,a<-factors n,a*a<3*n] |otherwise=[] slowfun x =[a|a<-factors x,a*a<3*x,let b=div x a,mod (a+b) 4==0] problem_135 =[a|a<-[1..groups],(length$fastfun a)==10]
6 Problem 136
Discover when the equation x2 − y2 − z2 = n has a unique solution.
Solution:
-- fastfun in the problem 135 groups=1000000 pfast=[a|a<-[1..5000],(length$fastfun a)==1] pslow=[a|a<-[1..5000],(length$slowfun a)==1] -- find len pfast=len pslow+2 -- so sum file.log and +2 problem_136 b=[a|a<-[1+b*groups..groups*(b+1)],(length$fastfun a)==1] google num -- write file to change bignum to small num =if (num>49) then return() else do appendFile "file.log" ((show$length$problem_136 num) ++ "\n") google (num+1) main=google 0
7 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
8 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)
9 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 where mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1] 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]
10 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 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==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)]
