Project Euler # 95 in Haskell - kind-of finding longest cycle in a graph

Question

I am trying to solve Project Euler #95 in Haskell, though I have already solved it in Java (see). I found that writing imperatively, we can easily do the task this way:

---

Pseudocode

• Define cache as an int array.
• Find all perfect numbers and store them in a HashSet.
• For each number create a new HashSet for terms (named terms) that have already occured while iterating.
• If the number is prime or perfect skip it (and set cache value to -1)
• Now iterate using sum of proper divisors, if we stumble upon a number that is out of bounds or has cache value -1 skip this too and set this number's cache value as -1 too. Iterate until we reach 1 or a perfect number or the number itself; keep adding to terms.
• If we reach the number, get the size of terms, otherwise (1 or perfect number) set cache value to -1.
• Keep record of number with maximum terms size.

---

Now thinking of functionally writing this solution I find it quite difficult to maintain something as cache, I have to iterate for each number. Also, my mind was quite stuck to this imperative solution so the Haskell equivalent was not quite different or unique. How can I improve it? (It is also quite slower - 32s)

95.hs

import           Control.Arrow
import qualified Data.IntSet   as Set
import           Data.List
import           Data.Ord
import           Divisors

lim :: Int
lim = 1000000

main :: IO ()
main = print . fst . maximumBy (comparing snd) . map (id &&& amicableChainLength) $ [2..lim]
    where
        amicableChainLength x
            | sumOfProperDivisors x == x = 1 -- perfect numbers
            | otherwise = (\((_, list), _) ->
                case elemIndices (last list) list of
                    -- Two occurences
                    (a:b:_) -> b - a
                    -- Cannot occur but anyways
                    _       -> 0
                )
                -- Take first element where include stopped
                . head . dropWhile snd . scanl (include x)
                -- ((Set of numbers observed, Ordered list of them), Continue?)
                ((Set.empty, []), True)
                $ iterate sumOfProperDivisors x
        -- tries to include number into set/list and also tell when to stop
        include x ((set, list),_) n
            -- number is member of observed numbers
            | Set.member n set =
                if x==n
                    -- chain should start at that number
                    then ((set, list ++ [n]), False)
                    -- otherwise no meaning
                    else ((Set.empty, []), False)
            -- Out of bounds or an number earlier encountered, this cannot be answer
            -- since we are required to find minimum element of that chain
            | n > lim || n < 2 || n < x = ((Set.empty, []), False)
            -- New number, add it & continue
            | otherwise = ((Set.insert n set, list ++ [n]), True)

Divisors.hs

module Divisors where

sumOfProperDivisors :: Int -> Int
sumOfProperDivisors n = subtract n . (\s -> if isPerfectSquare n then s - root else s)
    . sum . map (\x -> x + n `div` x) . filter (\x -> n `mod` x == 0)
    . takeWhile (\p -> p*p <= n) $ [1..]
    where
        root = round (sqrt . fromIntegral $ n :: Double)
        isPerfectSquare x = root * root == x

Answer 1

If something can't happen, put your money on it and make it crash if it does anyway instead of silently carrying on.

maximumOn deserves its own name to lift our burden of manual tuple juggling.

Adding elements to the end of a list smells. Let me reverse the list order to fix that.

The scanl with the booleans looks degenerated, there must be a better way - let me undo its introduction. The booleans can be replaced with conditional recursion. The set need not be returned in the cases that used to return True. The list entries that are to be later returned need not be passed deeper into the recursion - and then the list need not be passed down at all. Incidentally, this restores the original list order.

Let's look what I got so far:

maximumOn f = fst . maximumBy (comparing snd) . map (id &&& f)

main :: IO ()
main = print $ maximumOn amicableChainLength [2..lim] where
  amicableChainLength x
    | sumOfProperDivisors x == x = 1 -- perfect numbers
    | otherwise = (\list -> case elemIndices (last list) list of (a:b:_) -> b - a)
      $ include x Set.empty
      $ iterate sumOfProperDivisors x
  -- tries to include number into set/list and also tell when to stop
  include x set (n:ns)
    -- number is member of observed numbers
    | Set.member n set = if x==n
        then [n] -- chain should start at that number
        else error "otherwise no meaning"
    -- this cannot be answer since we are required to find minimum element of that chain
    | n > lim || n < 2 || n < x = error "out of bounds or an number earlier encountered"
    -- New number, add it & continue
    | otherwise = n : include x (Set.insert n set) ns

This code kinda looks like the error cases do happen regularly. Were your comments under the assumption that we are currently looking at the x that is going to win the maximumBy contest? Let me use list comprehension syntax to skip through erroring xs without hacking our way through the data we happen to be working with too much. (Sadly this requires pulling back of parts of maximumOn.) Also the perfect numbers case seems to be subsumed by the other. Also the last element of the list is x if we're interested in it. Also the two positions of x are always in the front and back so we can just compare lengths, and we need not even pass the list out of include.

main :: IO ()
main = print $ fst $ maximumBy (comparing snd)
  [ (x, l)
  | x <- [2..lim]
  , let Just l = include x Set.empty $ iterate sumOfProperDivisors x
  ] where
  -- tries to include number into set/list and also tell when to stop
  include x set (n:ns)
    -- number is member of observed numbers
    | Set.member n set = if x==n
        then Just 0
        else Nothing
    -- this cannot be answer since we are required to find minimum element of that chain
    | n > lim || n < 2 || n < x = Nothing
    -- New number, add it & continue
    | otherwise = (+1) <$> include x (Set.insert n set) ns

I now notice that list comprehensions don't actually use the Alternative instance of lists within let expressions. Ah well, since the Ord instance for Maybe happens to make Nothing smaller than Just anything, I can get rid of the list comprehension again, and restore maximumOn!

main :: IO ()
main = print $ maximumOn (\x -> include x Set.empty $ iterate sumOfProperDivisors x)
  [2..lim] where
  -- tries to include number into set/list and also tell when to stop
  include x set (n:ns)
    -- number is member of observed numbers
    | Set.member n set = if x==n
        then Just 0
        else Nothing
    -- this cannot be answer since we are required to find minimum element of that chain
    | n > lim || n < 2 || n < x = Nothing
    -- New number, add it & continue
    | otherwise = (+1) <$> include x (Set.insert n set) ns

n<2 is subsumed in n<x, the chain length is monotonous with the set size, and do notation feels like it might help with include.

main :: IO ()
main = print $ maximumOn (\x -> include x Set.empty x) [2..lim] where
  -- set keeps track of previously seen numbers
  include x set n = do
    guard $ n <= lim && n >= x
    if Set.member n set
      then guard (x == n) >> Just (Set.size set)
      else include x (Set.insert n set) (sumOfProperDivisors n)

I have a hunch there's a way to decompose include completely, but I don't see it.