update to work with the latest parallel package
[nofib.git] / parallel / coins / coins.hs
1 {-# LANGUAGE BangPatterns #-}
2
3 import Data.List
4 import System.Environment
5 import Control.Parallel
6 import Control.Parallel.Strategies
7 import Control.Applicative
8
9 -- Rough results, GHC 6.13: (val=777)
10 -- V1 (SDM): 2.2s
11 -- V2 (SDM): 2.7s
12 -- V3 (SDM, parallel): 1.0s on 7 cores
13 -- V4 (original): got bored waiting
14 -- V5 (HWL assoc): 5.2s
15 -- V6 (SDM, Int result): 0.9s
16 -- V7 (SDM, parallel): 0.2s on 7 cores
17
18 -----------------------------------------------------------------------------
19 -- Version 1: returns results as a list of list of coins
20
21 payL :: Int -> [(Int,Int)] -> [Int] -> [[Int]]
22 payL 0 coins acc = [acc]
23 payL _ [] acc = []
24 payL val ((c,q):coins) acc
25 | c > val = payL val coins acc
26 | otherwise = left ++ right
27 where
28 left = payL (val - c) coins' (c:acc)
29 right = payL val coins acc
30
31 coins' | q == 1 = coins
32 | otherwise = (c,q-1) : coins
33
34 -----------------------------------------------------------------------------
35 -- Version 2: uses a custom AList type to avoid repeated appends
36
37 -- The idea here is that by avoiding the append we might be able to
38 -- parallelise this more easily by just forcing evaluation to WHNF at
39 -- each level. I haven't parallelised this version yet, though (V5
40 -- below is much easier) --SDM
41
42 data AList a = ANil | ASing a | Append (AList a) (AList a)
43
44 lenA :: AList a -> Int
45 lenA ANil = 0
46 lenA (ASing _) = 1
47 lenA (Append l r) = lenA l + lenA r
48
49 append ANil r = r
50 append l ANil = l -- **
51 append l r = Append l r
52
53 -- making append less strict (omit ** above) can make the algorithm
54 -- faster in sequential mode, because it runs in constant space.
55 -- However, ** helps parallelism.
56
57 payA :: Int -> [(Int,Int)] -> [Int] -> AList [Int]
58 payA 0 coins acc = ASing acc
59 payA _ [] acc = ANil
60 payA val ((c,q):coins) acc
61 | c > val = payA val coins acc
62 | otherwise = append left right -- strict in l, maybe strict in r
63 where
64 left = payA (val - c) coins' (c:acc)
65 right = payA val coins acc
66 coins' | q == 1 = coins
67 | otherwise = (c,q-1) : coins
68
69 -----------------------------------------------------------------------------
70 -- Version 3: parallel version of V2
71
72 payA_par :: Int -> Int -> [(Int,Int)] -> [Int] -> AList [Int]
73 payA_par 0 val coins acc = payA val coins acc
74 payA_par _ 0 coins acc = ASing acc
75 payA_par _ _ [] acc = ANil
76 payA_par depth val ((c,q):coins) acc
77 | c > val = payA_par depth val coins acc
78 | otherwise = res
79
80 where
81 res = runEval $ pure append <*> rpar left <*> rseq right
82
83 left = payA_par (if q == 1 then (depth-1) else depth) (val - c) coins' (c:acc)
84 right = payA_par (depth-1) val coins acc
85
86 coins' | q == 1 = coins
87 | otherwise = (c,q-1) : coins
88
89 -----------------------------------------------------------------------------
90 -- Version 4: original list-of-list version (very slow)
91
92 pay :: Int -> Int -> [Int] -> [Int] -> [[Int]]
93 pay _ 0 coins accum = [accum]
94 pay _ val [] _ = []
95 pay pri val coins accum =
96 res
97 where --
98 coins' = dropWhile (>val) coins
99 coin_vals = nub coins'
100 res = concat ( map
101 ( \ c -> let
102 new_coins =
103 ((dropWhile (>c) coins')\\[c])
104 in
105 pay (pri-1)
106 (val-c)
107 new_coins
108 (c:accum)
109 )
110 coin_vals )
111
112
113 -----------------------------------------------------------------------------
114 -- Version 5: assoc-list version (by HWL?)
115
116 -- assoc-list-based version; still multiple list traversals
117 pay1 :: Int -> Int -> [(Int,Int)] -> [(Int,Int)] -> [[(Int,Int)]]
118 pay1 _ 0 coins accum = [accum]
119 pay1 _ val [] _ = []
120 pay1 pri val coins accum = res
121 where --
122 coins' = dropWhile ((>val) . fst) coins
123 res = concat (
124 map
125 ( \ (c,q) -> let
126 -- several traversals
127 new_coins =
128 filter (not . (==0) . snd) $
129 map (\ x'@(c',q') -> if c==c' then (c',q'-1) else x') $
130 dropWhile ((>c) . fst) $
131 coins'
132 new_accum =
133 map (\ x'@(c',q') -> if c==c' then (c',q'+1) else x') accum
134 in
135 pay1 (pri-1)
136 (val-c)
137 new_coins
138 new_accum
139 )
140 coins' )
141
142 -----------------------------------------------------------------------------
143 -- Version 6: just return the number of results, not the results themselves
144
145 payN :: Int -> [(Int,Int)] -> Int
146 payN 0 coins = 1
147 payN _ [] = 0
148 payN val ((c,q):coins)
149 | c > val = payN val coins
150 | otherwise = left + right
151 where
152 left = payN (val - c) coins'
153 right = payN val coins
154
155 coins' | q == 1 = coins
156 | otherwise = (c,q-1) : coins
157
158 -----------------------------------------------------------------------------
159 -- Version 7: parallel version of payN
160
161 payN_par :: Int -> Int -> [(Int,Int)] -> Int
162 payN_par 0 val coins = payN val coins
163 payN_par _ 0 coins = 1
164 payN_par _ _ [] = 0
165 payN_par depth val ((c,q):coins)
166 | c > val = payN_par depth val coins
167 | otherwise = res
168
169 where
170 res = right `par` left `pseq` left + right
171
172 left = payN_par (if q == 1 then (depth-1) else depth) (val - c) coins'
173 right = payN_par (depth-1) val coins
174
175 coins' | q == 1 = coins
176 | otherwise = (c,q-1) : coins
177
178 -----------------------------------------------------------------------------
179 -- driver
180
181 main = do
182 let vals = [250, 100, 25, 10, 5, 1]
183 -- let quants = [1, 3, 2, 5, 7, 12] -- small setup
184 -- let quants = [5, 8, 8, 9, 12, 17] -- std setup
185 let quants = [55, 88, 88, 99, 122, 177] -- large setup
186
187 let coins = concat (zipWith replicate quants vals)
188 coins1 = zip vals quants
189
190 [n, arg] <- fmap (fmap read) getArgs
191
192 case n of
193 -- sequential, list of results
194 1 -> print $ length $ payL arg coins1 []
195 -- sequential, append-list of results
196 2 -> print $ lenA $ payA arg coins1 []
197 -- parallel, append-list of results
198 3 -> print $ lenA $ payA_par 3 arg coins1 []
199
200 4 -> print $ length (pay 0 arg coins [])
201 5 -> print $ length (pay1 0 arg coins1 (map (\(c,q) -> (c,0)) coins1))
202 6 -> print $ payN arg coins1
203 7 -> print $ payN_par 4 arg coins1