「HaskellでProject Euler(Problem 43～45)」ブログ用

euler43-1.hs

import Data.List (permutations)
import Zaneli.Euler (primesLimitIndex)

main = print $ sum [read pand | pand <- pands, isSubStrDivisibility pand]
  where pands = permutations ['0'..'9']

isSubStrDivisibility :: String -> Bool
isSubStrDivisibility pand = all (\(n, m) -> n `mod` m == 0) $ zip subStrs primes
  where
    subStrs = map (\n -> read $ take 3 $ drop n pand)  [1..7]

primes = reverse $ primesLimitIndex 7

euler43-2.hs

import Data.Array (Array, listArray, (!))
import Zaneli.Euler (primesLimitIndex)

main = print subStrDivisSum

subStrDivisSum :: Integer
subStrDivisSum = sum $ f ("",  ['0'..'9'])
  where
    f (p, rest)
      | null rest && isDivisibe p = [read p]
      | length p <= 3 || isDivisibe p = concat $ map f $ addPand p rest
      | otherwise = [0]
    isDivisibe p = n `mod` m == 0
      where
        n = read $ drop ((length p) - 3) p
        m = primes ! ((length p) - 3)

primes :: Array Int Integer
primes = listArray (1, 7) $ reverse $ primesLimitIndex 7

select :: [a] -> [(a, [a])]
select xs = map select' [0..(length xs) - 1]
  where select' i = let (ys, z:zs) = splitAt i xs in (z, ys ++ zs)

addPand :: [a] -> [a] -> [([a], [a])]
addPand x rest = map (\(y, ys) -> (x ++ [y], ys)) $ select rest

euler43-3.hs

import Zaneli.Euler (listToNum, primesLimitIndex)

main = print $ sum subStrDivis

subStrDivis :: [Integer]
subStrDivis = toNum $ foldl (\a b -> a >>= f b) [([], [0..9], (0, 0))] $ 1:1:1:(reverse $ primesLimitIndex 7)
  where
    f m (p, rest, (a, b)) = [(x:p, rest', (b, x)) | (x, rest') <- select rest, (100 * a + 10 * b + x) `mod` m == 0]
    toNum = map (\(xs, _, _) -> listToNum $ reverse xs)

select :: [a] -> [(a, [a])]
select xs = map select' [0..(length xs) - 1]
  where select' i = let (ys, z:zs) = splitAt i xs in (z, ys ++ zs)

euler44.hs

import Data.List (find, unfoldr)
import Data.Maybe (maybeToList)

main = print $ minimisedPentagonal [] Nothing pentagonals

pentagonals :: [Integer]
pentagonals = unfoldr (\n -> Just ((pentagonal n, n+1))) 1
  where pentagonal n = n * (3 * n - 1) `div` 2

isPentagonal :: Integral a => a -> Bool
isPentagonal n = let m = (1 + sqrt (1 + 24 * (fromIntegral n))) / 6.0 in m == (fromIntegral $ truncate m)

minimisedPentagonal :: Integral a => [a] -> Maybe a -> [a] -> a
minimisedPentagonal (n:_) (Just d) (p:_)  | p - n >= d = d
minimisedPentagonal ns    d        (p:pns)             = minimisedPentagonal (p:newNs) newD pns
  where
    (newNs, newD) = case candidates of
                 [] -> (ns, Nothing)
                 d -> let newD = minimum d in (filter (\n -> p - n > newD) ns, Just newD)
      where candidates = (maybeToList $ fmap (\n -> p - n) (find (\n -> isPentagonal (p + n) && isPentagonal (p - n)) ns)) ++ (maybeToList d)

euler45-1.hs

import Data.List (find, unfoldr)
import Data.Maybe (fromJust)

main = print $ fromJust $ find f ns
  where
    f n = (isTriangle n) &&  (isPentagonal n)
    ns = dropWhile (\n -> n <= 40755) hexagonals

hexagonals :: [Integer]
hexagonals = unfoldr (\n -> Just ((hexagonal n, n+1))) 1
  where hexagonal n = n * (2 * n - 1)

isTriangle :: Integral a => a -> Bool
isTriangle n = let m = (1 + sqrt (1 + 8 * (fromIntegral n))) / 2.0 in m == (fromIntegral $ truncate m)

isPentagonal :: Integral a => a -> Bool
isPentagonal n = let m = (1 + sqrt (1 + 24 * (fromIntegral n))) / 6.0 in m == (fromIntegral $ truncate m)

euler45-2.hs

main = print $ head $ filter (> 40755) $ isect (poly 3) $ isect (poly 5) (poly 6)

-- p角数の数列の無限リストを作る
poly p = [i * ((p-2) * i - (p-4)) `div` 2 | i <- [1..]]

-- ソート済みの2つのリストから共通要素を取る
isect :: Ord a => [a] -> [a] -> [a]
isect = isectBy compare
  where
    isectBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
    isectBy cmp = loop
      where
         loop [] _ys  = []
         loop _xs []  = []
         loop (x:xs) (y:ys)
           = case cmp x y of
              LT ->     loop xs (y:ys)
              EQ -> x : loop xs ys
              GT ->     loop (x:xs) ys