prevent applying invalid proposalsrefactor-haskell

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 ]]
 
   ]