diff options
| -rw-r--r-- | nerine.cabal | 2 | ||||
| -rw-r--r-- | src/World/.Types.hs.swo | bin | 0 -> 12288 bytes | |||
| -rw-r--r-- | src/World/Types.hs | 61 | ||||
| -rw-r--r-- | test/Main.hs | 2 | ||||
| -rw-r--r-- | test/WorldTypesTest.hs | 71 |
5 files changed, 136 insertions, 0 deletions
diff --git a/nerine.cabal b/nerine.cabal index 0e1695a..418fec0 100644 --- a/nerine.cabal +++ b/nerine.cabal @@ -29,6 +29,7 @@ library Lattice Lib Mind + World.Types other-modules: Paths_nerine autogen-modules: @@ -67,6 +68,7 @@ test-suite nerine-test GenomeTest LatticeTest MindTest + WorldTypesTest Paths_nerine autogen-modules: Paths_nerine diff --git a/src/World/.Types.hs.swo b/src/World/.Types.hs.swo Binary files differnew file mode 100644 index 0000000..527fc99 --- /dev/null +++ b/src/World/.Types.hs.swo diff --git a/src/World/Types.hs b/src/World/Types.hs new file mode 100644 index 0000000..c7f77ce --- /dev/null +++ b/src/World/Types.hs @@ -0,0 +1,61 @@ +module World.Types + ( Merge (..) + , Pos + , LatticeProposal (..) + , AgentProposal (..) + , Proposal (..) + ) where + + +class Merge a where + mergeCompatible :: a -> a -> Bool + merge :: a -> a -> a + +instance (Merge a) => Merge (Maybe a) where + mergeCompatible (Just x) (Just y) = mergeCompatible x y + mergeCompatible _ _ = True + merge (Just x) (Just y) = Just $ merge x y + merge Nothing (Just y) = Just $ y + merge (Just x) (Nothing) = Just $ x + merge Nothing Nothing = Nothing + +class (Eq a) => MergeEq a where + mergeEqCompatible :: a -> a -> Bool + mergeEq :: a -> a -> a + +instance (Eq a) => MergeEq (Maybe a) where + mergeEqCompatible (Just x) (Just y) = x == y + mergeEqCompatible _ _ = True + mergeEq (Just x) (Just _) = Just $ x + mergeEq Nothing (Just y) = Just $ y + mergeEq (Just x) (Nothing) = Just $ x + mergeEq Nothing Nothing = Nothing + +type Pos = (Int, Int) + +data LatticeProposal a b = LatticeProposal + { cellPos :: Pos + , from :: Maybe a + , to :: Maybe a + , cellFlags :: Maybe b + } + deriving (Show, Eq) + +data AgentProposal a = AgentProposal + { id :: Int + , agentPos :: Pos + , agentFlags :: a + } + deriving (Show, Eq) + +newtype Proposal a b c = Proposal ([LatticeProposal a b], [AgentProposal c]) deriving (Show, Eq) + + +instance (Eq a, Merge b) => Merge (LatticeProposal a b) where + mergeCompatible x y = + if (cellPos x /= cellPos y) then True else + if mergeEqCompatible (from x) (from y) + && mergeEqCompatible (to x) (to y) + && mergeCompatible (cellFlags x) (cellFlags y) + then True + else False diff --git a/test/Main.hs b/test/Main.hs index 24666a6..8abc870 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -5,10 +5,12 @@ import Test.Tasty import qualified MindTest import qualified GenomeTest import qualified LatticeTest +import qualified WorldTypesTest main :: IO () main = defaultMain $ testGroup "all tests" $ [ MindTest.suite , GenomeTest.suite , LatticeTest.suite + , WorldTypesTest.suite ] diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs new file mode 100644 index 0000000..03c41d6 --- /dev/null +++ b/test/WorldTypesTest.hs @@ -0,0 +1,71 @@ +module WorldTypesTest (suite) where + + +import Test.Tasty +import Test.Tasty.HUnit +import World.Types + ( Merge (..) + , Pos + , LatticeProposal (..) + , AgentProposal (..) + , Proposal (..) + ) + + +suite :: TestTree +suite = testGroup "world types tests" $ + [ latticePropTests + ] + +newtype MockMerge = MockMerge Int +instance Merge MockMerge where + mergeCompatible (MockMerge x) (MockMerge y) = x == y + merge x _ = x + merge _ _ = error "incompatible merge!" + +latticePropTests :: TestTree +latticePropTests = testGroup "lattice proposal tests" $ + [ testCase "lattice proposals correctly detect mergability" $ + do + -- disjoint positions + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 1) Nothing Nothing Nothing) + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing Nothing) + True @=? mergeCompatible + (LatticeProposal (1, 0) (Just 4) (Just 5) Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) (Just 5) (Just 5) Nothing) + -- merge from + True @=? mergeCompatible + (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) (Just 4) Nothing Nothing) + True @=? mergeCompatible + (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing Nothing) + False @=? mergeCompatible + (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) (Just 5) Nothing Nothing) + -- merge to + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing (Just 4) Nothing) + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing Nothing) + False @=? mergeCompatible + (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing (Just 2) Nothing) + -- merge flags + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing Nothing) + True @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4)) + False @=? mergeCompatible + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) + (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 5)) + ] + |