Coins.hs

#!/usr/bin/env stack
-- stack script --resolver lts-18.18

module Main (main) where

import Control.Applicative    (liftA2)
import Control.Comonad        (extract)
import Control.Comonad.Cofree (Cofree ((:<)))
import Control.Monad          (forM_)
import Control.Monad.ST       (runST)
import Data.Functor.Foldable  (hylo, ListF (Nil, Cons))
import Data.List              (sort)
import qualified Criterion.Main as C
import qualified Data.Vector.Mutable as MV
import qualified Test.QuickCheck as Q

-- This process is based on Recursion Schemes for Dynamic Programming
-- https://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.60.9336&rep=rep1&type=pdf

dyna :: Functor f => (f (Cofree f b) -> b) -> (a -> f a) -> a -> b
dyna alg coalg = extract . hylo alg' coalg where alg' x = alg x :< x

-- Another equivalent definition
-- dyna alg coalg = ghylo distHisto distAna alg (fmap Identity . coalg)

-- For these, I assume that 'coins' is non-empty, non-decreasing, and includes 1

-- The basic definition. This is simple and inefficient
coins0 :: [Int] -> Int -> Int
coins0 coins = go where
    go 0 = 0
    go n = 1 + minimum (map go $ map (n -) $ takeWhile (<= n) coins)

-- The algorithm, rewritten to use a hylomorphism.
-- Not any more or less efficient.
-- Our functor is F(X) = 1 + NonEmptyList_X, which is the same as '[]'
coins1 :: [Int] -> Int -> Int
coins1 coins = hylo alg coalg where
    alg :: [Int] -> Int
    alg [] = 0
    alg ns = 1 + minimum ns

    coalg :: Int -> [Int]
    coalg 0 = []
    coalg n = map (n -) $ takeWhile (<= n) coins

-- The algorithm using a dynamorphism.
-- The 'ListF Int' functor represents the creation of the caching list.
coins2 :: [Int] -> Int -> Int
coins2 coins = dyna (alg . sigma) coalg where
    -- The same algebra as above
    alg :: [Int] -> Int
    alg [] = 0
    alg ns = 1 + minimum ns

    -- Perform the recursion using lookup via 'pi'
    sigma :: ListF Int (Cofree (ListF Int) Int) -> [Int]
    sigma Nil = []
    sigma (Cons n xs) = map (flip pi xs) $ map (n -) $ takeWhile (<= n) coins

    -- Look through the history to find the previous computation of 'n'
    pi :: Int -> Cofree (ListF Int) a -> a
    pi n = go where
        go (m :< Cons n' _) | n == n' = m
        go (m :< Nil) | n == 0 = m
        go (_ :< Cons _ xs) = go xs
        go _ = error "Partial function"

    -- This builds up the caching vector algebraically
    coalg :: Int -> ListF Int Int
    coalg 0 = Nil
    coalg n = Cons n (n - 1)

-- Direct translation of the C++ ring buffer implementation
coins3 :: [Int] -> Int -> Int
coins3 coins amt = runST $ do
    let bufSize = maximum coins + 1
    buffer <- MV.new bufSize
    MV.unsafeWrite buffer 0 0
    forM_ [1 .. amt] $ \a -> do
        let cur = a `mod` bufSize
        MV.unsafeWrite buffer cur maxBound
        forM_ (takeWhile (a >=) coins) $ \c -> do
            let prev = (a - c) `mod` bufSize
            bc <- MV.unsafeRead buffer cur
            bp <- MV.unsafeRead buffer prev
            MV.unsafeWrite buffer cur (min bc (bp + 1))
    MV.unsafeRead buffer (amt `mod` bufSize)

-- Benchmarking    

arbitraryCoins :: Int -> IO [Int]
arbitraryCoins n = Q.generate $ (1:) . sort <$> Q.vectorOf (n-1) (Q.chooseInt (2,50))

arbitraryAmount :: Int -> IO Int
arbitraryAmount n = Q.generate $ Q.chooseInt (n, n + 100)

main :: IO ()
main = C.defaultMain
    [ C.env (liftA2 (,) (arbitraryCoins 5) (arbitraryAmount 300)) $
        \ ~(coins, amt) -> C.bgroup "5 coins/200-300 amount"
            [ C.bench "dynamorphism" $ C.nf (coins2 coins) amt
            , C.bench "mutable" $ C.nf (coins3 coins) amt
            ]
    , C.env (liftA2 (,) (arbitraryCoins 6) (arbitraryAmount 400)) $
        \ ~(coins, amt) -> C.bgroup "6 coins/400-500 amount"
            [ C.bench "dynamorphism" $ C.nf (coins2 coins) amt
            , C.bench "mutable" $ C.nf (coins3 coins) amt
            ]
    ]

output.txt

benchmarking 5 coins/200-300 amount/dynamorphism
time                 11.11 ms   (10.61 ms .. 11.48 ms)
                     0.992 R²   (0.986 R² .. 0.998 R²)
mean                 11.47 ms   (11.23 ms .. 11.63 ms)
std dev              512.9 μs   (362.2 μs .. 707.9 μs)
variance introduced by outliers: 17% (moderately inflated)

benchmarking 5 coins/200-300 amount/mutable
time                 1.891 ms   (1.869 ms .. 1.909 ms)
                     0.999 R²   (0.999 R² .. 1.000 R²)
mean                 1.888 ms   (1.879 ms .. 1.898 ms)
std dev              32.78 μs   (27.79 μs .. 40.06 μs)

benchmarking 6 coins/400-500 amount/dynamorphism
time                 15.14 ms   (14.19 ms .. 16.03 ms)
                     0.987 R²   (0.974 R² .. 0.997 R²)
mean                 15.54 ms   (15.21 ms .. 15.77 ms)
std dev              674.6 μs   (426.4 μs .. 980.3 μs)
variance introduced by outliers: 16% (moderately inflated)

benchmarking 6 coins/400-500 amount/mutable
time                 3.656 ms   (3.607 ms .. 3.714 ms)
                     0.998 R²   (0.996 R² .. 0.999 R²)
mean                 3.610 ms   (3.558 ms .. 3.649 ms)
std dev              143.6 μs   (100.1 μs .. 194.5 μs)
variance introduced by outliers: 21% (moderately inflated)