Euler problems/131 to 140

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:

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

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]

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

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 
    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]

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)]