Euler Project No. 14 Haskell

Question

I am trying to solve the 14 Project Euler problem ( http://projecteuler.net/problem=14 ) and I hit a dead end with Haskell.

Now I know that the numbers can be quite small, and I can do brute force, but that is not the purpose of my exercise. I am trying to remember intermediate results in a Map type Map Integer (Bool, Integer) with a value:

 - the first Integer (the key) holds the number - the Tuple (Bool, Interger) holds either (True, Length) or (False, Number) where Length = length of the chain Number = the number before him 

Example:

  for 13: the chain is 13 → 40 → 20 → 10 → 5 → 16 → 8 → 4 → 2 → 1 My map should contain : 13 - (True, 10) 40 - (False, 13) 20 - (False, 40) 10 - (False, 20) 5 - (False, 10) 16 - (False, 5) 8 - (False, 16) 4 - (False, 8) 2 - (False, 4) 1 - (False, 2) 

Now, when I look for another number, for example 40 , I know that the chain has (10 - 1) length and so on. I want if I was looking for 10, not only tell me that the length is 10 (10 - 3) length and update the map, but also I want to update 20, 40 if they are still (False, _)

My code is:

 import Data.Map as Map solve :: [Integer] -> Map Integer (Bool, Integer) solve xs = solve' xs Map.empty where solve' :: [Integer] -> Map Integer (Bool, Integer) -> Map Integer (Bool, Integer) solve' [] table = table solve' (x:xs) table = case Map.lookup x table of Nothing -> countF x 1 (x:xs) table Just (b, _) -> case b of True -> solve' xs table False -> {-WRONG-} solve' xs table f :: Integer -> Integer fx | x `mod` 2 == 0 = x `quot` 2 | otherwise = 3 * x + 1 countF :: Integer -> Integer -> [Integer] -> Map Integer (Bool, Integer) -> Map Integer (Bool, Integer) countF n cnt (x:xs) table | n == 1 = solve' xs (Map.insert x (True, cnt) table) | otherwise = countF (fn) (cnt + 1) (x:xs) $ checkMap (fn) n table checkMap :: Integer -> Integer -> Map Integer (Bool, Integer) -> Map Integer (Bool, Integer) checkMap n rez table = case Map.lookup n table of Nothing -> Map.insert n (False, rez) table Just _ -> table 

In the {-WRONG-} part, we must update all the values, as in the following example:

 --We are looking for 10: 10 - (False, 20) | V {-finally-} update 10 => (True, 10 - 1 - 1 - 1) 20 - (False, 40) ^ | | V update 20 => 20 - (True, 10 - 1 - 1) 40 - (False, 13) ^ | | V update 40 => 40 - (True, 10 - 1) 13 - (True, 10) ^ | | --------------------------- 

The problem is that I don’t know if it is possible to do 2 things in a function, for example, update a number and continue repeating. In a C similar language, I can do something like (pseudocode):

 void f(int n, tuple(b,nr), int &length, table) { if(b == False) f (nr, (table lookup nr), 0, table); // the bool is true so we got a length else { length = nr; return; } // Since this is a recurence it would work as a stack, producing the right output table update(n, --cnt); } 

The last instruction will work as we send cnt by reference. We also always know that it will finish at some point, and cnt should not be <1.

Answer 1

The simplest optimization (as you defined) is memoization. You yourself tried to create a memoization system, but you ran into problems with saving saved values. There are solutions for this using a convenient method, for example, using the state monad or STArray . However, there is a much simpler solution to your problem - use haskell existing memoization. Haskell remembers constant values ​​by default, so if you create a value that stores collatz values, it will be automatically saved in memory!

A simple example of this is the following fibonacci definition:

 fib :: Int -> Integer fib n = fibValues !! n where fibValues = 1 : 1 : zipWith (+) fibValues (tail fibValues) 

fibValues is [Integer] , and since it is only a constant value, it is remembered. However, this does not mean that all this is instantly remembered, since this is a list of infinte, it will never end. Instead, values ​​are only calculated if necessary, since haskell is lazy.

---

So, if you do something similar to your problem, you will get a memorandum without much work. However, using such a list as indicated above will not work in your solution. This is because the collatz algorithm uses many different values ​​to get the result for a given number, so the container used requires random access to be effective. The obvious choice is an array.

 collatzMemoized :: Array Integer Int 

Then we need to fill the array with the correct values. I will write this function by pretending that there is a collatz function that computes the value of collatz for any n. Also note that arrays are a fixed size, so you must use a value to determine the maximum number for memoize. I will use a million, but any value can be used (this is memory / speed compilation).

 collatzMemoized = listArray (1, maxNumberToMemoize) $ map collatz [1..maxNumberToMemoize] where maxNumberToMemroize = 1000000 

It's pretty simple, a listArray set to a border, and it is assigned a list of all collatz values ​​in this range. Remember that this will not immediately calculate all collatz values, since the values ​​are lazy.

Now the collatz function can be written. The most important part is to check only the collatzMemoized array if the number being checked is within its borders:

 collatz :: Integer -> Int collatz 1 = 1 collatz n | inRange (bounds collatzMemoized) nextValue = 1 + collatzMemoized ! nextValue | otherwise = 1 + collatz nextValue where nextValue = case n of 1 -> 1 n | even n -> n `div` 2 | otherwise -> 3 * n + 1 

In ghci you can now see the effectiveness of memoization. Try collatz 200000 . It takes about 2 seconds. However, if you run it again, it will be completed instantly.

Finally, you can find a solution:

 maxCollatzUpTo :: Integer -> (Integer, Int) maxCollatzUpTo n = maximumBy (compare `on` snd) $ zip [1..n] (map collatz [1..n]) where 

and then printed:

 main = print $ maxCollatzUpTo 1000000 

If you run main, the result will print in about 10 seconds.

Now, a small problem with this approach is that it uses a lot of stack space. It works fine in ghci (which is likely to be more flexible regarding stack space). However, if you compile it and try to run the executable file, it will work (with a stack overflow). Therefore, to run the program, you need to specify more when you compile it. This can be done by adding -with-rtsopts='K64m' to the compilation options. This increases the stack to 64 MB.

Now the program can be compiled and launched:

 > ghc -O3 --make -with-rtsopts='-K6m' problem.hs 

Running ./problem will produce a result in less than a second.

Answer 2

You are going to demonize the hard way while trying to write a strong program in Haskell. Borrowing the solution of David Eisenstat, we will resolve it, as j_random_hacker suggested:

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

A dynamic programming solution for this is to replace recursion with finding things in a table. Let me make a function in which we can replace the recursive call:

 collatzLengthDef :: (Integer -> Integer) -> Integer -> Integer collatzLengthDef rn | n == 1 = 1 | even n = 1 + r (n `div` 2) | otherwise = 1 + r (3*n + 1) 

Now we could define a recursive algorithm as

 collatzLength :: Integer -> Integer collatzLength = collatzLengthDef collatzLength 

Now we can also make a version with a stool (it takes a number for the size of the table and returns the function collatzLength, which is calculated using a table of this size):

 -- A utility function that makes memoizing things easier buildTable :: (Ix i) => (i, i) -> (i -> e) -> Array ie buildTable bounds f = array $ map (\x -> (x, fx)) $ range bounds collatzLengthTabled :: Integer -> Integer -> Integer collatzLengthTabled n = collatzLengthTableLookup where bounds = (1, n) table = buildTable bounds (collatzLengthDef collatzLengthTableLookup) collatzLengthTableLookup = \x -> Case inRange bounds x of True -> table ! x _ -> (collatzLengthDef collatzLengthTableLookup) x 

This works by defining collatzLength for a table lookup, with the table being a function definition, but with recursive calls replaced by a table lookup. The table search function checks to see if the function argument is in the range that is displayed and returns to the function definition. We can even do this job to tab any function like this:

 tableRange :: (Ix a) => (a, a) -> ((a -> b) -> a -> b) -> a -> b tableRange bounds definition = tableLookup where table = buildTable bounds (definition tableLookup) tableLookup = \x -> Case inRange bounds x of True -> table ! x _ -> (definition tableLookup) x collatzLengthTabled n = tableRange (1, n) collatzLengthDef 

You just need to make sure that you

 let memoized = collatzLengthTabled 10000000 ... memoized ... 

So in memory only one table is built in.

Answer 3

I remember how Haskell had a very conflicting understanding of dynamic programming algorithms, and I have done it since then, but I hope that the next trick will work for you.

But firstly, I do not quite understand your existing DP scheme, although I suspect that it may be quite inefficient, as it seems that it will need to update many records for each answer. (a) I do not know how to do this in Haskell, and (b) you do not need to do this in order to solve the problem effectively; -)

Instead, I propose the following approach: first create a regular recursive function that calculates the correct answer for the input number. (Hint: it will have a signature of type collatzLength :: Int -> Int .) When you have this function, simply replace its definition with an array definition whose elements are defined lazily using the array function using the list of associations and replace all recursive calls functions to search for an array (for example, collatzLength 42 will become collatzLength ! 42 ). This will automatically fill the array in the required order! So your top-level collatzLength object will now be actually an array, not a function.

As I said above, I would use an array instead of the map data type to store the DP table, since you will need to store values ​​for all integer indices from 1 to 1,000,000.

Answer 4

I don't have a Haskell compiler, so I apologize for any broken code.

Without memoization, there is a function

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

With memoization type signature

 memoCL :: Map Integer Integer -> Integer -> (Map Integer Integer, Integer) 

since memoCL receives the table as input and gives the updated table as output. What memoCL needs to do is intercept the return of the recursive call using the let form and insert a new result.

 -- table must have an initial entry for 1 memoCL table n = case Map.lookup n table of Just m -> (table, m) Nothing -> let (table', m) = memoCL table (collatzStep n) in (Map.insert n (1 + m) table', 1 + m) collatzStep :: Integer -> Integer collatzStep n = if even n then n `div` 2 else 3*n + 1 

At some point, you will get tired of the above idiom. Then it's time for monads.

Answer 5

I end up changing the {-WRONG-} part to do what she needs with a call to mark x (b, n) [] xs table , where

  mark :: Integer -> (Bool, Integer) -> [Integer] -> [Integer] -> Map Integer (Bool, Integer) -> Map Integer (Bool, Integer) mark crtElem (b, n) list xs table | b == False = mark n (findElem n table) (crtElem:list) xs table | otherwise = continueWith n list xs table continueWith :: Integer -> [Integer] -> [Integer] -> Map Integer (Bool, Integer) -> Map Integer (Bool, Integer) continueWith _ [] xs table = solve' xs table continueWith cnt (y:ys) xs table = continueWith (cnt - 1) ys xs (Map.insert y (True, cnt - 1) table) findElem :: Integer -> Map Integer (Bool, Integer) -> (Bool, Integer) findElem n table = case Map.lookup n table of Nothing -> (False, 0) Just (b, nr) -> (b, nr) 

But this suggests that there are better (and much less detailed) answers than this 1

Answer 6

You might be interested to know how I solved the problem. It is quite functional, although it may not be the most effective thing on earth :)

The code can be found here: https://github.com/fmancinelli/project-euler/blob/master/haskell/project-euler/Problem014.hs

PS: Disclaimer: I did the Project Euler exercises to learn Haskell, so the quality of the solution can be controversial.

Answer 7

Since we are studying recursion schemes, here is one for you.

Let us consider the functor N (A, B, X) = A + B * X, which is a flow of Bs with the last element being A.

 {-# LANGUAGE DeriveFunctor , TypeFamilies , TupleSections #-} import Data.Functor.Foldable import qualified Data.Map as M import Data.List import Data.Function import Data.Int data N abx = Z a | S bx deriving (Functor) 

This thread is convenient for several types of iterations. First, we can use it to represent an Ints chain in a Collatz sequence:

 type instance Base Int64 = N Int Int64 instance Foldable Int64 where project 1 = Z 1 project x | odd x = S x $ 3*x+1 project x = S x $ x `div` 2 

This is just an algebra, not an initial one, because the transformation is not an isomorphism (the same chain from Ints is part of the chain for 2 * x and (x-1) / 3), but this is enough to represent the fixed Base Int64 Int64 base.

With this definition, cata is going to pass the chain to the given algebra, and you can use it to build the Map of integers reminder for the length of the chain. Finally, anamorphism can use it to generate a stream of solutions to problems of different sizes:

 problems = ana (uncurry $ cata . phi) (M.empty, 1) where phi :: M.Map Int64 Int -> Base Int64 (Prim [(Int64, Int)] (M.Map Int64 Int, Int64)) -> Prim [(Int64, Int)] (M.Map Int64 Int, Int64) phi m (Z v) = found m 1 v phi m (S x ~(Cons (_, v') (m', _))) = maybe (notFound m' x v') (found mx) $ M.lookup xm 

The ~ before (Cons ...) option means lazy pattern matching. We do not touch the template until the values ​​are needed. If not for lazy pattern matching, he would always build a whole chain, and using a map would be useless. With lazy pattern matching, we only build v 'and m' if the chain length for x was not on the map.

Helper functions build a stream of pairs (Int, chain length):

  found mxv = Cons (x, v) (m, x+1) notFound mxv = Cons (x, 1+v) (M.insert x (1+v) m, x+1) 

Now just take the first 999999 problems and find out the one that has the longest chain:

 main = print $ maximumBy (compare `on` snd) $ take 999999 problems 

This works slower than an array-based solution, since the map search is logarithmic to the size of the map, but this solution is not a fixed size. However, it ends in about 5 seconds.