[Haskell-cafe] Looking for suggestions to improve my algorithm

[David Frey]

Hello Haskellers,

I have been trying to learn a bit about Haskell by solving Project Euler
problems.  For those of you who don't know what Project Euler is, see
http://projecteuler.net

After solving problem 21, which is related to amicable pairs, I decided
to attempt problem 95 since it is an extension of the same topic.

The full description of problem 95 is here:
http://projecteuler.net/index.php?section=problems&id=95

This is the summary:
"Find the smallest member of the longest amicable chain with no element
exceeding one million."

I have attempted to solve this problem, but my solution is too resource
hungry to search the full set of 1000000 numbers.

I am hoping someone reading this list can suggest :
 - How I can improve my algorithm
 - An alternative algorithm that will be more efficient
 - Ways to profile a Haskell program to help me understand why my
   implementation is performing poorly.

In addition to the question above, I would also be interested in
comments on the style of the code.  If there is a more idiomatic way to
write portions of the code, I would like to see what it is.

My solution is at the bottom of this e-mail.  The program will probably
run obscenely slow  or die from stack overflow unless you replace
[1..999999] with [1..somethingSmaller]  in main.

Thanks,
David Frey



--- BEGIN Main.hs ---
module Main where

import ProjectEuler (takeUntil, divisors)
import qualified Data.Map as M
import qualified Data.IntSet as I

main = let initialContext = Context (I.fromList []) 0 0 in
    print $ cycleStart $ foldl checkForChain initialContext [1..999999]


{- Idea:
* Put all the numbers that have been visited into a map regardless of
whether
  they are a part of a chain or not.
* Store the min element in the cycle and the number of elements in the
cycle
* As you process, from 1->n if the stopping conditions for a sumOfDivisors
  result are:
   * has already been seen before
   * number is less than the start of this chain attempt
   * >= 1,000,000
-}

data Context = Context {seenNum::I.IntSet, cycleStart::Int,
cycleLength::Int}

hasBeenSeen :: Int -> Context -> Bool
hasBeenSeen n context = I.member n (seenNum context)


markSeen :: Int -> Context -> Context
markSeen n context = context { seenNum = (I.insert n (seenNum context)) }


deleteFromSeen :: Int -> Context -> Context
deleteFromSeen n context = context { seenNum = (I.delete n (seenNum
context)) }


{-
 - Examines the context to see if the input has potential to be a chain
or not
 - based on whether the input number has been visited before.  If it
could be a
 - chain, an attempt is made to build the chain.
 -}
checkForChain :: Context -> Int -> Context
checkForChain context n =
    if hasBeenSeen n context
        then deleteFromSeen n context
        else buildChain context (sum $ divisors n) n [n]


{-
 - Builds a chain until ones of the 3 stopping conditions are met or a
chain is
 - found.  If a chain is found the context will be updated with the new
chain if
 - it is the longest.
 -
 - Stopping Conditions:
 -  * Number has already been seen before
 -  * Number is less than the start of this chain attempt
 -  * Number >= 1,000,000
 -}
buildChain :: Context -> Int -> Int -> [Int] -> Context
buildChain context candidate first cycleList =
    if elem candidate cycleList
        then foundChain (takeUntil ((==) candidate) cycleList) context
        else if candidate < first ||
                candidate >= 1000000 ||
                hasBeenSeen candidate context
            then context
            else buildChain (markSeen candidate context)
                            (sum $ divisors candidate)
                            first
                            (candidate : cycleList)


{-
 - Updates the context with the new longest chain and the start value if
the
 - chain input parameter is longer than the one currently in the context.
 -}
foundChain :: [Int] -> Context -> Context
foundChain ls context = let
    l = length ls
    m = minimum ls in
    if l > (cycleLength context)
        then context { cycleLength = l, cycleStart = m }
        else if l == (cycleLength context)
            then let m = minimum ls in
                if m < (cycleStart context)
                    then context { cycleStart = m }
                    else context
            else context
--- END Main.hs ---


I put a bunch of common functions in ProjectEuler.hs.  Here are the
relevant functions for this problem:

{-
 - Gets all of the proper divisors of a number.  That is all divisors
starting
 - from 1, but not including itself.
 -}
divisors :: (Integral a) => a -> [a]
divisors n = let
    p1 = [x | x <- [1 .. floor $ sqrt $ fromIntegral n], n `mod` x == 0]
    p2 = map (div n) (tail p1)
    in p1 `concatNoDupe` (reverse p2) where
        {-
         - Concatenate two lists.  If the last element in the first list
and the
         - first element in the second list are ==, produce only the
value from
         - the first list in the output.
         -}
        concatNoDupe :: (Eq a) => [a] -> [a] -> [a]
        concatNoDupe [] ys = ys
        concatNoDupe [x] (y:ys) = if x == y then (y : ys) else (x : y :
ys)
        concatNoDupe (x:xs) ys = x : (concatNoDupe xs ys)


{-
 - Similar to takeWhile, but also takes the first element that fails the
 - predicate.
 -}
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil pred (x:xs) = (x : if pred x then [] else takeUntil pred xs)
takeUntil _ [] = []