module Reactive.QState where
import Reactive.Event
import Reactive.Updatable
import Reactive.Duration
import Reactive.TimeStamp
import Reactive.RTile
import Tile.Atom
import Tile.QList
import Tile.Tile
import Duration.Lattice
import Reactive.Input
import Debug.Trace
myTrace :: [Char] -> a -> a
myTrace w a = a
color c s = "\x1b["++ show (c::Int) ++"m" ++ s ++ "\x1b[0m"
colorPurple = color 35
colorGreen = color 32
colorRed = color 31
data QState d iv v = QState
{ now :: TimeStamp d
, qlist :: !(QList (RDuration d iv) iv v)
, rank :: Integer
, ouput :: ! [RAtom d iv v]
, isStateOn :: Bool
} deriving (Show)
data DelayedEvents d v = DelayedEvents !(TimeStamp d) [Event v] deriving (Show)
initQState :: (Num d, Ord d, Ord iv, Ord v) => (Tile (RDuration d iv) iv iv -> Tile (RDuration d iv) iv v) -> QState d iv v
initQState f
= let initInput = InQList [] (IDQ (durationFromID (DelayID 0)) InQUndef)
fq q = toQList $ f (Tile 0 0 q)
in QState (TimeStamp 0) (QRec 1 (fq . inputToQ) initInput) 0 [] False
inputToQ :: (Lattice d, Num d) => InQList d iv -> QList d iv iv
inputToQ (InQList ial (IDQ dd iq))
= let al = (map (\(d,v) -> (Atom d v)) ial)
in case partialCompare 0 dd of
Just LT -> QList al (DQ dd $ QRec 1 inputToQ iq)
Just EQ -> mergeQ (QList al (DQ 0 QEnd), inputToQ iq)
Just GT -> error "inputToQ: Illegal negative delay"
_ -> error "inputToQ: Illegal unknown delay"
inputToQ (InQEnd) = QEnd
inputToQ (InQUndef) = error "inputToQ: Undefined input : causality error"
updateState :: forall d iv v. (Num d, Ord d, Ord iv, Ord v, Show d, Show v, Show iv) =>
QState d iv v -> DelayedEvents d iv -> (QState d iv v,[DelayedEvents d v],WakeUpOrder d)
updateState q@(QState last state step active isStateOn) (DelayedEvents current le)
= let
parseEvent (On v) (lOn,lOff,lStop,lStart) = (On v:lOn,lOff,lStop,lStart)
parseEvent (Off v) (lOn,lOff,lStop,lStart) = (lOn,Off v:lOff,lStop,lStart)
parseEvent (Stop) (lOn,lOff,lStop,lStart) = (lOn,lOff,Stop:lStop,lStart)
parseEvent (Start) (lOn,lOff,lStop,lStart) = (lOn,lOff,lStop,Start:lStart)
(eventsOn, eventsOff, eventsStop,eventsStart) = foldr parseEvent ([],[],[],[]) le
d = case (eventsStart) of
[] -> timeStampDelta current last
_ -> 0
getNewTail eventsStart eventsOn eventsStop
= let newAtoms = [(durationFromID (ValueID v),v) | On v <- eventsOn]::[(Duration d (ID iv), iv)]
in case (eventsStart,eventsOn,eventsStop) of
([],[],[]) -> InQUndef
(_,[],[]) -> InQList [] (IDQ (durationFromID (DelayID step1)) InQUndef)
(_,_,[]) -> InQList newAtoms (IDQ (durationFromID (DelayID step1)) InQUndef)
(_,[],_) -> InQEnd
(_,_,_) -> InQList newAtoms (IDQ (durationFromConst 0) InQEnd)
newInputBundle = not $ null (eventsStart++eventsOn++eventsStop)
endingVarID
= let offVarID = [ValueID v | Off v <- eventsOff]
in case newInputBundle of
True -> DelayID step : offVarID
False -> offVarID
update1, update2, update3 :: UpdateData (RDuration d iv) iv
update1 = (updateOnDelay d, id)
update2 = let newTail = getNewTail eventsStart eventsOn eventsStop
in (id,const newTail)
update3 = (updateOnVariable endingVarID, id)
(state0, active1)
= update update1 (state,active)
(state1, active2)
= (dropQ (durationFromConst d) state0,
[Atom (d1durationFromConst d) v1 | Atom d1 v1 <- active1])
(state2,step1)
= case newInputBundle of
False -> (state1,step)
True -> (update update2 state1,step+1)
(state3, active3)
= update update3 (state2, active2)
(state4,newActive) = (dropAtomsQ state3, getAtomsQ state3)
newOnZero = [On v | Atom d v <- newActive,d==0]
newOffZero = [Off v | On v <- newOnZero]
newOtherOn = [On v | Atom d v <- newActive,d/=0]
oldOff = [Off v | Atom d v <- active3, d == 0]
allE0 = oldOff ++ newOnZero ++ newOffZero ++ newOtherOn
active4 = [ Atom d v | Atom d v <- (newActive ++ active3), not $ isZeroDuration d]
waitDurList
= let endActive = [d | Atom d _ <- active4]
in case delayToTailQ state4 of
0 -> endActive
d -> d:endActive
getNextConstDelay [] = []
getNextConstDelay (d:ds)
= case maybeConstDur d of
Just d1 -> d1:getNextConstDelay ds
Nothing -> getNextConstDelay ds
wakeUp = case getNextConstDelay waitDurList of
[] -> NoWakeUp
ld -> let d = minimum ld
in case compare 0 d of
EQ -> NoWakeUp
_ -> WakeUp $ shiftTimeStamp d current
isStateOn1 = isStateOn || (not $ null eventsStart)
(allE,isStateOn2) = case (active3,delayToTailQ state4,isStateOn1) of
([],0,True) -> (allE0 ++ [Stop],False)
_-> (allE0,isStateOn1)
in (QState current state4 step1 active4 isStateOn2, [DelayedEvents current allE], wakeUp)
updateStateOnEvent :: (Num d, Ord d, Ord iv, Ord v, Show d, Show v, Show iv) =>
QState d iv v -> (DelayedEvents d iv) -> Maybe(TimeStamp d) -> (QState d iv v,[DelayedEvents d v],WakeUpOrder d)
updateStateOnEvent ts bi@(DelayedEvents current _) maybeWakeTime
= case maybeWakeTime of
Nothing -> updateState ts bi
Just wakeTime -> if wakeTime >= current
then updateState ts bi
else let (nts,[bo],wo1) = updateState ts (DelayedEvents wakeTime [])
nextWakeTime = case (wo1) of
NoWakeUp -> Nothing
WakeUp newTimeStamp -> Just newTimeStamp
(nts1,bos,wo2) = updateStateOnEvent nts bi nextWakeTime
in (nts1,bo:bos,wo2)