diff --git a/Data/Teams/Examples/DecMdp.hs b/Data/Teams/Examples/DecMdp.hs --- a/Data/Teams/Examples/DecMdp.hs +++ b/Data/Teams/Examples/DecMdp.hs @@ -14,7 +14,7 @@ g2 = mkControl "g2" d = mkStochastic "d" -dynamics t = f(t).$.(x(t) .|. if t == 1 then [] else [x(t-1), u1(t-1), u2(t-1)]) +dynamics t = f(t).$.(x(t) .|. onlyif (t /= 1) [x(t-1), u1(t-1), u2(t-1)]) ++ g1(t).$.(u1(t) .|. map x[1..t] ++ map u1[1..t-1]) ++ g2(t).$.(u2(t) .|. map x[1..t] ++ map u2[1..t-1]) ++ d(t) .$.(r(t) .|. [x(t), u1(t), u2(t)]) diff --git a/Data/Teams/Examples/MAB.hs b/Data/Teams/Examples/MAB.hs --- a/Data/Teams/Examples/MAB.hs +++ b/Data/Teams/Examples/MAB.hs @@ -27,15 +27,15 @@ 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)]) +dynamics t = f1(t).$.(x1(t).|. onlyif (t /= 1) [x1(t-1), u1(t-1), z2(t-1)]) + ++ f2(t).$.(x2(t).|. onlyif (t /= 1) [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)]) + ++ 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 @@ -32,7 +32,5 @@ ++ l(t).$.(m(t) .|. [y(t), m(t-1)]) ++ d(t).$.(r(t) .|. [x(t), x'(t)]) -rt = mkTeamTime dynamics 4 - -rt' = simplify rt +rt = mkTeamTime dynamics 3 diff --git a/Data/Teams/Graph.hs b/Data/Teams/Graph.hs --- a/Data/Teams/Graph.hs +++ b/Data/Teams/Graph.hs @@ -46,6 +46,8 @@ , printTeam , showTeam , graphToDot , printGraph -- * Utility functions for "Data.Graph.Inductive" , label, labels + -- * Utility functions for "Control.Monad" + , onlyif ) where import qualified Data.Graph.Inductive as G @@ -53,6 +55,7 @@ import Data.Maybe (fromJust) import Data.List (nub, intercalate, delete) import Text.Printf (printf) +import Control.Monad (MonadPlus, mzero) -- | Time type Time = Int @@ -137,11 +140,11 @@ isStochastic _ = False isControl _ = False - attribute (Reward a) = [G.Style G.Filled, G.FillColor (G.RGB 0 255 0) + attribute (Reward a) = [G.Style [G.SItem G.Filled []], G.FillColor (G.RGB 255 204 255) , G.Shape G.Circle - , G.Label a] + , G.Label (G.StrLabel a)] attribute (NonReward a) = [G.Shape G.Circle - , G.Label a] + , G.Label (G.StrLabel a)] instance Vertex Factor where name (Deterministic a) = a @@ -164,13 +167,13 @@ isNonReward _ = False 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.Label (G.StrLabel a)] + attribute (Stochastic a) = [-- G.Style [G.SItem G.Filled []], G.FillColor (G.RGB 100 255 255) + {-,-} G.Shape G.Rectangle + , G.Label (G.StrLabel a)] + attribute (Control a) = [G.Style [G.SItem G.Filled []], G.FillColor (G.RGB 204 255 255) , G.Shape G.Rectangle - , G.Label a] + , G.Label (G.StrLabel a)] instance (Vertex a, Vertex b) => Vertex (Either a b) where name = either name name @@ -212,6 +215,9 @@ infixr 4 .|. infixr 6 .$. +onlyif :: MonadPlus m => Bool -> m a -> m a +onlyif p a = if p then a else mzero + -- | A sequential team as a directed acyclic factor graph (DAFG) type Team = G.Gr Node EdgeType @@ -368,8 +374,8 @@ -- * Convert to Graphviz graphs -- | Convert the graph to a dot file -graphToDot :: Team -> G.DotGraph -graphToDot team = G.graphToDot team [] (attribute.snd) +graphToDot :: Team -> G.DotGraph G.Node +graphToDot team = G.graphToDot True team [] (attribute.snd) (edgeAttribute. \(_,_,b) -> b) -- | Convert the dot file to a pdf diff --git a/Data/Teams/Structure.hs b/Data/Teams/Structure.hs --- a/Data/Teams/Structure.hs +++ b/Data/Teams/Structure.hs @@ -155,9 +155,8 @@ -- Then schedule all reward nodes to be visited from bottom. mteam = G.gmap initialize . G.nmap mkClean $ team initialize (pre,idx,lab,suc) = (pre, idx, lab', suc) - where lab' = if idx `elem` reward - then addSchedule BottomScheduled lab - else lab + where lab' | idx `elem` reward = addSchedule BottomScheduled lab + | otherwise = lab -- | The main loop of the Bayes Ball algorithm doBayesBall :: [G.Node] -> MTeam -> MTeam @@ -294,6 +293,7 @@ effective :: Team -> [G.Node] -> [G.Node] -> [G.Node] effective team conditioned reward = (determined team conditioned `intersect` ancestoral team reward) \\ conditioned +-- effective team conditioned reward = determined team conditioned \\ conditioned -- | The graph restructuring algorithm of the paper. simplifyAt :: Team -> G.Node -> Team @@ -319,7 +319,8 @@ simplify :: Team -> Team simplify team = untilEqual . zip stream $ [(1::Int)..] where stream = iterate simplifyOnce team - untilEqual ((a,n):as@((b,_):_)) = trace ("Simplify : Iteration " ++ show n) $ - if G.equal a b then a - else untilEqual as + untilEqual ((a,n):as@((b,_):_)) + | G.equal a b = a + | otherwise = trace ("Simplify : Iteration " ++ show n) + (untilEqual as) untilEqual _ = error "Infinite stream ended. This should not happen" diff --git a/teams.cabal b/teams.cabal --- a/teams.cabal +++ b/teams.cabal @@ -1,5 +1,5 @@ Name: teams -Version: 0.0.2.1 +Version: 0.0.2.3 Description: Graphical modeling tools for sequential teams License: GPL License-file: LICENSE @@ -11,7 +11,7 @@ Stability: experimental Synopsis: Graphical modeling tools for sequential teams Library - Build-Depends: base, fgl>=5.4, containers, graphviz>=2009.5.1 + Build-Depends: base<5.0, fgl>=5.4, containers, graphviz>=2909.6.0.0 Exposed-modules: Data.Teams.Graph Data.Teams.Structure Data.Teams.Examples.Wit79