Euler problems/101 to 110
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
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
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
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..])
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
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
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)
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
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
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)