diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | src/World/.Types.hs.swo | bin | 12288 -> 0 bytes | |||
| -rw-r--r-- | src/World/Types.hs | 50 | ||||
| -rw-r--r-- | test/WorldTypesTest.hs | 13 |
4 files changed, 52 insertions, 12 deletions
@@ -1,3 +1,4 @@ *~ *.swp .stack-work +*.swo diff --git a/src/World/.Types.hs.swo b/src/World/.Types.hs.swo Binary files differdeleted file mode 100644 index 29646f7..0000000 --- a/src/World/.Types.hs.swo +++ /dev/null diff --git a/src/World/Types.hs b/src/World/Types.hs index f69bfa1..f5a410e 100644 --- a/src/World/Types.hs +++ b/src/World/Types.hs @@ -3,6 +3,7 @@ module World.Types , Compatible (..) , Pos , LatticeProposal (..) + , LatticePropList (..) , AgentProposal (..) , Proposal (..) ) where @@ -18,8 +19,6 @@ class Compatible a where instance (Merge a) => Merge (Maybe a) where mergable (Just x) (Just y) = mergable x y mergable _ _ = True - 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 @@ -39,6 +38,8 @@ instance (Eq a) => MergeEq (Maybe a) where type Pos = (Int, Int) + +-- lattice proposals data LatticeProposal a b = LatticeProposal { cellPos :: Pos , from :: Maybe a @@ -46,16 +47,7 @@ data LatticeProposal a b = LatticeProposal , 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) - +newtype LatticePropList a b = LatticePropList [LatticeProposal a b] deriving (Show, Eq) instance (Eq a, Merge b) => Merge (LatticeProposal a b) where mergable x y = @@ -75,3 +67,37 @@ instance (Eq a, Merge b) => Merge (LatticeProposal a b) where 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) = + 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 + + + +-- agent proposals +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) + + + diff --git a/test/WorldTypesTest.hs b/test/WorldTypesTest.hs index 3c48c4e..f1822fc 100644 --- a/test/WorldTypesTest.hs +++ b/test/WorldTypesTest.hs @@ -8,6 +8,7 @@ import World.Types , Compatible (..) , Pos , LatticeProposal (..) + , LatticePropList (..) , AgentProposal (..) , Proposal (..) ) @@ -75,4 +76,16 @@ latticePropTests = testGroup "lattice proposal tests" $ 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" $ + 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]) ] |