「HaskellでProject Euler(Problem 19～21)」ブログ用

euler19.hs

main = print $ length $ filter (== Sun) firstOfTheMonthWeek

firstOfTheMonthWeek :: [Week]
firstOfTheMonthWeek = firstOfTheMonthWeek' 1900 1 [Mon]
  where
    firstOfTheMonthWeek' 2000 12 ws   = ws
    firstOfTheMonthWeek' y m ws@(w:_) = firstOfTheMonthWeek' y' m' $ ws' (week w $ dayNums y m)
      where
        (y', m') = nextMonth y m
        ws' w | y == 1900 = [w]  -- 1901年からの日曜日の個数を求めたいため、1900年の場合は次の月の曜日だけを再帰の引数に使用する
              | otherwise = w:ws

-- 年と月を与え、その月の日数を返す
dayNums :: (Eq n, Integral n) => n -> n -> n
dayNums y 2 | leapYear  = 29
            | otherwise = 28
 where leapYear = y `mod` 4 == 0 && not (y `mod` 100 == 0 && y `mod` 400 /= 0)
dayNums _ m | elem m [4, 6, 9, 11] = 30
            | otherwise = 31

-- 曜日と日数を与え、その日数後の曜日を返す
week :: Week -> Int -> Week
week w d = toEnum $ (d + (fromEnum w)) `mod` 7

nextMonth :: (Enum n, Eq n, Num n) => n -> n -> (n, n)
nextMonth y 12 = (succ y, 1)
nextMonth y m  = (y, succ m)

data Week = Sun | Mon | Tue | Wed | Thu | Fri | Sat deriving (Enum, Eq)

euler20.hs

import Data.Char

main = print $ digitSum $ fact 100

digitSum :: Show a => a -> Int
digitSum n = sum $ map digitToInt $ show $ n

fact :: (Eq a, Num a) => a -> a
fact 0 = 1
fact n = n * fact (n - 1)

euler21-1.hs

main = print $ sum $ amiNums 10000

amiNums :: Integral a => a -> [a]
amiNums n = amiNums' [1..n-1] [] []
  where
    amiNums' [] xs _                  = xs
    amiNums' (n:ns) xs ys | processed = amiNums' ns xs ys
                          | isAmiNums = amiNums' ns (n:m:xs) ys
                          | otherwise = amiNums' ns xs (m:ys)
      where
        processed = elem n xs || elem n ys
        isAmiNums = m /= n && (divSum m) == n
        m = divSum n

divSum :: Integral a => a -> a
divSum n = foldl addDivNum 1 [2..n-1]
  where
    addDivNum sum d | n `mod` d == 0 = sum + d
                    | otherwise      = sum
  

euler21-2.hs

main = print $ sum $ amiNums 10000

amiNums :: Integral a => a -> [a]
amiNums n = amiNums' [1..n-1] [] []
  where
    amiNums' [] xs _                  = xs
    amiNums' (n:ns) xs ys | processed = amiNums' ns xs ys
                          | isAmiNums = amiNums' ns (n:m:xs) ys
                          | otherwise = amiNums' ns xs (m:ys)
      where
        processed = elem n xs || elem n ys
        isAmiNums = m /= n && (divSum m) == n
        m = divSum n

divSum :: Integral a => a -> a
divSum n = sum [m| m <- [1..n `div` 2], n `mod` m == 0]

euler21-3.hs

main = print $ sum $ amiNums 10000

amiNums :: Integral a => a -> [a]
amiNums n = amiNums' [1..n-1] [] []
  where
    amiNums' [] xs _                  = xs
    amiNums' (n:ns) xs ys | processed = amiNums' ns xs ys
                          | isAmiNums = amiNums' ns (n:m:xs) ys
                          | otherwise = amiNums' ns xs (m:ys)
      where
        processed = elem n xs || elem n ys
        isAmiNums = m /= n && (properDivSum m) == n
        m = properDivSum n

properDivSum :: Integral a => a -> a
properDivSum 1 = 1
properDivSum n = (divSum n) - n

divSum :: Integral a => a -> a
divSum = product . map (\(b, e) -> (b ^ (e + 1) - 1) `div` (b - 1)) . primeFactors

-- 因数分解した結果を(基数, 指数)のタプルのリストとして返す
primeFactors :: (Integral a, Num b) => a -> [(a, b)]
primeFactors n = primeFactors' n 2 []
  where
    primeFactors' n m list
      | n < m ^ 2     = updateList
      | isPrimeFactor =
          let (next, cnt) = divide n m 0 in
          primeFactors' next (m + 1) ((m, cnt):list)
      | otherwise     = primeFactors' n (m + 1) list
        where
          isPrimeFactor = all (\(p, _) -> m `mod` p /= 0) list && n `mod` m == 0
          divide n m cnt | r == 0 && q /= 1 = divide q m (cnt + 1)
                         | otherwise        = (n, cnt)
                           where (q, r) = n `divMod` m
          updateList | any (\(p, _) -> p == n) list = map (\(p, a) -> (p, if p == n then a + 1 else a)) list
                     | otherwise                    = (n, 1):list