content: -- |
  -- Module:     FRP.Netwire.Utils.Timeline
  -- Copyright:  (c) 2013 Ertugrul Soeylemez
  -- License:    BSD3
  -- Maintainer: Ertugrul Soeylemez <es@ertes.de>
  
  {-# LANGUAGE DeriveDataTypeable #-}
  
  module FRP.Netwire.Utils.Timeline
      ( -- * Time lines for statistics wires
        Timeline,
  
        -- * Constructing time lines
        insert,
        singleton,
        union,
  
        -- * Linear sampling
        linAvg,
        linCutL,
        linCutR,
        linLookup,
  
        -- * Staircase sampling
        scAvg,
        scCutL,
        scCutR,
        scLookup
      )
      where
  
  import Control.Applicative
  import Data.Data
  import Data.Map.Strict (Map)
  import qualified Data.Map.Strict as M
  
  
  -- | A time line is a non-empty set of samples together with time
  -- information.
  
  newtype Timeline t a =
      Timeline {
        timeline :: Map t a
      }
      deriving (Data, Eq, Ord, Read, Show, Typeable)
  
  instance Functor (Timeline t) where
      fmap f (Timeline m) = Timeline (M.map f m)
  
  
  -- | Insert the given data point.
  
  insert :: (Ord t) => t -> a -> Timeline t a -> Timeline t a
  insert t x (Timeline m) = Timeline (M.insert t x m)
  
  
  -- | Linearly interpolate the points in the time line, integrate the
  -- given time interval of the graph, divide by the interval length.
  
  linAvg ::
      (Fractional a, Fractional t, Real t)
      => t -> t -> Timeline t a -> a
  linAvg t0 t1
      | t0 > t1 = const (error "linAvg: Invalid interval")
      | t0 == t1 = linLookup t0
  linAvg t0 t1 = avg 0 . M.assocs . timeline . linCutR t1 . linCutL t0
      where
      avg a' ((t', y1) : xs@((t, y2) : _)) =
          let dt = realToFrac (t - t')
              a  = a' + dt*(y1 + y2)/2
          in a `seq` avg a xs
      avg a' _ = a' / realToFrac (t1 - t0)
  
  
  -- | Cut the timeline at the given point in time @t@, such that all
  -- samples up to but not including @t@ are forgotten.  The most recent
  -- sample before @t@ is moved and interpolated accordingly.
  
  linCutL ::
      (Fractional a, Fractional t, Real t)
      => t -> Timeline t a -> Timeline t a
  linCutL t tl@(Timeline m) =
      Timeline $
      case M.splitLookup t m of
        (_, Just x, mr) -> M.insert t x mr
        (_, _, mr)      -> M.insert t (linLookup t tl) mr
  
  
  -- | Cut the timeline at the given point in time @t@, such that all
  -- samples later than @t@ are forgotten.  The most recent sample after
  -- @t@ is moved and interpolated accordingly.
  
  linCutR ::
      (Fractional a, Fractional t, Real t)
      => t -> Timeline t a -> Timeline t a
  linCutR t tl@(Timeline m) =
      Timeline $
      case M.splitLookup t m of
        (ml, Just x, _) -> M.insert t x ml
        (ml, _, _)      -> M.insert t (linLookup t tl) ml
  
  
  -- | Look up with linear sampling.
  
  linLookup :: (Fractional a, Fractional t, Real t) => t -> Timeline t a -> a
  linLookup t (Timeline m) =
      case M.splitLookup t m of
        (_, Just x, _) -> x
        (ml, _, mr)    ->
            case (fst <$> M.maxViewWithKey ml, fst <$> M.minViewWithKey mr) of
              (Just (t1, x1), Just (t2, x2)) ->
                  let f = realToFrac ((t - t1) / (t2 - t1))
                  in x1*(1 - f) + x2*f
              (Just (_, x), _) -> x
              (_, Just (_, x)) -> x
              _                -> error "linLookup: BUG: querying empty Timeline"
  
  
  -- | Integrate the given time interval of the staircase, divide by the
  -- interval length.
  
  scAvg :: (Fractional a, Real t) => t -> t -> Timeline t a -> a
  scAvg t0 t1
      | t0 > t1 = const (error "scAvg: Invalid interval")
      | t0 == t1 = scLookup t0
  scAvg t0 t1 = avg 0 . M.assocs . timeline . scCutR t1 . scCutL t0
      where
      avg a' ((t', y) : xs@((t, _) : _)) =
          let dt = realToFrac (t - t')
              a  = a' + dt*y
          in a `seq` avg a xs
      avg a' _ = a' / realToFrac (t1 - t0)
  
  
  -- | Cut the timeline at the given point in time @t@, such that all
  -- samples up to but not including @t@ are forgotten.  The most recent
  -- sample before @t@ is moved accordingly.
  
  scCutL :: (Ord t) => t -> Timeline t a -> Timeline t a
  scCutL t tl@(Timeline m) =
      Timeline $
      case M.splitLookup t m of
        (_, Just x, mr) -> M.insert t x mr
        (_, _, mr)      -> M.insert t (scLookup t tl) mr
  
  
  -- | Cut the timeline at the given point in time @t@, such that all
  -- samples later than @t@ are forgotten.  The earliest sample after @t@
  -- is moved accordingly.
  
  scCutR :: (Ord t) => t -> Timeline t a -> Timeline t a
  scCutR t tl@(Timeline m) =
      Timeline $
      case M.splitLookup t m of
        (ml, Just x, _) -> M.insert t x ml
        (ml, _, _)      -> M.insert t (scLookup t tl) ml
  
  
  -- | Look up on staircase.
  
  scLookup :: (Ord t) => t -> Timeline t a -> a
  scLookup t (Timeline m) =
      case (M.lookupLE t m, M.lookupGE t m) of
        (Just (_, x), _) -> x
        (_, Just (_, x)) -> x
        _                -> error "linLookup: BUG: querying empty Timeline"
  
  
  -- | Singleton timeline with the given point.
  
  singleton :: t -> a -> Timeline t a
  singleton t = Timeline . M.singleton t
  
  
  -- | Union of two time lines.  Right-biased.
  
  union :: (Ord t) => Timeline t a -> Timeline t a -> Timeline t a
  union (Timeline m1) (Timeline m2) = Timeline (M.union m2 m1)
  