Personal tools

Euler problems/51 to 60

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 24: Line 24:
 
nextN repl n= (+0)$read $map repl $show n
 
nextN repl n= (+0)$read $map repl $show n
 
same n= [isPrime$nextN (replace a) n |a<-['1'..'9']]
 
same n= [isPrime$nextN (replace a) n |a<-['1'..'9']]
problem_51=head [n|n<-[100003,100005..999999],numChar n==3,(sum $same n)==8]
+
problem_51=head [n|
+
n<-[100003,100005..999999],
  +
numChar n==3,
  +
(sum $same n)==8
  +
]
 
</haskell>
 
</haskell>
   
Line 33: Line 33:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_52 = head [n | n <- [1..],
+
problem_52 =
digits (2*n) == digits (3*n),
+
head [n | n <- [1..],
digits (3*n) == digits (4*n),
+
digits (2*n) == digits (3*n),
digits (4*n) == digits (5*n),
+
digits (3*n) == digits (4*n),
digits (5*n) == digits (6*n)]
+
digits (4*n) == digits (5*n),
where digits = sort . show
+
digits (5*n) == digits (6*n)
  +
]
  +
where
  +
digits = sort . show
 
</haskell>
 
</haskell>
   
Line 46: Line 46:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_53 = length [n | n <- [1..100], r <- [1..n], n `choose` r > 10^6]
+
problem_53 =
where n `choose` r
+
length [n | n <- [1..100], r <- [1..n], n `choose` r > 10^6]
  +
where
  +
n `choose` r
 
| r > n || r < 0 = 0
 
| r > n || r < 0 = 0
 
| otherwise = foldl (\z j -> z*(n-j+1) `div` j) n [2..r]
 
| otherwise = foldl (\z j -> z*(n-j+1) `div` j) n [2..r]
Line 62: Line 62:
 
import Data.List (sort, sortBy, tails, lookup, groupBy)
 
import Data.List (sort, sortBy, tails, lookup, groupBy)
 
import Data.Maybe (fromJust)
 
import Data.Maybe (fromJust)
+
data Hand = HighCard | OnePair | TwoPairs | ThreeOfKind | Straight | Flush | FullHouse | FourOfKind | StraightFlush
+
data Hand = HighCard | OnePair | TwoPairs | ThreeOfKind |
  +
Straight | Flush | FullHouse | FourOfKind | StraightFlush
 
deriving (Show, Read, Enum, Eq, Ord)
 
deriving (Show, Read, Enum, Eq, Ord)
+
 
values :: [(Char, Int)]
 
values :: [(Char, Int)]
 
values = zip ['2','3','4','5','6','7','8','9','T','J','Q','K','A'] [1..]
 
values = zip ['2','3','4','5','6','7','8','9','T','J','Q','K','A'] [1..]
+
 
value :: String -> Int
 
value :: String -> Int
 
value (c:cs) = fromJust $ lookup c values
 
value (c:cs) = fromJust $ lookup c values
+
 
suites :: [[Char]]
 
suites :: [[Char]]
 
suites = map sort $ take 9 $ map (take 5) $ tails cards
 
suites = map sort $ take 9 $ map (take 5) $ tails cards
+
 
cards :: [Char]
 
cards :: [Char]
 
cards = ['2','3','4','5','6','7','8','9','T','J','Q','K','A']
 
cards = ['2','3','4','5','6','7','8','9','T','J','Q','K','A']
+
 
flush :: [String] -> Bool
 
flush :: [String] -> Bool
 
flush = a . extractSuit
 
flush = a . extractSuit
Line 86: Line 86:
 
where
 
where
 
s (_:y:ys) = y
 
s (_:y:ys) = y
+
 
straight :: [String] -> Bool
 
straight :: [String] -> Bool
 
straight = a . extractValues
 
straight = a . extractValues
Line 94: Line 94:
 
where
 
where
 
v (x:xs) = x
 
v (x:xs) = x
+
 
groupByKind :: [String] -> [[String]]
 
groupByKind :: [String] -> [[String]]
 
groupByKind = sortBy l . groupBy g . sortBy s
 
groupByKind = sortBy l . groupBy g . sortBy s
Line 101: Line 101:
 
g (a:_) (b:_) = a == b
 
g (a:_) (b:_) = a == b
 
l a b = compare (length b) (length a)
 
l a b = compare (length b) (length a)
+
 
guessHand :: [String] -> Hand
 
guessHand :: [String] -> Hand
 
guessHand cards
 
guessHand cards
Line 117: Line 117:
 
g1 = head g
 
g1 = head g
 
g2 = head $ tail g
 
g2 = head $ tail g
+
 
playerOneScore :: ([String], [String]) -> Int
 
playerOneScore :: ([String], [String]) -> Int
 
playerOneScore (p1, p2)
 
playerOneScore (p1, p2)
Line 124: Line 124:
 
| otherwise = 0
 
| otherwise = 0
 
where
 
where
a = guessHand p1
+
a = guessHand p1
b = guessHand p2
+
b = guessHand p2
compare p1 p2 = if ((map value $ concat $ groupByKind p1) > (map value $ concat $ groupByKind p2)) then 1 else 0
+
compare p1 p2 =
+
if ((map value $ concat $ groupByKind p1) >
  +
(map value $ concat $ groupByKind p2))
  +
then 1
  +
else 0
  +
 
problem_54 :: String -> Int
 
problem_54 :: String -> Int
 
problem_54 = sum . map (\x -> playerOneScore $ splitAt 5 $ words x) . lines
 
problem_54 = sum . map (\x -> playerOneScore $ splitAt 5 $ words x) . lines
  +
main=do
  +
a<-readFile "poker.txt"
  +
print $problem_54 a
 
</haskell>
 
</haskell>
   
Line 137: Line 140:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_55 = length $ filter isLychrel [1..9999]
+
problem_55 =
where isLychrel n = all notPalindrome (take 50 (tail (iterate revadd n)))
+
length $ filter isLychrel [1..9999]
notPalindrome s = (show s) /= reverse (show s)
+
where
revadd n = n + rev n
+
isLychrel n = all notPalindrome (take 50 (tail (iterate revadd n)))
where rev n = read (reverse (show n))
+
notPalindrome s = (show s) /= reverse (show s)
  +
revadd n = n + rev n
  +
where
  +
rev n = read (reverse (show n))
 
</haskell>
 
</haskell>
   
Line 149: Line 152:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_56 = maximum [dsum (a^b) | a <- [1..99], b <-[1..99]]
+
problem_56 =
where dsum 0 = 0
+
maximum [dsum (a^b) | a <- [1..99], b <-[1..99]]
dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d )
+
where
  +
dsum 0 = 0
  +
dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d )
 
</haskell>
 
</haskell>
   
Line 159: Line 162:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_57 = length $ filter topHeavy $ take 1000 convergents
+
problem_57 =
where topHeavy r = numDigits (numerator r) > numDigits (denominator r)
+
length $ filter topHeavy $ take 1000 convergents
numDigits = length . show
+
where
convergents = iterate next (3%2)
+
topHeavy r = numDigits (numerator r) > numDigits (denominator r)
next r = 1 + 1/(1+r)
+
numDigits = length . show
  +
convergents = iterate next (3%2)
  +
next r = 1 + 1/(1+r)
 
</haskell>
 
</haskell>
   
Line 181: Line 184:
 
ratios (x:xs) = 1.0 : ratios' 0 1 xs
 
ratios (x:xs) = 1.0 : ratios' 0 1 xs
 
where
 
where
ratios' n d (w:x:y:z:xs) = ((fromInteger num)/(fromInteger den)) : (ratios' num den xs)
+
ratios' n d (w:x:y:z:xs) =
where
+
((fromInteger num)/(fromInteger den)) : (ratios' num den xs)
num = (p w + p x + p y + p z + n)
+
where
den = (d + 4)
+
num = (p w + p x + p y + p z + n)
p n = case isPrime n of
+
den = (d + 4)
True -> 1
+
p n = case isPrime n of
False -> 0
+
True -> 1
  +
False -> 0
   
problem_58 = fst $ head $ dropWhile (\(_,a) -> a > 0.1) $ zip [1,3..] (ratios pascal)
+
problem_58 =
  +
fst $ head $ dropWhile (\(_,a) -> a > 0.1) $
  +
zip [1,3..] (ratios pascal)
 
</haskell>
 
</haskell>
   
Line 205: Line 208:
   
 
keys :: [[Int]]
 
keys :: [[Int]]
keys = [a:b:c:[]| a <- [ord 'a' .. ord 'z'], b <- [ord 'a' .. ord 'z'], c <- [ord 'a' .. ord 'z']]
+
keys = [a:b:c:[]|
  +
a <- [ord 'a' .. ord 'z'],
  +
b <- [ord 'a' .. ord 'z'],
  +
c <- [ord 'a' .. ord 'z']
  +
]
   
 
brute :: [Int] -> [Int] -> ([Int], Int)
 
brute :: [Int] -> [Int] -> ([Int], Int)
 
brute text key = (key, score)
 
brute text key = (key, score)
 
where
 
where
score = sum $ map (\x -> if (any (==x) common) then 1 else 0) (words $ map toUpper $ decrypt key text)
+
score = sum $ map (\x -> if (any (==x) common) then 1 else 0)
  +
(words $ map toUpper $ decrypt key text)
   
 
decrypt :: [Int] -> [Int] -> String
 
decrypt :: [Int] -> [Int] -> String
Line 218: Line 221:
 
problem_59 text = sum $ map ord $ decrypt bestKey b
 
problem_59 text = sum $ map ord $ decrypt bestKey b
 
where
 
where
b = map read $ words $ map (\x -> if x == ',' then ' ' else x) text
+
b = map read $ words $ map (\x -> if x == ',' then ' ' else x) text
bestKey = fst $ head $ sortBy (\(_,s1) (_,s2) -> compare s2 s1) $ map (brute b) $ keys
+
bestKey = fst $ head $
  +
sortBy (\(_,s1) (_,s2) -> compare s2 s1) $
  +
map (brute b) $ keys
 
</haskell>
 
</haskell>
   
Line 276: Line 279:
   
 
problem_60 :: Integer
 
problem_60 :: Integer
problem_60 = sum $ head $ nub $ combine $ nub $ combine $ nub $ combine $ combine [[x]| x <- primes]
+
problem_60 =
  +
sum $ head $ nub $ combine $
  +
nub $ combine $ nub $ combine $
  +
combine [[x]| x <- primes]
 
</haskell>
 
</haskell>

Revision as of 03:33, 6 January 2008

Contents

1 Problem 51

Find the smallest prime which, by changing the same part of the number, can form eight different primes.

Solution:

import List
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
 
primeFactors n = factor n primes
    where
        factor _ [] = []
        factor m (p:ps) | p*p > m        = [m]
                        | m `mod` p == 0 = p : factor (m `div` p) (p:ps)
                        | otherwise      = factor m ps
 
isPrime 1 = 0
isPrime n = case (primeFactors n) of
                (_:_:_)   -> 0
                _         -> 1
ch='1'
numChar n= sum [1|x<-show(n),x==ch]
replace d c|c==ch=d
           |otherwise=c
nextN repl n= (+0)$read $map repl $show n  
same n= [isPrime$nextN (replace a) n |a<-['1'..'9']]
problem_51=head [n|
    n<-[100003,100005..999999],
    numChar n==3,
    (sum $same n)==8
    ]

2 Problem 52

Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, contain the same digits in some order.

Solution:

problem_52 = 
    head [n | n <- [1..],
    digits (2*n) == digits (3*n),
    digits (3*n) == digits (4*n),
    digits (4*n) == digits (5*n),
    digits (5*n) == digits (6*n)
    ]
    where 
    digits = sort . show

3 Problem 53

How many values of C(n,r), for 1 ≤ n ≤ 100, exceed one-million?

Solution:

problem_53 = 
    length [n | n <- [1..100], r <- [1..n], n `choose` r > 10^6]
    where 
    n `choose` r
           | r > n || r < 0 = 0
           | otherwise      = foldl (\z j -> z*(n-j+1) `div` j) n [2..r]

4 Problem 54

How many hands did player one win in the poker games?

Solution:

probably not the most straight forward way to do it.

import Data.List (sort, sortBy, tails, lookup, groupBy)
import Data.Maybe (fromJust)
 
data Hand = HighCard | OnePair | TwoPairs | ThreeOfKind |
        Straight | Flush | FullHouse | FourOfKind | StraightFlush
    deriving (Show, Read, Enum, Eq, Ord)
 
values :: [(Char, Int)]
values = zip ['2','3','4','5','6','7','8','9','T','J','Q','K','A'] [1..]
 
value :: String -> Int
value (c:cs) = fromJust $ lookup c values
 
suites :: [[Char]]
suites = map sort $ take 9 $ map (take 5) $ tails cards
 
cards :: [Char]
cards = ['2','3','4','5','6','7','8','9','T','J','Q','K','A']
 
flush :: [String] -> Bool
flush = a . extractSuit
    where
        a (x:y:xs) = x == y && a (y:xs)
        a _ = True
        extractSuit = map s
            where
                s (_:y:ys) = y
 
straight :: [String] -> Bool
straight = a . extractValues 
    where
        a xs = any (==(sort xs)) suites
        extractValues = map v
            where
                v (x:xs) = x
 
groupByKind :: [String] -> [[String]]
groupByKind = sortBy l . groupBy g . sortBy s
    where
        s (a) (b) = compare (value b) (value a)
        g (a:_) (b:_) = a == b
        l a b = compare (length b) (length a)
 
guessHand :: [String] -> Hand
guessHand cards
    | straight cards && flush cards = StraightFlush
    | length g1 == 4 = FourOfKind
    | length g1 == 3 && length g2 == 2 = FullHouse
    | flush cards = Flush
    | straight cards = Straight
    | length g1 == 3 = ThreeOfKind
    | length g1 == 2 && length g2 == 2 = TwoPairs
    | length g1 == 2 = OnePair
    | otherwise = HighCard
    where
        g = groupByKind cards
        g1 = head g
        g2 = head $ tail g
 
playerOneScore :: ([String], [String]) -> Int
playerOneScore (p1, p2)
    | a == b    = compare p1 p2
    | a > b     = 1
    | otherwise = 0
    where
    a = guessHand p1
    b = guessHand p2
    compare p1 p2 =
        if ((map value $ concat $ groupByKind p1) >
           (map value $ concat $ groupByKind p2))
        then 1 
        else 0
 
problem_54 :: String -> Int
problem_54 = sum . map (\x -> playerOneScore $ splitAt 5 $ words x) . lines
main=do
    a<-readFile "poker.txt"
    print $problem_54 a

5 Problem 55

How many Lychrel numbers are there below ten-thousand?

Solution:

problem_55 = 
    length $ filter isLychrel [1..9999]
    where 
    isLychrel n = all notPalindrome (take 50 (tail (iterate revadd n)))
    notPalindrome s = (show s) /= reverse (show s)
    revadd n = n + rev n
        where 
        rev n = read (reverse (show n))

6 Problem 56

Considering natural numbers of the form, ab, finding the maximum digital sum.

Solution:

problem_56 = 
    maximum [dsum (a^b) | a <- [1..99], b <-[1..99]]
    where
    dsum 0 = 0
    dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d )

7 Problem 57

Investigate the expansion of the continued fraction for the square root of two.

Solution:

problem_57 = 
    length $ filter topHeavy $ take 1000 convergents 
    where 
    topHeavy r = numDigits (numerator r) > numDigits (denominator r)
    numDigits = length . show
    convergents = iterate next (3%2)
    next r = 1 + 1/(1+r)

8 Problem 58

Investigate the number of primes that lie on the diagonals of the spiral grid.

Solution:

base :: (Integral a) => [a]
base = base' 2
    where
        base' n = n:n:n:n:(base' $ n + 2)
 
pascal = scanl (+) 1 base
 
ratios :: [Integer] -> [Double]
ratios (x:xs) = 1.0 : ratios' 0 1 xs
    where
    ratios' n d (w:x:y:z:xs) =
        ((fromInteger num)/(fromInteger den)) : (ratios' num den xs)
        where
            num = (p w + p x + p y + p z + n)
            den = (d + 4)
            p n = case isPrime n of
                    True -> 1
                    False -> 0
 
problem_58 = 
    fst $ head $ dropWhile (\(_,a) -> a > 0.1) $
    zip [1,3..] (ratios pascal)

9 Problem 59

Using a brute force attack, can you decrypt the cipher using XOR encryption?

Solution:

import Data.Bits (xor)
import Data.Char (toUpper, ord, chr)
import Data.List (sortBy)
 
common :: [String]
common = ["THE","OF","TO","AND","YOU","THAT","WAS","FOR","WORD"]
 
keys :: [[Int]]
keys = [a:b:c:[]| 
    a <- [ord 'a' .. ord 'z'], 
    b <- [ord 'a' .. ord 'z'], 
    c <- [ord 'a' .. ord 'z']
    ]
 
brute :: [Int] -> [Int] -> ([Int], Int)
brute text key = (key, score)
    where
    score = sum $ map (\x -> if (any (==x) common) then 1 else 0)
        (words $ map toUpper $ decrypt key text)
 
decrypt :: [Int] -> [Int] -> String
decrypt key text = [chr (t `xor` k)|(t,k) <- zip text (cycle key)]
 
problem_59 :: String -> Int
problem_59 text = sum $ map ord $ decrypt bestKey b
    where
    b = map read $ words $ map (\x -> if x == ',' then ' ' else x) text
    bestKey = fst $ head $
        sortBy (\(_,s1) (_,s2) -> compare s2 s1)  $
        map (brute b) $ keys

10 Problem 60

Find a set of five primes for which any two primes concatenate to produce another prime.

Solution:

Breadth first search that works on infinite lists. Breaks the 60 secs rule. This program finds the solution in 185 sec on my Dell D620 Laptop.

import Data.List
import Data.Maybe
 
primes :: [Integer]
primes = 2 : filter (l1 . primeFactors) [3,5..]
    where
        l1 (_:[]) = True
        l1      _ = False
 
primeFactors :: Integer -> [Integer]
primeFactors n = factor n primes
    where
        factor _ [] = []
        factor m (p:ps) | p*p > m        = [m]
                        | m `mod` p == 0 = p : factor (m `div` p) (p:ps)
                        | otherwise      = factor m ps
 
isPrime :: Integer -> Bool
isPrime 1 = False
isPrime n = case (primeFactors n) of
                (_:[]) -> True
                _      -> False
 
combine :: (Show a, Ord a) => [[a]] -> [[a]]
combine ls = combine' [] ls
    where
        combine' seen (x:xs) = mapMaybe m seen ++ combine' (seen ++ [x]) xs
            where
                c y = group $ sort $ y ++ x
                d y = map head $ filter l1 $ c y
                h y = map head $ c y
                t (x:y:[]) = test x y
                t _ = False
                l1 (x:[]) = True
                l1 _ = False
                m y
                    | t $ d y = Just $ h y
                    | otherwise = Nothing
 
test a b
    | isPrime c1 && isPrime c2 = True
    | otherwise                = False
    where
        c1 = read $ (show a) ++ (show b)
        c2 = read $ (show b) ++ (show a)
 
problem_60 :: Integer
problem_60 = 
    sum $ head $ nub $ combine $
    nub $ combine $ nub $ combine $
    combine [[x]| x <- primes]