Project Euler Question 14 (Collatz Problem)

Question

The following iterative sequence is defined for the set of positive integers:

n ->n/2 (n is even) n ->3n + 1 (n is odd)

Using the rule above and starting wit

Answer 1

Haskell solution, 2 second run time.

thomashartman@yucca:~/collatz>ghc -O3 -fforce-recomp --make collatz.hs
[1 of 1] Compiling Main             ( collatz.hs, collatz.o )
Linking collatz ...
thomashartman@yucca:~/collatz>time ./collatz
SPOILER REDACTED
real    0m2.881s

-- Maybe I could have gotten it a bit faster using a hash instead of a map.

import qualified Data.Map as M
import Control.Monad.State.Strict
import Data.List (maximumBy)
import Data.Function (on)

nextCollatz :: Integer -> Integer
nextCollatz n | even n = n `div` 2
               | otherwise = 3 * n + 1

newtype CollatzLength = CollatzLength Integer
  deriving (Read,Show,Eq,Ord)

main = print longestCollatzSequenceUnderAMill 
longestCollatzSequenceUnderAMill = longestCollatzLength [1..1000000]
-- sanity checks
tCollatzLengthNaive = CollatzLength 10 == collatzLengthNaive 13 
tCollatzLengthMemoized = (CollatzLength 10) == evalState (collatzLengthMemoized 13) M.empty

-- theoretically could be nonterminating. Since we're not in Agda, we'll not worry about it.
collatzLengthNaive :: Integer -> CollatzLength
collatzLengthNaive 1 = CollatzLength 1
collatzLengthNaive n = let CollatzLength nextLength = collatzLengthNaive (nextCollatz n)
                       in  CollatzLength $ 1 + nextLength

-- maybe it would be better to use hash here?
type CollatzLengthDb = M.Map Integer CollatzLength
type CollatzLengthState = State CollatzLengthDb 

-- handy for testing
cLM :: Integer -> CollatzLength
cLM n = flip evalState M.empty $ (collatzLengthMemoized n) 

collatzLengthMemoized :: Integer -> CollatzLengthState CollatzLength
collatzLengthMemoized 1 = return $ CollatzLength 1
collatzLengthMemoized n = do
  lengthsdb <- get
  case M.lookup n lengthsdb of 
    Nothing -> do let n' = nextCollatz n 
                  CollatzLength lengthN' <- collatzLengthMemoized n'
                  put $ M.insert n' (CollatzLength lengthN') lengthsdb
                  return $ CollatzLength $ lengthN' + 1
    Just lengthN -> return lengthN

longestCollatzLength :: [Integer] -> (Integer,CollatzLength)
longestCollatzLength xs = flip evalState M.empty $ do 
  foldM f (1,CollatzLength 1) xs
  where f maxSoFar@(maxN,lengthMaxN) nextN = do
          lengthNextN <- collatzLengthMemoized nextN
          let newMaxCandidate = (nextN,lengthNextN)
          return $ maximumBy (compare `on` snd) [maxSoFar, newMaxCandidate]

================================================================================

And here is another haskell solution, using monad-memo package. Unfortunately, this one has a stack space error that does not affect the rolled-my-own memoizer above.

./collatzMemo +RTS -K83886080 -RTS # this produces the answer, but it would be bettter to eliminate the space leak

{-# Language GADTs, TypeOperators #-} 

import Control.Monad.Memo
import Data.List (maximumBy)
import Data.Function (on)

nextCollatz :: Integer -> Integer
nextCollatz n | even n = n `div` 2
               | otherwise = 3 * n + 1

newtype CollatzLength = CollatzLength Integer
  deriving (Read,Show,Eq,Ord)

main = print longestCollatzSequenceUnderAMill 
longestCollatzSequenceUnderAMill = longestCollatzLength [1..1000000]

collatzLengthMemoized :: Integer -> Memo Integer CollatzLength CollatzLength
collatzLengthMemoized 1 = return $ CollatzLength 1
collatzLengthMemoized n = do
  CollatzLength nextLength <- memo collatzLengthMemoized (nextCollatz n)
  return $ CollatzLength $ 1 + nextLength 
{- Stack space error
./collatzMemo
Stack space overflow: current size 8388608 bytes.
Use `+RTS -Ksize -RTS' to increase it.

Stack error does not effect rolled-my-own memoizer at
http://stackoverflow.com/questions/2643260/project-euler-question-14-collatz-problem
-}
longestCollatzLength :: [Integer] -> (Integer,CollatzLength)
longestCollatzLength xs = startEvalMemo $ do
  foldM f (1,CollatzLength 1) xs
  where f maxSoFar nextN = do
          lengthNextN <- collatzLengthMemoized nextN
          let newMaxCandidate = (nextN,lengthNextN)
          return $ maximumBy (compare `on` snd) [maxSoFar, newMaxCandidate]

{-
-- sanity checks
tCollatzLengthNaive = CollatzLength 10 == collatzLengthNaive 13 
tCollatzLengthMemoized = (CollatzLength 10) ==startEvalMemo (collatzLengthMemoized 13) 

-- theoretically could be nonterminating. Since we're not in Agda, we'll not worry about it.
collatzLengthNaive :: Integer -> CollatzLength
collatzLengthNaive 1 = CollatzLength 1
collatzLengthNaive n = let CollatzLength nextLength = collatzLengthNaive (nextCollatz n)
                       in  CollatzLength $ 1 + nextLength
-}

==================================================

another one, factored more nicely. doesn't run as fast but still well under a minute

import qualified Data.Map as M
import Control.Monad.State
import Data.List (maximumBy, nubBy)
import Data.Function (on)

nextCollatz :: Integer -> Integer
nextCollatz n | even n = n `div` 2
               | otherwise = 3 * n + 1

newtype CollatzLength = CollatzLength Integer
  deriving (Read,Show,Eq,Ord)

main = print longestCollatzSequenceUnderAMillStreamy -- AllAtOnce                                                                                                                                                                                                         

collatzes = evalState collatzesM M.empty
longestCollatzSequenceUnderAMillAllAtOnce = winners . takeWhile ((<=1000000) .fst) $ collatzes
longestCollatzSequenceUnderAMillStreamy = takeWhile ((<=1000000) .fst) . winners  $ collatzes


-- sanity checks                                                                                                                                                                                                                                                          
tCollatzLengthNaive = CollatzLength 10 == collatzLengthNaive 13
tCollatzLengthMemoized = (CollatzLength 10) == evalState (collatzLengthMemoized 13) M.empty

-- maybe it would be better to use hash here?                                                                                                                                                                                                                             
type CollatzLengthDb = M.Map Integer CollatzLength
type CollatzLengthState = State CollatzLengthDb

collatzLengthMemoized :: Integer -> CollatzLengthState CollatzLength
collatzLengthMemoized 1 = return $ CollatzLength 1
collatzLengthMemoized n = do
  lengthsdb <- get
  case M.lookup n lengthsdb of
    Nothing -> do let n' = nextCollatz n
                  CollatzLength lengthN' <- collatzLengthMemoized n'
                  put $ M.insert n' (CollatzLength lengthN') lengthsdb
                  return $ CollatzLength $ lengthN' + 1
    Just lengthN -> return lengthN

collatzesM :: CollatzLengthState [(Integer,CollatzLength)]
collatzesM = mapM (\x -> do (CollatzLength l) <- collatzLengthMemoized x
                            return (x,(CollatzLength l)) ) [1..]

winners :: Ord b => [(a, b)] -> [(a, b)]
winners xs = (nubBy ( (==) `on` snd )) $ scanl1 (maxBy snd) xs

maxBy :: Ord b => (a -> b) -> a -> a -> a
maxBy f x y = if f x > f y then x else y