Euler problems/141 to 150
From HaskellWiki
Contents |
1 Problem 141
Investigating progressive numbers, n, which are also square.
Solution:
import Data.List 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 isSqrt n = n==((^2).intSqrt) n takec a b = two++takeWhile (<=e12) [sq| c1<-[1..], let c=c1*c1,let sq=(c^2*a^3*b+b^2*c) ] where e12=10^12 two=[sq|c<-[b,2*b],let sq=(c^2*a^3*b+b^2*c) ] problem_141= sum$nub[c| (a,b)<-takeWhile (\(a,b)->a^3*b+b^2<e12) [(a,b)| a<-[2..e4], b<-[1..(a-1)] ], gcd a b==1, c<-takec a b, isSqrt c ] where e4=120 e12=10^12
2 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 ]
3 Problem 143
Investigating the Torricelli point of a triangle
Solution:
import Data.List import Data.Array.ST import Data.Array import qualified Data.Array.Unboxed as U import Control.Monad mkCan :: [Int] -> [(Int,Int)] mkCan lst = map func $ group $ insert 3 lst where func ps@(p:_) | p == 3 = (3,2*l-1) | otherwise = (p, 2*l) where l = length ps spfArray :: U.UArray Int Int spfArray = runSTUArray (do ar <- newArray (2,13397) 0 let loop k | k > 13397 = return () | otherwise = do writeArray ar k 2 loop (k+2) loop 2 let go i | i > 13397 = return ar | otherwise = do p <- readArray ar i if (p == 0) then do writeArray ar i i let run k | k > 13397 = go (i+2) | otherwise = do q <- readArray ar k when (q == 0) (writeArray ar k i) run (k+2*i) run (i*i) else go (i+2) go 3) factArray :: Array Int [Int] factArray = runSTArray (do ar <- newArray (1,13397) [] let go i | i > 13397 = return ar | otherwise = do let p = spfArray U.! i q = i `div` p fs <- readArray ar q writeArray ar i (p:fs) go (i+1) go 2) sdivs :: Int -> [(Int,Int)] sdivs s = filter ((<= 100000) . uncurry (+)) $ zip sds' lds' where bd = 3*s*s pks = mkCan $ factArray ! s fun (p,k) = take (k+1) $ iterate (*p) 1 ds = map fun pks (sds,lds) = span ((< bd) . (^2)) . sort $ foldr (liftM2 (*)) [1] ds sds' = map (+ 2*s) sds lds' = reverse $ map (+ 2*s) lds pairArray :: Array Int [Int] pairArray = runSTArray (do ar <- newArray (3,50000) [] let go s | s > 13397 = return ar | otherwise = do let run [] = go (s+1) run ((r,q):ds) = do lst <- readArray ar r let nlst = insert q lst writeArray ar r nlst run ds run $ sdivs s go 1) select2 :: [Int] -> [(Int,Int)] select2 [] = [] select2 (a:bs) = [(a,b) | b <- bs] ++ select2 bs sumArray :: U.UArray Int Bool sumArray = runSTUArray (do ar <- newArray (12,100000) False let go r | r > 33332 = return ar | otherwise = do let run [] = go (r+1) run ((q,p):xs) = do when (p `elem` (pairArray!q)) (writeArray ar (p+q+r) True) run xs run $ filter ((<= 100000) . (+r) . uncurry (+)) $ select2 $ pairArray!r go 3) main :: IO () main = writeFile "p143.log"$show$ sum [s | (s,True) <- U.assocs sumArray] problem_143 = main
4 Problem 144
Investigating multiple reflections of a laser beam.
Solution:
problem_144 = undefined
5 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]]
6 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
7 Problem 147
Rectangles in cross-hatched grids
Solution:
problem_147 = undefined
8 Problem 148
Exploring Pascal's triangle.
Solution:
triangel 0 = 0 triangel n |n <7 =n+triangel (n-1) |n==k7 =28^k |otherwise=(triangel i) + j*(triangel (n-i)) where i=k7*((n-1)`div`k7) j= -(n`div`(-k7)) k7=7^k k=floor(log (fromIntegral n)/log 7) problem_148=triangel (10^9)
9 Problem 149
Searching for a maximum-sum subsequence.
Solution:
problem_149 = undefined
10 Problem 150
Searching a triangular array for a sub-triangle having minimum-sum.
Solution:
problem_150 = undefined
