begin implementing applyLatticeProposals

2 files changed, 112 insertions, 0 deletions

diff --git a/src/World/Lattice.hs b/src/World/Lattice.hs
index 257ea50..d377792 100644
--- a/src/World/Lattice.hs
+++ b/src/World/Lattice.hs
@@ -3,9 +3,17 @@ module World.Lattice
   , Lattice
   , LatticeRule
   , updateLattice
+  , applyLatticeProposals
   ) where
 
 
+import World.Types 
+  (Combinable (..)
+  , LatticeProposal (..)
+  , LatticePropList (..)
+  )
+
+
 data LatticeCell a b = LatticeCell { kind :: a, flags :: b } deriving (Show, Eq)
 type Lattice a b = [[LatticeCell a b]]
 type LatticeRule a b = Lattice a b -> Int -> Int -> LatticeCell a b
@@ -21,3 +29,27 @@ updateLattice lattice rules =
       )
       (zip row [0..])
   in map mapRow (zip lattice [0..])
+
+
+applyLatticeProposals :: (Combinable b) => Lattice a b -> LatticePropList a b -> Lattice a b
+applyLatticeProposals lattice (LatticePropList props) =
+  let
+    update list idx new =
+      let (front, _:back) = splitAt idx list in front ++ (new:back)
+    applyProp l (LatticeProposal (x, y) from to flags) = 
+      let
+        row = l !! y
+        cell = row !! x
+        cell' = LatticeCell to (combine flags $ cellFlags cell)
+      in
+        update l y (update row x cell')
+
+    -- replace each cell's flags with the identity
+    lattice' = map
+      (\row -> map
+        (\cell -> cell { flags = identity } )
+        row
+      )
+      lattice
+  in
+    foldl applyProp lattice' props
diff --git a/test/LatticeTest.hs b/test/LatticeTest.hs
index 403c650..9edff30 100644
--- a/test/LatticeTest.hs
+++ b/test/LatticeTest.hs
@@ -2,18 +2,44 @@ 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
@@ -35,3 +61,57 @@ latticeGrowth = testCase "growth update rule" $
   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)
+        ]
+      ]
+
+  ]