diff options
| -rw-r--r-- | src/World/Lattice.hs | 32 | ||||
| -rw-r--r-- | test/LatticeTest.hs | 80 |
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) + ] + ] + + ] |