diff options
| -rw-r--r-- | nerine.cabal | 4 | ||||
| -rw-r--r-- | src/Agent.hs | 16 | ||||
| -rw-r--r-- | src/Proposal.hs | 7 | ||||
| -rw-r--r-- | src/World/Types.hs | 100 | ||||
| -rw-r--r-- | test/AgentTest.hs | 10 | ||||
| -rw-r--r-- | test/ProposalTest.hs | 10 | ||||
| -rw-r--r-- | test/WorldTypesTest.hs | 84 |
7 files changed, 99 insertions, 132 deletions
diff --git a/nerine.cabal b/nerine.cabal index 418fec0..903ef49 100644 --- a/nerine.cabal +++ b/nerine.cabal @@ -25,10 +25,12 @@ source-repository head library exposed-modules: + Agent Genome Lattice Lib Mind + Proposal World.Types other-modules: Paths_nerine @@ -65,9 +67,11 @@ test-suite nerine-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + AgentTest GenomeTest LatticeTest MindTest + ProposalTest WorldTypesTest Paths_nerine autogen-modules: diff --git a/src/Agent.hs b/src/Agent.hs new file mode 100644 index 0000000..bb9e284 --- /dev/null +++ b/src/Agent.hs @@ -0,0 +1,16 @@ +module Agent + ( + ) where + + +import Mind (Network (..)) + + +data Agent a = Agent + { id :: Int + , net :: Network + , state :: [Float] + , x :: Int + , y :: Int + , flags :: a + } diff --git a/src/Proposal.hs b/src/Proposal.hs new file mode 100644 index 0000000..dd2ea84 --- /dev/null +++ b/src/Proposal.hs @@ -0,0 +1,7 @@ +module Proposal + ( + ) where + + +class Flag a where + compatibleFlag :: a -> a -> Bool diff --git a/src/World/Types.hs b/src/World/Types.hs index f5a410e..32e4df6 100644 --- a/src/World/Types.hs +++ b/src/World/Types.hs @@ -1,6 +1,5 @@ module World.Types - ( Merge (..) - , Compatible (..) + ( Combinable (..) , Pos , LatticeProposal (..) , LatticePropList (..) @@ -9,32 +8,27 @@ module World.Types ) where -class Merge a where - mergable :: a -> a -> Bool - merge :: a -> a -> a +class Combinable a where + -- the "identity" element of the class is combinable with all others + -- and (naturally) results in those others when combined + identity :: a + -- determine if two class elements can be combined + combinable :: a -> a -> Bool + -- combine two class elements + combine :: a -> a -> a -class Compatible a where - compatible :: a -> a -> Bool +-- define Combinable for Maybe +instance (Eq a) => Combinable (Maybe a) where + identity = Nothing -instance (Merge a) => Merge (Maybe a) where - mergable (Just x) (Just y) = mergable x y - mergable _ _ = 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 + combinable (Just x) (Just y) = x == y + combinable _ _ = True -class (Eq a) => MergeEq a where - mergableEq :: a -> a -> Bool - mergeEq :: a -> a -> a + combine (Just x) (Just y) = if x /= y then error "attempt to combine non-combinable Justs" else Just x + combine (Just x) Nothing = Just x + combine Nothing (Just x) = Just x + combine Nothing Nothing = Nothing -instance (Eq a) => MergeEq (Maybe a) where - mergableEq (Just x) (Just y) = x == y - mergableEq _ _ = 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) @@ -42,51 +36,30 @@ type Pos = (Int, Int) -- lattice proposals data LatticeProposal a b = LatticeProposal { cellPos :: Pos - , from :: Maybe a - , to :: Maybe a - , cellFlags :: Maybe b + , from :: a + , to :: a + , cellFlags :: b } deriving (Show, Eq) newtype LatticePropList a b = LatticePropList [LatticeProposal a b] deriving (Show, Eq) -instance (Eq a, Merge b) => Merge (LatticeProposal a b) where - mergable x y = - if (cellPos x /= cellPos y) then True else - if mergableEq (from x) (from y) - && mergableEq (to x) (to y) - && mergable (cellFlags x) (cellFlags y) - then True - else False - merge x y = if not (mergable x y) - then error "attempt to merge incompatible lattice proposals" - else LatticeProposal - (cellPos x) - (mergeEq (from x) (from y)) - (mergeEq (to x) (to y)) - (merge (cellFlags x) (cellFlags y)) +instance (Combinable a, Combinable b) => Combinable (LatticePropList a b) where + identity = LatticePropList [] -instance (Eq a, Merge b) => Compatible (LatticeProposal a b) where - compatible x y = (cellPos x /= cellPos y) || (mergable x y) - -instance (Eq a, Merge b) => Merge (LatticePropList a b) where - mergable _ _ = True - merge xs (LatticePropList ys) = + combinable (LatticePropList xs) (LatticePropList ys) = let - mergeAcross as b = foldl - (\(valid, LatticePropList list) x -> if valid - then - let - b' = head list - rest = tail list - in if mergable b' x - then (True, LatticePropList $ (merge b' x):rest) - else if compatible b' x then (True, LatticePropList $ b':x:rest) else (False, LatticePropList []) - else (False, LatticePropList list) - ) - (True, LatticePropList [b]) - as - in snd $ foldl (\(valid, LatticePropList list) x -> if valid then mergeAcross list x else (False, LatticePropList [])) (True, xs) ys + pairIsCombinable (a, b) = + if (cellPos a) /= (cellPos b) then True + else if + combinable (from a) (from b) && + combinable (to a) (to b) && + combinable (cellFlags a) (cellFlags b) + then True else False + pairs = [ (x, y) | x <- xs, y <- ys ] + in + all pairIsCombinable pairs + combine (LatticePropList xs) (LatticePropList ys) = LatticePropList $ xs ++ ys -- agent proposals @@ -98,6 +71,3 @@ data AgentProposal a = AgentProposal deriving (Show, Eq) newtype Proposal a b c = Proposal ([LatticeProposal a b], [AgentProposal c]) deriving (Show, Eq) - - - diff --git a/test/AgentTest.hs b/test/AgentTest.hs new file mode 100644 index 0000000..c89d28a --- /dev/null +++ b/test/AgentTest.hs @@ -0,0 +1,10 @@ +module AgentTest (suite) where + +import Test.Tasty +import Test.Tasty.HUnit +import Agent + +suite :: TestTree +suite = testGroup "agent tests" $ + [ + ] diff --git a/test/ProposalTest.hs b/test/ProposalTest.hs new file mode 100644 index 0000000..1b78c69 --- /dev/null +++ b/test/ProposalTest.hs @@ -0,0 +1,10 @@ +module ProposalTest (suite) where + +import Test.Tasty +import Test.Tasty.HUnit +import Proposal + +suite :: TestTree +suite = testGroup "proposal tests" $ + [ + ] diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs index f1822fc..5a45418 100644 --- a/test/WorldTypesTest.hs +++ b/test/WorldTypesTest.hs @@ -4,8 +4,7 @@ module WorldTypesTest (suite) where import Test.Tasty import Test.Tasty.HUnit import World.Types - ( Merge (..) - , Compatible (..) + ( Combinable (..) , Pos , LatticeProposal (..) , LatticePropList (..) @@ -19,73 +18,24 @@ suite = testGroup "world types tests" $ [ latticePropTests ] -newtype MockMerge = MockMerge Int deriving (Show, Eq) -instance Merge MockMerge where - mergable (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 @=? compatible - (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 1) Nothing Nothing Nothing) - True @=? compatible - (LatticeProposal (1, 0) (Just 4) (Just 5) Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) (Just 5) (Just 5) Nothing) - -- merge from - True @=? mergable - (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) (Just 4) Nothing Nothing) - True @=? mergable - (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing Nothing) - False @=? mergable - (LatticeProposal (0, 0) (Just 4) Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) (Just 5) Nothing Nothing) - -- merge to - True @=? mergable - (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing (Just 4) Nothing) - True @=? mergable - (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing Nothing) - False @=? mergable - (LatticeProposal (0, 0) Nothing (Just 4) Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing (Just 2) Nothing) - -- merge flags - True @=? mergable - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing Nothing) - True @=? mergable - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4)) - False @=? mergable - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 5)) - - - , testCase "merge lattice proposals" $ - do - LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4) @?= merge - (LatticeProposal (0, 0) Nothing Nothing Nothing :: LatticeProposal Int MockMerge) - (LatticeProposal (0, 0) Nothing Nothing (Just $ MockMerge 4)) - LatticeProposal (0, 0) (Just 2) (Just 4) (Just $ MockMerge 4) @?= merge - (LatticeProposal (0, 0) (Just 2) Nothing Nothing) - (LatticeProposal (0, 0) Nothing (Just 4) (Just $ MockMerge 4)) - - , testCase "merge lattice proposal lists" $ + [ testCase "combine LatticePropList with identity" $ + let + propList :: LatticePropList (Maybe Int) (Maybe Int) + propList = LatticePropList + [ LatticeProposal (0, 0) (Just 0) (Just 0) (Just 0) + , LatticeProposal (0, 1) Nothing (Just 0) (Just 0) + , LatticeProposal (1, 1) (Just 0) Nothing Nothing + ] + in combine identity propList @?= propList + , testCase "conditionally combine proposal lists" $ let - a = LatticeProposal (0, 0) Nothing (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge - b = LatticeProposal (1, 0) Nothing (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge - c = LatticeProposal (0, 0) (Just 3) (Just 2) (Just $ MockMerge 4) :: LatticeProposal Int MockMerge - d = LatticeProposal (0, 0) (Just 3) (Just 2) (Just $ MockMerge 5) :: LatticeProposal Int MockMerge - in do - (LatticePropList [a, b]) @=? merge (LatticePropList [a]) (LatticePropList [b]) - (LatticePropList [c, b]) @=? merge (LatticePropList [a]) (LatticePropList [b, c]) - (LatticePropList [c]) @=? merge (LatticePropList [a, b]) (LatticePropList [c, d]) - (LatticePropList [b, d]) @=? merge (LatticePropList [b]) (LatticePropList [d]) + a :: [LatticeProposal (Maybe Int) (Maybe Int)] + a = [ LatticeProposal (0, 0) (Just 0) Nothing Nothing ] + a' :: [LatticeProposal (Maybe Int) (Maybe Int)] + a' = [ LatticeProposal(0, 0) (Just 4) Nothing Nothing ] + in + combinable (LatticePropList a) (LatticePropList a') @?= False ] |