{-|
Module      : Player
Description : The reactive player of (functions of) tiles
Copyright   : (c) Simon Archipoff, 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 FlexibleContexts #-}
{-# LANGUAGE Arrows #-}
module Runtime.Player where

import FRP.UISF
import Data.Maybe (isJust)

import Reactive.Event
import Reactive.QState
import Reactive.RTile

import Runtime.Probe
import Tile.QList

import Duration.Lattice
-- import Runtime.LoadMeter

import Control.Monad.State.Strict

import Reactive.TimeStamp
import Runtime.SymbolicTime

import System.Mem
import System.Clock
-- import Debug.Trace

-- | Internal clock in nanosecond
timeStamperNS :: UISF () (TimeStamp Integer)
timeStamperNS = proc () ->
  do ts <-  arr (const Monotonic) >>> liftAIO System.Clock.getTime >>> (arr $ toNanoSecs)  -< ()
     rec start <- delay Nothing -< if start == Nothing
                                   then Just ts
                                   else start
     returnA -< case start of
       Nothing -> TimeStamp 0
       Just start -> TimeStamp $ ts - start

-- | Produces symbolic time stamps, uses SymbolicTime
timeStamper :: UISF BPM (TimeStamp Quarters)
timeStamper = proc (bpm) ->
  do tsns <- timeStamperNS -< ()
     rec (stq,s) <- delay (TimeStamp $ Quarters 0,quartersInitState) <<<  arr (loopState nsToQuarters) -< ((tsns, bpm), s)
     returnA -< stq
  where
    loopState :: (a -> State s b) -> (a,s) -> (b,s)
    loopState f (a,s) = runState (f a) s

-- | Gets a list from a maybe list
maybeListToList :: Maybe [t] -> [t]
maybeListToList Nothing = []
maybeListToList (Just l)  = l

-- | Gets a maybe list from a list
listToMaybeList :: [t] -> Maybe [t]
listToMaybeList [] = Nothing
listToMaybeList l = Just l

-- | Generates Just ts when the current time stamp is greater or equal the ealierst wake up order (WakeUp ts); generates Nothing otherwise.
-- wakeUpTimer :: (Ord d, Show d) => UISF (TimeStamp d, WakeUpOrder d) (Maybe (TimeStamp d))

wakeUpTimer = proc (current, wakeUpOrder) ->
  do rec regWakeUp <- delay NoWakeUp -< newRegWakeUp
         let (wakeUpDate,newRegWakeUp)
                 = let earliestWakeUp
                       -- the earliest (and still active) wakeUp order received so far
                           = minimum [regWakeUp,wakeUpOrder]
                   in case earliestWakeUp of
                        NoWakeUp -> (Nothing,NoWakeUp)
                                  -- no active wakeUp order
                        WakeUp ts -> case (current < ts) of
                                     True -> (Nothing,WakeUp ts)
                                             -- wakeUp order still active
                                     False -> (Just ts,NoWakeUp)
                                             -- wakeUp ordered triggered and reseted to Nothing                                     
     returnA -< wakeUpDate


-- | Arrowizes a tile function into a event arrow
arrowizeTile :: (Ord iv, Ord v, Show v, Show iv) => (RTile Quarters iv iv -> RTile Quarters iv v) -> UISF (Maybe[Event iv],BPM) (Maybe[Event v])
arrowizeTile f
    = proc (inputMaybeEvents,beatPerMinutes) ->
      do rec let lattency = (epsilon*(fromInteger.getBPM $  beatPerMinutes))/60
             qState <- delay (initQState f)  -< newQState
             writeProbe -< qState
             -- liftAIO print -< (width_qlist (qlist qState))
             wakeUp <- delay (NoWakeUp) -< newWakeUp
             timeStamp <- timeStamper -< beatPerMinutes
             maybeWakeTime <- wakeUpTimer -< (shiftTimeStamp lattency timeStamp, wakeUp)
             let bundleInput = DelayedEvents  (shiftTimeStamp lattency timeStamp)  (maybeListToList  inputMaybeEvents)
             let (newQState, bundleOuput,newWakeUp)
                   = if isJust inputMaybeEvents || isJust maybeWakeTime
                     then updateStateOnEvent  qState bundleInput maybeWakeTime
                     else (qState, [], NoWakeUp)

         -- bufferizer les evènements créé pour ne sortir sur "returnA" que les évènements de timestamp antérieur à timeStamp....
         output <- launchOnTime -< (timeStamp,bundleOuput)
         returnA -< listToMaybeList $ concat $ map (\(DelayedEvents _ l) -> l)  output


-- | Global latency interval

epsilon = 2/100 -- in fraction of a second
          

-- | Launch event on time
launchOnTime :: UISF (TimeStamp Quarters, [DelayedEvents Quarters t]) [DelayedEvents Quarters t]
launchOnTime
    = proc (current, de) ->
      do rec (o,s) <- delay ([],[]) <<< arr f -< (current,s,de)
         returnA -< o
    where
      f (current,s,de)
              = span (\(DelayedEvents t' _) -> (t'< current))
                (case de of
                   [] -> s
                   _ -> forceDE $ s ++ de)
           
forceDE e = seq (foldl (\() (DelayedEvents d l) -> seq (seq d (seqEventList l ())) ()) () e) e
  where 
      seqEventList [] b = b
      seqEventList (x:l) b = seqEventList (seq (case x of
                                                   Start -> ()
                                                   Stop -> ()
                                                   On v -> seq v ()
                                                   Off v -> seq v ()) l) b