Project Euler 95 (35s)

pr95.hs

import Data.Numbers.Primes
import Data.List (group, sort)
import Control.Arrow ((&&&))

sumOfDivisors :: Integer -> Integer
sumOfDivisors n = (-n +) . product . map ( productOfPowers . (&&&) head length ) . group . primeFactors $ n
    where
        productOfPowers :: (Integer, Int) -> Integer
        productOfPowers (base, power) = sum [ base ^ powers | powers <- [0..power] ]
        
perfect :: Integer -> Bool
perfect n = n == sumOfDivisors n

amicableChainBelow :: Integer -> Integer -> Maybe [Integer]
amicableChainBelow m n = go $ Just [n]
    where
        go Nothing = Nothing
        go (Just list)
            | newElement > m          = Nothing
            | newElement == head list = Just list
            | newElement `elem` list  = Nothing
            | otherwise               = go $ Just $ list ++ [newElement]
            where newElement = sumOfDivisors $ last list

amicableChainBelowMillion = amicableChainBelow 1000000

main = print . snd . last . sort . map (\(Just x) -> (length x, minimum x)) . filter (/= Nothing) . map amicableChainBelowMillion $ [1..1000000]