module FRP.Netwire.Utils.Timeline
(
Timeline,
insert,
singleton,
union,
linAvg,
linCutL,
linCutR,
linLookup,
scAvg,
scCutL,
scCutR,
scLookup
)
where
import qualified Data.Map.Strict as M
import Data.Data
import Data.Map.Strict (Map)
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 :: (Ord t) => t -> a -> Timeline t a -> Timeline t a
insert t x (Timeline m) = Timeline (M.insert t x m)
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)
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
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
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"
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)
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
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
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 :: t -> a -> Timeline t a
singleton t = Timeline . M.singleton t
union :: (Ord t) => Timeline t a -> Timeline t a -> Timeline t a
union (Timeline m1) (Timeline m2) = Timeline (M.union m2 m1)