Personal tools

Euler problems/101 to 110

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
(add problem_107)
Line 1: Line 1:
== [http://projecteuler.net/index.php?section=problems&id=101 Problem 101] ==
+
Do them on your own!
Investigate the optimum polynomial function to model the first k terms of a given sequence.
+
 
+
Solution:
+
<haskell>
+
problem_101 = undefined
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=102 Problem 102] ==
+
For how many triangles in the text file does the interior contain the origin?
+
 
+
Solution:
+
<haskell>
+
import Text.Regex
+
--ghc -M p102.hs
+
isOrig (x1:y1:x2:y2:x3:y3:[])=
+
    t1*t2>=0 && t3*t4>=0 && t5*t6>=0
+
    where
+
    x4=0
+
    y4=0
+
    t1=(y2-y1)*(x4-x1)+(x1-x2)*(y4-y1)
+
    t2=(y2-y1)*(x3-x1)+(x1-x2)*(y3-y1)
+
    t3=(y3-y1)*(x4-x1)+(x1-x3)*(y4-y1)
+
    t4=(y3-y1)*(x2-x1)+(x1-x3)*(y2-y1)
+
    t5=(y3-y2)*(x4-x2)+(x2-x3)*(y4-y2)
+
    t6=(y3-y2)*(x1-x2)+(x2-x3)*(y1-y2)
+
buildTriangle s = map read (splitRegex (mkRegex ",") s) :: [Integer]
+
problem_102=do
+
    x<-readFile "triangles.txt"
+
    let y=map buildTriangle$lines x
+
    print $length$ filter isOrig y
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=103 Problem 103] ==
+
Investigating sets with a special subset sum property.
+
 
+
Solution:
+
<haskell>
+
six=[11,18,19,20,22,25]
+
seven=[mid+a|let mid=six!!3,a<-0:six]
+
problem_103=foldl (++) "" $map show seven
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=104 Problem 104] ==
+
Finding Fibonacci numbers for which the first and last nine digits are pandigital.
+
 
+
Solution:
+
 
+
Very nice problem. I didnt realize you could deal with the precision problem.
+
Therefore I used this identity to speed up the fibonacci calculation:
+
f_(2*n+k)
+
= f_k*(f_(n+1))^2
+
+ 2*f_(k-1)*f_(n+1)*f_n
+
+ f_(k-2)*(f_n)^2
+
 
+
<haskell>
+
import Data.List
+
import Data.Char
+
+
fibos = rec 0 1
+
    where
+
        rec a b = a:rec b (a+b)
+
+
fibo_2nk n k =
+
    let       
+
        fkm1 = fibo (k-1)
+
        fkm2 = fibo (k-2)
+
        fk = fkm1 + fkm2
+
        fnp1 = fibo (n+1)
+
        fnp1sq = fnp1^2
+
        fn = fibo n
+
        fnsq = fn^2
+
    in
+
        fk*fnp1sq + 2*fkm1*fnp1*fn + fkm2*fnsq
+
+
fibo x =
+
    let
+
        threshold = 30000
+
        n = div x 3
+
        k = n+mod x 3
+
    in
+
        if x < threshold
+
        then fibos !! x
+
        else fibo_2nk n k
+
+
findCandidates = rec 0 1 0
+
    where
+
        m = 10^9
+
        rec a b n  =
+
            let
+
                continue = rec b (mod (a+b) m) (n+1)
+
                isBackPan a = (sort $ show a) == "123456789"
+
            in
+
                if isBackPan a
+
                then n:continue
+
                else continue
+
search =
+
    let
+
        isFrontPan x = (sort $ take 9 $ show x) == "123456789"
+
    in
+
        map fst
+
            $ take 1
+
            $ dropWhile (not.snd)           
+
            $ zip findCandidates
+
            $ map (isFrontPan.fibo) findCandidates
+
+
problem_104 = search
+
</haskell>
+
It took 8 sec on a 2.2Ghz machine.
+
 
+
The lesson I learned fom this challenge, is: know mathematical identities and exploit them. They allow you take short cuts.
+
Normally you compute all previous fibonacci numbers to compute a random fibonacci number. Which has linear costs. The aforementioned identity builds the number not from its two predecessors but from 4 much smaller ones. This makes the algorithm logarithmic in its complexity. It really shines if you want to compute a random very large fibonacci number. f.i. the 10mio.th fibonacci number which is over 2mio characters long, took 20sec to compute on my 2.2ghz laptop.
+
== [http://projecteuler.net/index.php?section=problems&id=105 Problem 105] ==
+
Find the sum of the special sum sets in the file.
+
 
+
Solution:
+
<haskell>
+
import Data.List
+
import Control.Monad
+
import Text.Regex
+
+
solNum=map solve [7..12]
+
solve n =  twoSetsOf [0..n-1] =<< [2..div n 2]         
+
twoSetsOf xs n = do
+
        firstSet <- setsOf n xs
+
        let rest = dropWhile (/= head firstSet) xs \\ firstSet
+
        secondSet <- setsOf n rest
+
        let f = firstSet  >>= enumFromTo 1
+
            s = secondSet >>= enumFromTo 1
+
        guard $ not $ null (f \\ s) || null (s \\ f)
+
        [(firstSet,secondSet)]
+
 
+
setsOf 0 _ = [[]]
+
setsOf (n+1) xs = concat [map (y:) (setsOf n ys) | (y:ys) <- tails xs]
+
comp lst a b=
+
    a1/=b1
+
    where
+
    a1=sum$map (lst!!) a
+
    b1=sum$map (lst!!) b
+
notEqu lst =
+
    all id[comp slst a b|(a,b)<-solNum!!s]
+
    where
+
    s=length lst-7
+
    slst=sort lst
+
moreElem lst =
+
    all id maE
+
    where
+
    le=length lst
+
    sortLst=sort lst
+
    maxElem =
+
        (-1):[sum $drop (le-a) sortLst|
+
        a<-[0..le]
+
        ]
+
    minElem =
+
        [sum $take a sortLst|
+
        a<-[0..le]
+
        ]
+
    maE=[a<b|(a,b)<-zip maxElem minElem]
+
stoInt s=map read (splitRegex (mkRegex ",") s) :: [Integer] 
+
check x=moreElem x && notEqu x
+
main = do
+
    f <- readFile "sets.txt"
+
    let sets = map stoInt$ lines f
+
    let ssets = filter check sets
+
    print $ sum $ concat ssets
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=106 Problem 106] ==
+
Find the minimum number of comparisons needed to identify special sum sets.
+
 
+
Solution:
+
<haskell>
+
binomial x y =div (prodxy (y+1) x) (prodxy 1 (x-y))
+
prodxy x y=product[x..y]
+
-- http://mathworld.wolfram.com/DyckPath.html
+
catalan n=flip div (n+1) $binomial (2*n) n
+
calc n=
+
    sum[e*(c-d)|
+
    a<-[1..di2],
+
    let mu2=a*2,
+
    let c=flip div 2 $ binomial mu2 a,
+
    let d=catalan a,
+
    let e=binomial n mu2]
+
    where
+
    di2=div n 2
+
problem_106 = calc 12
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=107 Problem 107] ==
+
Determining the most efficient way to connect the network.
+
 
+
Solution:
+
<haskell>
+
import Control.Monad.ST
+
import Control.Monad
+
import Data.Array.MArray
+
import Data.Array.ST
+
import Data.List
+
import Data.Map (fromList,(!))
+
import Text.Regex
+
makeArr x=map zero (splitRegex (mkRegex ",") x) 
+
makeNet x lst y=[((a,b),m)|a<-[0..x-1],b<-[0..a-1],let m=lst!!a!!b,m/=y]
+
zero x
+
    |'-' `elem` x=0
+
    |otherwise=read x::Int
+
problem_107 =do
+
    a<-readFile "network.txt"
+
    let b=map makeArr $lines a
+
        network = makeNet 40 b 0
+
        edges = sortBy (\x y->compare (snd x) (snd y)) network
+
        eedges =map fst edges
+
        mape=fromList edges
+
        d=sum $ map snd edges
+
        e=sum$map (mape!)$kruskal eedges
+
    print (d-e)
+
kruskal es = runST ( do
+
    let hi = maximum $ map (uncurry max) es
+
        lo = minimum $ map (uncurry min) es
+
    djs <- makeDjs (lo,hi)
+
    filterM (kruskalST djs) es)
+
+
kruskalST djs (u,v) = do
+
    disjoint <- djsDisjoint u v djs
+
    when disjoint $ djsUnion u v djs
+
    return disjoint
+
+
type DisjointSet s = STArray s Int (Maybe Int)
+
+
makeDjs :: (Int,Int) -> ST s (DisjointSet s)
+
makeDjs b = newArray b Nothing
+
 
+
djsUnion a b djs = do
+
    root <- djsFind a djs
+
    writeArray djs root $ Just b
+
 
+
djsFind a djs = maybe (return a) f =<< readArray djs a
+
where f p = do p' <- djsFind p djs
+
                writeArray djs a (Just p')
+
                return p'
+
+
djsDisjoint  a b uf = liftM2 (/=) (djsFind a uf) (djsFind b uf)
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=108 Problem 108] ==
+
Solving the Diophantine equation 1/x + 1/y = 1/n.
+
 
+
Solution:
+
<haskell>
+
import List
+
primes=[2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73]
+
series _ 1 =[[0]]
+
series xs n =[x:ps|x<-xs,ps<-series [0..x] (n-1) ]
+
distinct=product. map (+1)
+
sumpri x=product $map (\(x,y)->x^y)$zip  primes x
+
prob x y =head$sort[(sumpri m ,m)|m<-series [1..3] x,(>y)$distinct$map (*2) m]
+
problem_108=prob 7 2000
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=109 Problem 109] ==
+
How many distinct ways can a player checkout in the game of darts with a score of less than 100?
+
 
+
Solution:
+
<haskell>
+
problem_109 = undefined
+
</haskell>
+
 
+
== [http://projecteuler.net/index.php?section=problems&id=110 Problem 110] ==
+
Find an efficient algorithm to analyse the number of solutions of the equation 1/x + 1/y = 1/n.
+
 
+
Solution:
+
<haskell>
+
-- prob in problem_108
+
problem_110 = prob 13 (8*10^6)
+
</haskell>
+

Revision as of 21:45, 29 January 2008

Do them on your own!