Personal tools

Euler problems/101 to 110

From HaskellWiki

< Euler problems
Revision as of 06:44, 2 February 2008 by Lisp (Talk | contribs)

Jump to: navigation, search


1 Problem 101

Investigate the optimum polynomial function to model the first k terms of a given sequence.


import Data.List
f s n = sum $ zipWith (*) (iterate (*n) 1) s
fits t = sum $ map (p101 . map (f t)) $ inits [1..toInteger $ length t - 1]
problem_101 = fits (1 : (concat $ replicate 5 [-1,1]))
diff s = zipWith (-) (drop 1 s) s
p101 = sum . map last . takeWhile (not . null) . iterate diff

2 Problem 102

For how many triangles in the text file does the interior contain the origin?


import Text.Regex 
--ghc -M p102.hs
isOrig (x1:y1:x2:y2:x3:y3:[])=
    t1*t2>=0 && t3*t4>=0 && t5*t6>=0
buildTriangle s = map read (splitRegex (mkRegex ",") s) :: [Integer] 
    x<-readFile "triangles.txt"
    let y=map buildTriangle$lines x
    print $length$ filter isOrig y

3 Problem 103

Investigating sets with a special subset sum property.


seven=[mid+a|let mid=six!!3,a<-0:six]
problem_103=foldl (++) "" $map show seven

4 Problem 104

Finding Fibonacci numbers for which the first and last nine digits are pandigital.


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

import Data.List
import Data.Char
fibos = rec 0 1
        rec a b = a:rec b (a+b)
fibo_2nk n k = 
        fkm1 = fibo (k-1)
        fkm2 = fibo (k-2)
        fk = fkm1 + fkm2
        fnp1 = fibo (n+1)
        fnp1sq = fnp1^2
        fn = fibo n
        fnsq = fn^2
        fk*fnp1sq + 2*fkm1*fnp1*fn + fkm2*fnsq
fibo x = 
        threshold = 30000
        n = div x 3
        k = n+mod x 3
        if x < threshold 
        then fibos !! x
        else fibo_2nk n k
findCandidates = rec 0 1 0
        m = 10^9
        rec a b n  =
                continue = rec b (mod (a+b) m) (n+1)
                isBackPan a = (sort $ show a) == "123456789"
                if isBackPan a 
                then n:continue
                else continue
search = 
        isFrontPan x = (sort $ take 9 $ show x) == "123456789"
        map fst
            $ take 1
            $ dropWhile (not.snd)            
            $ zip findCandidates
            $ map (isFrontPan.fibo) findCandidates
problem_104 = search

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 fibonacci number which is over 2mio characters long, took 20sec to compute on my 2.2ghz laptop.

5 Problem 105

Find the sum of the special sum sets in the file.


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)
setsOf 0 _ = [[]]
setsOf (n+1) xs = concat [map (y:) (setsOf n ys) | (y:ys) <- tails xs]
comp lst a b=
    a1=sum$map (lst!!) a
    b1=sum$map (lst!!) b
notEqu lst =
    all id[comp slst a b|(a,b)<-solNum!!s]
    s=length lst-7
    slst=sort lst
moreElem lst =
    all id maE
    le=length lst
    sortLst=sort lst
    maxElem = 
        (-1):[sum $drop (le-a) sortLst|
    minElem = 
        [sum $take a sortLst|
    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

6 Problem 106

Find the minimum number of comparisons needed to identify special sum sets.


binomial x y =div (prodxy (y+1) x) (prodxy 1 (x-y))
prodxy x y=product[x..y]
catalan n=flip div (n+1) $binomial (2*n) n
calc n=
    let mu2=a*2,
    let c=flip div 2 $ binomial mu2 a,
    let d=catalan a,
    let e=binomial n mu2]
    di2=div n 2
problem_106 = calc 12

7 Problem 107

Determining the most efficient way to connect the network.


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)

8 Problem 108

Solving the Diophantine equation 1/x + 1/y = 1/n.


import List
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

9 Problem 109

How many distinct ways can a player checkout in the game of darts with a score of less than 100?


problem_109 = undefined

10 Problem 110

Find an efficient algorithm to analyse the number of solutions of the equation 1/x + 1/y = 1/n.


-- prob in problem_108
problem_110 = prob 13 (8*10^6)