Personal tools

Euler problems/131 to 140

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Current revision (21:35, 27 July 2010) (edit) (undo)
 
(10 intermediate revisions not shown.)
Line 30: Line 30:
<haskell>
<haskell>
-- primes powMod in problem_133
-- primes powMod in problem_133
-
fun x = (powMod x 10 n)==1
+
fun x =
 +
(powMod x 10 n)==1
where
where
n=10^9
n=10^9
Line 77: Line 78:
where f (x:xt) ys = x : (merge xt ys)
where f (x:xt) ys = x : (merge xt ys)
g p = [ n*p | n <- [p,p+2..]]
g p = [ n*p | n <- [p,p+2..]]
-
fact25 m | m `mod` 2 == 0 = 2 : fact25 (m `div` 2)
+
fact25 m
-
| m `mod` 5 == 0 = 5 : fact25 (m `div` 5)
+
| m `mod` 2 == 0 = 2 : fact25 (m `div` 2)
-
| otherwise = []
+
| m `mod` 5 == 0 = 5 : fact25 (m `div` 5)
 +
| otherwise = []
fun x
fun x
|n==x-1=True
|n==x-1=True
Line 96: Line 98:
Solution:
Solution:
<haskell>
<haskell>
-
import List
 
-
 
merge xs@(x:xt) ys@(y:yt) = case compare x y of
merge xs@(x:xt) ys@(y:yt) = case compare x y of
LT -> x : (merge xt ys)
LT -> x : (merge xt ys)
Line 114: Line 114:
g p = [ n*p | n <- [p,p+2..]]
g p = [ n*p | n <- [p,p+2..]]
-
dign x=(+1)$floor$logBase 10$fromInteger x
+
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
 +
-
euler x1 x2 x3 y1 y2 1=(x3,y2)
+
expo :: Integer -> Int
-
euler x1 x2 x3 y1 y2 y3
+
expo = length . show
-
=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)
+
find :: Integer -> Integer -> (Integer, Integer)
-
split' c l
+
find a b = findStep a 1 0 b 0 1
-
| null l = Nothing
+
-
| otherwise = Just (h, drop 1 t)
+
-
where (h, t) = span (/=c) l
+
-
sToInt x=((+0).read) $head$split ' ' x
+
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)
-
problem_134=do
+
checkL :: Integer -> Integer -> (Integer,Integer)
-
x<-readFile "file.log"
+
checkL 0 _ = (-1,1)
-
let y=sum$map sToInt $lines x
+
checkL n d
-
print y
+
= 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>
</haskell>
Line 181: Line 155:
Solution:
Solution:
<haskell>
<haskell>
-
import List
+
import Control.Monad
-
primes :: [Integer]
+
import Data.List
-
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
+
import Data.Array.ST
 +
import Control.Monad.ST
 +
import Control.Monad.Cont
-
primeFactors :: Integer -> [Integer]
+
-- ghc -package mtl p135.hs
-
primeFactors n = factor n primes
+
p135 m = runST (do
-
where
+
counts <- newArray (1,m-1) 0 :: ST s (STUArray s Int Int)
-
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
+
forM_ [1 .. m - 1] $ \ x ->
-
isPrime 1 = False
+
forM_' [x `div` 3 + 1 .. m `div` 2] $ \ break n ->
-
isPrime n = case (primeFactors n) of
+
-
(_:_:_) -> False
+
let t = (n + x) * (3 * n - x)
-
_ -> True
+
in if t < m
-
fstfac x = [(head a ,length a)|a<-group$primeFactors x]
+
then lift $ incArray counts t
-
fac [(x,y)]=[x^a|a<-[0..y]]
+
else break ()
-
fac (x:xs)=[a*b|a<-fac [x],b<-fac xs]
+
-
factors x=fac$fstfac x
+
xs <- getElems counts
-
fastfun x
+
return $ length $ filter (==10) xs)
-
|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]
+
where
-
|mod x 16==12=[a|let n=div x 4,a<-factors n,a*a<3*n]
+
forM_' xs f = flip runContT return $ callCC $ forM_ xs . f
-
|mod x 16==0=[a|let n=div x 16,a<-factors n,a*a<3*n]
+
-
|otherwise=[]
+
incArray arr index = do
-
 
+
v <- readArray arr index
-
slowfun x =[a|a<-factors x,a*a<3*x,let b=div x a,mod (a+b) 4==0]
+
writeArray arr index (v + 1)
 +
main=appendFile "p135.log"$show $p135 (10^6)
 +
problem_135=main
 +
</haskell>
-
problem_135 =[a|a<-[1..groups],(length$fastfun a)==10]
+
Another solution by expressing x, y, z as n+k, n, n-k, then x^2 - y^2 - z^2 = n*(4*k - n):
 +
<haskell>
 +
import Data.Array
 +
prob_135 = concat
 +
[takeWhile ((<1000000).fst)
 +
[(r,1)|k <- [1+(n`div`4)..n-1], let r = n*(4*k-n)] |n <- [1..1000000]]
 +
main = putStrLn $ show $ length $
 +
filter ((==10).snd) $ assocs $ accumArray (+) 0 (1,1000000) prob_135
</haskell>
</haskell>
Line 219: Line 201:
Solution:
Solution:
<haskell>
<haskell>
-
-- fastfun in the problem 135
+
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=all (millerRabinPrimality x) [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
groups=1000000
-
pfast=[a|a<-[1..5000],(length$fastfun a)==1]
+
fillmap num total rlimit=do
-
pslow=[a|a<-[1..5000],(length$slowfun a)==1]
+
let a=nextPrime num
-
-- find len pfast=len pslow+2
+
if a>rlimit then
-
-- so sum file.log and +2
+
return total
-
problem_136 b=[a|a<-[1+b*groups..groups*(b+1)],(length$fastfun a)==1]
+
else do
-
google num
+
let b=testPrime a
 +
fillmap (a+1) (total+b) rlimit
 +
testPrime p =p1+p2+p3
 +
where
 +
p1=if p`mod`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
-- write file to change bignum to small num
-- write file to change bignum to small num
-
=if (num>49)
+
= forM_ [1..49] $ \num ->
-
then return()
+
do t1<-problem_136 num
-
else do appendFile "file.log" ((show$length$problem_136 num) ++ "\n")
+
appendFile "file.log" $show t1 ++ "\n"
-
google (num+1)
+
main=do
-
main=google 0
+
appendFile "file.log" $show fun ++ "\n"
 +
k<-fillmap 100 0 groups
 +
appendFile "file.log" $show k ++ "\n"
 +
google
 +
problem_136a=do
 +
s<-readFile "file.log"
 +
print$sum$map read$lines s
</haskell>
</haskell>
Line 251: Line 306:
import Data.List
import Data.List
-
findmin d = d:head [[n,m]|m<-[1..10],n<-[1..10],n*n==d*m*m+1]
+
findmin d =
-
findmin_s d = d:head [[n,m]|m<-[1..10],n<-[1..10],n*n==d*m*m-1]
+
d:head [[n,m]|
-
findmu d y= d:head [[n,m]|m<-[1..10],n<-[1..10],n*n==d-y*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]
mux2 [d,a, b]=[d,a,-b]
-
mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1]
+
mult [d,a, b] [_,a1, b1]=
 +
d:[a*a1+d*b*b1,a*b1+b*a1]
pow 1 x=x
pow 1 x=x
pow n x =mult x $pow (n-1) x
pow n x =mult x $pow (n-1) x
where
where
-
mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1]
+
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]
+
fun =[c|
 +
a<-[1..20],
 +
[_,b,_]<-powmu a,
 +
let bb=abs b,
 +
bb`mod`5==1,
 +
let c=bb`div`5
 +
]
powmu n =
powmu n =
[a,b]
[a,b]
Line 269: Line 346:
a=mult c x1
a=mult c x1
b=mult c x2
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]
+
fun2=[c|
 +
a<-[1..20],
 +
let[_,b,_]=pow a $findmin_s 5,
 +
let bb=b*2,bb`mod`5==1,
 +
let c=bb`div`5
 +
]
problem_137 =(!!14)$sort $(++fun)$fun2
problem_137 =(!!14)$sort $(++fun)$fun2
</haskell>
</haskell>
Line 285: Line 367:
-}
-}
import Data.List
import Data.List
-
mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1]
+
mult [d,a, b] [_,a1, b1]=
 +
[d,a*a1+d*b*b1,a*b1+b*a1]
pow 1 x=x
pow 1 x=x
pow n x =mult x $pow (n-1) x
pow n x =mult x $pow (n-1) x
where
where
-
mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1]
+
mult [d,a, b] [_,a1, b1]=[d,a*a1+d*b*b1,a*b1+b*a1]
-- 2^2-5*1^2=-1
-- 2^2-5*1^2=-1
-- so [5,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]
+
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
-- 9^2-5*4^2=1
-- so [5,9,4]
-- 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]
+
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_138 =sum$take 12 $nub$sort (fun++fun2)
</haskell>
</haskell>
Line 304: Line 397:
Solution:
Solution:
<haskell>
<haskell>
-
problem_139 = undefined
+
{-
 +
- 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]
 +
|even x && even y && even z=
 +
[x`div`2,y`div`2,z`div`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=m`div`(n+k),
 +
let y=m`div`(n-1),
 +
let side=[y^2-x^2, 2*x*y, y^2+x^2]
 +
]
 +
limit=100000000
 +
problem_139=sum [limit `div` sum a|a<-fun, sum a<limit]
</haskell>
</haskell>
Line 328: Line 453:
-}
-}
import Data.List
import Data.List
-
findmin d = d:head [[n,m]|m<-[1..10],n<-[1..10],n*n==d*m*m+1]
+
findmin d =
-
findmin_s d = d:head [[n,m]|m<-[1..10],n<-[1..10],n*n==d*m*m+1]
+
d:head [[n,m]|
-
findmu d y= d:head [[n,m]|m<-[1..10],n<-[1..10],n*n==d+y*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]
mux2 [d,a, b]=[d,a,-b]
-
mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1]
+
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]
+
div2 [d,a, b] =[d,a`div`2,b`div`2]
pow 1 x=x
pow 1 x=x
pow n x =mult x $pow (n-1) x
pow n x =mult x $pow (n-1) x
-
where
+
fun =
-
mult [d,a, b] [_,a1, b1]=d:[a*a1+d*b*b1,a*b1+b*a1]
+
[c|
-
fun =[c|a<-[1..20],[_,b,_]<-powmu a,let bb=abs(b),mod bb 5==2,let c=div bb 5]
+
a<-[1..20],
-
fun2=[c|a<-[1..20],[_,b,_]<-powmu1 a ,let bb=(abs b)*2,mod bb 5==2,let c=div bb 5]
+
[_,b,_]<-powmu a,
 +
let bb=abs b,
 +
bb`mod`5==2,
 +
let c=bb`div`5
 +
]
 +
fun2=
 +
[c|
 +
a<-[1..20],
 +
[_,b,_]<-powmu1 a ,
 +
let bb=(abs b)*2,
 +
bb`mod`5==2,
 +
let c=bb`div`5
 +
]
powmu n =
powmu n =
[a,b,a1,a2,b1,b2]
[a,b,a1,a2,b1,b2]

Current revision

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: 

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

5 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 .. m `div` 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

Another solution by expressing x, y, z as n+k, n, n-k, then x^2 - y^2 - z^2 = n*(4*k - n): 

import Data.Array
prob_135 = concat
  [takeWhile ((<1000000).fst) 
    [(r,1)|k <- [1+(n`div`4)..n-1], let r = n*(4*k-n)] |n <- [1..1000000]]
main = putStrLn $ show $ length $
  filter ((==10).snd) $ assocs $ accumArray (+) 0 (1,1000000) prob_135

6 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=all (millerRabinPrimality x) [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 p`mod`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
-- write file to change bignum to small num
  = forM_ [1..49] $ \num ->
           do t1<-problem_136 num
              appendFile "file.log" $show t1  ++ "\n"
main=do
    appendFile "file.log" $show fun  ++ "\n"
    k<-fillmap 100 0 groups
    appendFile "file.log" $show k  ++ "\n"
    google
problem_136a=do
    s<-readFile "file.log"
    print$sum$map read$lines s

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,
    bb`mod`5==1,
    let c=bb`div`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,bb`mod`5==1,
    let c=bb`div`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 
div2 [x,y,z]
    |even x && even y && even z=
        [x`div`2,y`div`2,z`div`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=m`div`(n+k),
    let y=m`div`(n-1),
    let side=[y^2-x^2, 2*x*y, y^2+x^2]
    ]
limit=100000000
problem_139=sum [limit `div` 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,a`div`2,b`div`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,
    bb`mod`5==2,
    let c=bb`div`5
    ]
fun2=
    [c|
    a<-[1..20],
    [_,b,_]<-powmu1 a ,
    let bb=(abs b)*2,
    bb`mod`5==2,
    let c=bb`div`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)]
Retrieved from "http://www.haskell.org/haskellwiki/Euler_problems/131_to_140"