Commit 2288f53d authored by Simon Marlow's avatar Simon Marlow

add coins example

parent 3eff07c1
TOP = ../..
include $(TOP)/mk/boilerplate.mk
SRC_RUNTEST_OPTS += 3 863
SRC_HC_OPTS += -package parallel
include $(TOP)/mk/target.mk
{-# LANGUAGE BangPatterns #-}
import Data.List
import System.Environment
import Control.Parallel
-- Rough results, GHC 6.13: (val=777)
-- V1 (SDM): 2.2s
-- V2 (SDM): 2.7s
-- V3 (SDM, parallel): 1.0s on 7 cores
-- V4 (original): got bored waiting
-- V5 (HWL assoc): 5.2s
-- V6 (SDM, Int result): 0.9s
-- V7 (SDM, parallel): 0.2s on 7 cores
-----------------------------------------------------------------------------
-- Version 1: returns results as a list of list of coins
payL :: Int -> [(Int,Int)] -> [Int] -> [[Int]]
payL 0 coins acc = [acc]
payL _ [] acc = []
payL val ((c,q):coins) acc
| c > val = payL val coins acc
| otherwise = left ++ right
where
left = payL (val - c) coins' (c:acc)
right = payL val coins acc
coins' | q == 1 = coins
| otherwise = (c,q-1) : coins
-----------------------------------------------------------------------------
-- Version 2: uses a custom AList type to avoid repeated appends
-- The idea here is that by avoiding the append we might be able to
-- parallelise this more easily by just forcing evaluation to WHNF at
-- each level. I haven't parallelised this version yet, though (V5
-- below is much easier) --SDM
data AList a = ANil | ASing a | Append (AList a) (AList a)
lenA :: AList a -> Int
lenA ANil = 0
lenA (ASing _) = 1
lenA (Append l r) = lenA l + lenA r
append ANil r = r
append l ANil = l -- **
append l r = Append l r
-- making append less strict (omit ** above) can make the algorithm
-- faster in sequential mode, because it runs in constant space.
-- However, ** helps parallelism.
payA :: Int -> [(Int,Int)] -> [Int] -> AList [Int]
payA 0 coins acc = ASing acc
payA _ [] acc = ANil
payA val ((c,q):coins) acc
| c > val = payA val coins acc
| otherwise = append left right -- strict in l, maybe strict in r
where
left = payA (val - c) coins' (c:acc)
right = payA val coins acc
coins' | q == 1 = coins
| otherwise = (c,q-1) : coins
-----------------------------------------------------------------------------
-- Version 3: parallel version of V2
payA_par :: Int -> Int -> [(Int,Int)] -> [Int] -> AList [Int]
payA_par 0 val coins acc = payA val coins acc
payA_par _ 0 coins acc = ASing acc
payA_par _ _ [] acc = ANil
payA_par depth val ((c,q):coins) acc
| c > val = payA_par depth val coins acc
| otherwise = res
where
res = right `par` left `pseq` append left right
left = payA_par (if q == 1 then (depth-1) else depth) (val - c) coins' (c:acc)
right = payA_par (depth-1) val coins acc
coins' | q == 1 = coins
| otherwise = (c,q-1) : coins
-----------------------------------------------------------------------------
-- Version 4: original list-of-list version (very slow)
pay :: Int -> Int -> [Int] -> [Int] -> [[Int]]
pay _ 0 coins accum = [accum]
pay _ val [] _ = []
pay pri val coins accum =
res
where --
coins' = dropWhile (>val) coins
coin_vals = nub coins'
res = concat ( map
( \ c -> let
new_coins =
((dropWhile (>c) coins')\\[c])
in
pay (pri-1)
(val-c)
new_coins
(c:accum)
)
coin_vals )
-----------------------------------------------------------------------------
-- Version 5: assoc-list version (by HWL?)
-- assoc-list-based version; still multiple list traversals
pay1 :: Int -> Int -> [(Int,Int)] -> [(Int,Int)] -> [[(Int,Int)]]
pay1 _ 0 coins accum = [accum]
pay1 _ val [] _ = []
pay1 pri val coins accum = res
where --
coins' = dropWhile ((>val) . fst) coins
res = concat (
map
( \ (c,q) -> let
-- several traversals
new_coins =
filter (not . (==0) . snd) $
map (\ x'@(c',q') -> if c==c' then (c',q'-1) else x') $
dropWhile ((>c) . fst) $
coins'
new_accum =
map (\ x'@(c',q') -> if c==c' then (c',q'+1) else x') accum
in
pay1 (pri-1)
(val-c)
new_coins
new_accum
)
coins' )
-----------------------------------------------------------------------------
-- Version 6: just return the number of results, not the results themselves
payN :: Int -> [(Int,Int)] -> Int
payN 0 coins = 1
payN _ [] = 0
payN val ((c,q):coins)
| c > val = payN val coins
| otherwise = left + right
where
left = payN (val - c) coins'
right = payN val coins
coins' | q == 1 = coins
| otherwise = (c,q-1) : coins
-----------------------------------------------------------------------------
-- Version 7: parallel version of payN
payN_par :: Int -> Int -> [(Int,Int)] -> Int
payN_par 0 val coins = payN val coins
payN_par _ 0 coins = 1
payN_par _ _ [] = 0
payN_par depth val ((c,q):coins)
| c > val = payN_par depth val coins
| otherwise = res
where
res = right `par` left `pseq` left + right
left = payN_par (if q == 1 then (depth-1) else depth) (val - c) coins'
right = payN_par (depth-1) val coins
coins' | q == 1 = coins
| otherwise = (c,q-1) : coins
-----------------------------------------------------------------------------
-- driver
main = do
let vals = [250, 100, 25, 10, 5, 1]
-- let quants = [1, 3, 2, 5, 7, 12] -- small setup
-- let quants = [5, 8, 8, 9, 12, 17] -- std setup
let quants = [55, 88, 88, 99, 122, 177] -- large setup
let coins = concat (zipWith replicate quants vals)
coins1 = zip vals quants
[n, arg] <- fmap (fmap read) getArgs
case n of
-- sequential, list of results
1 -> print $ length $ payL arg coins1 []
-- sequential, append-list of results
2 -> print $ lenA $ payA arg coins1 []
-- parallel, append-list of results
3 -> print $ lenA $ payA_par 4 arg coins1 []
4 -> print $ length (pay 0 arg coins [])
5 -> print $ length (pay1 0 arg coins1 (map (\(c,q) -> (c,0)) coins1))
6 -> print $ payN arg coins1
7 -> print $ payN_par 4 arg coins1
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment