diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Agent.hs | 16 | ||||
| -rw-r--r-- | src/Proposal.hs | 7 | ||||
| -rw-r--r-- | src/World/Types.hs | 100 |
3 files changed, 58 insertions, 65 deletions
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) - - - |