diff --git a/Data/Teams/Examples/MAB.hs b/Data/Teams/Examples/MAB.hs new file mode 100644 --- /dev/null +++ b/Data/Teams/Examples/MAB.hs @@ -0,0 +1,41 @@ +-- | Multiaccess broadcast +-- Based on the example in +-- Aditya Mahajan, Ashutosh Nayyar, and Demosthenis Teneketzis, +-- \"Identifying tractable decentralized problems +-- on the basis of information structures,\" +-- Proceedings of the 46th annual Allerton conference on +-- communication, control, and computing, pp. 1440-1449, +-- Monticello, IL, September 23-26, 2008. + +module Data.Teams.Examples.MAB where + +import Data.Teams.Structure + +x1 = mkNonReward "x1" -- queue length of user 1 +x2 = mkNonReward "x2" -- queue length of user 2 +u1 = mkNonReward "u1" -- decision of user 1 +u2 = mkNonReward "u2" -- decision of user 2 +z1 = mkNonReward "z1" -- feedback to user 2 (= x1*u1) +z2 = mkNonReward "z2" -- feedback to user 1 (= x2*u2) +r = mkReward "r" + +f1 = mkStochastic "f1" +f2 = mkStochastic "f2" +g1 = mkControl "g1" +g2 = mkControl "g2" +c1 = mkDeterministic "c1" +c2 = mkDeterministic "c2" +d = mkStochastic "d" + +dynamics t = f1(t).$.(x1(t).|. if t==1 then [] else [x1(t-1), u1(t-1), z2(t-1)]) + ++ f2(t).$.(x2(t).|. if t==1 then [] else [x2(t-1), u2(t-1), z1(t-1)]) + ++ g1(t).$.(u1(t).|. map x1[1..t] ++ map u1[1..t-1] + ++ map z2[1..t-1]) + ++ g2(t).$.(u2(t).|. map x2[1..t] ++ map u2[1..t-1] + ++ map z1[1..t-1]) + ++ c1(t).$.(z1(t).|. [x1(t), u1(t)]) + ++ c2(t).$.(z2(t).|. [x2(t), u2(t)]) + ++ d(t).$.(r(t) .|. [x1(t), x2(t), u1(t), u2(t)]) + +mab = mkTeamTime dynamics 4 + diff --git a/Data/Teams/Examples/Wit79.hs b/Data/Teams/Examples/Wit79.hs --- a/Data/Teams/Examples/Wit79.hs +++ b/Data/Teams/Examples/Wit79.hs @@ -1,7 +1,7 @@ -- | Real time source coding -- Based on -- Hans S. Witsenhausen --- "On the structure of real-time source coders," +-- \"On the structure of real-time source coders,\" -- Bell Systems Technical Journal, -- vol 58, no 6, pp 1437-1451, July-August 1979 diff --git a/Data/Teams/Graph.hs b/Data/Teams/Graph.hs --- a/Data/Teams/Graph.hs +++ b/Data/Teams/Graph.hs @@ -31,7 +31,8 @@ , Edge , EdgeType (..) , Team -- * Constructors for nodes - , mkVertex , mkReward , mkNonReward , mkDynamics , mkControl + , mkVertex , mkReward , mkNonReward , mkControl + , mkDeterministic, mkStochastic -- * Constructor for edges , (.$.) , (.|.) -- * Constructors for teams @@ -62,8 +63,9 @@ deriving (Eq, Ord, Show) -- | Factor Vertexs -data Factor = Dynamics String -- ^ Factor node representing system dynamics - | Control String -- ^ Factor node representing control function +data Factor = Deterministic String -- ^ Factor node representing deterministic system dynamics + | Stochastic String -- ^ Factor node representing stochastic system dynamics + | Control String -- ^ Factor node representing control function deriving (Eq, Ord, Show) -- | Create a sequence of nodes of a specific type @@ -78,10 +80,14 @@ mkNonReward :: String -> Time -> Variable mkNonReward = mkVertex NonReward --- | Create a sequence of system dynamics nodes -mkDynamics :: String -> Time -> Factor -mkDynamics = mkVertex Dynamics +-- | Create a sequence of stochastic system dynamics nodes +mkStochastic :: String -> Time -> Factor +mkStochastic = mkVertex Stochastic +-- | Create a sequence of deterministic system dynamics nodes +mkDeterministic :: String -> Time -> Factor +mkDeterministic = mkVertex Deterministic + -- | Create a sequence of control nodes mkControl :: String -> Time -> Factor mkControl = mkVertex Control @@ -92,27 +98,29 @@ -- | A type class for defining operations on all nodes class Vertex a where -- | Name of node @a@ - name :: a -> String + name :: a -> String -- | Name of a list of nodes - names :: [a] -> String + names :: [a] -> String -- | Check if node @a@ is a reward node - isReward :: a -> Bool + isReward :: a -> Bool -- | Check if node @a@ is a non reward node - isNonReward :: a -> Bool + isNonReward :: a -> Bool -- | Check if node @a@ is a variable node - isVariable :: a -> Bool - -- | Check if node @a@ is a system dynamics - isDynamics :: a -> Bool + isVariable :: a -> Bool + -- | Check if node @a@ is a stochastic system dynamics + isStochastic :: a -> Bool + -- | Check if node @a@ is a deterministic stochastic system dynamics + isDeterministic :: a -> Bool -- | Check if node @a@ is a control node - isControl :: a -> Bool + isControl :: a -> Bool -- | Check if node @a@ is a factor node - isFactor :: a -> Bool + isFactor :: a -> Bool -- | The attributes of the node. Used to contruct the dot file. - attribute :: a -> [G.Attribute] + attribute :: a -> [G.Attribute] -- Default implmentation names xs = "[" ++ intercalate ", " (map name xs) ++ "]" isVariable = or . sequence [isReward, isNonReward] - isFactor = or . sequence [isControl, isDynamics] + isFactor = or . sequence [isControl, isDeterministic, isStochastic] instance Vertex Variable where @@ -125,8 +133,9 @@ isNonReward (Reward _) = False isNonReward (NonReward _) = True - isDynamics _ = False - isControl _ = False + isDeterministic _ = False + isStochastic _ = False + isControl _ = False attribute (Reward a) = [G.Style G.Filled, G.FillColor (G.RGB 0 255 0) , G.Shape G.Circle @@ -135,31 +144,42 @@ , G.Label a] instance Vertex Factor where - name (Dynamics a) = a - name (Control a) = a + name (Deterministic a) = a + name (Stochastic a) = a + name (Control a) = a - isDynamics (Dynamics _) = True - isDynamics (Control _) = False + isDeterministic (Deterministic _) = True + isDeterministic (Stochastic _) = False + isDeterministic (Control _) = False - isControl (Dynamics _) = False - isControl (Control _) = True + isStochastic (Deterministic _) = False + isStochastic (Stochastic _) = True + isStochastic (Control _) = False + isControl (Deterministic _) = False + isControl (Stochastic _) = False + isControl (Control _) = True + isReward _ = False isNonReward _ = False - attribute (Dynamics a) = [G.Shape G.Rectangle - , G.Label a] - attribute (Control a) = [G.Style G.Filled, G.FillColor (G.RGB 255 0 0) - , G.Shape G.Rectangle - , G.Label a] + attribute (Deterministic a) = [G.Shape G.Rectangle + , G.Label a] + attribute (Stochastic a) = [G.Style G.Filled, G.FillColor (G.RGB 100 0 0) + , G.Shape G.Rectangle + , G.Label a] + attribute (Control a) = [G.Style G.Filled, G.FillColor (G.RGB 255 0 0) + , G.Shape G.Rectangle + , G.Label a] instance (Vertex a, Vertex b) => Vertex (Either a b) where - name = either name name - isReward = either isReward isReward - isNonReward = either isNonReward isNonReward - isDynamics = either isDynamics isDynamics - isControl = either isControl isControl - attribute = either attribute attribute + name = either name name + isReward = either isReward isReward + isNonReward = either isNonReward isNonReward + isDeterministic = either isDeterministic isDeterministic + isStochastic = either isStochastic isStochastic + isControl = either isControl isControl + attribute = either attribute attribute -- | An edge in a graph type Edge = (Node, Node, EdgeType) @@ -218,9 +238,9 @@ u = 'mkNonReward' \"u\" r = 'mkReward' \"r\" -f = 'mkDynamics' \"f\" -g = 'mkControl' \"g\" -d = 'mkDynamics' \"d\" +f = 'mkStochastic' \"f\" +g = 'mkControl' \"g\" +d = 'mkStochastic' \"d\" dynamics t = f(t-1).$.( x(t) .|. if t == 1 then [] else [x(t-1), u(t-1)] ) ++ g(t) .$.( u(t) .|. map x[1..t] ++ map u[1..t-1] ) @@ -237,18 +257,18 @@ follows. @ -m = 'NonReward' \"m\" -mhat = 'NonReward' \"mhat\" -r = 'Reward' \"r\" -h = 'Dynamics' \"h\" -g = 'Control' \"g\" -d = 'Dynamics' \"d\" +m = 'NonReward' \"m\" +mhat = 'NonReward' \"mhat\" +r = 'Reward' \"r\" +h = 'Stochastic' \"h\" +g = 'Control' \"g\" +d = 'Stochastic' \"d\" x = 'mkNonReward' \"x\" y = 'mkNonReward' \"y\" -f = 'mkControl' \"f\" -c = 'mkDynamics' \"c\" +f = 'mkControl' \"f\" +c = 'mkStochastic' \"c\" start = h .$.( m .|. [] ) dynamics t = f(t) .$. ( x(t) .|. m : map x [1..t-1] ++ map y [1..t-1] ) @@ -328,8 +348,9 @@ -- | Pretty print the team specification showTeam :: Team -> String -showTeam team = showTeamBy team isDynamics "Dynamics:" ++ "\n" - ++ showTeamBy team isControl "Control :" ++ "\n" +showTeam team = showTeamBy team isStochastic "Stochastic:" ++ "\n" + ++ showTeamBy team isDeterministic "Deterministic" ++ "\n" + ++ showTeamBy team isControl "Control :" ++ "\n" showTeamBy :: Team -> (Node -> Bool) -> String -> String showTeamBy team p str = if null equations diff --git a/Data/Teams/Structure.hs b/Data/Teams/Structure.hs --- a/Data/Teams/Structure.hs +++ b/Data/Teams/Structure.hs @@ -133,8 +133,9 @@ mkClean v@(NonReward _) = VMarked v NotMarked NotScheduled NotVisited instance Initializable Factor where - mkClean f@(Dynamics _) = FMarked f NotMarked NotScheduled NotVisited - mkClean f@(Control _) = FMarked f NotMarked NotScheduled NotVisited + mkClean f@(Deterministic _) = FMarked f NotMarked NotScheduled NotVisited + mkClean f@(Stochastic _) = FMarked f NotMarked NotScheduled NotVisited + mkClean f@(Control _) = FMarked f NotMarked NotScheduled NotVisited instance (Initializable a, Initializable b) => Initializable (Either a b) where mkClean (Left a) = mkClean a @@ -195,7 +196,7 @@ bottomVisit | x `elem` condition = id | otherwise = checkAction . markBottom -- Check if a node is a deterministic node or not. - checkAction | isDeterministic gr x = id + checkAction | isFunctional gr x = id | otherwise = markTop -- When the visit is from the top, is the node is in the -- conditioning node and its bottom is not marked, mark its bottom @@ -231,12 +232,12 @@ markVisited{- g -} = visitNode x -- g markClean {- g -} = cleanNode x -- g --- | Check if a node is deterministic. Currently we simply check if its parent --- is a control node. -isDeterministic :: MTeam -> G.Node -> Bool -isDeterministic mteam x = case G.pre mteam x of +-- | Check if a node is functionally deterministic. We check if its parent +-- is a control node or a deterministic +isFunctional :: MTeam -> G.Node -> Bool +isFunctional mteam x = case G.pre mteam x of [] -> True - [y] -> isControl. node . label mteam $ y + [y] -> or . sequence [isControl, isDeterministic] . node . label mteam $ y _ -> False -- | Modify a marked node diff --git a/teams.cabal b/teams.cabal --- a/teams.cabal +++ b/teams.cabal @@ -1,5 +1,5 @@ Name: teams -Version: 0.0.1 +Version: 0.0.2 Description: Graphical modeling tools for sequential teams License: GPL License-file: LICENSE @@ -16,4 +16,5 @@ Data.Teams.Structure Data.Teams.Examples.Wit79 Data.Teams.Examples.DecMdp + Data.Teams.Examples.MAB ghc-options: -Wall