Difference between revisions of "Euler problems/101 to 110"
(add problem_107) 
m 

(13 intermediate revisions by 7 users not shown)  
Line 4:  Line 4:  
Solution: 
Solution: 

<haskell> 
<haskell> 

−  problem_101 = undefined 

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

Line 39:  Line 50:  
six=[11,18,19,20,22,25] 
six=[11,18,19,20,22,25] 

seven=[mid+alet mid=six!!3,a<0:six] 
seven=[mid+alet mid=six!!3,a<0:six] 

−  problem_103= 
+  problem_103=concatMap show seven 
</haskell> 
</haskell> 

Line 111:  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 118:  Line 144:  
import Data.List 
import Data.List 

import Control.Monad 
import Control.Monad 

⚫  
solNum=map solve [7..12] 
solNum=map solve [7..12] 

Line 129:  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) 

−  +  return (firstSet,secondSet) 

setsOf 0 _ = [[]] 
setsOf 0 _ = [[]] 

Line 139:  Line 164:  
b1=sum$map (lst!!) b 
b1=sum$map (lst!!) b 

notEqu lst = 
notEqu lst = 

−  +  and [comp slst a b(a,b)<solNum!!s] 

where 
where 

s=length lst7 
s=length lst7 

slst=sort lst 
slst=sort lst 

moreElem lst = 
moreElem lst = 

−  +  and maE 

where 
where 

le=length lst 
le=length lst 

Line 156:  Line 181:  
a<[0..le] 
a<[0..le] 

] 
] 

−  maE= 
+  maE=zipWith (<) maxElem minElem 
−  stoInt s= 
+  stoInt s=read "["++s++"]" :: [Integer] 
check x=moreElem x && notEqu x 
check x=moreElem x && notEqu x 

main = do 
main = do 

Line 171:  Line 196:  
Solution: 
Solution: 

<haskell> 
<haskell> 

−  binomial x y = 
+  binomial x y =(prodxy (y+1) x) `div` (prodxy 1 (xy)) 
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= 
+  catalan n=(`div` (n+1)) $binomial (2*n) n 
calc n= 
calc n= 

sum[e*(cd) 
sum[e*(cd) 

a<[1..di2], 
a<[1..di2], 

let mu2=a*2, 
let mu2=a*2, 

−  let c= 
+  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= 
+  di2=n `div` 2 
problem_106 = calc 12 
problem_106 = calc 12 

</haskell> 
</haskell> 

Line 199:  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..x1],b<[0..a1],let m=lst!!a!!b,m/=y] 
makeNet x lst y=[((a,b),m)a<[0..x1],b<[0..a1],let m=lst!!a!!b,m/=y] 

Line 208:  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 ( 
+  edges = sortBy (comparing snd) network 
eedges =map fst edges 
eedges =map fst edges 

mape=fromList edges 
mape=fromList edges 

Line 252:  Line 278:  
series xs n =[x:psx<xs,ps<series [0..x] (n1) ] 
series xs n =[x:psx<xs,ps<series [0..x] (n1) ] 

distinct=product. map (+1) 
distinct=product. map (+1) 

−  sumpri x=product $ 
+  sumpri x=product $zipWith (^) primes x 
−  prob x y = 
+  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 262:  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
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=(y2y1)*(x4x1)+(x1x2)*(y4y1)
t2=(y2y1)*(x3x1)+(x1x2)*(y3y1)
t3=(y3y1)*(x4x1)+(x1x3)*(y4y1)
t4=(y3y1)*(x2x1)+(x1x3)*(y2y1)
t5=(y3y2)*(x4x2)+(x2x3)*(y4y2)
t6=(y3y2)*(x1x2)+(x2x3)*(y1y2)
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+alet 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_(k1)*f_(n+1)*f_n + f_(k2)*(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 (k1)
fkm2 = fibo (k2)
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..n1] =<< [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 lst7
slst=sort lst
moreElem lst =
and maE
where
le=length lst
sortLst=sort lst
maxElem =
(1):[sum $drop (lea) 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 (xy))
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*(cd)
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..x1],b<[0..a1],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 (de)
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:psx<xs,ps<series [0..x] (n1) ]
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)