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
128
129
130
131
|
module LatticeTest (suite) where
import Test.Tasty
import Test.Tasty.HUnit
import World.Types
( Combinable (..)
, LatticeProposal (..)
, LatticePropList (..)
)
import World.Lattice
(LatticeCell (..)
, Lattice
, LatticeRule
, updateLattice
, applyLatticeProposals
)
suite :: TestTree
suite = testGroup "lattice tests" $
[ latticeGrowth
, proposalApplication
]
data GrowKind = Empty | Plant deriving (Show, Enum, Eq)
instance Combinable GrowKind where
identity = Empty
combinable _ _ = True
combine Plant _ = Plant
combine _ Plant = Plant
combine Empty Empty = Empty
data GrowFlags = None deriving (Show, Eq)
newtype MergeInt = MergeInt Int deriving (Show, Eq)
instance Combinable MergeInt where
identity = MergeInt 0
combinable _ _ = True
combine (MergeInt x) (MergeInt y) = MergeInt $ x+y
latticeGrowth :: TestTree
latticeGrowth = testCase "growth update rule" $
let
plant = LatticeCell Plant None
empty = LatticeCell Empty None
lattice = [[ empty, empty, plant ]]
rules =
[
-- empty
\l x y ->
if kind ((l !! y) !! (x+1)) == Plant
then LatticeCell Plant None
else LatticeCell Empty None
-- plant
, \_ _ _ -> LatticeCell Plant None
] :: [LatticeRule GrowKind GrowFlags]
lattice' = updateLattice lattice rules
lattice'' = updateLattice lattice' rules
in do
lattice' @?= [[ empty, plant, plant ]]
lattice'' @?= [[ plant, plant, plant ]]
proposalApplication :: TestTree
proposalApplication = testGroup "apply proposal lists to lattices" $
[ testCase "update cell kinds" $
let
plant = LatticeCell Plant Nothing
empty = LatticeCell Empty Nothing
lattice = [[ empty, plant, empty ]]
proposals :: LatticePropList GrowKind (Maybe Bool)
proposals = LatticePropList
[ LatticeProposal (0, 0) Empty Plant Nothing
, LatticeProposal (1, 0) Plant Empty Nothing
, LatticeProposal (2, 0) Empty Plant Nothing
]
lattice' = applyLatticeProposals lattice proposals
in
lattice' @?= [[ plant, empty, plant ]]
, testCase "update cell kinds and flags" $
let
plant = LatticeCell Plant (Just True)
empty = LatticeCell Empty Nothing
lattice = [[ empty, plant, empty ]]
proposals :: LatticePropList GrowKind (Maybe Bool)
proposals = LatticePropList
[ LatticeProposal (0, 0) Empty Plant (Just False)
, LatticeProposal (2, 0) Empty Plant (Just True)
]
lattice' = applyLatticeProposals lattice proposals
in
lattice' @?= [
[ LatticeCell Plant (Just False)
, LatticeCell Plant Nothing -- reset by the application process
, LatticeCell Plant (Just True)
]
]
, testCase "cell flags combine correctly" $
let
lattice = [[ LatticeCell Empty (MergeInt 4) ]]
proposals :: LatticePropList GrowKind MergeInt
proposals = LatticePropList
[ LatticeProposal (0, 0) Empty Plant (MergeInt $ 0-1)
, LatticeProposal (0, 0) Empty Plant (MergeInt $ 0-2)
, LatticeProposal (0, 0) Empty Plant (MergeInt $ 0-3)
]
lattice' = applyLatticeProposals lattice proposals
in
lattice' @?= [
[ LatticeCell Plant (MergeInt $ 0-6)
]
]
, testCase "invalid proposals are not applied" $
let
plant = LatticeCell Plant Nothing
empty = LatticeCell Empty Nothing
lattice = [[ empty, plant, empty ]]
proposals :: LatticePropList GrowKind (Maybe Bool)
proposals = LatticePropList
[ LatticeProposal (0, 0) Plant Plant Nothing
, LatticeProposal (1, 0) Plant Empty Nothing
, LatticeProposal (2, 0) Empty Plant Nothing
]
lattice' = applyLatticeProposals lattice proposals
in
lattice' @?= [[ empty, empty, plant ]]
]
|
