# Euler problems/101 to 110

### From HaskellWiki

DonStewart (Talk | contribs) m (How to Tie and Wear a Womans Scarf Many Fashionable Ways moved to Euler problems/101 to 110) |
m |
||

(3 intermediate revisions by 2 users not shown) | |||

Line 1: | Line 1: | ||

− | == | + | == [http://projecteuler.net/index.php?section=problems&id=101 Problem 101] == |

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

− | + | Solution: | |

+ | <haskell> | ||

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

− | + | </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=concatMap show seven | ||

+ | </haskell> | ||

− | [http:// | + | == [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. | ||

+ | |||

+ | 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] == | ||

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

+ | |||

+ | Solution: | ||

+ | <haskell> | ||

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

+ | </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 =(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 | ||

+ | </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 | ||

+ | 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) | ||

+ | </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 $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 | ||

+ | </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> | ||

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

+ | |||

+ | == [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> |

## 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)