diff options
| -rw-r--r-- | src/World/Lattice.hs | 34 | ||||
| -rw-r--r-- | test/LatticeTest.hs | 16 |
2 files changed, 40 insertions, 10 deletions
diff --git a/src/World/Lattice.hs b/src/World/Lattice.hs index d377792..587a8cb 100644 --- a/src/World/Lattice.hs +++ b/src/World/Lattice.hs @@ -8,21 +8,27 @@ module World.Lattice import World.Types - (Combinable (..) - , LatticeProposal (..) + ( Combinable (..) + , LatticeProposal (LatticeProposal) , LatticePropList (..) ) -data LatticeCell a b = LatticeCell { kind :: a, flags :: b } deriving (Show, Eq) +data LatticeCell a b = LatticeCell { kind :: a, cellFlags :: b } deriving (Show, Eq) type Lattice a b = [[LatticeCell a b]] type LatticeRule a b = Lattice a b -> Int -> Int -> LatticeCell a b +-- apply update rules to a lattice +-- each rule is specific to a cell kind. it should +-- take a lattice, an X-coordinate, and a Y-coordinate, and +-- return a new LatticeCell updateLattice :: (Enum a) => Lattice a b -> [LatticeRule a b] -> Lattice a b updateLattice lattice rules = let + -- map across each row in the lattice mapRow = \(row, y) -> map + -- map each cell to its new state, based on the relevant rule (\((LatticeCell k _), x) -> let rule = rules !! (fromEnum k) in rule lattice x y @@ -31,25 +37,35 @@ updateLattice lattice rules = in map mapRow (zip lattice [0..]) -applyLatticeProposals :: (Combinable b) => Lattice a b -> LatticePropList a b -> Lattice a b +-- apply proposals to a lattice +-- during preprocessing, each cell's `flags` field is replaced by +-- its Combinable identity. postprocessing rules should be used to +-- restore any "persistent" flags. +applyLatticeProposals :: (Eq a, Combinable b) => Lattice a b -> LatticePropList a b -> Lattice a b applyLatticeProposals lattice (LatticePropList props) = let + -- helper: replace single element in a list update list idx new = let (front, _:back) = splitAt idx list in front ++ (new:back) - applyProp l (LatticeProposal (x, y) from to flags) = + + -- apply a single proposal to the lattice + applyProp l (LatticeProposal (x, y) from to flgs) = let row = l !! y cell = row !! x - cell' = LatticeCell to (combine flags $ cellFlags cell) + cell' = LatticeCell to (combine flgs (cellFlags cell)) in - update l y (update row x cell') + if kind ((lattice !! y) !! x) == from -- check against original lattice, as kind may have been changed by other proposals c: + then update l y (update row x cell') + else l -- invalid proposal, don't change anything -- replace each cell's flags with the identity lattice' = map (\row -> map - (\cell -> cell { flags = identity } ) + (\cell -> cell { cellFlags = identity } ) row ) lattice in - foldl applyProp lattice' props + -- apply each proposal to the lattice' + foldl (applyProp) lattice' props diff --git a/test/LatticeTest.hs b/test/LatticeTest.hs index 9edff30..40c0a85 100644 --- a/test/LatticeTest.hs +++ b/test/LatticeTest.hs @@ -94,7 +94,7 @@ proposalApplication = testGroup "apply proposal lists to lattices" $ in lattice' @?= [ [ LatticeCell Plant (Just False) - , LatticeCell Plant (Just True) + , LatticeCell Plant Nothing -- reset by the application process , LatticeCell Plant (Just True) ] ] @@ -113,5 +113,19 @@ proposalApplication = testGroup "apply proposal lists to lattices" $ [ 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 ]] ] |