# [Haskell-cafe] 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 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 _ [] = []
```