Segment.hs

{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ViewPatterns               #-}

-------------------------------------------------------------------------------------
-- |
-- Copyright   : (c) Hans Hoglund 2012-2014
--
-- License     : BSD-style
--
-- Maintainer  : hans@hanshoglund.se
-- Stability   : experimental
-- Portability : non-portable (TF,GNTD)
--
-------------------------------------------------------------------------------------

module Music.Time.Segment (

        -- * Behavior type
        Behavior,
        -- ** Examples
        -- $musicTimeBehaviorExamples
        -- (!^),
        -- behavior',

        -- * Construction
        behavior,

        -- ** Common versions
        line,
        unit,
        impulse,
        turnOn,
        turnOff,
        sawtooth,
        sine,
        cosine,

        -- ** Combine
        switch,
        switch',
        splice,
        trim,
        trimBefore,
        trimAfter,
        concatB,

        -- * Segment type
        Segment,
        -- ** Examples
        -- $XXmusicTimeSegmentExamples

        -- * Construction
        segment,

        -- * Combine
        focusing,
        apSegments',
        apSegments,
        -- concatS,

        -- * Bound type
        Bound,
        -- * Query        
        bounds,
        bounding,
        -- * Combine
        trim,
        splice,
        bounded',
        bounded,     

  ) where

import           Data.AffineSpace
import           Data.AffineSpace.Point
import           Data.Clipped
import           Data.Map               (Map)
import qualified Data.Map               as Map
import           Data.Ratio
import           Data.Semigroup
import           Data.Set               (Set)
import qualified Data.Set               as Set
import           Data.VectorSpace

import           Music.Time.Behavior
import           Music.Time.Bound
import           Music.Time.Event
import           Music.Time.Reverse
import           Music.Time.Score
import           Music.Time.Split
import           Music.Time.Note
import           Music.Time.Voice

import           Control.Applicative
import           Control.Lens           hiding (Indexable, Level, above, below,
                                         index, inside, parts, reversed,
                                         transform, (<|), (|>))
import           Data.Distributive
import           Data.Functor.Rep as R
import           Data.Functor.Rep.Lens
import           Data.Maybe
import           Data.Typeable
import           Music.Dynamics.Literal
import           Music.Pitch.Literal


-- TODO Compare Diagram's Trail and Located (and see the conal blog post)

-- |
--
-- A 'Segment' is a value varying over some unknown time span. 
-- Intuitively, a 'Segment' is to a 'Behavior' what a /ray/ is to a /line/.
--
-- To give a segment an explicit duration, use 'Event' 'Segment'.
--
-- To place a segment in a particular time span, use 'Event' 'Segment'.
--
newtype Segment a = Segment { getSegment :: Clipped Duration -> a }
  deriving (Functor, Applicative, Monad{-, Comonad-}, Typeable)

-- $semantics Segment
--
-- @
-- type Segment a = 'Duration' -> a
-- @
--

-- $musicTimeSegmentExamples
--
-- > foldr1 apSegments' $ map (view note) $ [(0.5,0::Segment Float), (1, timeS), (2,rev timeS), (3,-1)]
--
-- > openG $ draw $ (1, timeS :: Segment Float)^.note
--

instance Show (Segment a) where
  show _ = "<<Segment>>"

instance Distributive Segment where
  distribute = Segment . distribute . fmap getSegment

instance Representable Segment where
  type Rep Segment = Duration
  tabulate f = Segment (f . fromClipped)
  index    (Segment f) = f . unsafeToClipped

-- |
-- Segments are /invariant/ under transformation. To transform a timve varying value, use
-- 'fromSegment'.
--
instance Transformable (Segment a) where
  transform _ = id

instance Reversible (Segment a) where
  -- TODO in terms of Representable
  rev (Segment f) = Segment (f . unsafeToClipped . r . fromClipped)
    where
      r x = (x * (-1)) + 1

-- TODO
-- type instance Pitch                 (Segment a) = Segment (Pitch a)
-- type instance SetPitch (Segment g)  (Segment a) = Segment (SetPitch g a)
--
-- instance (HasPitch a a, HasPitch a b) => HasPitches (Segment a) (Segment b) where
--   pitches = through pitch pitch
-- instance (HasPitch a a, HasPitch a b) => HasPitch (Segment a) (Segment b) where
--   pitch = through pitch pitch
--
-- type instance Dynamic                 (Segment a) = Segment (Dynamic a)
-- type instance SetDynamic (Segment g) (Segment a) = Segment (SetDynamic g a)
--
-- instance (HasDynamic a a, HasDynamic a b) => HasDynamics (Segment a) (Segment b) where
--   dynamics = through dynamic dynamic
-- instance (HasDynamic a a, HasDynamic a b) => HasDynamic (Segment a) (Segment b) where
--   dynamic = through dynamic dynamic
--
--
-- type instance Articulation                 (Segment a) = Segment (Articulation a)
-- type instance SetArticulation (Segment g) (Segment a) = Segment (SetArticulation g a)
--
-- instance (HasArticulation a a, HasArticulation a b) => HasArticulations (Segment a) (Segment b) where
--   articulations = through articulation articulation
-- instance (HasArticulation a a, HasArticulation a b) => HasArticulation (Segment a) (Segment b) where
--   articulation = through articulation articulation
--
--
-- type instance Part                 (Segment a) = Segment (Part a)
-- type instance SetPart (Segment g) (Segment a) = Segment (SetPart g a)
--
-- instance (HasPart a a, HasPart a b) => HasParts (Segment a) (Segment b) where
--   parts = through part part
-- instance (HasPart a a, HasPart a b) => HasPart (Segment a) (Segment b) where
--   part = through part part

-- deriving instance Semigroup a => Semigroup (Segment a)
-- deriving instance Monoid a => Monoid (Segment a)
-- deriving instance Num a => Num (Segment a)
-- deriving instance Fractional a => Fractional (Segment a)
-- deriving instance Floating a => Floating (Segment a)
--
-- instance IsPitch a => IsPitch (Segment a) where
--   fromPitch = pure . fromPitch
--
-- instance IsInterval a => IsInterval (Segment a) where
--   fromInterval = pure . fromInterval
--
-- instance Alterable a => Alterable (Segment a) where
--     sharpen = fmap sharpen
--     flatten = fmap flatten
--
-- instance Augmentable a => Augmentable (Segment a) where
--     augment = fmap augment
--     diminish = fmap diminish
--
-- instance Eq a => Eq (Segment a) where
--   (==) = error "No fun"
--
-- instance Ord a => Ord (Segment a) where
--   (<) = error "No fun"
--   max = liftA2 max
--   min = liftA2 min

-- |
-- View a segment as a time function and vice versa.
--
segment :: Iso (Duration -> a) (Duration -> b) (Segment a) (Segment b)
segment = R.tabulated

apSegments' :: Note (Segment a) -> Note (Segment a) -> Note (Segment a)
apSegments' (view (from note) -> (d1,s1)) (view (from note) -> (d2,s2))
  = view note (d1+d2, slerp (d1/(d1+d2)) s1 s2)

-- |
-- Append a voice of segments to a single note segment.
--
apSegments :: Voice (Segment a) -> Note (Segment a)
apSegments = foldr1 apSegments' . toListOf (notes . each)

-- t < i && 0 <= t <= 1   ==> 0 < (t/i) < 1
-- i     is the fraction of the slerped segment spent in a
-- (1-i) is the fraction of the slerped segment spent in b
slerp :: Duration -> Segment a -> Segment a -> Segment a
slerp i a b
  | i < 0 || i >= 1    = error "slerp: Bad value"
  | otherwise = tabulate $ \t -> if t < i then a ! (t/i) else b ! ((t-i)/(1-i))

slerp2 :: (a -> a -> a) -> Duration -> Segment a -> Segment a -> Segment a
slerp2 f i a b
  | i < 0 || i >= 1    = error "slerp: Bad value"
  | otherwise = tabulate $ \t -> case t `compare` i of
      LT -> a ! (t/i)
      EQ -> (a ! 1) `f` (b ! 1)
      GT -> b ! ((t-i)/(1-i))


-- |
-- View a 'Event' 'Segment' as a 'Bound' 'Behavior' and vice versa.
--
-- This can be used to safely turn a behavior into a segment and vice
-- versa. Often 'focusing' is more convenient to use.
--
bounded' :: Iso' (Event (Segment a)) (Bound (Behavior a))
bounded' = bounded

-- |
-- View a 'Event' 'Segment' as a 'Bound' 'Behavior' and vice versa.
--
-- This can be used to safely turn a behavior into a segment and vice
-- versa. Often 'focusing' is more convenient to use.
--
bounded :: Iso (Event (Segment a)) (Event (Segment b)) (Bound (Behavior a)) (Bound (Behavior b))
bounded = iso ns2bb bb2ns
  where
    bb2ns (Bound (s, x)) = view event (s, b2s $ transform (negateV s) $ x)
    ns2bb (view (from event) -> (s, x)) = Bound (s,       transform s           $ s2b $ x)
    s2b = under R.tabulated (. realToFrac)
    b2s = under R.tabulated (. realToFrac)

--
-- Event that the isomorhism only works because of 'Bound' being abstract.
-- A function @unBound :: Bound a -> a@ could break the isomorphism
-- as follows:
--
-- > (unBound . view (from bounded . bounded) . bounds 0 1) b ! 2
-- *** Exception: Outside 0-1
--

-- |
-- Extract a bounded behavior, replacing all values outside the bound with 'mempty'.
--
-- @
-- 'trim'   = 'splice' 'mempty'
-- 'trim' x = 'trimBefore' '_onset' x . 'trimAfter' '_offset' x
-- @
--
trim :: Monoid b => Bound (Behavior b) -> Behavior b
trim = trimG
  where
    trimG :: (Monoid b, Representable f, Rep f ~ Time) => Bound (f b) -> f b
    trimG (Bound (s, x)) = tabulate (trimOutside s) `apRep` x

trimOutside :: Monoid a => Span -> Time -> a -> a
trimOutside s t x = if t `inside` s then x else mempty

-- |
-- Inserts a bounded behavior on top of another behavior.
--
-- @
-- 'trim' = 'splice' 'mempty'
-- @
--
-- (Named after the analogous tape-editing technique.)
--
splice :: Behavior a -> Bound (Behavior a) -> Behavior a
splice constant insert = fmap fromLast $ fmap toLast constant <> trim (fmap (fmap toLast) insert)
  where
    toLast   = Option . Just . Last
    fromLast = getLast . fromJust . getOption
    -- fromJust is safe here, as toLast is used to create the Maybe wrapper


concatSegment :: Monoid a => Event (Segment a) -> Behavior a
concatSegment = trim . view bounded

-- |
-- Concatenate a score of (possibly overlapping) segments.
--
-- See also 'concatB' and 'continous'.
--
concatS :: Monoid a => Score (Segment a) -> Behavior a
concatS = mconcat . map concatSegment . view events
-- Or: mconcat.fmap trim.toListOf (events.each.bounded)

-- |
-- Concatenate a score of (possibly overlapping) segments.
--
-- See also 'concatSegment' and 'continous'.
--
concatB :: Monoid a => Score (Behavior a) -> Behavior a
concatB = concatS . fmap (view focusing)
-- Or (more generally): mconcat.toListOf (events.each.eventee)


-- |
-- View part of a 'Behavior' as a 'Segment'.
--
-- @
-- 'line' & 'focusing' `onSpan` (2 '<->' 3) '*~' 0
-- @
--
focusing :: Lens' (Behavior a) (Segment a)
focusing = lens get set
  where
    get = view (from bounded . eventee) . {-pure-}bounding mempty
    set x = splice x . (view bounded) . pure