Euler problems/41 to 50

-- Assuming isPrime has been implemented
import Data.Char (intToDigit)
problem_41 = maximum [ n' | d <- [3..9], n <- permute ['1'..intToDigit d],
                            let n' = read n, isPrime n']
    where
        permute "" = [""]
        permute str = [(x:xs)| x <- str, xs <- permute (delete x str)]

import Data.Char
trilist = takeWhile (<300) (scanl1 (+) [1..])
wordscore xs = sum $ map (subtract 64 . ord) xs
problem_42 megalist = 
    length [ wordscore a | a <- megalist,
                           elem (wordscore a) trilist ]
main = do f <- readFile "words.txt"
          let words = read $"["++f++"]"
          print $ problem_42 words

import Data.List
l2n :: (Integral a) => [a] -> a
l2n = foldl' (\a b -> 10*a+b) 0
 
swap (a,b) = (b,a)
 
explode :: (Integral a) => a -> [a]
explode = 
    unfoldr (\a -> if a==0 then Nothing else Just $ swap $ quotRem a 10)
problem_43 = sum . map l2n . map (\s -> head ([0..9] \\ s):s) 
                 . filter (elem 0) . genSeq [] $ [17,13,11,7,5,3,2]
 
mults mi ma n = takeWhile (< ma) . dropWhile (<mi) . iterate (+n) $ n
 
sequ xs ys = tail xs == init ys
 
addZ n xs = replicate (n - length xs) 0 ++ xs
 
genSeq [] (x:xs) = genSeq (filter (not . doub) 
                           . map (addZ 3 . reverse . explode)
                           $ mults 9 1000 x)
                          xs
genSeq ys (x:xs) = 
    genSeq (do m <- mults 9 1000 x
               let s = addZ 3 . reverse . explode $ m
               y <- filter (sequ s . take 3) $ filter (notElem (head s)) ys
               return (head s:y))
           xs
genSeq ys [] = ys
 
doub xs = nub xs /= xs

import Control.Monad
import Control.Monad.State
import Data.Set
 
type Select elem a = StateT (Set elem) [] a
 
select :: (Ord elem) => [elem] -> Select elem elem
select as = do
  set <- get
  a <- lift as
  guard (not (member a set))
  put (insert a set)
  return a
 
runSelect :: Select elem a -> [a]
runSelect m = Prelude.map fst (runStateT m empty)
 
fromDigits = foldl (\tot d -> 10 * tot + d) 0
 
ds = runSelect $ do
       d4 <- select [0,2..8]
       d3 <- select [0..9]
       d5 <- select [0..9]
       guard ((d3 + d4 + d5) `mod` 3 == 0)
       d6 <- select [0,5]
       d7 <- select [0..9]
       guard ((100 * d5 + 10 * d6 + d7) `mod` 7 == 0)
       d8 <- select [0..9]
       guard ((d6 - d7 + d8) `mod` 11 == 0)
       d9 <- select [0..9]
       guard ((100 * d7 + 10 * d8 + d9) `mod` 13 == 0)
       d10 <- select [0..9]
       guard ((100 * d8 + 10 * d9 + d10) `mod` 17 == 0)
       d2 <- select [0..9]
       d1 <- select [0..9]
       return (fromDigits [d1, d2, d3, d4, d5, d6, d7, d8, d9, d10])
 
answer = sum ds
 
main = do 
  print ds
  print answer

import Data.List ((\\), nub)
 
main = print q43
 
q43 = sum [ read n | (d7d8d9, remDigits)   <- permMults digits 17, 
                     (d4d5d6, remDigits')  <- permMults remDigits 7,
                     d4d5d6 !! 1 == '0' || d4d5d6 !! 1 == '5', 
                     (d1d2d3, remDigit) <- permMults remDigits' 2,
                     let n = remDigit ++ d1d2d3 ++ d4d5d6 ++ d7d8d9,
                     hasProperty (tail n) primes] 
    where
        digits = "0123456789"
        primes = [2,3,5,7,11,13,17] 
        hasProperty _ [] = True
        hasProperty c (p:ps) = (read $ take 3 c) `mod` p == 0 
                               && hasProperty (tail c) ps
        permMults cs p = [ (ds, cs \\ ds) | n <- [p,2*p..987],
                                            let ds = leadingZero n,
                                            ds == nub ds,
                                            all (flip elem cs) ds]
            where 
                leadingZero n
                    | n < 10    = "00" ++ show n
                    | n < 100   = "0"  ++ show n
                    | otherwise = show n

import Data.Set
problem_44 = head solutions
  where solutions = [a-b | a <- penta,
                           b <- takeWhile (<a) penta,
                           isPenta (a-b),
                           isPenta (b+a) ]
    isPenta = (`member` fromList  penta)
    penta = [(n * (3*n-1)) `div` 2 | n <- [1..5000]]

isPent n = (af == 0) && ai `mod` 6 == 5
  where (ai, af) = properFraction . sqrt $ 1 + 24 * (fromInteger n)
 
problem_45 = head [x | x <- scanl (+) 1 [5,9..], x > 40755, isPent x]

import Data.List
isPrime x | x==3      = True
          | otherwise = millerRabinPrimality x 2
problem_46 = find (\x -> not (isPrime x) && check x) [3,5..]
  where 
    check x = not . any isPrime
                  . takeWhile (>0)
                  . map (\y -> x - 2 * y * y) $ [1..]

primes :: [Int]
primes = 2 : filter isPrime [3, 5..]
 
isPrime :: Int -> Bool
isPrime n = all (not . divides n) $ takeWhile (\p -> p^2 <= n) primes
    where
      divides n p = n `mod` p == 0
 
compOdds :: [Int]
compOdds = filter (not . isPrime) [3, 5..]
 
verifConj :: Int -> Bool
verifConj n = any isPrime (takeWhile (>0) $ map (\i -> n - 2*i*i) [1..])
 
problem_46 :: Int
problem_46 = head $ filter (not . verifConj) compOdds

import Data.List
problem_47 = find (all ((==4).snd)) . map (take 4) . tails 
                 . zip [1..] . map (length . factors) $ [1..]
fstfac x = [(head a ,length a) | a <- group $ primeFactors x]
fac [(x,y)] = [x^a | a <- [0..y]]
fac (x:xs) = [a*b | a <- fac [x], b <- fac xs]
factors x = fac $ fstfac x
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, m `div` p]
                        | otherwise      = factor m ps

import Data.List
import Data.Numbers
import Data.Numbers.Primes
import qualified Data.Set as Set
 
dPrimeFactors n = Set.fromList $ primeFactors n
 
dPFList n = [(k, dPrimeFactors k)
             | k <- filter (\z -> (not $ isPrime z)) [1..n]]
 
nConsec n s = 
  let dpf   = dPFList s
      fltrd = filter (\z -> Set.size (snd z) == n) dpf 
      gps   = [take (fromIntegral n) (drop (fromIntegral k) fltrd) 
                | k <- [0..(length fltrd - n)] ]
      gps2  = filter (\z -> isConsec (map fst z)) gps
  in filter (\zz -> Set.empty == 
              foldl (\acc z -> Set.intersection acc (snd z)) 
                    (snd (head zz)) 
                    zz) gps2 
 
isConsec xs = (sort xs) == [(minimum xs)..(maximum xs)]
 
problem_47 = (fst . head . head) $ nConsec 4 20000

problem_48 = (`mod` limit) $ sum [powMod limit n n | n <- [1..1000]]
    where limit=10^10

problem_48 = reverse $ take 10 
             $ reverse $ show $ sum $ map (\x -> x^x) [1..1000]

import Data.List
 
isPrime x
    | x==3      = True
    | otherwise = millerRabinPrimality x 2
 
primes4 = filter isPrime [1000..9999]
 
problem_49 = [ (a,b,c) | a <- primes4,
                         b <- dropWhile (<= a) primes4,
                         sort (show a) == sort (show b),
                         let c = 2 * b - a,
                         c `elem` primes4,
                         sort (show a) == sort (show c) ]

import Control.Monad
findPrimeSum ps 
    | isPrime sumps = Just sumps
    | otherwise     = findPrimeSum (tail ps) `mplus` findPrimeSum (init ps)
    where
    sumps = sum ps
 
problem_50 = findPrimeSum $ take 546 primes