{-|
Module      : QState
Description : Turning function over (nice) tiles into reactive systems
Copyright   : (c) David Janin, 2016
License     : see the LICENSE file in the distribution
Maintainer  : janin@labri.fr
Stability   : experimental

-}

{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

{-# LANGUAGE ScopedTypeVariables,
  BangPatterns #-}

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 -- seq  (trace w ()) a

color c s = "\x1b["++ show (c::Int) ++"m" ++ s ++ "\x1b[0m"
colorPurple = color 35
colorGreen = color 32
colorRed = color 31

-- * Qstate data

-- | Embedding of qlists into event function
data QState d iv v = QState
   { now :: TimeStamp d
   -- ^ State timestamp
   , qlist :: !(QList (RDuration d iv) iv v)
   -- ^ Qlist to be played
   , rank :: Integer
   -- ^ Rank of the last received bundle of time values
   , ouput :: ! [RAtom d iv v]
   -- ^ Unfinished output temporal values
   , isStateOn :: Bool
   -- ^ Is the state active
   } deriving (Show)
        
-- | Delayed event bundles
data DelayedEvents d v = DelayedEvents !(TimeStamp d) [Event v] deriving (Show)

                       
-- * Initialization


-- | Init a qstate from a function of tile turned into a function over QLists.
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

-- | converts input lists to output lists
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"

-- * Transition loops

-- | Updates states upon reception of list of a bundle of new events, possibly empty in case of wake up.
--
-- In updateState ts le, ts is the Qstate, le is the possibly empty list of timed stamped events (aka DelayedEvents) 
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 -- up1, up2, up3 :: UpdateData  (RDuration d iv) iv
              -- WARNING: THIS FUNCTION IS THE TRUE KERNEL OF ALL THE REACTIVE PART OF THE T-CALCULUS.
              -- ITS CODE IS YET EXTREEMELY SENSITIVE... AND IT SHOULD BE COMPLETELY REWRITTEN WHEN FULLY (OR RATHER NEATLY UNDERSTOOD)
              -- ALL "myTrace" CALLS ARE THERE ONLY FOR READING TRACE EXECUTIONS FOR DEBUG...
              -- AND, AS ONCE SAID BY A FRENCH COLLEAGUE, TRACING HASKELL RUNTIME... IS A BIT HARD... :-)  
        -- getting update arguments
        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
        -- eventsOff with old matching On must be distinguished from eventsOff with received matchingOn
        d =  case (eventsStart) of
               [] -> timeStampDelta current last
               _ -> 0
                    
        -- a function to compute QUndef replacement
        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
                                 -- this should never happend
                   (_,[],[]) -> InQList [] (IDQ (durationFromID (DelayID step1)) InQUndef)
                                -- just a start
                   (_,_,[]) -> InQList newAtoms (IDQ (durationFromID (DelayID step1)) InQUndef)
                               -- new events and no stops
                   (_,[],_) -> InQEnd
                               -- no event and a stop
                   (_,_,_) -> InQList newAtoms (IDQ (durationFromConst 0) InQEnd)
                              -- new events and a stop
                              
        -- various controler values
        newInputBundle = not $ null  (eventsStart++eventsOn++eventsStop)
        endingVarID
            = let offVarID = [ValueID v | Off v <- eventsOff]
              in case newInputBundle of
                   True -> DelayID step : offVarID
                   False -> offVarID
        -- various update values                    
        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)
        -- duration update
        (state0, active1)
            = update update1 (state,active)
        -- nibbling update
        (state1, active2)
            = (dropQ (durationFromConst d) state0,
                     [Atom (d1-durationFromConst d) v1 | Atom d1 v1 <- active1])
        -- update on new bundle
        (state2,step1)
            = case newInputBundle of
                False -> (state1,step)
                True -> (update update2 state1,step+1)
        -- update on ending duration
        (state3, active3)
            =  update update3 (state2, active2)
        -- getting new atoms
                           
        (state4,newActive) = (dropAtomsQ state3, getAtomsQ state3)
        -- getting new events
        newOnZero = [On v | Atom d v <- newActive,d==0]-- isZeroDuration d]
        newOffZero = [Off v | On v <- newOnZero]
        newOtherOn = [On v | Atom d v <- newActive,d/=0] -- not $ isZeroDuration d]
        oldOff = [Off v | Atom d v <- active3, d == 0] -- isZeroDuration d]
        allE0 =  oldOff ++ newOnZero ++ newOffZero  ++ newOtherOn
               
        -- updating active atom list
        active4 =  [ Atom d v | Atom d v <- (newActive ++ active3), not $ isZeroDuration d]
        -- timer
        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
                                   --- concert version (THE SHOW MUST GO ON)
                                   --- the correct version below
                         {-
                              LT -> WakeUp $ shiftTimeStamp d current
                              GT -> error "State update : running late"
                                    -}
        -- Ouput Stop event if needed
        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)

-- | The kernel update step upon reception of list of non empty bundle of new events
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)