about summary refs log tree commit diff
path: root/users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs
blob: b53c657f75593ba5d1b74d488d78e1d5830ef343 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
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
64
65
66
67
68
69
70
71
72
73
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
116
117
118
119
120
121
122
123
124
125
126
127
{-# LANGUAGE PackageImports #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.Level.UtilSpec (main, test) where
--------------------------------------------------------------------------------
import Test.Prelude
import System.Random (mkStdGen)
import Control.Monad.Random (runRandT)
import Data.Array.ST (STUArray, runSTUArray, thaw)
import Data.Array.IArray (bounds, array)
import Data.Array.MArray (newArray, readArray, writeArray)
import Data.Array (Array, range, listArray, Ix)
import Control.Monad.ST (ST, runST)
import "checkers" Test.QuickCheck.Instances.Array ()
import Linear.V2
--------------------------------------------------------------------------------
import Xanthous.Util
import Xanthous.Data (width, height)
--------------------------------------------------------------------------------
import Xanthous.Generators.Level.Util
--------------------------------------------------------------------------------

main :: IO ()
main = defaultMain test

--------------------------------------------------------------------------------

newtype GenArray a b = GenArray (Array a b)
  deriving stock (Show, Eq)

instance (Ix a, Arbitrary a, CoArbitrary a, Arbitrary b)
       => Arbitrary (GenArray a b) where
  arbitrary = GenArray <$> do
    (mkElem :: a -> b) <- arbitrary
    minDims <- arbitrary
    maxDims <- arbitrary
    let bnds = (minDims, maxDims)
    pure $ listArray bnds $ mkElem <$> range bnds

test :: TestTree
test = testGroup "Xanthous.Generators.Util"
  [ testGroup "randInitialize"
    [ testProperty "returns an array of the correct dimensions"
      $ \dims seed aliveChance ->
        let gen = mkStdGen seed
            res = runSTUArray
                $ fmap fst
                $ flip runRandT gen
                $ randInitialize dims aliveChance
        in bounds res === (0, V2 (dims ^. width) (dims ^. height))
    ]
  , testGroup "numAliveNeighborsM"
    [ testProperty "maxes out at 8"
      $ \(GenArray (arr :: Array (V2 Word) Bool)) loc ->
        let
          act :: forall s. ST s Word
          act = do
            mArr <- thaw @_ @_ @_ @(STUArray s) arr
            numAliveNeighborsM mArr loc
          res = runST act
        in counterexample (show res) $ between 0 8 res
    , testCase "on the outer x edge" $
      let act :: forall s. ST s Word
          act = do
            cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word)
              (V2 0 0, V2 2 2)
              [ (V2 0 0, True),  (V2 1 0, True),  (V2 2 0, True)
              , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True)
              , (V2 0 2, True),  (V2 1 2, True),  (V2 2 2, True)
              ]
            numAliveNeighborsM cells (V2 0 1)
          res = runST act
      in res @?= 7
    , testCase "on the outer y edge" $
      let act :: forall s. ST s Word
          act = do
            cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word)
              (V2 0 0, V2 2 2)
              [ (V2 0 0, True),  (V2 1 0, True),  (V2 2 0, True)
              , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True)
              , (V2 0 2, True),  (V2 1 2, True),  (V2 2 2, True)
              ]
            numAliveNeighborsM cells (V2 1 0)
          res = runST act
      in res @?= 6
    ]
  , testGroup "numAliveNeighbors"
    [ testProperty "is equivalient to runST . numAliveNeighborsM . thaw" $
      \(GenArray (arr :: Array (V2 Word) Bool)) loc ->
        let
          act :: forall s. ST s Word
          act = do
            mArr <- thaw @_ @_ @_ @(STUArray s) arr
            numAliveNeighborsM mArr loc
          res = runST act
        in numAliveNeighbors arr loc === res
    , testCase "on the outer x edge" $
      let cells =
            array @Array @Bool @(V2 Word)
            (V2 0 0, V2 2 2)
            [ (V2 0 0, True),  (V2 1 0, True),  (V2 2 0, True)
            , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True)
            , (V2 0 2, True),  (V2 1 2, True),  (V2 2 2, True)
            ]
      in numAliveNeighbors cells (V2 0 1) @?= 7
    , testCase "on the outer y edge" $
      let cells =
            array @Array @Bool @(V2 Word)
            (V2 0 0, V2 2 2)
            [ (V2 0 0, True),  (V2 1 0, True),  (V2 2 0, True)
            , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True)
            , (V2 0 2, True),  (V2 1 2, True),  (V2 2 2, True)
            ]
      in numAliveNeighbors cells (V2 1 0) @?= 6
    ]
  , testGroup "cloneMArray"
      [ testCase "clones the array" $ runST $
          let
            go :: forall s. ST s Assertion
            go = do
              arr <- newArray @(STUArray s) (0 :: Int, 5) (1 :: Int)
              arr' <- cloneMArray @_ @(STUArray s) arr
              writeArray arr' 0 1234
              x <- readArray arr 0
              pure $ x @?= 1
          in go
      ]
  ]