[Haskellcafe] Looking for suggestions to improve my algorithm
David Frey
dpfrey at shaw.ca
Wed Aug 29 17:12:22 EDT 2007
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 email. 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 _ [] = []
More information about the HaskellCafe
mailing list