「HaskellでProject Euler(Problem 61～63)」ブログ用

euler61-1.hs

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

main = print $ sum search

search :: [Integer]
search = fst $ head $ appendCyclics $ map (\o -> ([o], candidates)) octagonals

appendCyclics :: (Show a, Eq b) => [([a], [(a, b)])] -> [([a], [(a, b)])]
appendCyclics nss | Just r' <- r = [r']
                  | otherwise =  nss' >>= appendCyclics
  where
    nss' = map (uncurry appendCyclic) nss
    r = find (\(m', _) -> length m' == 6) $ concat nss'

appendCyclic :: (Show a, Eq b) => [a] -> [(a, b)] -> [([a], [(a, b)])]
appendCyclic ns@[n,_,_,_,n'] cs = maybeToList $ fmap (\(m, _) -> (m:ns, [])) cyclic
  where
    cyclic = find (\(m, _) -> isCyclic n m && isCyclic m n') cs
appendCyclic ns@(n:_) cs        = map (\(m, d) -> (m:ns, nextCs d)) cyclics
  where
    cyclics = filter (\(m, _) -> isCyclic n m) cs
    nextCs d = filter (\(_, d') -> d /= d') cs

candidates :: [(Integer, Integer)]
candidates = zip triangles (repeat 3) ++
             zip squares (repeat 4) ++
             zip pentagonals (repeat 5) ++
             zip hexagonals (repeat 6) ++
             zip heptagonals (repeat 7)

triangles :: [Integer]
triangles = digitRange 4 $ map triangle [1..]
  where triangle n = n * (n + 1) `div` 2

squares :: [Integer]
squares = digitRange 4 $ map square [1..]
  where square n = n ^ 2

pentagonals :: [Integer]
pentagonals = digitRange 4 $ map pentagonal [1..]
  where pentagonal n = n * (3 * n - 1) `div` 2

hexagonals :: [Integer]
hexagonals = digitRange 4 $ map hexagonal [1..]
  where hexagonal n = n * (2 * n - 1)

heptagonals :: [Integer]
heptagonals = digitRange 4 $ map heptagonal [1..]
  where heptagonal n = n * (5 * n - 3) `div` 2

octagonals :: [Integer]
octagonals = digitRange 4 $ map octagonal [1..]
  where octagonal n = n * (3 * n - 2)

digitRange :: (Integral a, Num b, Ord b) => a -> [b] -> [b]
digitRange n ns = dropWhile (<10^(n-1)) $ takeWhile (<=10^n-1) ns

isCyclic :: (Show a, Show b) => a -> b -> Bool
isCyclic n m = drop 2 (show n) == take 2 (show m)

euler61-2.hs

main = print answer

answer :: Integer
answer = head [
    sum [n1, n2, n3, n4, n5, n6] |
    n1 <- octagonals,
    (n2, d2) <- candidates, isCyclic n1 n2,
    let cs2 = filter (\(_, d) -> d /= d2) candidates,
    (n3, d3) <- cs2, isCyclic n2 n3,
    let cs3 = filter (\(_, d) -> d /= d3) cs2,
    (n4, d4) <- cs3, isCyclic n3 n4,
    let cs4 = filter (\(_, d) -> d /= d4) cs3,
    (n5, d5) <- cs4, isCyclic n4 n5,
    let cs5 = filter (\(_, d) -> d /= d5) cs4,
    (n6, _) <- cs5, isCyclic n5 n6, isCyclic n6 n1
  ]

candidates :: [(Integer, Integer)]
candidates = zip triangles (repeat 3) ++
             zip squares (repeat 4) ++
             zip pentagonals (repeat 5) ++
             zip hexagonals (repeat 6) ++
             zip heptagonals (repeat 7)

triangles :: [Integer]
triangles = digitRange 4 $ map triangle [1..]
  where triangle n = n * (n + 1) `div` 2

squares :: [Integer]
squares = digitRange 4 $ map square [1..]
  where square n = n ^ 2

pentagonals :: [Integer]
pentagonals = digitRange 4 $ map pentagonal [1..]
  where pentagonal n = n * (3 * n - 1) `div` 2

hexagonals :: [Integer]
hexagonals = digitRange 4 $ map hexagonal [1..]
  where hexagonal n = n * (2 * n - 1)

heptagonals :: [Integer]
heptagonals = digitRange 4 $ map heptagonal [1..]
  where heptagonal n = n * (5 * n - 3) `div` 2

octagonals :: [Integer]
octagonals = digitRange 4 $ map octagonal [1..]
  where octagonal n = n * (3 * n - 2)

digitRange :: (Integral a, Num b, Ord b) => a -> [b] -> [b]
digitRange n ns = dropWhile (<10^(n-1)) $ takeWhile (<=10^n-1) ns

isCyclic :: (Show a, Show b) => a -> b -> Bool
isCyclic n m = drop 2 (show n) == take 2 (show m)

euler61-3.hs

main = print answer

answer :: Integer
answer = head [
    sum [n1, n2, n3, n4, n5, n6] |
    n1 <- digitRange 4 $ map (polygonal 8) [1..],
    (n2, p2) <- candidates, isCyclic n1 n2,
    let cs2 = filter (\(_, p) -> p /= p2) candidates,
    (n3, p3) <- cs2, isCyclic n2 n3,
    let cs3 = filter (\(_, p) -> p /= p3) cs2,
    (n4, p4) <- cs3, isCyclic n3 n4,
    let cs4 = filter (\(_, p) -> p /= p4) cs3,
    (n5, p5) <- cs4, isCyclic n4 n5,
    let cs5 = filter (\(_, p) -> p /= p5) cs4,
    (n6, _) <- cs5, isCyclic n5 n6, isCyclic n6 n1
  ]

candidates :: [(Integer, Integer)]
candidates = [(x, p) | p <- [3..7], x <- digitRange 4 $ map (polygonal p) [1..]]

polygonal :: Integral a => a -> a -> a
polygonal p n = ((p - 2) * (n^2) - ((p - 4) * n)) `div` 2

digitRange :: (Integral a, Num b, Ord b) => a -> [b] -> [b]
digitRange n ns = dropWhile (<10^(n-1)) $ takeWhile (<=10^n-1) ns

isCyclic :: (Show a, Show b) => a -> b -> Bool
isCyclic n m = drop 2 (show n) == take 2 (show m)

euler62-1.hs

import Data.List (find, groupBy, sort, sortBy)
import Data.Maybe (mapMaybe)

main = print $ head search

search :: [Integer]
search = head $ mapMaybe (\(n, m) -> search' n m cubes) $ iterate (\(n, m) -> (n*10, m*10)) (1, 10)
  where search' n m = permuted 5 . dropWhile (<n) . takeWhile (<m)

cubes :: [Integer]
cubes = map (^3) [1..]

permuted :: Show a => Int -> [a] -> Maybe [a]
permuted cnt = find (\ns -> length ns == cnt) . groupBy grouping . sortBy sorting
  where
    grouping n m = (sort $ show n) == (sort $ show m)
    sorting n m = (sort $ show n) `compare` (sort $ show m)

euler62-2.hs

import Data.Function (on)
import Data.List (find, groupBy, sort, sortBy)
import Data.Maybe (mapMaybe)

main = print $ head search

search :: [Integer]
search = head $ mapMaybe (\(n, m) -> search' n m cubes) $ iterate (\(n, m) -> (n*10, m*10)) (1, 10)
  where search' n m = permuted 5 . dropWhile (<n) . takeWhile (<m)

cubes :: [Integer]
cubes = map (^3) [1..]

permuted :: (Ord a, Show a) => Int -> [a] -> Maybe [a]
permuted cnt = find (\ns -> length ns == cnt) . grouped
  where grouped = map (map snd) . groupBy ((==) `on` fst) . sort . map (\x -> (sort $ show x, x))

euler63.hs

main = print $ sum answer

answer :: [Int]
answer = takeWhile (>0) $ map f [1..]
  where f n = length $ filter (==n) $ takeWhile (<= n) $ map powerLength [1..]
         where powerLength m = length $ show $ m^n