Difference between revisions of "Euler problems/101 to 110"

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

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>