RefinablePartitionSpec.hs 15 KB
Newer Older
1
2
3
4
5
6
7
module Data.RefinablePartitionSpec (spec) where

import Test.Hspec
import Test.QuickCheck

import Control.Exception (ErrorCall(..))
import Control.Monad.ST
8
import Data.Foldable
9
import Data.Function (on)
10
import Data.List (intersect, isInfixOf,sort,nubBy)
11
12
import Data.Maybe (isJust,isNothing,fromJust)

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
13
14
import qualified Data.Vector as V
import qualified Data.Vector.Algorithms.Intro as V
15
import qualified Data.Vector.Unboxed as VU
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
16

17
18
19
20
21
22
23
import Data.RefinablePartition

spec :: Spec
spec = do
  makeSpec
  statesOfBlockSpec
  markSpec
24
  unmarkSpec
25
  hasMarkedSpec
26
  markedStatesSpec
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
  splitMarkedSpec
  splitBySpec
  groupBySpec

makeSpec :: Spec
makeSpec = describe "make" $ do
  let initPart s
        | s < 3 = 0
        | s < 7 || s > 8 = 1
        | otherwise = 2

  it "creates blocks of the correct size" $
    let test p = (,,) <$> blockSize p 0 <*> blockSize p 1 <*> blockSize p 2
    in runST (make 10 3 initPart >>= test) `shouldBe` (3,5,2)

  it "assignes the states to blocks correctly" $
    let test p = mapM (blockOfState p) [0..9]
    in runST (make 10 3 initPart >>= test) `shouldBe` [0,0,0,1,1,1,1,2,2,1]

  it "errors out with more blocks than states" $
    stToIO (make 2 3 initPart) `shouldThrow` errorContaining "states"

  it "errors out with zero blocks, but some states" $
    stToIO (make 2 0 initPart) `shouldThrow` errorContaining "blocks"

  it "doesn't mark any states initially" $
    let test p = mapM (isMarked p) [0..9]
    in runST (make 10 3 initPart >>= test) `shouldBe` replicate 10 False

statesOfBlockSpec :: Spec
statesOfBlockSpec = describe "statesOfBlock" $ do
  let initPart s
        | s < 3 = 0
        | s < 7 || s > 8 = 1
        | otherwise = 2

  it "returns the correct states" $
64
    VU.toList (runST (make 10 3 initPart >>= flip statesOfBlock 1))
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
65
      `shouldMatchList` [3,4,5,6,9]
66
67

  it "works with empty blocks" $
68
    VU.toList (runST (make 5 3 initPart >>= flip statesOfBlock 2))
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
69
      `shouldMatchList` []
70
71

  it "works with block containing all states" $
72
    VU.toList (runST (make 3 3 initPart >>= flip statesOfBlock 0))
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
73
      `shouldMatchList` [0,1,2]
74
75
76
77
78
79
80
81
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

markSpec :: Spec
markSpec = describe "mark" $ do
  let initPart s
        | s < 3 = 0
        | s < 7 || s > 8 = 1
        | otherwise = 2

  it "it marks the correct state" $
    let doMark i = runST $ do
          p <- make 10 3 initPart
          mark p i
          isMarked p i
    in
      property $ forAll (elements [0..9]) $ \(i::Int) ->
        doMark (fromIntegral i) === True

  it "doesn't mark another state" $
    let doMark i = runST $ do
          p <- make 10 3 initPart
          mark p i
          mapM (isMarked p) [x | x <- [0..9], x /= i]
    in
      property $ forAll (elements [0..9]) $ \i ->
        doMark i === replicate 9 False

  it "works when marking many states in one block" $
    let res = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) [4,5,9]
          mapM (isMarked p) [4,5,9,6]
    in
      res `shouldBe` [True,True,True,False]

  it "works when marking all states in one block" $
    let res = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) [4,5,6,9]
          mapM (isMarked p) [4,5,9,6]
    in
      res `shouldBe` [True,True,True,True]

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
unmarkSpec :: Spec
unmarkSpec = describe "unmark" $ do
  let initPart s
        | s < 3 = 0
        | s < 7 || s > 8 = 1
        | otherwise = 2

  it "it unmarks the correct state" $
    let doMark i = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) [0..9]
          unmark p i
          isMarked p i
    in
      property $ forAll (elements [0..9]) $ \(i::Int) ->
        doMark (fromIntegral i) === False

  it "doesn't unmark other states" $
    let doMark i = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) [0..9]
          unmark p i
          mapM (isMarked p) [x | x <- [0..9], x /= i]
    in
      property $ forAll (elements [0..9]) $ \i ->
        doMark i === replicate 9 True

  it "works when unmarking many states in one block" $
    let res = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) [0..9]
          mapM_ (unmark p) [4,5,9]
          mapM (isMarked p) [4,5,9,6]
    in
      res `shouldBe` [False,False,False,True]

  it "works when marking all states in one block" $
    let res = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) [0..9]
          mapM_ (unmark p) [4,5,6,9]
          mapM (isMarked p) [4,5,9,6]
    in
      res `shouldBe` [False,False,False,False]

  it "it is the inverse of mark" $
    let doMark i = runST $ do
          p <- make 10 3 initPart
          mark p i
          unmark p i
          hasMarked p =<< blockOfState p i
    in
      property $ forAll (elements [0..9]) $ \(i::Int) ->
        doMark (fromIntegral i) === False

171
172
173
174
175
176
177
178
179
180
181
182
183
hasMarkedSpec :: Spec
hasMarkedSpec = describe "hasMarked" $ do
  let initPart s
        | s < 3 = 0
        | s < 7 || s > 8 = 1
        | otherwise = 2

  it "initially reports false for every block" $
    let res = runST $ do
          p <- make 10 3 initPart
          mapM (hasMarked p) [0,1,2]
    in res `shouldBe` [False,False,False]

184
185
186
187
188
189
190
191
192
  it "reports false if we mark and then umark all states" $
    let res = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) [0..9]
          mapM_ (unmark p) [0..9]
          mapM (hasMarked p) [0,1,2]
    in
      res `shouldBe` [False,False,False]

193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
  it "reports a block as marked when one of its states get marked" $
    let doMark st = runST $ do
          p <- make 10 3 initPart
          mark p st
          blk <- blockOfState p st
          hasMarked p blk
    in
      property $ forAll (elements [0..9]) $ \i ->
        doMark i === True

  it "can handle the case where every state in the block is marked" $
    let doMark is blk = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) is
          hasMarked p blk
    in
      doMark [0,1,2] 0 `shouldBe` True

211
212
213
214
215
216
217
218
219
220
221
222
223
markedStatesSpec :: Spec
markedStatesSpec = describe "markedStates" $ do
  let initPart s
        | s < 3 = 0
        | s < 7 || s > 8 = 1
        | otherwise = 2

  it "returns the marked states" $
    let doMark states blk = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) states

          marked <- markedStates p blk
224
225
          blockStates <- VU.toList <$> statesOfBlock p blk
          return $ sort (intersect states blockStates) == sort (VU.toList marked)
226
227
228
229
230
231
    in
      property $
        forAll (arbitraryBlock 3) $ \block ->
        forAll (arbitraryStates 10) $ \states ->
          doMark states block === True

232
233
234
235
236
237
238
239
240
241
242
splitMarkedSpec :: Spec
splitMarkedSpec = describe "splitMarkedSpec" $ do
  let initPart s
        | s < 3 = 0
        | s < 7 || s > 8 = 1
        | otherwise = 2

  it "assignes all previously marked states to block 1" $
    let doIt markStates block = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) markStates
243
          markedPreviously <- statesOfBlock p block >>= VU.filterM (isMarked p)
244
          (a, _) <- splitMarked p block
245
          nowInBlock <- maybe (return VU.empty) (statesOfBlock p) a
246
247
248
249
250
251
252
253
254
255
256
257
258
          return (nowInBlock, markedPreviously)
    in
      property $
        forAll (arbitraryBlock 3) $ \block ->
        forAll (arbitraryStates 10) $ \states ->
          let (nowInBlock, markedPreviously) = doIt states block
          in nowInBlock === markedPreviously

  it "assignes all previously unmarked states to block 2" $
    let doIt markStates block = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) markStates
          unMarkedPreviously <- statesOfBlock p block
259
            >>= VU.filterM (fmap not . isMarked p)
260
          (_, b) <- splitMarked p block
261
          nowInBlock <- maybe (return VU.empty) (statesOfBlock p) b
262
263
264
265
266
267
268
269
270
271
272
273
274
275
          return (nowInBlock, unMarkedPreviously)
    in
      property $
        forAll (arbitraryBlock 3) $ \block ->
        forAll (arbitraryStates 10) $ \states ->
          let (nowInBlock, markedPreviously) = doIt states block
          in nowInBlock === markedPreviously

  it "unmarks all states in the new blocks" $
    let doIt markStates block = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) markStates
          blockStates <- statesOfBlock p block
          _ <- splitMarked p block
276
          VU.mapM (isMarked p) blockStates
277
278
279
280
    in
      property $
        forAll (arbitraryBlock 3) $ \block ->
        forAll (arbitraryStates 10) $ \states ->
281
          doIt states block `shouldSatisfy` VU.all (==False)
282
283
284
285
286
287
288

  it "works without marked states" $
    let doIt = runST $ do
          p <- make 10 3 initPart
          (Nothing, Just b) <- splitMarked p 1
          statesOfBlock p b
    in
289
      VU.toList doIt `shouldMatchList` [3,4,5,6,9]
290
291
292
293
294
295
296
297

  it "works without unmarked states" $
    let doIt = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) [3,4,5,6,9]
          (Just b, Nothing) <- splitMarked p 1
          statesOfBlock p b
    in
298
      VU.toList doIt `shouldMatchList` [3,4,5,6,9]
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339

  it "gives the identity of the original block to the largest new block" $
    let doIt markStates block = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) markStates
          (a, b) <- splitMarked p block
          a' <- traverse (\x -> (x,) <$> blockSize p x) a
          b' <- traverse (\x -> (x,) <$> blockSize p x) b
          return (a', b')
    in
      property $
        forAll (arbitraryBlock 3) $ \block ->
        forAll (arbitraryStates 10) $ \states ->
          case doIt states block of
            (Just (a,asize), Just (b,bsize)) ->
              counterexample (show ((a,asize), (b,bsize))) $
                if asize > bsize then a === block else b === block
            _ -> property Discard

  it "shares the identity of the original block if only one new block is created" $
    let doIt markStates block = runST $ do
          p <- make 10 3 initPart
          mapM_ (mark p) markStates
          (a, b) <- splitMarked p block
          return (block, a, b)
    in
      property $
        forAll (arbitraryBlock 3) $ \block ->
        forAll (arbitraryStates 10) $ \states ->
          let (old,marked,unmarked) = doIt states block
          in isNothing unmarked ==> (Just old === marked)

splitBySpec :: Spec
splitBySpec = describe "splitBy" $ do
  let predicate = odd

  it "assignes all states matching the predicate to block 1" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let
          (oldStates, newA, _) = split block predicate
340
          matchingStates = V.convert $ V.filter predicate oldStates
341
342
        in
          not (null matchingStates) ==>
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
343
            (isJust newA .&. vSort (snd (fromJust newA)) === vSort matchingStates)
344
345
346
347
348
349

  it "assignes all states not matching the predicate to block 2" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let
          (oldStates, _, newB) = split block predicate
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
350
          nonMatchingStates = V.filter (not . predicate) oldStates
351
352
        in
          not (null nonMatchingStates) ==>
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
353
            (isJust newB .&. vSort (snd (fromJust newB)) === vSort nonMatchingStates)
354
355
356
357
358
359
360
361
362
363

  it "works when no states match the predicate" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let
          res@(oldStates, newA, newB) = split block (const False)
        in
          counterexample (show res) $
              isNothing newA
          .&. isJust newB
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
364
          .&. vSort (snd (fromJust newB)) === vSort oldStates
365
366
367
368
369
370
371
372
373
374

  it "works when all states match the predicate" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let
          res@(oldStates, newA, newB) = split block (const True)
        in
          counterexample (show res) $
              isNothing newB
          .&. isJust newA
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
375
          .&. vSort (snd (fromJust newA)) === vSort oldStates
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399

  it "gives the old block identity to the largest block by default" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        case split block predicate of
          (_, Just (a, aStates), Just (b, bStates))
            | length aStates > length bStates -> a === block
            | otherwise                       -> b === block
          _ -> property Discard

  it "gives the old block identity to the second block if the first doesn't exist" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let
          (_, _, newB) = split block (const False)
        in
          isJust newB ==> fst (fromJust newB) === block

  where
    initPart s
      | s < 3 = 0
      | s < 7 || s > 8 = 1
      | otherwise = 2

400
401
402
403
404
405
406
407
408
409
410
411
412
413
    split ::
         Block
      -> (State -> Bool)
      -> ( V.Vector State
         , Maybe (Block, V.Vector State)
         , Maybe (Block, V.Vector State))
    split block predicate =
      runST $ do
        p <- make 10 3 initPart
        oldStates <- V.convert <$> statesOfBlock p block
        (a, b) <- splitBy p block predicate
        aStates <- traverse (fmap V.convert . statesOfBlock p) a
        bStates <- traverse (fmap V.convert . statesOfBlock p) b
        return (oldStates, (,) <$> a <*> aStates, (,) <$> b <*> bStates)
414
415
416
417
418
419
420
421
422


groupBySpec :: Spec
groupBySpec = describe "groupBy" $ do
  it "distributes the old states over the new blocks" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let (oldStates,newBlocks) = split block (`div` 3)
        in
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
423
          toList oldStates `shouldMatchList` toList (V.concat newBlocks)
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442

  it "returns blocks that have each equal elements (according to attribute)" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let (_,newBlocks) = split block (`div` 3)
        in
          all (haveEqualElems (`div` 3)) newBlocks

  it "returns nonempty blocks" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let (_, newBlocks) = split block (`div` 3)
        in
          all (not . null) newBlocks

  it "returns blocks that have distinct elements from each other" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let (_, newBlocks) = split block (`div` 3)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
443
            oneElemFromAll = map V.head newBlocks
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
        in
          nubBy ((==) `on` (`div` 3)) oneElemFromAll === oneElemFromAll

  it "gives one of the new blocks the old identity" $
    property $
      forAll (arbitraryBlock 3) $ \block ->
        let newBlocks = runST $ do
              p <- make 10 3 initPart
              groupBy p block (`div` 3)
        in
          filter (==block) newBlocks === [block]

  where
    initPart s
      | s < 3 = 0
      | s < 7 || s > 8 = 1
      | otherwise = 2

462
    split :: Block -> (State -> State) -> (V.Vector State, [V.Vector State])
463
464
    split block attribute = runST $ do
      p <- make 10 3 initPart
465
      oldStates <- V.convert <$> statesOfBlock p block
466
467
      newBlocks <- groupBy p block attribute

468
      (oldStates,) <$> mapM (fmap (V.convert @VU.Vector @State @V.Vector) . statesOfBlock p) newBlocks
469
470

    haveEqualElems attribute lst =
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
471
      length (nubBy ((==) `on` attribute) (sort (toList lst))) <= 1
472
473
474
475
476
477
478
479
480

arbitraryBlock :: Int -> Gen Block
arbitraryBlock n = elements [Block x | x <- [0..n-1]]

arbitraryStates :: Int -> Gen [State]
arbitraryStates n = sublistOf [x | x <- [0..n-1]]

errorContaining :: String -> Selector ErrorCall
errorContaining s (ErrorCallWithLocation msg _) = s `isInfixOf` msg
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
481
482

vSort :: Ord a => V.Vector a -> V.Vector a
483
vSort = V.modify V.sort