Personal tools

Euler problems/51 to 60

From HaskellWiki

< Euler problems(Difference between revisions)
Jump to: navigation, search
m
 
(11 intermediate revisions by 5 users not shown)
Line 1: Line 1:
== [http://projecteuler.net/index.php?section=view&id=51 Problem 51] ==
+
== [http://projecteuler.net/index.php?section=problems&id=51 Problem 51] ==
 
Find the smallest prime which, by changing the same part of the number, can form eight different primes.
 
Find the smallest prime which, by changing the same part of the number, can form eight different primes.
  
 
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 23: 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 31: Line 23:
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=52 Problem 52] ==
+
== [http://projecteuler.net/index.php?section=problems&id=52 Problem 52] ==
 
Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, contain the same digits in some order.
 
Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, contain the same digits in some order.
  
 
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>
  
== [http://projecteuler.net/index.php?section=view&id=53 Problem 53] ==
+
== [http://projecteuler.net/index.php?section=problems&id=53 Problem 53] ==
 
How many values of C(n,r), for 1 ≤ n ≤ 100, exceed one-million?
 
How many values of C(n,r), for 1 ≤ n ≤ 100, exceed one-million?
  
 
Solution:
 
Solution:
 
<haskell>
 
<haskell>
problem_53 =  
+
facs = scanl (*) 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 = [(n,x) | x<-[1..100], n<-[1..x]]
    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>
  
== [http://projecteuler.net/index.php?section=view&id=54 Problem 54] ==
+
== [http://projecteuler.net/index.php?section=problems&id=54 Problem 54] ==
 
How many hands did player one win in the [http://www.pokerroom.com poker games]?
 
How many hands did player one win in the [http://www.pokerroom.com poker games]?
  
Line 68: 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 $ elemIndex 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  = sortBy (flip compare) $ 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>
  
== [http://projecteuler.net/index.php?section=view&id=55 Problem 55] ==
+
== [http://projecteuler.net/index.php?section=problems&id=55 Problem 55] ==
 
How many Lychrel numbers are there below ten-thousand?
 
How many Lychrel numbers are there below ten-thousand?
  
 
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>
  
== [http://projecteuler.net/index.php?section=view&id=56 Problem 56] ==
+
== [http://projecteuler.net/index.php?section=problems&id=56 Problem 56] ==
 
Considering natural numbers of the form, a<sup>b</sup>, finding the maximum digital sum.
 
Considering natural numbers of the form, a<sup>b</sup>, finding the maximum digital sum.
  
 
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>
  
== [http://projecteuler.net/index.php?section=view&id=57 Problem 57] ==
+
Alternate solution:
 +
<haskell>
 +
import Data.Char (digitToInt)
 +
 
 +
digiSum :: Integer -> Int
 +
digiSum = sum . map digitToInt . show
 +
 
 +
problem_56 :: Int
 +
problem_56 = maximum $ map digiSum [a^b | a <- [1..100], b <- [1..100]]
 +
</haskell>
 +
 
 +
== [http://projecteuler.net/index.php?section=problems&id=57 Problem 57] ==
 
Investigate the expansion of the continued fraction for the square root of two.
 
Investigate the expansion of the continued fraction for the square root of two.
  
 
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>
  
== [http://projecteuler.net/index.php?section=view&id=58 Problem 58] ==
+
The following solution is based on the observation that the fractions needed appear regularly in the repeating pattern _______$____$ where underscores are ignored and dollars are interesting fractions.
Investigate the number of primes that lie on the diagonals of the spiral grid.
+
  
Solution:
 
 
<haskell>
 
<haskell>
base :: (Integral a) => [a]
+
calc :: Int -> Int
base = base' 2
+
calc n = nd13 * 2 + ((n-nd13*13) `div` 8)
 
     where
 
     where
        base' n = n:n:n:n:(base' $ n + 2)
+
      nd13 = n `div` 13
  
pascal = scanl (+) 1 base
+
problem_57 :: Int
 +
problem_57 = calc 1000
 +
</haskell>
  
ratios :: [Integer] -> [Double]
+
== [http://projecteuler.net/index.php?section=problems&id=58 Problem 58] ==
ratios (x:xs) = 1.0 : ratios' 0 1 xs
+
Investigate the number of primes that lie on the diagonals of the spiral grid.
    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
+
  
 +
Solution:
 +
<haskell>
 +
isPrime x
 +
    |x==3=True
 +
    |otherwise=and [millerRabinPrimality x n|n<-[2,3]]
 +
diag = 1:3:5:7:zipWith (+) diag [8,10..]
 
problem_58 =  
 
problem_58 =  
     fst $ head $ dropWhile (\(_,a) -> a > 0.1) $
+
     result $ dropWhile tooBig $ drop 2 $ scanl primeRatio (0,0) diag
     zip [1,3..] (ratios pascal)
+
    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
 
</haskell>
 
</haskell>
  
== [http://projecteuler.net/index.php?section=view&id=59 Problem 59] ==
+
== [http://projecteuler.net/index.php?section=problems&id=59 Problem 59] ==
 
Using a brute force attack, can you decrypt the cipher using XOR encryption?
 
Using a brute force attack, can you decrypt the cipher using XOR encryption?
  
 
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
 
+
import Data.Ord (comparing)
common :: [String]
+
common = ["THE","OF","TO","AND","YOU","THAT","WAS","FOR","WORD"]
+
keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ]
 
+
allAlpha = all (\k -> let a = ord k in (a >= 32 && a <= 122))
keys :: [[Int]]
+
howManySpaces = length . filter (==' ')
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) | key <- keys ]
brute :: [Int] -> [Int] -> ([Int], Int)
+
alphaDecrypts = filter allAlpha decrypts
brute text key = (key, score)
+
message = maximumBy (comparing howManySpaces) alphaDecrypts
    where
+
asciisum = sum (map ord message)
    score = sum $ map (\x -> if (any (==x) common) then 1 else 0)
+
print 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>
  
== [http://projecteuler.net/index.php?section=view&id=60 Problem 60] ==
+
== [http://projecteuler.net/index.php?section=problems&id=60 Problem 60] ==
 
Find a set of five primes for which any two primes concatenate to produce another prime.
 
Find a set of five primes for which any two primes concatenate to produce another prime.
  
Line 262: Line 215:
 
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 || millerRabinPrimality x 2  
 
+
primes :: [Integer]
+
solve = do
primes = 2 : filter (l1 . primeFactors) [3,5..]
+
a <- primesTo10000
    where
+
let m = f a $ dropWhile (<= a) primesTo10000
        l1 (_:[]) = True
+
b <- m
        l1      _ = False
+
let n = f b $ dropWhile (<= b) m
 
+
c <- n
primeFactors :: Integer -> [Integer]
+
let o = f c $ dropWhile (<= c) n
primeFactors n = factor n primes
+
d <- o
    where
+
let p = f d $ dropWhile (<= d) o
        factor _ [] = []
+
e <- p
        factor m (p:ps) | p*p > m        = [m]
+
return [a,b,c,d,e]
                        | m `mod` p == 0 = p : factor (m `div` p) (p:ps)
+
where
                        | otherwise      = factor m ps
+
f x = filter (\y -> and [isPrime $read $shows x $show y,
 
+
                isPrime $read $shows y $show x])
isPrime :: Integer -> Bool
+
primesTo10000 = 2:filter isPrime [3,5..9999]
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]
+
 
</haskell>
 
</haskell>

Latest revision as of 00:17, 17 February 2010

Contents

[edit] 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
    ]

[edit] 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..]

[edit] 3 Problem 53

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

Solution:

facs = scanl (*) 1 [1..100]
comb (r,n) = facs!!n `div` (facs!!r * facs!!(n-r))
perms = [(n,x) | x<-[1..100], n<-[1..x]]
problem_53 = length $ filter (>1000000) $ map comb $ perms

[edit] 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 $ elemIndex 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  = sortBy (flip compare) $ 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

[edit] 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]

[edit] 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]]

Alternate solution:

import Data.Char (digitToInt)
 
digiSum :: Integer -> Int
digiSum = sum . map digitToInt . show
 
problem_56 :: Int
problem_56 = maximum $ map digiSum [a^b | a <- [1..100], b <- [1..100]]

[edit] 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

The following solution is based on the observation that the fractions needed appear regularly in the repeating pattern _______$____$ where underscores are ignored and dollars are interesting fractions.

calc :: Int -> Int
calc n = nd13 * 2 + ((n-nd13*13) `div` 8)
    where
      nd13 = n `div` 13
 
problem_57 :: Int
problem_57 = calc 1000

[edit] 8 Problem 58

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

Solution:

isPrime x
    |x==3=True
    |otherwise=and [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

[edit] 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
import Data.Ord (comparing)
 
keys = [ [a,b,c] | a <- [97..122], b <- [97..122], c <- [97..122] ]
allAlpha = all (\k -> let a = ord k in (a >= 32 && a <= 122))
howManySpaces = length . filter (==' ')
 
problem_59 = do
	s <- readFile "cipher1.txt"
	let 
		cipher = (read ("[" ++ s ++ "]") :: [Int])
		decrypts = [ map chr (zipWith xor (cycle key) cipher) | key <- keys ]
		alphaDecrypts = filter allAlpha decrypts
		message = maximumBy (comparing howManySpaces) alphaDecrypts
		asciisum = sum (map ord message)
	print asciisum

[edit] 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 || 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 -> and [isPrime $read $shows x $show y,
                 isPrime $read $shows y $show x])
primesTo10000 = 2:filter isPrime [3,5..9999]