Write custom strict folds (#281)
[packages/containers.git] / benchmarks / Sequence.hs
1 module Main where
2
3 import Control.Applicative
4 import Control.DeepSeq (rnf)
5 import Control.Exception (evaluate)
6 import Control.Monad.Trans.State.Strict
7 import Criterion.Main (bench, bgroup, defaultMain, nf)
8 import Data.Foldable (foldl', foldr')
9 import qualified Data.Sequence as S
10 import qualified Data.Foldable
11 import Data.Traversable (traverse)
12 import System.Random (mkStdGen, randoms)
13
14 main = do
15 let s10 = S.fromList [1..10] :: S.Seq Int
16 s100 = S.fromList [1..100] :: S.Seq Int
17 s1000 = S.fromList [1..1000] :: S.Seq Int
18 s10000 = S.fromList [1..10000] :: S.Seq Int
19 evaluate $ rnf [s10, s100, s1000, s10000]
20 let g = mkStdGen 1
21 let rlist n = map (`mod` (n+1)) (take 10000 (randoms g)) :: [Int]
22 r10 = rlist 10
23 r100 = rlist 100
24 r1000 = rlist 1000
25 r10000 = rlist 10000
26 evaluate $ rnf [r10, r100, r1000, r10000]
27 let u10 = S.replicate 10 () :: S.Seq ()
28 u100 = S.replicate 100 () :: S.Seq ()
29 u1000 = S.replicate 1000 () :: S.Seq ()
30 u10000 = S.replicate 10000 () :: S.Seq ()
31 evaluate $ rnf [u10, u100, u1000, u10000]
32 defaultMain
33 [ bgroup "splitAt/append"
34 [ bench "10" $ nf (shuffle r10) s10
35 , bench "100" $ nf (shuffle r100) s100
36 , bench "1000" $ nf (shuffle r1000) s1000
37 ]
38 , bgroup "foldl'"
39 [ bench "10" $ nf (foldl' (+) 0) s10
40 , bench "100" $ nf (foldl' (+) 0) s100
41 , bench "1000" $ nf (foldl' (+) 0) s1000
42 , bench "10000" $ nf (foldl' (+) 0) s10000
43 ]
44 , bgroup "foldr'"
45 [ bench "10" $ nf (foldr' (+) 0) s10
46 , bench "100" $ nf (foldr' (+) 0) s100
47 , bench "1000" $ nf (foldr' (+) 0) s1000
48 , bench "10000" $ nf (foldr' (+) 0) s10000
49 ]
50 , bgroup "update"
51 [ bench "10" $ nf (updatePoints r10 10) s10
52 , bench "100" $ nf (updatePoints r100 10) s100
53 , bench "1000" $ nf (updatePoints r1000 10) s1000
54 ]
55 , bgroup "adjust"
56 [ bench "10" $ nf (adjustPoints r10 (+10)) s10
57 , bench "100" $ nf (adjustPoints r100 (+10)) s100
58 , bench "1000" $ nf (adjustPoints r1000 (+10)) s1000
59 ]
60 , bgroup "deleteAt"
61 [ bench "10" $ nf (deleteAtPoints r10) s10
62 , bench "100" $ nf (deleteAtPoints r100) s100
63 , bench "1000" $ nf (deleteAtPoints r1000) s1000
64 ]
65 , bgroup "insertAt"
66 [ bench "10" $ nf (insertAtPoints r10 10) s10
67 , bench "100" $ nf (insertAtPoints r100 10) s100
68 , bench "1000" $ nf (insertAtPoints r1000 10) s1000
69 ]
70 , bgroup "traverseWithIndex/State"
71 [ bench "10" $ nf multiplyDown s10
72 , bench "100" $ nf multiplyDown s100
73 , bench "1000" $ nf multiplyDown s1000
74 ]
75 , bgroup "traverse/State"
76 [ bench "10" $ nf multiplyUp s10
77 , bench "100" $ nf multiplyUp s100
78 , bench "1000" $ nf multiplyUp s1000
79 ]
80 , bgroup "replicateA/State"
81 [ bench "10" $ nf stateReplicate 10
82 , bench "100" $ nf stateReplicate 100
83 , bench "1000" $ nf stateReplicate 1000
84 ]
85 , bgroup "zip"
86 [ bench "ix10000/5000" $ nf (\(xs,ys) -> S.zip xs ys `S.index` 5000) (s10000, u10000)
87 , bench "nf100" $ nf (uncurry S.zip) (s100, u100)
88 , bench "nf10000" $ nf (uncurry S.zip) (s10000, u10000)
89 ]
90 , bgroup "fromFunction"
91 [ bench "ix10000/5000" $ nf (\s -> S.fromFunction s (+1) `S.index` (s `div` 2)) 10000
92 , bench "nf10" $ nf (\s -> S.fromFunction s (+1)) 10
93 , bench "nf100" $ nf (\s -> S.fromFunction s (+1)) 100
94 , bench "nf1000" $ nf (\s -> S.fromFunction s (+1)) 1000
95 , bench "nf10000" $ nf (\s -> S.fromFunction s (+1)) 10000
96 ]
97 , bgroup "<*>"
98 [ bench "ix500/1000^2" $
99 nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s `div` 2)) (S.fromFunction 1000 (+1))
100 , bench "ix500000/1000^2" $
101 nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s * S.length s `div` 2)) (S.fromFunction 1000 (+1))
102 , bench "ixBIG" $
103 nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s * S.length s `div` 2))
104 (S.fromFunction (floor (sqrt $ fromIntegral (maxBound::Int))-10) (+1))
105 , bench "nf100/2500/rep" $
106 nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (100,2500)
107 , bench "nf100/2500/ff" $
108 nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (100,2500)
109 , bench "nf500/500/rep" $
110 nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (500,500)
111 , bench "nf500/500/ff" $
112 nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (500,500)
113 , bench "nf2500/100/rep" $
114 nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (2500,100)
115 , bench "nf2500/100/ff" $
116 nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (2500,100)
117 ]
118 ]
119
120 {-
121 -- This is around 4.6 times as slow as insertAt
122 fakeInsertAt :: Int -> a -> S.Seq a -> S.Seq a
123 fakeInsertAt i x xs = case S.splitAt i xs of
124 (before, after) -> before S.>< x S.<| after
125 -}
126
127 adjustPoints :: [Int] -> (a -> a) -> S.Seq a -> S.Seq a
128 adjustPoints points f xs =
129 foldl' (\acc k -> S.adjust f k acc) xs points
130
131 insertAtPoints :: [Int] -> a -> S.Seq a -> S.Seq a
132 insertAtPoints points x xs =
133 foldl' (\acc k -> S.insertAt k x acc) xs points
134
135 updatePoints :: [Int] -> a -> S.Seq a -> S.Seq a
136 updatePoints points x xs =
137 foldl' (\acc k -> S.update k x acc) xs points
138
139 {-
140 -- For comparison. Using the old implementation of update,
141 -- which this simulates, can cause thunks to build up in the leaves.
142 fakeupdatePoints :: [Int] -> a -> S.Seq a -> S.Seq a
143 fakeupdatePoints points x xs =
144 foldl' (\acc k -> S.adjust (const x) k acc) xs points
145 -}
146
147 deleteAtPoints :: [Int] -> S.Seq a -> S.Seq a
148 deleteAtPoints points xs =
149 foldl' (\acc k -> S.deleteAt k acc) xs points
150
151 {-
152 fakedeleteAtPoints :: [Int] -> S.Seq a -> S.Seq a
153 fakedeleteAtPoints points xs =
154 foldl' (\acc k -> fakeDeleteAt k acc) xs points
155
156 -- For comparison with deleteAt. deleteAt is several
157 -- times faster for long sequences.
158 fakeDeleteAt :: Int -> S.Seq a -> S.Seq a
159 fakeDeleteAt i xs
160 | 0 < i && i < S.length xs = case S.splitAt i xs of
161 (before, after) -> before S.>< S.drop 1 after
162 | otherwise = xs
163 -}
164
165 -- splitAt+append: repeatedly cut the sequence at a random point
166 -- and rejoin the pieces in the opposite order.
167 -- Finally getting the middle element forces the whole spine.
168 shuffle :: [Int] -> S.Seq Int -> Int
169 shuffle ps s = case S.viewl (S.drop (S.length s `div` 2) (foldl' cut s ps)) of
170 x S.:< _ -> x
171 where cut xs p = let (front, back) = S.splitAt p xs in back S.>< front
172
173 stateReplicate :: Int -> S.Seq Char
174 stateReplicate n = flip evalState 0 . S.replicateA n $ do
175 old <- get
176 if old > (10 :: Int) then put 0 else put (old + 1)
177 return $ toEnum old
178
179 multiplyUp :: S.Seq Int -> S.Seq Int
180 multiplyUp = flip evalState 0 . traverse go where
181 go x = do
182 s <- get
183 put (s + 1)
184 return (s * x)
185
186 multiplyDown :: S.Seq Int -> S.Seq Int
187 multiplyDown = flip evalState 0 . S.traverseWithIndex go where
188 go i x = do
189 s <- get
190 put (s - 1)
191 return (s * i * x)