Personal tools

Euler problems/51 to 60

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
Line 3: Line 3:
   
 
Solution:
 
Solution:
  +
  +
millerRabinPrimality on the [[Prime_numbers]] page
  +
 
<haskell>
 
<haskell>
import List
+
isPrime x
primes = 2 : filter ((==1) . length . primeFactors) [3,5..]
+
|x==3=True
+
|otherwise=millerRabinPrimality x 2
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'
 
ch='1'
 
numChar n= sum [1|x<-show(n),x==ch]
 
numChar n= sum [1|x<-show(n),x==ch]
Line 12: Line 15:
 
|otherwise=c
 
|otherwise=c
 
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= [if isPrime$nextN (replace a) n then 1 else 0|a<-['1'..'9']]
 
problem_51=head [n|
 
problem_51=head [n|
 
n<-[100003,100005..999999],
 
n<-[100003,100005..999999],
Line 25: Line 28:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_52 =
+
import List
head [n | n <- [1..],
+
digits (2*n) == digits (3*n),
+
has_same_digits a b = (show a) \\ (show b) == []
digits (3*n) == digits (4*n),
+
digits (4*n) == digits (5*n),
+
check n = all (has_same_digits n) (map (n*) [2..6])
digits (5*n) == digits (6*n)
+
]
+
problem_52 = head $ filter check [1..]
where
 
digits = sort . show
 
 
</haskell>
 
</haskell>
   
Line 39: Line 42:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_53 =
+
facs = reverse $ foldl (\y x->(head y) * x : y) [1] [1..100]
length [n | n <- [1..100], r <- [1..n], n `choose` r > 10^6]
+
comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r))
where
+
perms = concat $ map (\x -> [(n,x) | n<-[1..x]]) [1..100]
n `choose` r
+
problem_53 = length $ filter (>1000000) $ map comb $ perms
| r > n || r < 0 = 0
 
| otherwise = foldl (\z j -> z*(n-j+1) `div` j) n [2..r]
 
 
</haskell>
 
</haskell>
   
Line 53: Line 56:
   
 
<haskell>
 
<haskell>
import Data.List (sort, sortBy, tails, lookup, groupBy)
+
import Data.List
import Data.Maybe (fromJust)
+
import Data.Maybe
  +
import Control.Monad
  +
  +
readCard [r,s] = (parseRank r, parseSuit s)
  +
where parseSuit = translate "SHDC"
  +
parseRank = translate "23456789TJQKA"
  +
translate from x = fromJust $ findIndex (==x) from
  +
  +
solveHand hand = (handRank,tiebreak)
  +
where
  +
handRank
  +
| flush && straight = 9
  +
| hasKinds 4 = 8
  +
| all hasKinds [2,3] = 7
  +
| flush = 6
  +
| straight = 5
  +
| hasKinds 3 = 4
  +
| 1 < length (kind 2) = 3
  +
| hasKinds 2 = 2
  +
| otherwise = 1
  +
tiebreak = kind =<< [4,3,2,1]
  +
hasKinds = not . null . kind
  +
kind n = map head $ filter ((n==).length) $ group ranks
  +
ranks = reverse $ sort $ map fst hand
  +
flush = 1 == length (nub (map snd hand))
  +
straight = length (kind 1) == 5 && 4 == head ranks - last ranks
 
 
data Hand = HighCard | OnePair | TwoPairs | ThreeOfKind |
+
gameLineToHands = splitAt 5 . map readCard . words
Straight | Flush | FullHouse | FourOfKind | StraightFlush
+
p1won (a,b) = solveHand a > solveHand b
deriving (Show, Read, Enum, Eq, Ord)
+
+
problem_54 = do
values :: [(Char, Int)]
+
f <- readFile "poker.txt"
values = zip ['2','3','4','5','6','7','8','9','T','J','Q','K','A'] [1..]
+
let games = map gameLineToHands $ lines f
+
wins = filter p1won games
value :: String -> Int
+
print $ length wins
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
 
 
</haskell>
 
</haskell>
   
Line 71: Line 74:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_55 =
+
reverseNum = read . reverse . show
length $ filter isLychrel [1..9999]
+
where
+
palindrome x =
isLychrel n = all notPalindrome (take 50 (tail (iterate revadd n)))
+
sx == reverse sx
notPalindrome s = (show s) /= reverse (show s)
+
where
revadd n = n + rev n
+
sx = show x
where
+
rev n = read (reverse (show n))
+
lychrel =
  +
not . any palindrome . take 50 . tail . iterate next
  +
where
  +
next x = x + reverseNum x
  +
  +
problem_55 = length $ filter lychrel [1..10000]
 
</haskell>
 
</haskell>
   
Line 86: Line 89:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
  +
digitalSum 0 = 0
  +
digitalSum n =
  +
let (d,m) = quotRem n 10 in m + digitalSum d
  +
 
problem_56 =
 
problem_56 =
maximum [dsum (a^b) | a <- [1..99], b <-[1..99]]
+
maximum [digitalSum (a^b) | a <- [99], b <- [90..99]]
where
 
dsum 0 = 0
 
dsum n = let ( d, m ) = n `divMod` 10 in m + ( dsum d )
 
 
</haskell>
 
</haskell>
   
Line 95: Line 102:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
  +
twoex = zip ns ds
  +
where
  +
ns = 3 : zipWith (\x y -> x + 2 * y) ns ds
  +
ds = 2 : zipWith (+) ns ds
  +
  +
len = length . show
  +
 
problem_57 =
 
problem_57 =
length $ filter topHeavy $ take 1000 convergents
+
length $ filter (\(n,d) -> len n > len d) $ take 1000 twoex
where
 
topHeavy r = numDigits (numerator r) > numDigits (denominator r)
 
numDigits = length . show
 
convergents = iterate next (3%2)
 
next r = 1 + 1/(1+r)
 
 
</haskell>
 
</haskell>
   
Line 104: Line 118:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
base :: (Integral a) => [a]
+
isPrime x
base = base' 2
+
|x==3=True
  +
|otherwise=all id [millerRabinPrimality x n|n<-[2,3]]
  +
diag = 1:3:5:7:zipWith (+) diag [8,10..]
  +
problem_58 =
  +
result $ dropWhile tooBig $ drop 2 $ scanl primeRatio (0,0) diag
 
where
 
where
base' n = n:n:n:n:(base' $ n + 2)
+
primeRatio (n,d) num = (if d `mod` 4 /= 0 && isPrime num then n+1 else n,d+1)
+
tooBig (n,d) = n*10 >= d
pascal = scanl (+) 1 base
+
result ((_,d):_) = (d+2) `div` 4 * 2 + 1
 
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)
 
 
</haskell>
 
</haskell>
   
Line 117: Line 131:
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
import Data.Bits (xor)
+
import Data.Bits
import Data.Char (toUpper, ord, chr)
+
import Data.Char
import Data.List (sortBy)
+
import Data.List
+
common :: [String]
+
keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ]
common = ["THE","OF","TO","AND","YOU","THAT","WAS","FOR","WORD"]
+
allAlpha a = all (\k -> let a = ord k in (a >= 32 && a <= 122)) a
+
howManySpaces x = length (elemIndices ' ' x)
keys :: [[Int]]
+
compareBy f x y = compare (f x) (f y)
keys = [a:b:c:[]|
+
a <- [ord 'a' .. ord 'z'],
+
problem_59 = do
b <- [ord 'a' .. ord 'z'],
+
s <- readFile "cipher1.txt"
c <- [ord 'a' .. ord 'z']
+
let
]
+
cipher = (read ("[" ++ s ++ "]") :: [Int])
+
decrypts = [ (map chr (zipWith xor (cycle key) cipher), map chr key) | key <- keys ]
brute :: [Int] -> [Int] -> ([Int], Int)
+
alphaDecrypts = filter (\(x,y) -> allAlpha x) decrypts
brute text key = (key, score)
+
message = maximumBy (\(x,y) (x',y') -> compareBy howManySpaces x x') alphaDecrypts
where
+
asciisum = sum (map ord (fst message))
score = sum $ map (\x -> if (any (==x) common) then 1 else 0)
+
putStrLn (show asciisum)
(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
 
 
</haskell>
 
</haskell>
   
Line 144: Line 158:
 
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.
 
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.
 
<haskell>
 
<haskell>
import Data.List
+
problem_60 = print$sum $head solve
import Data.Maybe
+
isPrime x
+
|x==3=True
primes :: [Integer]
+
|otherwise=millerRabinPrimality x 2
primes = 2 : filter (l1 . primeFactors) [3,5..]
+
where
+
solve = do
l1 (_:[]) = True
+
a <- primesTo10000
l1 _ = False
+
let m = f a $ dropWhile (<= a) primesTo10000
+
b <- m
primeFactors :: Integer -> [Integer]
+
let n = f b $ dropWhile (<= b) m
primeFactors n = factor n primes
+
c <- n
where
+
let o = f c $ dropWhile (<= c) n
factor _ [] = []
+
d <- o
factor m (p:ps) | p*p > m = [m]
+
let p = f d $ dropWhile (<= d) o
| m `mod` p == 0 = p : factor (m `div` p) (p:ps)
+
e <- p
| otherwise = factor m ps
+
return [a,b,c,d,e]
+
where
isPrime :: Integer -> Bool
+
f x = filter (\y -> all id[isPrime $read $shows x $show y,
isPrime 1 = False
+
isPrime $read $shows y $show x])
isPrime n = case (primeFactors n) of
+
primesTo10000 = 2:filter (isPrime) [3,5..9999]
(_:[]) -> 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]
 
 
</haskell>
 
</haskell>

Revision as of 03:36, 18 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:

millerRabinPrimality on the Prime_numbers page

isPrime x
    |x==3=True
    |otherwise=millerRabinPrimality x 2
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= [if isPrime$nextN (replace a) n then 1 else 0|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:

import List
 
has_same_digits a b = (show a) \\ (show b) == []
 
check n = all (has_same_digits n) (map (n*) [2..6])
 
problem_52 = head $ filter check [1..]

3 Problem 53

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

Solution:

facs = reverse $ foldl (\y x->(head y) * x : y) [1] [1..100]
comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r))
perms = concat $ map (\x -> [(n,x) | n<-[1..x]]) [1..100]
problem_53 = length $ filter (>1000000) $ map comb $ perms

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
import Data.Maybe
import Control.Monad
 
readCard [r,s] = (parseRank r, parseSuit s)
 where parseSuit = translate "SHDC"
       parseRank = translate "23456789TJQKA"
       translate from x = fromJust $ findIndex (==x) from
 
solveHand hand = (handRank,tiebreak)
 where
 handRank
  | flush && straight   = 9
  | hasKinds 4          = 8
  | all hasKinds [2,3]  = 7
  | flush               = 6
  | straight            = 5
  | hasKinds 3          = 4
  | 1 < length (kind 2) = 3
  | hasKinds 2          = 2
  | otherwise           = 1
 tiebreak = kind =<< [4,3,2,1]
 hasKinds = not . null . kind
 kind n = map head $ filter ((n==).length) $ group ranks
 ranks  = reverse $ sort $ map fst hand
 flush  = 1 == length (nub (map snd hand))
 straight = length (kind 1) == 5 && 4 == head ranks - last ranks
 
gameLineToHands = splitAt 5 . map readCard . words
p1won (a,b) = solveHand a > solveHand b
 
problem_54 = do
    f <- readFile "poker.txt"
    let games = map gameLineToHands $ lines f
        wins = filter p1won games
    print $ length wins

5 Problem 55

How many Lychrel numbers are there below ten-thousand?

Solution:

reverseNum = read . reverse . show
 
palindrome x =
    sx == reverse sx
    where
    sx = show x 
 
lychrel = 
    not . any palindrome . take 50 . tail . iterate next
    where
    next x = x + reverseNum x
 
problem_55 = length $ filter lychrel [1..10000]

6 Problem 56

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

Solution:

digitalSum 0 = 0
digitalSum n = 
    let (d,m) = quotRem n 10 in m + digitalSum d 
 
problem_56 = 
    maximum [digitalSum (a^b) | a <- [99], b <- [90..99]]

7 Problem 57

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

Solution:

twoex = zip ns ds 
    where
    ns = 3 : zipWith (\x y -> x + 2 * y) ns ds
    ds = 2 : zipWith (+) ns ds
 
len = length . show
 
problem_57 = 
    length $ filter (\(n,d) -> len n > len d) $ take 1000 twoex

8 Problem 58

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

Solution:

isPrime x
    |x==3=True
    |otherwise=all id [millerRabinPrimality x n|n<-[2,3]]
diag = 1:3:5:7:zipWith (+) diag [8,10..]
problem_58 = 
    result $ dropWhile tooBig $ drop 2 $ scanl primeRatio (0,0) diag
    where
    primeRatio (n,d) num = (if d `mod` 4 /= 0 && isPrime num then n+1 else n,d+1)
    tooBig (n,d) = n*10 >= d
    result ((_,d):_) = (d+2) `div` 4 * 2 + 1

9 Problem 59

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

Solution:

import Data.Bits
import Data.Char
import Data.List
 
keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ]
allAlpha a = all (\k -> let a = ord k in (a >= 32 && a <= 122)) a
howManySpaces x = length (elemIndices ' ' x)
compareBy f x y = compare (f x) (f y)
 
problem_59 = do
	s <- readFile "cipher1.txt"
	let 
		cipher = (read ("[" ++ s ++ "]") :: [Int])
		decrypts = [ (map chr (zipWith xor (cycle key) cipher), map chr key) | key <- keys ]
		alphaDecrypts = filter (\(x,y) -> allAlpha x) decrypts
		message = maximumBy (\(x,y) (x',y') -> compareBy howManySpaces x x') alphaDecrypts
		asciisum = sum (map ord (fst message))
	putStrLn (show asciisum)

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.

problem_60 = print$sum $head solve 
isPrime x
    |x==3=True
    |otherwise=millerRabinPrimality x 2 
 
solve = do
 a <- primesTo10000
 let m = f a $ dropWhile (<= a) primesTo10000
 b <- m
 let n = f b $ dropWhile (<= b) m
 c <- n
 let o = f c $ dropWhile (<= c) n
 d <- o
 let p = f d $ dropWhile (<= d) o
 e <- p
 return [a,b,c,d,e]
 where
 f x = filter (\y -> all id[isPrime $read $shows x $show y,
                 isPrime $read $shows y $show x])
primesTo10000 = 2:filter (isPrime) [3,5..9999]