Euler problems/141 to 150
Problem 141
Investigating progressive numbers, n, which are also square.
Solution:
problem_141 = undefined
Problem 142
Perfect Square Collection
Solution:
import List
isSquare n = (round . sqrt $ fromIntegral n) ^ 2 == n
aToX (a,b,c)=[x,y,z]
where
x=div (a+b) 2
y=div (a-b) 2
z=c-x
{-
- 2 2 2
- a = c + d
- 2 2 2
- a = e + f
- 2 2 2
- c = e + b
- let b=x*y then
- (y + xb)
- c= ---------
- 2
- (-y + xb)
- e= ---------
- 2
- (-x + yb)
- d= ---------
- 2
- (x + yb)
- f= ---------
- 2
-
- and
- 2 2 2
- a = c + d
- then
- 2 2 2 2
- 2 (y + x ) (x y + 1)
- a = ---------------------
- 4
-
-}
problem_142 = sum$head[aToX(t,t2 ,t3)|
a<-[3,5..50],
b<-[(a+2),(a+4)..50],
let a2=a^2,
let b2=b^2,
let n=(a2+b2)*(a2*b2+1),
isSquare n,
let t=div n 4,
let t2=a2*b2,
let t3=div (a2*(b2+1)^2) 4
]
Problem 143
Investigating the Torricelli point of a triangle
Solution:
import Data.List
import Data.Map((!),fromList,member)
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..]]
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
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
intSqrt :: Integral a => a -> a
intSqrt n
| n < 0 = error "intSqrt: negative n"
| otherwise = f n
where
f x = if y < x then f y else x
where y = (x + (n `quot` x)) `quot` 2
prim40=tail$take 40 primes
primeSqr=
fromList[(a,fromList$zip b [1..])|
a<-prim40,
let b=nub[t|c<-[0..a-1],
let t=mod (c*c) a]
]
isSqrt n
|k= n==((^2).intSqrt) n
|otherwise=False
where
k=foldl (&&) True [member k ma |
a<-prim40,
let ma=(primeSqr !a),
let k=mod n a
]
getOne a = [c|
x<-factors t,
a>x,
let y=(a-x)*(3*a+x),
let k=4*x,
let (c,m)=divMod y k,
m==0
]
where
t=(3*a^2)
getThree a = [[a,m,n]|
m<-t,
n<-[k|k<-t,mod k 5/=0],
let z=(2*m+n)^2+3*n*n,
isSqrt z
]
where
t=getOne a
gcdlst [x,y]=gcd x y
gcdlst (x:xs)=gcd x$gcdlst xs
p143 k=[c|
a<-[1+k*groups..groups*(k+1)],
c<-getThree (a*5),
gcdlst c==1
]
-- run test find test==[],so one of a b c is 5*x
test=[(a,b,c)|a<-t,b<-t,c<-t,
f a b,
f b c,
f c a]
where
t=[1..4]
f a b=elem (mod (a^2+b^2+a*b) 5) [0,1,4]
groups=200
google num
-- write file to change bignum to small num
=if (num>33)
then return()
else do let k=p143 num
appendFile "file.log" $(show$k) ++" "++(show num) ++"\n"
appendFile "files.log" $(show$map sum k) ++" "++(show num) ++"\n"
google (num+1)
-- first use main to make file.log
-- then run problem_143
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=((++[-1]).read) $head$split ' ' x
filer x
|x<0=False
|x>100000=False
|otherwise=True
problem_143=do
x<-readFile "files.log"
let y=concat$map sToInt $lines x
let z= filter filer y
let t=[b|a<-z,b<-takeWhile (<=100000) [a*b|b<-[1..]]]
print$ sum$nub t
Problem 144
Investigating multiple reflections of a laser beam.
Solution:
problem_144 = undefined
Problem 145
How many reversible numbers are there below one-billion?
Solution:
import List
digits n
{- 123->[3,2,1]
-}
|n<10=[n]
|otherwise= y:digits x
where
(x,y)=divMod n 10
-- 123 ->321
dmm=(\x y->x*10+y)
palind n=foldl dmm 0 (digits n)
isOdd x=(length$takeWhile odd x)==(length x)
isOdig x=isOdd m && s<=h
where
k=x+palind x
m=digits k
y=floor$logBase 10 $fromInteger x
ten=10^y
s=mod x 10
h=div x ten
a2=[i|i<-[10..99],isOdig i]
aa2=[i|i<-[10..99],isOdig i,mod i 10/=0]
a3=[i|i<-[100..999],isOdig i]
m5=[i|i1<-[0..99],i2<-[0..99],
let i3=i1*1000+3*100+i2,
let i=10^6* 8+i3*10+5,
isOdig i
]
fun i
|i==2 =2*le aa2
|even i=(fun 2)*d^(m-1)
|i==3 =2*le a3
|i==7 =fun 3*le m5
|otherwise=0
where
le=length
m=div i 2
d=2*le a2
problem_145 = sum[fun a|a<-[1..9]]
Problem 146
Investigating a Prime Pattern
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=millerRabinPrimality x 2
--isPrime x=foldl (&& )True [millerRabinPrimality x y|y<-[2,3,7,61,24251]]
six=[1,3,7,9,13,27]
allPrime x=foldl (&&) True [isPrime k|a<-six,let k=x^2+a]
linkPrime [x]=filterPrime x
linkPrime (x:xs)=[y|
a<-linkPrime xs,
b<-[0..(x-1)],
let y=b*prxs+a,
let c=mod y x,
elem c d]
where
prxs=product xs
d=filterPrime x
filterPrime p=
[a|
a<-[0..(p-1)],
length[b|b<-six,mod (a^2+b) p/=0]==6
]
testPrimes=[2,3,5,7,11,13,17,23]
primes=[2,3,5,7,11,13,17,23,29]
test =
sum[y|
y<-linkPrime testPrimes,
y<1000000,
allPrime (y)
]==1242490
p146 =[y|y<-linkPrime primes,y<150000000,allPrime (y)]
problem_146=[a|a<-p146, allNext a]
allNext x=
sum [1|(x,y)<-zip a b,x==y]==6
where
a=[x^2+b|b<-six]
b=head a:(map nextPrime a)
nextPrime x=head [a|a<-[(x+1)..],isPrime a]
main=writeFile "p146.log" $show $sum problem_146
Problem 147
Rectangles in cross-hatched grids
Solution:
problem_147 = undefined
Problem 148
Exploring Pascal's triangle.
Solution:
import List
digits n
{- 123->[3,2,1]
- -}
|n<7=[n]
|otherwise= y:digits x
where
(x,y)=divMod n 7
notDivX x=product$map (+1) $digits x
array::[Integer]
array=
[a*b*c*d*e*f|
let t=[1..7],
a<-t,
b<-t,
c<-t,
d<-t,
e<-t,
f<-t
]
fastNotDivX::Integer->Integer
fastNotDivX x=sum[k*a|a<-array]
where
k=product$map (+1) $digits x
sumNotDivX x=sum[notDivX a|a<-[0..x]]
-- sum[fastNotDivX x|x<-[0..b]]=sumNotDivX ((b+1)*7^6-1)
moreNotDivX =sum[notDivX a|a<-[1000000000.. 1000016499 ]]
google num
-- write file to change bignum to small num
=if (num>8499)
then return()
else do appendFile "file.log" $(show$fastNotDivX num) ++" "++(show num) ++"\n"
google (num+1)
-- first use main to make file.log
-- then run problem_148
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_148=do
x<-readFile "file.log"
let y=sum$map sToInt $lines x
print ( y-(fromInteger moreNotDivX))
Problem 149
Searching for a maximum-sum subsequence.
Solution:
problem_149 = undefined
Problem 150
Searching a triangular array for a sub-triangle having minimum-sum.
Solution:
problem_150 = undefined