９５問目

http://projecteuler.net/index.php?section=problems&id=95
ある数に対して、約数の和を求めるという操作を繰り返すとき、無限ループとなる数がある。そのようなループのうち、どの要素も百万を超えない最長のものを求め、その最小の要素を求める。
これまで作った関数を色々呼んで、コードが長くなっていますが、今回新たに書いたのは関数 next だけです。

--import Control.Applicative
import Data.Array
import Data.List
import Data.Ord

main = print $ euler095 1000000

euler095 :: Integer -> Integer
euler095 m = minimum $ maximumBy (comparing length) lens
    where lens = map (cyclePart . chain m) [1..m]

cyclePart :: [Integer] -> [Integer]
cyclePart xs
    | (t == 0) = []
    | otherwise = t : takeWhile (/= t) ts
    where (t : ts) = map fst $ dropWhile (\ (t, r) -> t /= r)
              $ zip xs $ map head $ iterate (drop 2) $ tail xs
--cyclePart =
--    ((:) . head <*> (takeWhile . (/=) . head <*> tail))
--    . map fst . dropWhile  ((/=) . fst <*> snd)
--    . (zip <*> map head . iterate (drop 2) . tail)

chain :: Integer -> Integer -> [Integer]
chain m n = iterate (nexts m !) n

nexts :: Integer -> Array Integer Integer
nexts m = listArray (0, m) $ map (next m) [0..]

next :: Integer -> Integer -> Integer
next m n = if 1 < n && 1 < n' && n' < m then n' else 0
    where n' = subtract n $ product $ map sigma $ group $ factors primes n 
          sigma xs@(x:_) = div (x ^ (length xs + 1) - 1) (x - 1)
--  where n' = subtract <*> product . map sigma . group . factors primes $ n 
--        sigma = div . subtract 1 . ((^) . head <*> (+ 1) . length) <*> subtract 1 . head

factors :: [Integer] -> Integer -> [Integer]
factors (p : ps) n
    | q < p = [n]
    | r == 0 = p : factors (p : ps) q
    | otherwise = factors ps n
    where (q, r) = divMod n p

primes :: [Integer]
primes = 2 : filter isPrime [3..]

isPrime :: Integer -> Bool
isPrime x = all ((/= 0) . mod x) $
    takeWhile (<= (floor $ sqrt $ fromIntegral x)) primes