Personal tools

Euler problems/101 to 110

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
(add problem 101)
m
 
(10 intermediate revisions by 5 users not shown)
Line 50: Line 50:
 
six=[11,18,19,20,22,25]
 
six=[11,18,19,20,22,25]
 
seven=[mid+a|let mid=six!!3,a<-0:six]
 
seven=[mid+a|let mid=six!!3,a<-0:six]
problem_103=foldl (++) "" $map show seven
+
problem_103=concatMap show seven
 
</haskell>
 
</haskell>
   
Line 122: Line 122:
 
The lesson I learned fom this challenge, is: know mathematical identities and exploit them. They allow you take short cuts.
 
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.
 
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.
  +
  +
I have a slightly simpler solution, which I think is worth posting. It runs in about 6 seconds. HenryLaxen June 2, 2008
  +
  +
<haskell>
  +
fibs = 1 : 1 : zipWith (+) fibs (tail fibs)
  +
  +
isFibPan n =
  +
let a = n `mod` 1000000000
  +
b = sort (show a)
  +
c = sort $ take 9 $ show n
  +
in b == "123456789" && c == "123456789"
  +
  +
ex_104 = snd $ head $ dropWhile (\(x,y) -> (not . isFibPan) x) (zip fibs [1..])
  +
</haskell>
  +
 
== [http://projecteuler.net/index.php?section=problems&id=105 Problem 105] ==
 
== [http://projecteuler.net/index.php?section=problems&id=105 Problem 105] ==
 
Find the sum of the special sum sets in the file.
 
Find the sum of the special sum sets in the file.
Line 129: Line 144:
 
import Data.List
 
import Data.List
 
import Control.Monad
 
import Control.Monad
import Text.Regex
 
 
 
 
solNum=map solve [7..12]
 
solNum=map solve [7..12]
Line 140: Line 154:
 
s = secondSet >>= enumFromTo 1
 
s = secondSet >>= enumFromTo 1
 
guard $ not $ null (f \\ s) || null (s \\ f)
 
guard $ not $ null (f \\ s) || null (s \\ f)
[(firstSet,secondSet)]
+
return (firstSet,secondSet)
   
 
setsOf 0 _ = [[]]
 
setsOf 0 _ = [[]]
Line 150: Line 164:
 
b1=sum$map (lst!!) b
 
b1=sum$map (lst!!) b
 
notEqu lst =
 
notEqu lst =
all id[comp slst a b|(a,b)<-solNum!!s]
+
and [comp slst a b|(a,b)<-solNum!!s]
 
where
 
where
 
s=length lst-7
 
s=length lst-7
 
slst=sort lst
 
slst=sort lst
 
moreElem lst =
 
moreElem lst =
all id maE
+
and maE
 
where
 
where
 
le=length lst
 
le=length lst
Line 167: Line 181:
 
a<-[0..le]
 
a<-[0..le]
 
]
 
]
maE=[a<b|(a,b)<-zip maxElem minElem]
+
maE=zipWith (<) maxElem minElem
stoInt s=map read (splitRegex (mkRegex ",") s) :: [Integer]
+
stoInt s=read "["++s++"]" :: [Integer]
 
check x=moreElem x && notEqu x
 
check x=moreElem x && notEqu x
 
main = do
 
main = do
Line 182: Line 196:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
binomial x y =div (prodxy (y+1) x) (prodxy 1 (x-y))
+
binomial x y =(prodxy (y+1) x) `div` (prodxy 1 (x-y))
 
prodxy x y=product[x..y]
 
prodxy x y=product[x..y]
 
-- http://mathworld.wolfram.com/DyckPath.html
 
-- http://mathworld.wolfram.com/DyckPath.html
catalan n=flip div (n+1) $binomial (2*n) n
+
catalan n=(`div` (n+1)) $binomial (2*n) n
 
calc n=
 
calc n=
 
sum[e*(c-d)|
 
sum[e*(c-d)|
 
a<-[1..di2],
 
a<-[1..di2],
 
let mu2=a*2,
 
let mu2=a*2,
let c=flip div 2 $ binomial mu2 a,
+
let c=(`div` 2) $ binomial mu2 a,
 
let d=catalan a,
 
let d=catalan a,
 
let e=binomial n mu2]
 
let e=binomial n mu2]
 
where
 
where
di2=div n 2
+
di2=n `div` 2
 
problem_106 = calc 12
 
problem_106 = calc 12
 
</haskell>
 
</haskell>
Line 210: Line 224:
 
import Data.Map (fromList,(!))
 
import Data.Map (fromList,(!))
 
import Text.Regex
 
import Text.Regex
  +
import Data.Ord (comparing)
 
makeArr x=map zero (splitRegex (mkRegex ",") x)
 
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]
 
makeNet x lst y=[((a,b),m)|a<-[0..x-1],b<-[0..a-1],let m=lst!!a!!b,m/=y]
Line 219: Line 234:
 
let b=map makeArr $lines a
 
let b=map makeArr $lines a
 
network = makeNet 40 b 0
 
network = makeNet 40 b 0
edges = sortBy (\x y->compare (snd x) (snd y)) network
+
edges = sortBy (comparing snd) network
 
eedges =map fst edges
 
eedges =map fst edges
 
mape=fromList edges
 
mape=fromList edges
Line 263: Line 278:
 
series xs n =[x:ps|x<-xs,ps<-series [0..x] (n-1) ]
 
series xs n =[x:ps|x<-xs,ps<-series [0..x] (n-1) ]
 
distinct=product. map (+1)
 
distinct=product. map (+1)
sumpri x=product $map (\(x,y)->x^y)$zip primes x
+
sumpri x=product $zipWith (^) primes x
prob x y =head$sort[(sumpri m ,m)|m<-series [1..3] x,(>y)$distinct$map (*2) m]
+
prob x y =minimum[(sumpri m ,m)|m<-series [1..3] x,(>y)$distinct$map (*2) m]
 
problem_108=prob 7 2000
 
problem_108=prob 7 2000
 
</haskell>
 
</haskell>
Line 273: Line 288:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_109 = undefined
+
import Data.Array
  +
wedges = [1..20]
  +
zones = listArray (0,62) $ 0:25:50:wedges++map (2*) wedges++map (3*) wedges
  +
checkouts =
  +
[[a,b,c] |
  +
a <- 2:[23..42],
  +
b <- [0..62],
  +
c <- [b..62]
  +
]
  +
score = sum.map (zones!)
  +
problem_109 = length $ filter ((<100).score) checkouts
 
</haskell>
 
</haskell>
   

Latest revision as of 20:04, 21 February 2010

Contents

[edit] 1 Problem 101

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

Solution:

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

[edit] 2 Problem 102

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

Solution:

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

[edit] 3 Problem 103

Investigating sets with a special subset sum property.

Solution:

six=[11,18,19,20,22,25]
seven=[mid+a|let mid=six!!3,a<-0:six]
problem_103=concatMap show seven

[edit] 4 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

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

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.

I have a slightly simpler solution, which I think is worth posting. It runs in about 6 seconds. HenryLaxen June 2, 2008

fibs = 1 : 1 : zipWith (+) fibs (tail fibs)
 
isFibPan n =
  let a = n `mod` 1000000000
      b = sort (show a)
      c = sort $ take 9 $ show n
  in  b == "123456789" && c == "123456789"
 
ex_104 = snd $ head $ dropWhile (\(x,y) -> (not . isFibPan) x) (zip fibs [1..])

[edit] 5 Problem 105

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

Solution:

import Data.List
import Control.Monad
 
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)
        return (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 =
    and [comp slst a b|(a,b)<-solNum!!s]
    where
    s=length lst-7
    slst=sort lst
moreElem lst =
    and 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=zipWith (<) maxElem minElem
stoInt s=read "["++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

[edit] 6 Problem 106

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

Solution:

binomial x y =(prodxy (y+1) x) `div` (prodxy 1 (x-y))
prodxy x y=product[x..y]
-- http://mathworld.wolfram.com/DyckPath.html
catalan n=(`div` (n+1)) $binomial (2*n) n
calc n=
    sum[e*(c-d)|
    a<-[1..di2],
    let mu2=a*2,
    let c=(`div` 2) $ binomial mu2 a,
    let d=catalan a,
    let e=binomial n mu2]
    where
    di2=n `div` 2
problem_106 = calc 12

[edit] 7 Problem 107

Determining the most efficient way to connect the network.

Solution:

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 
import Data.Ord (comparing)
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 (comparing snd) 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)

[edit] 8 Problem 108

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

Solution:

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 $zipWith (^) primes x
prob x y =minimum[(sumpri m ,m)|m<-series [1..3] x,(>y)$distinct$map (*2) m]
problem_108=prob 7 2000

[edit] 9 Problem 109

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

Solution:

import Data.Array
wedges = [1..20]
zones = listArray (0,62) $ 0:25:50:wedges++map (2*) wedges++map (3*) wedges
checkouts = 
    [[a,b,c] |
    a <- 2:[23..42],
    b <- [0..62],
    c <- [b..62]
    ]
score = sum.map (zones!)    
problem_109 = length $ filter ((<100).score) checkouts

[edit] 10 Problem 110

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

Solution:

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