７４問目

http://projecteuler.net/index.php?section=problems&id=74
ある数に対して、各桁の数字の階乗の和を求めていくとき、どんな数でも無限ループとなるが、繰り返し部分を除いた鎖の長さがちょうど 60 となるような数は百万未満でいくつあるか求める。
最初に書いたコード。コンパイルして 2 分かかります。

import Data.Char
import Data.List

main = print $ euler074 60 999999

euler074 :: Int -> Int -> Int
euler074 n m = length $ filter ((== n) . len . chain) [1..m]

len :: [Int] -> Int
len xs = length $ fst $ head $ dropWhile (\ (ys, z:zs) -> notElem z ys)
     [ splitAt n xs | n <- [1..] ]

chain :: Int -> [Int]
chain n = iterate f n
    where f = sum . map ((facts !!) . digitToInt) . show
          facts = scanl (*) 1 [1..]

階乗の和を求めるときは、どんな数字があるかが問題であって、それぞれの数字の順番はどうでもいいよね、ということがフォーラムにあって、それで調べる数字を絞り込んだのが↓のバージョン。題意を満たす数字の組合せを求めてから、それぞれの組合せに対する順列の個数を求めています。
確かに速くはなったのですが、0が含まれる場合とかを考慮すると、ちょっとコードが長くなってしまいました。
う〜ん、もう一息。

import Data.Char
import Data.List

main = print $ euler074 60 6

euler074 :: Int -> Int -> Int
euler074 n m = sum $ map (length . filter (\ (x:xs) -> x /= 0) . perm)
    $ filter ((== n) . len . chain) $ concat $ map (comb [0..9]) [1..m]

perm :: [Int] -> [[Int]]
perm [] = [[]]
perm xs = nub [ x : xs' | x <- xs, xs' <- perm (delete x xs) ]

len :: [[Int]] -> Int
len xs = length $ fst $ head $ dropWhile (\ (ys, z:zs) -> notElem z ys)
     [ splitAt n xs | n <- [1..] ]

chain :: [Int] -> [[Int]]
chain n = iterate f n
    where f = map digitToInt . show . sum . map (facts !!)
          facts = scanl (*) 1 [1..]

comb :: [Int] -> Int -> [[Int]]
comb _ 0 = [[]]
comb xs m = [ x : xs' | x <- xs, xs' <- comb (filter (>= x) xs) (m - 1) ]