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
|
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 (Just True)
, 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)
]
]
]
|
