{-|
Module      : Event
Description : Events from which temporal values can be converted back and forth
Copyright   : (c) David Janin, 2016
License     : see the LICENSE file in the distribution
Maintainer  : janin@labri.fr
Stability   : experimental

Temporal values arise from well bracketed events.

-}

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

{-# LANGUAGE ScopedTypeVariables #-}

module Reactive.Event (Event(..),eventsToQList,eventsToTile,qListToEvents,tileToEvents, filterEvent, emptyWeight) where

import Tile.Tile
import Tile.QList
import Tile.Atom
import Duration.Lattice
    
import qualified Data.Map as M
import Data.List as L -- (sortOn,groupBy)

-- * Events type

-- | Events of type v. A temporal value v is then a pair of event On v, Off v, that tells how much last the value v.
-- The duration of an temporal value v is defined as the time elpased between the reception of event On v and teh event Off v.
--
-- A sequence of events over the value type v is well parenthesized, that is, for every value v:
--
-- * every On v event (resp. Off v event) is necessarily followed (resp. preceeded) by an Off v event (resp. On v event),
-- * two On v events (resp. Off v events) are necessarily separated by an Off v event (resp. an On v event).
--
-- Simultaneous events On v and Off v events denote a temporal value of duration 0 that is our encoding of classical (unpaired) events

data Event v = Start | Off !v | On !v | Stop deriving (Eq, Show)

instance Functor Event where
  fmap f (Off v) = Off (f v)
  fmap f (On v) = On (f v)
  fmap _ Stop = Stop
  fmap _ Start = Start

-- * Events vs qlist conversion functions

-- | Converts a qList into a sequence of a timed sequence of On/Off events.
-- The sequence starts with a 'Start' event and ends with a 'Stop' event.
-- Essentially used for testing purposes.

qListToEvents :: (Eq d, Num d,Ord d, Lattice d, Eq v, POrd v) =>
     QList d iv v -> [(d, Event v)]
qListToEvents qList
    = (0,Start):(L.sortOn fst . makeEvents 0 0) qList where
      makeEvents now lastOff qList
          =  let ldv = getAllFromAtomsQ qList
                 dn = delayToTailQ (dropAtomsQ qList)
                 newLastOff = maximum (lastOff:[now + d | (d,_) <- ldv])
             in (ldv >>= (\(d,v) -> [(now,On v), (now + d,Off v)]))
                         ++ if dn == 0 -- ldv == []
                            then [(newLastOff,Stop)]
                                 -- closing event
                            else makeEvents (now + dn) newLastOff (tailQ qList)

-- | Converts a tile into a sequence of a timed sequence of On/Off events.
-- The sequence starts with a 'Start' event and ends with a 'Stop' event.
-- All anticipation (atoms before the input root) are droped. 
tileToEvents :: (Eq d, Num d,Ord d, Lattice d, Eq v, POrd v) =>
     Tile d iv v -> [(d, Event v)]
tileToEvents t = qListToEvents $ toQList $ t 
    
-- we uses this function to pop the matching off given a on
popFirstElementThatSatisfyPredicate :: (a -> Bool) -> [a] -> (Maybe a, [a])
popFirstElementThatSatisfyPredicate p l =
  let (a,b) = break p l
  in case b of
       (e:b') -> (Just e, a ++ b')
       [] -> (Nothing, a)

-- | Converts a sequence of a timed sequence of On/Off events, starting with 'Start' event and ending with a 'Stop' event
-- into a qlist. Essentially used for testing purposes.
eventsToQList :: (Eq d, Eq v, Num d, Lattice d) => [(d, Event v)] -> QList d iv v
eventsToQList ((0,Start):l)  = eventsToQList l
eventsToQList ((_,Start):_) = error "eventsToQList: illegal start event date"
eventsToQList ((t,On v):l)  = 
  let (maybeMachingOff,l') = popFirstElementThatSatisfyPredicate (\e -> case e of (_,Off v') -> v == v'
                                                                                  _ -> False) l
  in case maybeMachingOff of -- given On v, we get the date of the corresponding Off v
        Nothing -> error "eventsToQList : No matching Off"
        Just (t', Off _) -> case (partialCompare 0 t) of
                              Just LT -> mergeQ (QList [] (DQ t (QList [Atom (t'- t) v] (DQ 0 QEnd)))
                                                ,eventsToQList l')
                              Just EQ -> mergeQ (QList [Atom (t'- t) v] (DQ 0 QEnd), eventsToQList l')
                              _ -> error "eventsToQList: this should never happen"
        _ -> error "eventsToQList: this should never happen"
eventsToQList ((_,Off _):_) = error "eventsToQList : eventsToQListStand alone Off"
eventsToQList [(_,Stop)] = QEnd
eventsToQList ((_,Stop):_) = error "eventsToQList: events after End events"
eventsToQList [] = error "eventsToQList: empty list ! missing Stop event"

-- | Converts the resulting qlists into tiles (obsolete)
eventsToTile :: (Eq d, Eq v, Num d, Lattice d) => [(d, Event v)] -> Tile d iv v
eventsToTile l = Tile 0 0 $ eventsToQList l


-- * Handling non well bracketed events (adhoc, but used with MIDI)

-- | Accumulates weight of events
type Weight v = M.Map v Integer

-- | initial Weight value
emptyWeight :: Weight v
emptyWeight = M.empty

-- | Updates the weight of a values upon the reception of On or Off event
updateWeight :: (Ord v) => Weight v -> Event v -> Weight v
updateWeight weight (On v)  = M.insertWith (+) v 1 weight
updateWeight weight (Off v) = M.update (\w -> if w == 1 then Nothing else Just (w-1)) v weight
updateWeight weight _ = weight
    
-- | Filters On and Off events to ensure they are well parenthesized
filterEvent ::  (Ord v) => Weight v -> [Event v] -> (Weight v, [Event v])
filterEvent w el = stepFilterEvent w [] el where -- ([Off v | Off v <- el] ++ [On v | On v <- el]) where
    stepFilterEvent w oel [] = (w,oel)
    stepFilterEvent w oel (e:iel)
        = let w1 = updateWeight w e
              oel1 = case (e) of
                       Off v -> case M.lookup v w1 of
                                  Nothing -> e:oel
                                  -- truely closing event
                                  _ -> oel
                                  -- remove the event
                       On v -> case M.lookup v w1 of
                                 Just 1  -> e:oel
                                 -- truely opening event
                                 _ -> oel
                       _ -> oel
          in stepFilterEvent w1 oel1 iel