module Reactive.Banana.Internal.PushGraph (
compileToAutomaton
) where
import Control.Applicative
import Control.Arrow (first)
import Control.Category
import Prelude hiding ((.),id)
import Data.Label
import Data.Maybe
import Data.Monoid (Dual, Endo, Monoid(..))
import qualified Data.Vault as Vault
import Data.Hashable
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import Reactive.Banana.Internal.AST
import Reactive.Banana.Internal.InputOutput
import Reactive.Banana.Internal.TotalOrder as TotalOrder
import Debug.Trace
type Map = Map.HashMap
type Set = Set.HashSet
data Graph b
= Graph
{ grFormulas :: Formulas
, grChildren :: Map SomeNode [SomeNode]
, grEvalOrder :: EvalOrder
, grOutput :: Node b
, grInputs :: Inputs
}
type Formulas = Vault.Vault
type EvalOrder = TotalOrder SomeNode
type Values = Vault.Vault
type Inputs = Map Channel [SomeNode]
vaultLens :: Vault.Key a -> (Vault.Vault :-> Maybe a)
vaultLens key = lens (Vault.lookup key) (adjust)
where
adjust Nothing = Vault.delete key
adjust (Just x) = Vault.insert key x
formula :: Node a -> (Graph b :-> Maybe (FormulaD Nodes a))
formula node = vaultLens (keyFormula node) . formulaLens
where formulaLens = lens grFormulas (\x g -> g { grFormulas = x})
children :: Node a -> (Graph b :-> [SomeNode])
children node = lens (Map.lookupDefault [] (Exists node) . grChildren)
(error "TODO: can't set children yet")
value :: Node a -> (Values :-> Maybe a)
value node = vaultLens (keyValue node)
dependencies :: ToFormula t => FormulaD t a -> [SomeFormula t]
dependencies = caseFormula goE goB
where
goE :: ToFormula t => EventD t a -> [SomeFormula t]
goE (Never) = []
goE (UnionWith f e1 e2) = [ee e1,ee e2]
goE (FilterE _ e1) = [ee e1]
goE (ApplyE b1 e1) = [bb b1, ee e1]
goE (AccumE _ e1) = [ee e1]
goE _ = []
goB :: ToFormula t => BehaviorD t a -> [SomeFormula t]
goB (Stepper x e1) = [ee e1]
goB _ = []
dependenciesEval :: ToFormula t => FormulaD t a -> [SomeFormula t]
dependenciesEval (E (ApplyE b e)) = [ee e]
dependenciesEval formula = dependencies formula
toFormulaNodes :: FormulaD Expr a -> FormulaD Nodes a
toFormulaNodes = caseFormula (E . goE) (B . goB)
where
node :: Pair Node f a -> Node a
node = fstPair
goE :: forall a. EventD Expr a -> EventD Nodes a
goE (Never) = Never
goE (UnionWith f e1 e2) = UnionWith f (node e1) (node e2)
goE (FilterE p e) = FilterE p (node e)
goE (ApplyE b e) = ApplyE (node b) (node e)
goE (AccumE x e) = AccumE x (node e)
goE (InputE x) = InputE x
goB :: BehaviorD Expr a -> BehaviorD Nodes a
goB (Stepper x e) = Stepper x (node e)
goB (InputB x) = InputB x
calculateE
:: forall a b.
(forall e. Node e -> Maybe e)
-> (forall b. Node b -> b)
-> Node a
-> EventD Nodes a
-> ( Maybe a
, Graph b -> Graph b)
calculateE valueE valueB node =
maybe (Nothing,id) (\(x,f) -> (Just x, f)) . goE
where
goE :: EventD Nodes a -> Maybe (a, Graph b -> Graph b)
goE (Never) = nothing
goE (UnionWith f e1 e2) = case (valueE e1, valueE e2) of
(Just e1, Just e2) -> just $ f e1 e2
(Just e1, Nothing) -> just e1
(Nothing, Just e2) -> just e2
(Nothing, Nothing) -> nothing
goE (FilterE p e) = valueE e >>=
\e -> if p e then just e else nothing
goE (ApplyE b e) = (just . (valueB b $)) =<< valueE e
goE (AccumE x e) = case valueE e of
Nothing -> just x
Just f -> let y = f x in
Just (y, set (formula node) . Just $ E (AccumE y e))
goE (InputE _) =
just =<< valueE node
just x = Just (x, id)
nothing = Nothing
calculateB
:: forall a b.
(forall e. Node e -> Maybe e)
-> Node a
-> BehaviorD Nodes a
-> Graph b -> Graph b
calculateB valueE node = maybe id id . goB
where
goB :: BehaviorD Nodes a -> Maybe (Graph b -> Graph b)
goB (Stepper x e) =
(\y -> set (formula node) $ Just $ B (Stepper y e)) <$> valueE e
goB (InputB x) = error "TODO"
buildGraph :: Formula Expr b -> Graph b
buildGraph expr = graph
where
graph = Graph
{ grFormulas = grFormulas
, grChildren = buildChildren (Exists root) grFormulas
, grEvalOrder = buildEvalOrder graph
, grOutput = root
, grInputs = buildInputs (Exists root) grFormulas
}
grFormulas = buildFormulas (Exists expr)
root = fstPair expr
buildFormulas :: SomeFormula Expr -> Formulas
buildFormulas expr =
unfoldGraphDFSWith leftComposition f expr $ Vault.empty
where
f (Exists (Pair node formula)) =
( \formulas -> Vault.insert (keyFormula node) formula' formulas
, dependencies formula )
where
formula' = toFormulaNodes formula
buildChildren :: SomeNode -> Formulas -> Map SomeNode [SomeNode]
buildChildren root formulas =
unfoldGraphDFSWith leftComposition f root $ Map.empty
where
f (Exists node) = (addChild deps, deps)
where
addChild = concatenate . map (\node -> Map.insertWith (++) node [child])
child = Exists node :: SomeNode
Just formula' = getFormula' node formulas
deps = dependencies formula'
getFormula' node formulas = Vault.lookup (keyFormula node) formulas
concatenate :: [a -> a] -> (a -> a)
concatenate = foldr (.) id
updateEvalOrder :: SomeNode -> Formulas -> EvalOrder -> EvalOrder
updateEvalOrder = error "TODO"
buildEvalOrder :: Graph a -> EvalOrder
buildEvalOrder graph =
TotalOrder.fromAscList $
concatMap (\x -> unfoldGraphDFSWith leftComposition f x [])
(root:findBehaviors)
where
root = Exists $ grOutput graph
f (Exists node) = ((Exists node:), dependenciesEval formula')
where Just formula' = get (formula node) graph
findBehaviors :: [SomeNode]
findBehaviors = traverseNodes g graph
where
g :: Node a -> FormulaD Nodes a -> [SomeNode]
g node (B _) = [Exists node]
g _ _ = []
buildInputs :: SomeNode -> Formulas -> Inputs
buildInputs root formulas =
unfoldGraphDFSWith leftComposition f root Map.empty
where
f (Exists node) = (addInput, dependencies formula')
where
Just formula' = getFormula' node formulas
addInput :: Inputs -> Inputs
addInput = case formula' of
E (InputE i) -> Map.insertWith (++) (getChannel i) [Exists node]
_ -> id
traverseNodes
:: Monoid t
=> (forall a. Node a -> FormulaD Nodes a -> t)
-> Graph b
-> t
traverseNodes f graph =
unfoldGraphDFSWith reifyMonoid g (Exists $ grOutput graph)
where
g (Exists node) = (f node formula', dependencies formula')
where Just formula' = get (formula node) graph
data MonoidDict t = MonoidDict t (t -> t -> t)
reifyMonoid :: Monoid t => MonoidDict t
reifyMonoid = MonoidDict mempty mappend
unfoldGraphDFSWith
:: forall s t. (Hashable s, Eq s) => MonoidDict t -> (s -> (t,[s])) -> s -> t
unfoldGraphDFSWith (MonoidDict empty append) f s = go Set.empty [s]
where
go :: Set s -> [s] -> t
go seen [] = empty
go seen (x:xs)
| x `Set.member` seen = go seen xs
| otherwise = t `append` go (Set.insert x seen) (ys++xs)
where
(t,ys) = f x
leftComposition :: MonoidDict (a -> a)
leftComposition = MonoidDict id (flip (.))
evaluate :: Queue q => q SomeNode -> Graph b -> Values -> (Maybe b, Graph b)
evaluate startQueue startGraph startValues =
(get (value (grOutput startGraph)) endValues, endGraph)
where
(_,endValues,endGraph) =
until (isEmpty . queue) step (startQueue,startValues,startGraph)
queue (q,_,_) = q
step (q,v,g) = (q',v',f g)
where (q',v',f) = evaluationStep startGraph q v
evaluationStep
:: forall q b. Queue q
=> Graph b
-> q SomeNode
-> Values
-> (q SomeNode, Values, Graph b -> Graph b)
evaluationStep graph queue values = case minView queue of
Just (Exists node, queue) -> go node queue
Nothing -> error "evaluationStep: queue empty"
where
go :: forall a b.
Node a -> q SomeNode -> (q SomeNode, Values, Graph b -> Graph b)
go node queue =
let
valueE :: forall e. Node e -> Maybe e
valueE node = get (value node) values
valueB :: forall b. Node b -> b
valueB node = case get (formula node) graph of
Just (B (Stepper b _)) -> b
_ -> error "evaluationStep: behavior not found"
err = error "evaluationStep: formula not found"
in
case maybe err id $ get (formula node) graph of
B formulaB ->
(queue, values, calculateB valueE node formulaB)
E formulaE ->
let
(maybeval, f) =
calculateE valueE valueB node formulaE
setValue = case maybeval of
Just x -> set (value node) (Just x)
Nothing -> id
setQueue = case maybeval of
Just _ -> insertList $ get (children node) graph
Nothing -> id
in (setQueue queue, setValue values, f)
compileToAutomaton :: Event Expr b -> IO (Automaton b)
compileToAutomaton expr = return $ fromStateful automatonStep $ buildGraph (e expr)
where
e :: Event Expr b -> Formula Expr b
e (Pair n x) = Pair n (E x)
automatonStep :: [InputValue] -> Graph b -> IO (Maybe b, Graph b)
automatonStep inputs graph = return (b, graph')
where
inputNodes :: [(InputValue, SomeNode)]
inputNodes =
[ (i, node)
| i <- inputs
, nodes <- maybeToList $ Map.lookup (getChannel i) (grInputs graph)
, node <- nodes]
startValues = foldr insertInput Vault.empty inputNodes
insertInput :: (InputValue, SomeNode) -> Values -> Values
insertInput (i,somenode) = maybe id id $
withInputNode somenode (\node channel ->
maybe id (Vault.insert (keyValue node)) $ fromValue channel i
)
withInputNode :: SomeNode
-> (forall a. Node a -> InputChannel a -> b) -> Maybe b
withInputNode somenode f = case somenode of
Exists node ->
let theformula = get (formula node) graph
in case theformula of
Just (E (InputE channel)) -> Just $ f node channel
_ -> Nothing
(b,graph') = withTotalOrder (grEvalOrder graph) $ \qempty ->
evaluate (insertList (map snd inputNodes) qempty) graph startValues