From 15a0b3d4658faced5e5e09c582f4c22365b31ad7 Mon Sep 17 00:00:00 2001
From: sanine <sanine.not@pm.me>
Date: Tue, 5 Dec 2023 12:50:56 -0600
Subject: begin implementing applyLatticeProposals

---
 test/LatticeTest.hs | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 80 insertions(+)

(limited to 'test')

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)
+        ]
+      ]
+
+  ]
-- 
cgit v1.2.1