{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Temporal.Media ( -- * Time classes Dur(..), Temporal(..), Stretchable(..), ToMaybe(..), TemporalFunctor(..), -- * Transformers Reversible(..), Sliceable(..), cut, -- * Structure Construct(..), Arrangeable(..), Controlable(..), sequent, parallel, loop, delay, temp, -- * Media Media(..), fold, fromMedia, -- * Simple interperetation -- ** Event list Event, EventList(..), mapEvent, toEvent, toEventList, -- ** Unit Temporal Media MediaUnit(..), unMediaUnit, foldU, fromMediaUnit, Unit(..) ) where import Control.Applicative import Control.Monad import Data.Function import Data.Ratio import Prelude hiding (reverse, take, drop) import qualified Prelude as P (reverse) ------------------------------------------------- -- Classes -- ------------------------------------------------- -- Time classes -- | time class class (Num t, Ord t, Fractional t) => Dur t instance Dur Double instance Integral a => Dur (Ratio a) -- | Temporal structures class Dur t => Temporal t a where none :: t -> a -- ^ absence of value dur :: a -> t -- ^ duration of value -- | Stretching values by given time-factor class Dur t => Stretchable t a where stretch :: t -> a -> a -- | Values covertible to 'Maybe' -- -- auxiliary class for conversion to 'EventList' class ToMaybe m where toMaybe :: m a -> Maybe a -- | temporal map class Dur t => TemporalFunctor t f where tmap :: (t -> a -> b) -> f a -> f b --------------------------------------------------- -- transformers -- class Reversible a where reverse :: a -> a -- | extracting parts, minimal complete definition: 'slice'. class Temporal t a => Sliceable t a where slice :: t -> t -> a -> a -- ^ @slice t0 t1 v@ extracts part of @v@ inside @[t0, t1]@ take :: t -> a -> a drop :: t -> a -> a take t = slice 0 t drop t x = slice t (dur x) x sliceErrorMessage = error "should be t0 <= t1, for slice t0 t1" -- | mixing slice and reverse. -- -- @cut t0 t1 v@ - if @t1 < t0@ reverses result of 'slice' cut :: (Reversible a, Sliceable t a) => t -> t -> a -> a cut t0 t1 m | t0 <= t1 = slice t0 t1 m | otherwise = slice (tm - t0) (tm - t1) $ reverse m where tm = dur m ---------------------------------------------------- -- Structure -- -- | constructor for generic structures class Construct m where prim :: a -> m a -- | composing structures in sequent and parallel ways class Arrangeable a where (+:+) :: a -> a -> a (=:=) :: a -> a -> a -- | modifer class Controlable c a where control :: c -> a -> a sequent, parallel :: Arrangeable a => [a] -> a sequent = foldl1 (+:+) parallel = foldl1 (=:=) loop :: Arrangeable a => Int -> a -> a loop n = sequent . replicate n delay :: (Temporal t a, Arrangeable a) => t -> a -> a delay t x = none t +:+ x -- | constructs generic temporal structure @m a@ form time @t@ and initial value @a@ temp :: (Construct m, Temporal t (m a), Stretchable t (m a)) => t -> a -> m a temp t = stretch t . prim ---------------------------------------------------- -- Media -- | Data type to represent temporal media data Media c a = Prim a -- ^ single value | Media c a :+: Media c a -- ^ sequential composition | Media c a :=: Media c a -- ^ parallel composition | Control c (Media c a) -- ^ specific environment modifier deriving (Show, Eq) -- | Folding Media -- -- > fold prim seq par mod x -- -- * prim - responds to 'Prim' -- -- * seq - responds to ':+:' -- -- * par - responds to ':=:' -- -- * mod - responds to 'Control' fold :: (a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> b -> b) -> Media c a -> b fold prim seq par mod m = case m of Prim a -> prim a a :+: b -> (seq `on` f) a b a :=: b -> (par `on` f) a b Control c a -> mod c $ f a where f = fold prim seq par mod instance Functor (Media c) where fmap f x = case x of Prim a -> Prim $ f a a :+: b -> fmap f a :+: fmap f b a :=: b -> fmap f a :=: fmap f b Control c a -> Control c $ fmap f a instance Monad (Media c) where return = Prim ma >>= f = case ma of Prim a -> f a a :+: b -> (a >>= f) :+: (b >>= f) a :=: b -> (a >>= f) :=: (b >>= f) Control c a -> Control c $ a >>= f instance Applicative (Media c) where pure = return (<*>) = ap -- time instance Temporal t a => Temporal t (Media c a) where none = Prim . none dur = fold dur (+) max (const id) instance Stretchable t a => Stretchable t (Media c a) where stretch d = fmap $ stretch d -- transformers instance Reversible a => Reversible (Media c a) where reverse x = case x of Prim a -> Prim $ reverse a a :+: b -> ((:+:) `on` reverse) b a a :=: b -> ((:=:) `on` reverse) a b Control c a -> Control c $ reverse a instance Sliceable t a => Sliceable t (Media c a) where slice t0 t1 m | t1 < t0 = sliceErrorMessage | t0 < 0 = none (abs t0) :+: slice 0 t1 m | t1 > tm = slice t0 tm m :+: none (t1 - tm) | otherwise = case m of Prim a -> Prim $ slice t0 t1 a a :+: b -> sliceSeq t0 t1 a b a :=: b -> ((:=:) `on` slice t0 t1) a b Control c a -> Control c $ slice t0 t1 a where tm = dur m sliceSeq :: Sliceable t a => t -> t -> Media c a -> Media c a -> Media c a sliceSeq t0 t1 a b | t1 <= ta = slice t0 t1 a | t0 >= ta = slice (t0 - ta) (t1 - ta) b | otherwise = slice t0 ta a :+: slice 0 (t1 - ta) b where ta = dur a -- Structure instance Construct (Media c) where prim = Prim instance Arrangeable (Media c a) where (+:+) = (:+:) (=:=) = (:=:) instance Controlable c (Media c a) where control = Control ---------------------------------------------------- -- Meaning -- | Media imterpretation -- -- given two functions (to convert elementary value @(a -> b)@, -- and to convert modifiers @(c -> b -> b)@) `fromMedia` interprets 'Media' structure fromMedia :: Arrangeable b => (a -> b) -> (c -> b -> b) -> Media c a -> b fromMedia prim mod = fold prim (+:+) (=:=) mod -------------------------------------------------------------------------------------- -- | Event type -- -- @(t, dt, a)@ - value @a@ starts at @t@ and lasts for @dt@ type Event t a = (t, t, a) -- | list of events with given total time data EventList t a = EventList t [Event t a] deriving (Show, Eq) toEvent :: (Temporal t (m a), ToMaybe m) => m a -> EventList t a toEvent a = EventList (dur a) $ maybe [] (return . singleEvent) $ toMaybe a where singleEvent x = (0, dur a, x) mapEvent :: Dur t => (a -> b) -> Event t a -> Event t b mapEvent f (t, dt, a) = (t, dt, f a) instance Dur t => Functor (EventList t) where fmap f (EventList t es) = EventList t $ fmap (mapEvent f) es -- time instance Dur t => Temporal t (EventList t a) where none t = EventList t [] dur (EventList t _) = t instance (Dur t, Stretchable t a) => Stretchable t (EventList t a) where stretch d (EventList t es) = EventList (d * t) $ map (stretchEvent d) es where stretchEvent d (t, dt, a) = (d * t, d * dt, stretch d a) instance Dur t => TemporalFunctor t (EventList t) where tmap f (EventList t es) = EventList t $ map (tmapEvent f) es where tmapEvent f (t, dt, a) = (t, dt, f dt a) -- structure instance Dur t => Construct (EventList t) where prim a = EventList 1 [(0, 1, a)] instance Dur t => Arrangeable (EventList t a) where (EventList t es) +:+ (EventList t' es') = EventList (t + t') (es ++ map (delayEvent t) es') where delayEvent d (t, dt, a) = (t + d, dt, a) (EventList t es) =:= (EventList t' es') = EventList (max t t') $ merge es es' where merge [] x = x merge x [] = x merge (a@(ta, _, _):as) (b@(tb, _, _):bs) | ta < tb = a : merge as (b:bs) | otherwise = b : merge (a:as) bs instance Dur t => Controlable () (EventList t a) where control = const id -- meaning -- | converting to 'EventList' -- -- 'toEventList' mapps generic temporal value @(m a)@ that can be -- represented with @(t, Maybe a)@ to 'EventList' toEventList :: (Temporal t (m a), ToMaybe m) => (c -> EventList t a -> EventList t a) -> Media c (m a) -> EventList t a toEventList = fromMedia toEvent ------------------------------------------------------------------------- ------------------------------------------------------------------- -- Special case : Media with explicit time. Value is unit -- -- | Media with explicit time -- -- Value is unit (undividable, invariant to reverse and time stretching) -- O(1) 'dur' data Dur t => MediaUnit t c a = MediaUnit t (Media c (Unit t a)) unMediaUnit :: Dur t => MediaUnit t c a -> Media c (Unit t a) unMediaUnit (MediaUnit _ m) = m instance Dur t => Functor (MediaUnit t c) where fmap f (MediaUnit t m) = MediaUnit t $ fmap (fmap f) m instance Dur t => Monad (MediaUnit t c) where return = MediaUnit 1 . return . return (MediaUnit t ma) >>= f = MediaUnit (dur ma') ma' where ma' = ft =<< ma ft ta = case unMediaUnit . f <$> ta of (Unit t (Just a)) -> stretch t a (Unit t Nothing) -> none t instance Dur t => Applicative (MediaUnit t c) where pure = return (<*>) = ap -- time instance Dur t => Temporal t (MediaUnit t c a) where none t = MediaUnit t $ none t dur (MediaUnit t _) = t instance Dur t => Stretchable t (MediaUnit t c a) where stretch d (MediaUnit t m) = MediaUnit (t * d) $ stretch d m instance Dur t => TemporalFunctor t (MediaUnit t c) where tmap f (MediaUnit t m) = MediaUnit t $ fmap (tmap f) m -- transformers -- | 'fold' replica for MediaUnit foldU :: Dur t => (t -> a -> b) -> (b -> b -> b) -> (b -> b -> b) -> (c -> b -> b) -> MediaUnit t c a -> Maybe b foldU prim seq par mod = fold prim' (liftA2 seq) (liftA2 par) mod' . unMediaUnit where prim' (Unit t a) = prim t <$> a mod' c = fmap (mod c) instance Dur t => Reversible (MediaUnit t c a) where reverse (MediaUnit t m) = MediaUnit t $ reverse $ m instance Dur t => Sliceable t (MediaUnit t c a) where slice t0 t1 (MediaUnit t a) = MediaUnit (t1 - t0) $ slice t0 t1 a -- Structure instance Dur t => Construct (MediaUnit t c) where prim = MediaUnit 1 . prim . prim instance Dur t => Arrangeable (MediaUnit t c a) where a +:+ b = MediaUnit (dur a + dur b) $ (unMediaUnit a) +:+ (unMediaUnit b) a =:= b | ta < tb = f tb (a' +:+ none (tb - ta)) b' | ta > tb = f ta (b' +:+ none (ta - tb)) a' | otherwise = f ta a' b' where ta = dur a tb = dur b a' = unMediaUnit a b' = unMediaUnit b f t a b = MediaUnit t $ a =:= b instance Dur t => Controlable c (MediaUnit t c a) where control c (MediaUnit t a) = MediaUnit t $ control c a -- meaning -- | Interpretation of 'MediaUnit' -- -- it relies on properties of 'Unit' (it's temporal and covertible to 'Maybe') fromMediaUnit :: Dur t => (c -> EventList t a -> EventList t a) -> MediaUnit t c a -> EventList t a fromMediaUnit f = toEventList f . unMediaUnit ------------------------------------------------------------ -- Unit -- | unit values that can happen and lasts for some time data Dur t => Unit t a = Unit t (Maybe a) deriving (Show, Eq) instance Dur t => Functor (Unit t) where fmap f (Unit t a) = Unit t $ fmap f a instance Dur t => Monad (Unit t) where return = prim (Unit t a) >>= f = case fmap f a of Nothing -> none t Just (Unit t' b) -> Unit (t * t') b instance Dur t => Applicative (Unit t) where pure = return (<*>) = ap -- time instance Dur t => Temporal t (Unit t a) where none t = Unit t Nothing dur (Unit t _) = t instance Dur t => Stretchable t (Unit t a) where stretch d (Unit t a) = Unit (d * t) a instance Dur t => ToMaybe (Unit t) where toMaybe (Unit _ a) = a instance Dur t => TemporalFunctor t (Unit t) where tmap f (Unit t a) = Unit t $ fmap (f t) a -- Unit transformers instance Dur t => Reversible (Unit t a) where reverse = id instance Dur t => Sliceable t (Unit t a) where slice t0 t1 u@(Unit t a) | t1 < t0 = sliceErrorMessage | t1 < (t - eps) || t0 > eps = none $ t1 - t0 | otherwise = u where eps = 1e-6 -- structure instance Dur t => Construct (Unit t) where prim a = Unit 1 $ Just a