coin-change kata

the task

given a list of coins \([c_1,..,c_n]\) and a amount of money \(A\) we shall find a list \([a_1,..,a_n]\) of integers such that \(\sum_i a_i c_i = A\) – but not just any: We want to minimize the number of coins given: \( minimize \sum_i a_i\)

See here for more on this problem.

I stumpled on this reading twitter, where Mike Bild solved this using various LINQ-like expressions (well the first version of what I give you here) … as I could not stand the not-optimal solution I had to brute-force a better solution (… and maybe I come back and try to improve on that some time)

remark (shameless plug)

You can find the same article on school of haskell – where you can even play with it.
But make sure to give me some nice comments here 😀

a trivial algorithm (that does give you correct change but not with fewest coins)

First define the coins used (as a Integer-list):

coins :: [Integer]
coins = [100, 25, 10, 5, 1]

Then the idea is to fold over the coins using the remaining amount we have to change and the count of used coins so far (so a 3 at position 2 will mean 2 – 25ct coins used)

change :: Integer -> [Integer]
change n = reverse . snd $ foldl next (n, []) coins
    where next (remaining, cs) coin
            | coin <= remaining = (r', cnt:cs)
            | otherwise         = (remaining, 0:cs)
            where r' = remaining `mod` coin
                  cnt = remaining `div` coin

Why this might fail in the general case

Well sometimes … let’s change the coins and look for 30cts …

change :: Integer -> [Integer]
change n = reverse . snd $ foldl next (n, []) coins
    where next (remaining, cs) coin
            | coin <= remaining = (r', cnt:cs)
            | otherwise         = (remaining, 0:cs)
            where r' = remaining `mod` coin
                  cnt = remaining `div` coin

so 6 coins (1x25ct and 5*1ct) – WTF … well the algorithm is too stupid in this case (the answer is of course 2x15ct) … stay tuned – I gonna fix it … soon

brute-forcing our way

An easy way to fix this is to try every possible combination for small cases like the samples it’s still ok

  import Data.List(minimumBy)
  import Data.Maybe(mapMaybe)
  import Control.Applicative ( (<$>) )

  findChange :: [Coin] -> Cents -> Maybe [Integer]
  findChange coins amount = snd <$> calc amount coins
      where calc r []
              | r == 0    = Just (0, [])
              | otherwise = Nothing
            calc r (c:cs)
              | r < 0     = Nothing
              | otherwise = findMinimum . mapMaybe try $ [0 .. r `div` c]
                  where try n = do
                          (n', ns) <- calc (r-n*c) cs
                          return (n + n', n:ns)
                        findMinimum [] = Nothing
                        findMinimum vs = Just . minimumBy (\ (a,_) (b, _) -> compare a b) $ vs

As you can see, the code has changed a bit – but produces the right answer (2x15ct)!

Instead of trying to find the right fold-function I went for manual recursion for now:
You will find the algorithm inside of calc. The first few guards handle the edge-cases (nothing more to change, no-coins left to try, to much change given).
But in the case that there is still something to give-back and where there are coins left to change with the algorithm tries every combination and finaly turns back the one with fewest coins given recursivley.

brute-force brakes down

Remember: I told you “it’s still ok”?
Well I lied – try the brute-force algorithm for your normal coins [100, 50, 25, 10, 5, 2, 1] and (say) 2$34ct … this will take the algorithm on my machine almost 10seconds!
Try the same for 100$ and get yourself some coffee…

What can we do…

If you look carefully you’ll see that we do the recursive-call not one time but two times – and just as with fibonacci numbers we will sureley hit the same spot more than once – but every time we calculate the thing again.
Just write the algorithm down as a tree and you will see that we recalculate the same branches time-and-time again…

So how can we change this?

We have to memoize the caluclated values! This is more or less the basic idea in dynamic programming (DP) – and while I will not give a complete introduction here I will try to show how you can change the algorithm to use this.

First step towards DP

The first thing we are going to do is modify the algorithm a bit so that we can see better where the recursion is (the case expression below):

  -- | tries change (using coins form the first parameter) to the amount of money in the second parameter with the fewest number of pieces in the change
  -- | the first parameter should be a decreasing list of distinct values
  takeCoin :: [Coin] -> Cents -> Maybe (Integer, [Coin])
  takeCoin [] cents
      | cents == 0   = Just (0, [])
      | otherwise    = Nothing
  takeCoin coins@(coin:coins') cents
      | cents < 0    = Nothing
      | coin > cents = takeCoin coins' cents
      | otherwise    = 
          case (takeCoin coins (cents-coin), takeCoin coins' cents) of
             (Just (n, t), Just (n',t')) -> Just $ if n+1 <= n' then (n+1, coin:t) else (n', t')
             (Nothing,     Just (n',t')) -> Just (n', t')
             (Just (n,t),  Nothing)      -> Just (n+1, coin:t)

This will still take long (indeed it will do slightly worse) but you can see better where the magic (aka recursion) is and where the edge-cases gets handled.

enter lazy-arrays

Now how to memoize … well the easiest thing I can think of (and indeed almost the same as with real DP) is to use an array.
Well now you cannot mutate arrays in Haskell but as Haskell is lazy this will be no problem!
How so? Well we just put lots of chunks into the array and let the algorithm lazily evalute those at needed.
BTW: this is the point where this algorithm can break down: the chunks need quite some memory and if your DP-table is large this will exhaust your memory (look for the knapsackproblem with large data-sets …) but again (this time for sure): for this it will be sufficient (for me)!

So here it is – the final (quite quick) DP-solution to the problem

  import Data.Array
  takeCoinDP :: [Coin] -> Cents -> Maybe (Integer, [Coin])
  takeCoinDP coins cents = get ltCoin cents
      where arr = array ( (0,0), (ltCoin, cents)) [( (i,c), takeC i c) | i <- [0..ltCoin], c <- [0..cents]]
            get i c
              | i < 0 && c == 0 = Just (0, [])
              | i < 0 || c < 0  = Nothing
              | otherwise      = arr!(i,c)
            ltCoin = length coins - 1
            takeC cNr cts
              | coin > cts  = get (cNr-1) cts
              | otherwise   = 
                 case (get cNr (cts-coin), get (cNr-1) cts) of
                    (Just (n, t), Just (n',t')) -> Just $ if n+1 <= n' 
                                                          then (n+1, coin:t) 
                                                          else (n', t')
                    (Nothing,     Just (n',t')) -> Just (n', t')
                    (Just (n,t),  Nothing)      -> Just (n+1, coin:t)
                    (Nothing,     Nothing)      -> Nothing
              where coin = coins !! cNr

  main :: IO ()
  main = do
      putStrLn "let's change 2$34ct"
      let coins = defaultCoins
      let amount = 234

      putStrLn "here we go ... this should be alot quicker..."
      let res = takeCoinDP coins amount
      print res

I hope you see the similarity to the version above.
The only trick here is to move the edge cases to the selection from the array (to avoid index-out-of-range exceptions and stuff).

Enjoy!