Difference between revisions of "Euler problems/141 to 150"

From HaskellWiki
Jump to: navigation, search
(rv: vandalism)
Line 1: Line 1:
−
Do them on your own!
  
  +
== [http://projecteuler.net/index.php?section=view&id=141 Problem 141] ==
  +
Investigating progressive numbers, n, which are also square.
  +
  +
Solution:
  +
<haskell>
  +
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
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=view&id=142 Problem 142] ==
  +
Perfect Square Collection
  +
  +
Solution:
  +
<haskell>
  +
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
  +
]
  +
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=view&id=143 Problem 143] ==
  +
Investigating the Torricelli point of a triangle
  +
  +
Solution:
  +
<haskell>
  +
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
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=view&id=144 Problem 144] ==
  +
Investigating multiple reflections of a laser beam.
  +
  +
Solution:
  +
<haskell>
  +
problem_144 = undefined
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=view&id=145 Problem 145] ==
  +
How many reversible numbers are there below one-billion?
  +
  +
Solution:
  +
<haskell>
  +
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]]
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=view&id=146 Problem 146] ==
  +
Investigating a Prime Pattern
  +
  +
Solution:
  +
<haskell>
  +
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
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=view&id=147 Problem 147] ==
  +
Rectangles in cross-hatched grids
  +
  +
Solution:
  +
<haskell>
  +
problem_147 = undefined
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=view&id=148 Problem 148] ==
  +
Exploring Pascal's triangle.
  +
  +
Solution:
  +
<haskell>
  +
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)
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=view&id=149 Problem 149] ==
  +
Searching for a maximum-sum subsequence.
  +
  +
Solution:
  +
<haskell>
  +
problem_149 = undefined
  +
</haskell>
  +
  +
== [http://projecteuler.net/index.php?section=view&id=150 Problem 150] ==
  +
Searching a triangular array for a sub-triangle having minimum-sum.
  +
  +
Solution:
  +
<haskell>
  +
problem_150 = undefined
  +
</haskell>

Revision as of 04:59, 30 January 2008

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

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

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: 

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)

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
Retrieved from "https://wiki.haskell.org/index.php?title=Euler_problems/141_to_150&oldid=18804"