SplitSpec.hs 10.3 KB
Newer Older
1
module Copar.Algorithm.SplitSpec (spec) where
2

3
import           Test.Hspec
4
5

import           Control.Monad.ST
6
import           Data.STRef
7
import           Data.List                      ( sort )
8
9

import           Control.Monad.Reader
10
11
12
import qualified Data.Vector                   as V
import qualified Data.Vector.Unboxed           as VU
import           Lens.Micro.Platform
13

14
15
import           Copar.Algorithm.Types
import           Copar.Algorithm.Split
16
import           Data.BlockQueue                ( BlockQueue )
17
import           Data.Partition.Common
18
19
20
21
import           Data.MorphismEncoding          ( fromEdgeRef
                                                , Encoding
                                                )
import qualified Data.MorphismEncoding         as Encoding
22
23
import           Copar.RefinementInterface
import           Copar.Algorithm.Initialize
24
import qualified Data.BlockQueue               as Queue
25
26
import           Copar.Functors.Powerset
import           Copar.Functors.GroupValued
27
import qualified Data.RefinablePartition       as Partition
28
29
import qualified Data.Partition                as Partition
                                                ( toBlocks )
30
31
32
33

spec :: Spec
spec = do
  collectTouchedBlocksSpec
34
  updateBlockSpec
35
  splitBlockSpec
36
  addBlocksToQueueSpec
37
  splitSpec
38

39
40
41

collectTouchedBlocksSpec :: Spec
collectTouchedBlocksSpec = describe "collectTouchedBlocks" $ do
42
43
44
45
46
47
  it "returns an empty list when no predecessors exist" $ do
    withState @Powerset (enc [True, False] [(0, (), 1)])
                        (collectTouchedBlocks (Block 0))
      `shouldBe` []

  it "returns the correct block when predecessors exist" $ do
48
    withState @Powerset (enc [True, True, False] [(0, (), 2), (1, (), 2)])
49
50
                        (map fst <$> collectTouchedBlocks (Block 1))
      `shouldBe` [Block 0]
51

52
53
54
55
  it "doesn't return duplicates" $ do
    withState @Powerset (enc [True, True, False] [(0, (), 2), (1, (), 2)])
                        (map fst <$> collectTouchedBlocks (Block 1))
      `shouldBe` [Block 0]
56

57
58
59
60
61
62
  it "computes the correct v0" $ do
    withState @Powerset (enc [True, True, False] [(0, (), 2), (1, (), 2)])
                        (map snd <$> collectTouchedBlocks (Block 1))
      -- initially, C contains all blocks, so calling update with empty list of
      -- edges to S, the result is: No edges to "outside of C", all edges to C
      -- and no edges to S.
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
63
      `shouldBe` [mkPowerF3 False True False]
64

65
66
67
68
69
  it "marks the correct states" $ do
    let res =
          withState @Powerset (enc [True, True, False] [(0, (), 2), (1, (), 2)])
            $ do
                [(b, _)] <- collectTouchedBlocks (Block 1)
70
                p <- view (_1 . partitionL)
71
72
                VU.toList <$> lift (Partition.markedStates p b)
    res `shouldMatchList` [0, 1]
73

74
75
76
77
78
79
80
81
  it "adds the correct edges to toSub" $ do
    let res =
          withState @Powerset (enc [True, True, False] [(0, (), 2), (1, (), 2)])
            $ do
                _  <- collectTouchedBlocks (Block 1)
                ts <- view (_1 . toSubL) >>= V.freeze
                return (ts & each . each %~ fromEdgeRef & V.toList)
    res `shouldBe` [[0], [1], []]
82
83


84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
updateBlockSpec :: Spec
updateBlockSpec = describe "updateBlock" $ do
  it "resets toSub to all empty lists"
    $ let
        res =
          withState @Powerset (enc [True, True, False] [(0, (), 2), (1, (), 2)])
            $ do
                [(b, v0)] <- collectTouchedBlocks (Block 1)
                updateBlock b v0
                view (_1 . toSubL)
                  >>= V.freeze
                  <&> (each . each %~ fromEdgeRef)
                  <&> V.toList
      in  res `shouldBe` [[], [], []]

  -- Visualization of the graph. Can be rendered with ditaa.
  -- @
  --    e1
  --   /-\
  --   | |
  --   v |
  --  +---+  e0
  --  | 0 +-------\
  --  +-+-+       |
  --    |         v
  --    | e2    +---+
  --    |       | 2 |
  --    |       +---+
  --    v         ^
  --  +---+       |
  --  | 1 |-------/
  --  +---+  e3
  -- @
  it "updates lastW correctly"
    $ let res =
            withState @Powerset
                (enc [True, True, False]
                     [(0, (), 2), (0, (), 0), (0, (), 1), (1, (), 2)]
                )
              $ do
                  [(b, v0)] <- collectTouchedBlocks (Block 1)
                  updateBlock b v0
                  lw <- view (_1 . lastWL) >>= lift . V.freeze
                  lift (lw & V.toList & mapM readSTRef)
128
      in  res
129
130
131
132
            `shouldBe` [ packWeight True 1
                       , packWeight True 2
                       , packWeight True 2
                       , packWeight False 1
133
                       ]
134
135
136

  -- The idea here is that the edges from state 0 to block 1 cancel each other
  -- out and thus the state has a total weight of 0 and must be unmarked.
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
137
  it "unmarks states where F3 is v0"
138
    $ let res =
139
            withState @(GroupValued Int)
140
141
142
143
144
145
146
147
148
149
                (enc [1, 1, 0, 0]
                     [(0, 1, 2), (0, (-1), 3), (1, 1, 3), (0, 1, 1)]
                )
              $ do
                  [(b, v0)] <- collectTouchedBlocks (Block 1)
                  updateBlock b v0
                  p <- view (_1 . partitionL)
                  lift (Partition.markedStates p b) <&> VU.toList
      in  res `shouldBe` [1]

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
150
  it "caches F3 values for all non-v0 states"
151
    $ let res =
152
            withState @(GroupValued Int)
153
154
155
156
157
158
                (enc [1, 1, 0, 0]
                     [(0, 1, 2), (0, (-1), 3), (1, 1, 3), (0, 1, 1)]
                )
              $ do
                  [(b, v0)] <- collectTouchedBlocks (Block 1)
                  updateBlock b v0
159
160
                  f3 <- view (_1 . f3CacheL) >>= lift . V.freeze
                  return (f3 V.! 1)
161
      in  res `shouldBe` (mkGroupF3 0 1)
162
163


164
165
splitBlockSpec :: Spec
splitBlockSpec = describe "splitBlock" $ do
166
167
168
169
170
171
172
173
174
175
  it "splits blocks into marked and unmaked"
    $ let
        res =
          withState @Powerset (enc [True, True, False] [(0, (), 2), (1, (), 0)])
            $ do
                [(b, v0)] <- collectTouchedBlocks (Block 1)
                updateBlock b v0
                splitBlock b
      in  res `shouldMatchList` [Block 0, Block 2]

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
176
  it "splits different F3s into different blocks"
177
178
179
180
181
182
183
184
185
    $ let res =
            withState @(GroupValued Int)
                (enc [3, 3, 3, 0]
                     [(0, 1, 3), (1, 2, 3), (2, 3, 3), (0, 2, 0), (1, 1, 1)]
                )
              $ do
                  [(b, v0)] <- collectTouchedBlocks (Block 1)
                  updateBlock b v0
                  splitBlock b
186
187
      in  res `shouldMatchList` [Block 0, Block 2, Block 3]

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
188
  it "combines equal F3s into the same block"
189
190
191
192
193
194
195
196
197
    $ let res =
            withState @(GroupValued Int)
                (enc [3, 3, 3, 0]
                     [(0, 1, 3), (1, 1, 3), (2, 3, 3), (0, 2, 0), (1, 2, 1)]
                )
              $ do
                  [(b, v0)] <- collectTouchedBlocks (Block 1)
                  updateBlock b v0
                  splitBlock b
198
      in  res `shouldMatchList` [Block 0, Block 2]
199
200


201
202
203
204
addBlocksToQueueSpec :: Spec
addBlocksToQueueSpec = describe "addBlocksToQueue" $ do
  it "doesn't add the largest block to the queue"
    $ let res =
205
            withState @(GroupValued Int)
206
207
208
209
210
211
212
213
214
215
216
                (enc [1, 1, 2, 3] [(0, 1, 0), (1, 1, 1), (2, 2, 2), (3, 3, 3)])
              $ do
                  lift . Queue.clear =<< view _2
                  addBlocksToQueue (Block 0) (map Block [0, 1, 2])
                  q <- lift . Queue.toList =<< view _2
                  p <- view (_1 . partitionL)
                  lift $ forM q $ \b -> Partition.blockSize p b
      in  res `shouldMatchList` ([1, 1])

  it "does add all new blocks, if the original was already queued"
    $ let res =
217
            withState @(GroupValued Int)
218
219
220
221
222
223
224
225
226
                (enc [1, 1, 2, 3] [(0, 1, 0), (1, 1, 1), (2, 2, 2), (3, 3, 3)])
              $ do
                  queue <- view _2
                  lift (Queue.clear queue)
                  lift (Queue.enqueue queue (Block 0))
                  addBlocksToQueue (Block 0) (map Block [0, 1, 2])
                  lift (Queue.toList queue)
      in  res `shouldMatchList` (map Block [0, 1, 2])

227

228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
splitSpec :: Spec
splitSpec = describe "split" $ do
  let encoding =
        (enc
          [10, 10, 10, 1, 1, 20, 20, 0]
          [ (0, 1 , 7)
          , (0, 9 , 0)
          , (1, 2 , 7)
          , (1, 8 , 1)
          , (2, 3 , 7)
          , (2, 7 , 2)
          , (3, 1 , 7)
          , (4, 1 , 4)
          , (5, 20, 6)
          , (6, 20, 5)
          ]
        )

  it "splits all touched blocks correctly"
247
    $ let res = withState @(GroupValued Int) encoding $ do
248
249
250
251
252
253
254
255
256
            p <- view (_1 . partitionL)
            b <- lift (Partition.blockOfState p 7)
            split b
            Partition.toBlocks <$> lift (Partition.freeze p)
      in  (map sort res)
            `shouldMatchList` [[0], [1], [2], [3], [4], [5, 6], [7]]

  it "adds the correct blocks to the queue"
    $ let
257
        res = withState @(GroupValued Int) encoding $ do
258
259
260
261
262
263
264
265
266
267
268
269
270
271
          p  <- view (_1 . partitionL)
          b  <- lift (Partition.blockOfState p 7)
          b3 <- lift (Partition.blockOfState p 3)
          (lift . Queue.delete b) =<< view _2
          (lift . Queue.delete b3) =<< view _2
          split b
          queuedBlocks <- lift . Queue.toList =<< view _2
          lift (mapM (fmap VU.toList . Partition.statesOfBlock p) queuedBlocks)
      in
        res
          `shouldSatisfy` (\l ->
                            ([0] `elem` l)
                              && ([1] `elem` l)
                              && ([2] `elem` l)
272
                              && ([5, 6] `elem` (map sort l))
273
274
275
276
277
                              && (  ([3] `elem` l && not ([4] `elem` l))
                                 || ([4] `elem` l && not ([3] `elem` l))
                                 )
                          )

278
withState
279
280
281
  :: RefinementInterface f
  => Encoding (Label f) (F1 f)
  -> (forall s . SplitM s f a)
282
283
  -> a
withState e action = runST $ do
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
284
  (q, as) <- initialize e True
285
  queue   <- Queue.empty 20
286
287
288
  mapM_ (Queue.enqueue queue) q
  runSplit as queue action

289
runSplit :: AlgoState s f -> BlockQueue s -> SplitM s f a -> ST s a
290
291
runSplit as queue action = runReaderT action (as, queue)

292
293
enc :: [f1] -> [(State, label, State)] -> Encoding label f1
enc f1s transitions = Encoding.new (V.fromList f1s) edges
294
295
296
  where
    edges = V.fromList (map mkEdge transitions)
    mkEdge (from, lab, to) = Encoding.Edge from lab to