Personal tools

Euler problems/141 to 150

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 1: Line 1:
== [http://projecteuler.net/index.php?section=view&id=141 Problem 141] ==
+
Do them on your own!
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 21:44, 29 January 2008

Do them on your own!