-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | Post-processing utils.  These are transformers that directly modify the
    output of a deriver, as opposed to simply modifying the 'Derive.Dynamic'.

    Unfortunately things are complicated by the presence of 'LEvent.Log's in
    the output stream.  I haven't been able to figure out how to cleanly
    abstract that away, so I wind up with a collection of functions to handle
    specific kinds of maps.

    There are variants for each axis:

    - monadic vs. pure

    - state vs. stateless

    - 1:1 vs. 1:many

    - preserves order vs. doesn't preserve order

    TODO

    One big problem with this is the permutations.  Another is that I should be
    able to fuse composed maps, but I think it'll mostly be defeated by the
    monadic bits, and maybe state.  But even monadic bits should be
    theoretically fusible since I don't mind if the effects (i.e. exceptions)
    are interleaved.  A job for pipes maybe?
-}
module Derive.Call.Post where
import qualified Data.DList as DList
import qualified Data.List as List
import qualified Data.Set as Set

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Derive.Call as Call
import qualified Derive.Call.NoteUtil as NoteUtil
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.LEvent as LEvent
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack
import qualified Derive.Stream as Stream
import           Derive.Stream (Stream)
import qualified Derive.Typecheck as Typecheck

import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


-- * map events

-- 'emap' is kind of an ugly name, but at least it's consistent and short.
-- I previously used 'map', but it turns out replacing the Prelude map is
-- really confusing.

-- ** non-monadic

-- | 1:1 non-monadic map without state.
--
-- TODO this is expected to not destroy the order, but that isn't checked.
-- That means either the event doesn't move, or it doesn't move past its
-- neighbors.  Way back when events didn't have their start times, I could
-- express this by only mapping over the event, but I'm not sure how to do it
-- now.  And in any case, "don't destroy order" is more permissive than "don't
-- move."
emap1_ :: (a -> b) -> Stream a -> Stream b
emap1_ :: forall a b. (a -> b) -> Stream a -> Stream b
emap1_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

-- | Map on Score.Events.  The function is allowed to move the events, since it
-- sorts them afterwards.
emap1_ord_ :: (a -> Score.Event) -> Stream a -> Stream Score.Event
emap1_ord_ :: forall a. (a -> Event) -> Stream a -> Stream Event
emap1_ord_ a -> Event
f = Stream Event -> Stream Event
Stream.sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Event
f

-- | 1:1 non-monadic map with state.  This is like mapAccumL.
emap1 :: (state -> a -> (state, b)) -> state -> Stream a -> (state, Stream b)
emap1 :: forall state a b.
(state -> a -> (state, b))
-> state -> Stream a -> (state, Stream b)
emap1 state -> a -> (state, b)
f state
state =
    forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. [LEvent a] -> Stream a
Stream.from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL state -> LEvent a -> (state, LEvent b)
go state
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    go :: state -> LEvent a -> (state, LEvent b)
go state
state (LEvent.Log Msg
log) = (state
state, forall a. Msg -> LEvent a
LEvent.Log Msg
log)
    go state
state (LEvent.Event a
event) = forall a. a -> LEvent a
LEvent.Event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> state -> a -> (state, b)
f state
state a
event

-- | 1:n non-monadic map with state.
emap :: (state -> a -> (state, [Score.Event])) -> state
    -> Stream a -> (state, Stream Score.Event)
emap :: forall state a.
(state -> a -> (state, [Event]))
-> state -> Stream a -> (state, Stream Event)
emap state -> a -> (state, [Event])
f state
state = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Stream Event] -> Stream Event
Stream.merge_asc_lists forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state a b.
(state -> a -> (state, [b]))
-> state -> Stream a -> (state, [Stream b])
emap_groups state -> a -> (state, [Event])
f state
state
    where
    emap_groups :: (state -> a -> (state, [b])) -> state
        -> Stream a -> (state, [Stream b])
    emap_groups :: forall state a b.
(state -> a -> (state, [b]))
-> state -> Stream a -> (state, [Stream b])
emap_groups state -> a -> (state, [b])
f state
state = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL state -> LEvent a -> (state, Stream b)
go state
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list
        where
        go :: state -> LEvent a -> (state, Stream b)
go state
state (LEvent.Log Msg
log) = (state
state, forall a. [Msg] -> Stream a
Stream.from_logs [Msg
log])
        go state
state (LEvent.Event a
event) =
            forall a. [a] -> Stream a
Stream.from_sorted_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> state -> a -> (state, [b])
f state
state a
event

-- | This is 'emap', but it promises to emit events in sorted order.
-- TODO except that's not enforced, and maybe I should just always sort.
emap_asc :: (state -> a -> (state, [Score.Event])) -> state
    -> Stream a -> (state, Stream Score.Event)
emap_asc :: forall state a.
(state -> a -> (state, [Event]))
-> state -> Stream a -> (state, Stream Event)
emap_asc = forall state a.
(state -> a -> (state, [Event]))
-> state -> Stream a -> (state, Stream Event)
emap

-- | 'emap' without state.
emap_ :: (a -> [Score.Event]) -> Stream a -> Stream Score.Event
emap_ :: forall a. (a -> [Event]) -> Stream a -> Stream Event
emap_ a -> [Event]
f = [Stream Event] -> Stream Event
Stream.merge_asc_lists forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. LEvent [a] -> Stream a
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> [Event]
f
    where
    flatten :: LEvent [a] -> Stream a
flatten (LEvent.Log Msg
log) = forall a. [Msg] -> Stream a
Stream.from_logs [Msg
log]
    flatten (LEvent.Event [a]
events) = forall a. [a] -> Stream a
Stream.from_sorted_events [a]
events

emap_asc_ :: (a -> [Score.Event]) -> Stream a -> Stream Score.Event
emap_asc_ :: forall a. (a -> [Event]) -> Stream a -> Stream Event
emap_asc_ = forall a. (a -> [Event]) -> Stream a -> Stream Event
emap_

-- ** monadic

-- | Apply a function to the non-log events.
-- TODO assumes the function doesn't destroy the order.
apply :: ([a] -> [b]) -> Stream.Stream a -> Stream.Stream b
apply :: forall a b. ([a] -> [b]) -> Stream a -> Stream b
apply [a] -> [b]
f Stream a
stream = forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Stream a
Stream.from_sorted_events ([a] -> [b]
f [a]
events)
    where ([a]
events, [Msg]
logs) = forall a. Stream a -> ([a], [Msg])
Stream.partition Stream a
stream

apply_m :: Functor f => ([a] -> f [b]) -> Stream.Stream a -> f (Stream.Stream b)
apply_m :: forall (f :: * -> *) a b.
Functor f =>
([a] -> f [b]) -> Stream a -> f (Stream b)
apply_m [a] -> f [b]
f Stream a
stream =
    forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Stream a
Stream.from_sorted_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> f [b]
f [a]
events
    where ([a]
events, [Msg]
logs) = forall a. Stream a -> ([a], [Msg])
Stream.partition Stream a
stream

-- | 1:1 monadic map without state.
emap1m_ :: (a -> Score.Event) -> (a -> Derive.Deriver b) -> Stream a
    -> Derive.Deriver (Stream b)
emap1m_ :: forall a b.
(a -> Event) -> (a -> Deriver b) -> Stream a -> Deriver (Stream b)
emap1m_ a -> Event
event_of a -> Deriver b
f =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [LEvent a] -> Stream a
Stream.from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM LEvent a -> Deriver State Error (Maybe (LEvent b))
process forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    process :: LEvent a -> Deriver State Error (Maybe (LEvent b))
process (LEvent.Log Msg
log) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Msg -> LEvent a
LEvent.Log Msg
log
    process (LEvent.Event a
a) =
        forall a. Event -> Deriver a -> Deriver (Maybe a)
Derive.with_event (a -> Event
event_of a
a) forall a b. (a -> b) -> a -> b
$ forall a. a -> LEvent a
LEvent.Event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Deriver b
f a
a

-- | Monadic map with state.  The event type is polymorphic, so you can use
-- 'LEvent.zip' and co. to zip up unthreaded state, constructed with 'control'
-- and 'nexts' and such.
emap_m :: (a -> Score.Event)
    -> (state -> a -> Derive.Deriver (state, [b]))
    -- ^ Process an event. Exceptions are caught and logged.
    -> state -> Stream a -> Derive.Deriver (state, Stream b)
emap_m :: forall a state b.
(a -> Event)
-> (state -> a -> Deriver (state, [b]))
-> state
-> Stream a
-> Deriver (state, Stream b)
emap_m a -> Event
event_of state -> a -> Deriver (state, [b])
f state
state =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. [LEvent a] -> Stream a
Stream.from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. DList a -> [a]
DList.toList)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. state
-> [LEvent a] -> Deriver State Error (state, DList (LEvent b))
go state
state
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    go :: state
-> [LEvent a] -> Deriver State Error (state, DList (LEvent b))
go state
state [] = forall (m :: * -> *) a. Monad m => a -> m a
return (state
state, forall a. Monoid a => a
mempty)
    go state
state (LEvent.Log Msg
log : [LEvent a]
events) =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> DList a -> DList a
DList.cons (forall a. Msg -> LEvent a
LEvent.Log Msg
log)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> state
-> [LEvent a] -> Deriver State Error (state, DList (LEvent b))
go state
state [LEvent a]
events
    go state
state (LEvent.Event a
event : [LEvent a]
events) = do
        (state
state, [b]
output) <- forall a. a -> Maybe a -> a
fromMaybe (state
state, []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall a. Event -> Deriver a -> Deriver (Maybe a)
Derive.with_event (a -> Event
event_of a
event) (state -> a -> Deriver (state, [b])
f state
state a
event)
        (state
final, DList (LEvent b)
outputs) <- state
-> [LEvent a] -> Deriver State Error (state, DList (LEvent b))
go state
state [LEvent a]
events
        forall (m :: * -> *) a. Monad m => a -> m a
return (state
final, forall a. [a] -> DList a
DList.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event [b]
output) forall a. Semigroup a => a -> a -> a
<> DList (LEvent b)
outputs)
    -- TODO this could also take [(a, LEvent Score.Event)] and omit 'event_of'
    -- since it's always 'snd', but this is basically the same as the separate
    -- annots approach I had earlier, and forces you to have a () annotation
    -- if you don't want one.

emap_asc_m :: (a -> Score.Event)
    -> (state -> a -> Derive.Deriver (state, [Score.Event]))
    -- ^ Process an event. Exceptions are caught and logged.
    -> state -> Stream a -> Derive.Deriver (state, Stream Score.Event)
emap_asc_m :: forall a state.
(a -> Event)
-> (state -> a -> Deriver (state, [Event]))
-> state
-> Stream a
-> Deriver (state, Stream Event)
emap_asc_m a -> Event
event_of state -> a -> Deriver (state, [Event])
f state
state =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[LEvent Event]] -> Stream Event
merge) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) state x y.
Monad m =>
(state -> x -> m (state, y)) -> state -> [x] -> m (state, [y])
Lists.mapAccumLM state -> LEvent a -> Deriver State Error (state, [LEvent Event])
go state
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    merge :: [[LEvent Event]] -> Stream Event
merge = [Stream Event] -> Stream Event
Stream.merge_asc_lists forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. [LEvent a] -> Stream a
Stream.from_sorted_list
    go :: state -> LEvent a -> Deriver State Error (state, [LEvent Event])
go state
state (LEvent.Event a
event) =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (state
state, []) (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall a. Event -> Deriver a -> Deriver (Maybe a)
Derive.with_event (a -> Event
event_of a
event) (state -> a -> Deriver (state, [Event])
f state
state a
event)
    go state
state (LEvent.Log Msg
log) = forall (m :: * -> *) a. Monad m => a -> m a
return (state
state, [forall a. Msg -> LEvent a
LEvent.Log Msg
log])

-- | 'emap_m' without the state.
emap_m_ :: (a -> Score.Event) -> (a -> Derive.Deriver [b]) -> Stream a
    -> Derive.Deriver (Stream b)
emap_m_ :: forall a b.
(a -> Event)
-> (a -> Deriver [b]) -> Stream a -> Deriver (Stream b)
emap_m_ a -> Event
event_of a -> Deriver [b]
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a state b.
(a -> Event)
-> (state -> a -> Deriver (state, [b]))
-> state
-> Stream a
-> Deriver (state, Stream b)
emap_m a -> Event
event_of (\() a
e -> (,) () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Deriver [b]
f a
e) ()

emap_asc_m_ :: (a -> Score.Event) -> (a -> Derive.Deriver [Score.Event])
    -> Stream a -> Derive.Deriver (Stream Score.Event)
emap_asc_m_ :: forall a.
(a -> Event)
-> (a -> Deriver [Event]) -> Stream a -> Deriver (Stream Event)
emap_asc_m_ a -> Event
event_of a -> Deriver [Event]
f =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a state.
(a -> Event)
-> (state -> a -> Deriver (state, [Event]))
-> state
-> Stream a
-> Deriver (state, Stream Event)
emap_asc_m a -> Event
event_of (\() a
e -> (,) () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Deriver [Event]
f a
e) ()

-- | Postprocess each event with a NoteDeriver.  This is necessary if you need
-- to generate more notes, e.g. with 'Call.note'.
emap_s_ :: (a -> Score.Event) -> (a -> Derive.NoteDeriver) -> Stream a
    -> Derive.NoteDeriver
emap_s_ :: forall a.
(a -> Event)
-> (a -> Deriver (Stream Event))
-> Stream a
-> Deriver (Stream Event)
emap_s_ a -> Event
event_of a -> Deriver (Stream Event)
f = forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM LEvent a -> Deriver (Stream Event)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    go :: LEvent a -> Deriver (Stream Event)
go (LEvent.Log Msg
log) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Msg] -> Stream a
Stream.from_logs [Msg
log]
    go (LEvent.Event a
a) = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a. Event -> Deriver a -> Deriver (Maybe a)
Derive.with_event (a -> Event
event_of a
a) (a -> Deriver (Stream Event)
f a
a)

merge_asc :: [[Score.Event]] -> [Score.Event]
merge_asc :: [[Event]] -> [Event]
merge_asc = forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeAscLists Event -> RealTime
Score.event_start

-- * only

-- | Only process the events that match, otherwise pass unchanged.
only :: (a -> event) -> (event -> Bool) -> (a -> event) -> a -> event
only :: forall a event.
(a -> event) -> (event -> Bool) -> (a -> event) -> a -> event
only a -> event
event_of event -> Bool
match a -> event
f a
a = if event -> Bool
match (a -> event
event_of a
a) then a -> event
f a
a else a -> event
event_of a
a

has_instrument :: [ScoreT.Instrument] -> Score.Event -> Bool
has_instrument :: [Instrument] -> Event -> Bool
has_instrument [Instrument]
wanted = (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Instrument
set) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument
    where set :: Set Instrument
set = forall a. Ord a => [a] -> Set a
Set.fromList [Instrument]
wanted

-- ** unthreaded state

control :: ScoreT.Function -> Stream Score.Event -> [Signal.Y]
control :: Function -> Stream Event -> [Y]
control Function
f = forall a b. (a -> b) -> [a] -> [b]
map (Function
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [a]
Stream.events_of

real_time_control :: ScoreT.Function -> Stream Score.Event -> [RealTime]
real_time_control :: Function -> Stream Event -> [RealTime]
real_time_control Function
f = forall a b. (a -> b) -> [a] -> [b]
map Y -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Stream Event -> [Y]
control Function
f

-- | Take a typed signal to RealTime durations.
duration_control :: ScoreT.TimeT -> ScoreT.Function
    -> Stream Score.Event -> Derive.Deriver [RealTime]
duration_control :: TimeT -> Function -> Stream Event -> Deriver [RealTime]
duration_control TimeT
time_t Function
f Stream Event
events = do
    let starts :: [RealTime]
starts = forall a b. (a -> b) -> [a] -> [b]
map Event -> RealTime
Score.event_start (forall a. Stream a -> [a]
Stream.events_of Stream Event
events)
    case TimeT
time_t of
        TimeT
ScoreT.TReal -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Y -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
f) [RealTime]
starts
        TimeT
ScoreT.TScore ->
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\RealTime
t -> forall t1 t2.
(Time t1, Time t2) =>
t1 -> t2 -> Deriver State Error RealTime
Call.real_duration RealTime
t (Y -> ScoreTime
ScoreTime.from_double (Function
f RealTime
t)))
                [RealTime]
starts

-- | Zip each event up with its neighbors.
neighbors :: Stream a -> Stream ([a], a, [a])
neighbors :: forall a. Stream a -> Stream ([a], a, [a])
neighbors Stream a
events = forall a b. (a -> b) -> Stream a -> Stream b
emap1_ (\([a]
ps, [a]
ns, a
e) -> ([a]
ps, a
e, [a]
ns)) forall a b. (a -> b) -> a -> b
$
    forall a b c.
([a] -> [b]) -> ([a] -> [c]) -> Stream a -> Stream (b, c, a)
Stream.zip3_on forall a. [a] -> [[a]]
prevs forall a. [a] -> [[a]]
nexts Stream a
events

-- | Zip each event with its nearest neighbor with the same key.  A key might
-- be 'Score.event_instrument', 'hand_key', or 'voice_key'.
--
-- TODO it's awkward how calls that are not instrument-specific still have to
-- choose between hand or voice when they want the next \"relevant\" note.
-- Perhaps hand and voice should be merged into a single concept.  They have to
-- be distinct for the lilypond backend though.
neighbors_by :: Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a)
neighbors_by :: forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a)
neighbors_by a -> key
key = forall a b. (a -> b) -> Stream a -> Stream b
emap1_ ([a], a, [a]) -> (Maybe a, a, Maybe a)
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> Stream ([a], a, [a])
neighbors
    where
    extract :: ([a], a, [a]) -> (Maybe a, a, Maybe a)
extract ([a]
ps, a
e, [a]
ns) = ([a] -> Maybe a
same [a]
ps, a
e, [a] -> Maybe a
same [a]
ns)
        where same :: [a] -> Maybe a
same = forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== a -> key
key a
e) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> key
key)

nexts_by :: Eq key => (a -> key) -> Stream a -> Stream (a, [a])
nexts_by :: forall key a. Eq key => (a -> key) -> Stream a -> Stream (a, [a])
nexts_by a -> key
key = forall a b. (a -> b) -> Stream a -> Stream b
emap1_ ([a], a) -> (a, [a])
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ([a] -> [b]) -> Stream a -> Stream (b, a)
Stream.zip_on forall a. [a] -> [[a]]
nexts
    where
    extract :: ([a], a) -> (a, [a])
extract ([a]
ns, a
e) = (a
e, [a] -> [a]
same [a]
ns)
        where same :: [a] -> [a]
same = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== a -> key
key a
e) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> key
key)

-- | Like 'neighbors_by', but only the next neighbor.
next_by :: Eq key => (a -> key) -> Stream a -> Stream (a, Maybe a)
next_by :: forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (a, Maybe a)
next_by a -> key
key = forall a b. (a -> b) -> Stream a -> Stream b
emap1_ forall {a} {a} {b}. (a, a, b) -> (a, b)
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a)
neighbors_by a -> key
key
    where extract :: (a, a, b) -> (a, b)
extract (a
_, a
e, b
n) = (a
e, b
n)

prev_by :: Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a)
prev_by :: forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (Maybe a, a)
prev_by a -> key
key = forall a b. (a -> b) -> Stream a -> Stream b
emap1_ forall {a} {b} {c}. (a, b, c) -> (a, b)
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a)
neighbors_by a -> key
key
    where extract :: (a, b, c) -> (a, b)
extract (a
p, b
e, c
_) = (a
p, b
e)

hand_key :: Score.Event -> (ScoreT.Instrument, Maybe Text)
hand_key :: Event -> (Instrument, Maybe Text)
hand_key Event
e =
    ( Event -> Instrument
Score.event_instrument Event
e
    , forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.hand forall a b. (a -> b) -> a -> b
$ Event -> Environ
Score.event_environ Event
e
    )

voice_key :: Score.Event -> (ScoreT.Instrument, Int)
voice_key :: Event -> (Instrument, Int)
voice_key Event
e =
    ( Event -> Instrument
Score.event_instrument Event
e
    , forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.voice forall a b. (a -> b) -> a -> b
$ Event -> Environ
Score.event_environ Event
e
    )

-- | Extract subsequent events.
nexts :: [a] -> [[a]]
nexts :: forall a. [a] -> [[a]]
nexts = forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
List.tails

-- | Extract previous events.
prevs :: [a] -> [[a]]
prevs :: forall a. [a] -> [[a]]
prevs = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) []

-- ** misc maps

-- | Apply a function on the first Event of an LEvent stream.
-- TODO this shouldn't destroy the order, but it isn't checkded.
map_first :: (a -> Derive.Deriver a) -> Stream a
    -> Derive.Deriver (Stream.Stream a)
map_first :: forall a. (a -> Deriver a) -> Stream a -> Deriver (Stream a)
map_first a -> Deriver a
f = forall a.
(a -> Stream a -> Deriver (Stream a))
-> Stream a -> Deriver (Stream a)
map_head_tail forall a b. (a -> b) -> a -> b
$ \a
e Stream a
es -> do
    a
e <- a -> Deriver a
f a
e
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [LEvent a] -> Stream a
Stream.from_sorted_list forall a b. (a -> b) -> a -> b
$ forall a. a -> LEvent a
LEvent.Event a
e forall a. a -> [a] -> [a]
: forall a. Stream a -> [LEvent a]
Stream.to_list Stream a
es

-- | Transform the first event and the rest of the events.
map_head_tail :: (a -> Stream.Stream a -> Derive.Deriver (Stream.Stream a))
    -> Stream a
    -> Derive.Deriver (Stream.Stream a)
map_head_tail :: forall a.
(a -> Stream a -> Deriver (Stream a))
-> Stream a -> Deriver (Stream a)
map_head_tail a -> Stream a -> Deriver (Stream a)
f = [LEvent a] -> Deriver (Stream a)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    go :: [LEvent a] -> Deriver (Stream a)
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty
    go (LEvent.Log Msg
log : [LEvent a]
rest) = forall a. Msg -> Stream a -> Stream a
Stream.merge_log Msg
log forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LEvent a] -> Deriver (Stream a)
go [LEvent a]
rest
    go (LEvent.Event a
event : [LEvent a]
rest) = a -> Stream a -> Deriver (Stream a)
f a
event (forall a. [LEvent a] -> Stream a
Stream.from_sorted_list [LEvent a]
rest)

-- * signal

control_range :: Derive.ControlDeriver
    -> Derive.Deriver (Signal.Control, (RealTime, RealTime), [Log.Msg])
control_range :: ControlDeriver -> Deriver (Control, (RealTime, RealTime), [Msg])
control_range ControlDeriver
deriver = do
    (Control
sig, [Msg]
logs) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> ([a], [Msg])
Stream.partition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlDeriver
deriver
    let range :: (RealTime, RealTime)
range = case (forall {k} (kind :: k). Signal kind -> Maybe (RealTime, Y)
Signal.head Control
sig, forall {k} (kind :: k). Signal kind -> Maybe (RealTime, Y)
Signal.last Control
sig) of
            (Just (RealTime
s, Y
_), Just (RealTime
e, Y
_)) -> (RealTime
s, RealTime
e)
            (Maybe (RealTime, Y), Maybe (RealTime, Y))
_ -> (RealTime
0, RealTime
0)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Control
sig, (RealTime, RealTime)
range, [Msg]
logs)

pitch_range :: Derive.PitchDeriver
    -> Derive.Deriver (PSignal.PSignal, (RealTime, RealTime), [Log.Msg])
pitch_range :: PitchDeriver -> Deriver (PSignal, (RealTime, RealTime), [Msg])
pitch_range PitchDeriver
deriver = do
    (PSignal
sig, [Msg]
logs) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> ([a], [Msg])
Stream.partition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PitchDeriver
deriver
    let range :: (RealTime, RealTime)
range = case (PSignal -> Maybe (RealTime, Pitch)
PSignal.head PSignal
sig, PSignal -> Maybe (RealTime, Pitch)
PSignal.last PSignal
sig) of
            (Just (RealTime
s, Pitch
_), Just (RealTime
e, Pitch
_)) -> (RealTime
s, RealTime
e)
            (Maybe (RealTime, Pitch), Maybe (RealTime, Pitch))
_ -> (RealTime
0, RealTime
0)
    forall (m :: * -> *) a. Monad m => a -> m a
return (PSignal
sig, (RealTime, RealTime)
range, [Msg]
logs)

-- | Transform a pitch or control signal.
signal :: Monoid sig => (sig -> sig)
    -> Derive.Deriver (Stream.Stream sig) -> Derive.Deriver (Stream.Stream sig)
signal :: forall sig.
Monoid sig =>
(sig -> sig) -> Deriver (Stream sig) -> Deriver (Stream sig)
signal sig -> sig
f Deriver (Stream sig)
deriver = do
    (sig
sig, [Msg]
logs) <- forall sig.
Monoid sig =>
Deriver (Stream sig) -> Deriver (sig, [Msg])
derive_signal Deriver (Stream sig)
deriver
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [LEvent a] -> Stream a
Stream.from_sorted_list forall a b. (a -> b) -> a -> b
$
        forall a. a -> LEvent a
LEvent.Event (sig -> sig
f sig
sig) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs

derive_signal :: Monoid sig => Derive.Deriver (Stream.Stream sig)
    -> Derive.Deriver (sig, [Log.Msg])
derive_signal :: forall sig.
Monoid sig =>
Deriver (Stream sig) -> Deriver (sig, [Msg])
derive_signal Deriver (Stream sig)
deriver = do
    ([sig]
chunks, [Msg]
logs) <- forall a. Stream a -> ([a], [Msg])
Stream.partition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream sig)
deriver
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => [a] -> a
mconcat [sig]
chunks, [Msg]
logs)

-- * delayed events

{- | Make a delayed event.

    A delayed event should be realized by an accompanying postproc call. It has
    an 'EnvKey.args', which are the arguments to the postproc call, and so
    it's a little bit like a closure or a delayed thunk.

    It's awkward because you have to manually call the postproc, which then has
    to extract the args and re-typecheck them.  I considered storing actual
    thunks as functions, and running a generic postproc which forces them, but
    I think each one is likely to require a different context.  E.g. previous
    and next events for the same instrument, or with the same hand, or map
    over groups of events, etc.  TODO wait until I have more experience.

    TODO this stuff is now unused, but maybe I'll find a use for it again some
    day.
-}
make_delayed :: Derive.PassedArgs a -> RealTime -> [DeriveT.Val]
    -> Derive.NoteDeriver
make_delayed :: forall a.
PassedArgs a -> RealTime -> [Val] -> Deriver (Stream Event)
make_delayed PassedArgs a
args RealTime
start [Val]
event_args = do
    Dynamic
dyn <- forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic forall a. a -> a
id
    forall a. a -> Stream a
Stream.from_event forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> Event -> Event
delayed_event [Val]
event_args forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a.
PassedArgs a
-> Dynamic
-> RealTime
-> RealTime
-> Text
-> Flags
-> Deriver Event
NoteUtil.make_event PassedArgs a
args Dynamic
dyn RealTime
start RealTime
0 Text
"" forall a. Monoid a => a
mempty

delayed_event :: [DeriveT.Val] -> Score.Event -> Score.Event
delayed_event :: [Val] -> Event -> Event
delayed_event [Val]
args = (Environ -> Environ) -> Event -> Event
Score.modify_environ forall a b. (a -> b) -> a -> b
$
    forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
EnvKey.args ([Val] -> Val
DeriveT.VList [Val]
args)

-- | Return the args if this is a delayed event created by the given call.
delayed_args :: Expr.Symbol -> Score.Event -> Maybe [DeriveT.Val]
delayed_args :: Symbol -> Event -> Maybe [Val]
delayed_args (Expr.Symbol Text
call) Event
event
    | forall a. [a] -> Maybe a
Lists.head (Stack -> [Frame]
Stack.innermost (Event -> Stack
Score.event_stack Event
event))
            forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (Text -> Frame
Stack.Call Text
call) =
        forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.args (Event -> Environ
Score.event_environ Event
event)
    | Bool
otherwise = forall a. Maybe a
Nothing

-- * modify events

-- | Like 'add_environ', but check the type.
put_environ :: Typecheck.ToVal a => Env.Key -> a -> Score.Event
    -> Either Text Score.Event
put_environ :: forall a. ToVal a => Text -> a -> Event -> Either Text Event
put_environ Text
name a
val Event
event =
    case forall a. ToVal a => Text -> a -> Environ -> Either Text Environ
Env.put_val Text
name a
val (Event -> Environ
Score.event_environ Event
event) of
        Left Text
err -> forall a b. a -> Either a b
Left Text
err
        Right Environ
env -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Event
event { event_environ :: Environ
Score.event_environ = Environ
env }

add_environ :: Typecheck.ToVal a => Env.Key -> a -> Score.Event -> Score.Event
add_environ :: forall a. ToVal a => Text -> a -> Event -> Event
add_environ Text
name a
val = (Environ -> Environ) -> Event -> Event
Score.modify_environ forall a b. (a -> b) -> a -> b
$ forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
name a
val

set_instrument :: (ScoreT.Instrument, Derive.Instrument)
    -- ^ unaliased instrument name, from 'Derive.get_instrument'
    -> Score.Event -> Score.Event
set_instrument :: (Instrument, Instrument) -> Event -> Event
set_instrument (Instrument
score_inst, Instrument
inst) =
    Instrument -> Environ -> Event -> Event
Score.set_instrument Instrument
score_inst (Instrument -> Environ
Derive.inst_environ Instrument
inst)

-- * misc

-- | Like 'Derive.with_event_stack', but directly add the event's innermost
-- stack to a log msg.
-- TODO unused
add_event_stack :: Score.Event -> Log.Msg -> Log.Msg
add_event_stack :: Event -> Msg -> Msg
add_event_stack =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (BlockId, TrackId, (ScoreTime, ScoreTime)) -> Msg -> Msg
with_stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Maybe (BlockId, TrackId, (ScoreTime, ScoreTime))
Stack.block_track_region_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Stack
Score.event_stack
    where
    with_stack :: (BlockId, TrackId, (ScoreTime, ScoreTime)) -> Msg -> Msg
with_stack (BlockId
block_id, TrackId
track_id, (ScoreTime
s, ScoreTime
e)) Msg
msg =
        Msg
msg { msg_stack :: Maybe Stack
Log.msg_stack = Msg -> Maybe Stack
add_stack Msg
msg }
        where
        add_stack :: Msg -> Maybe Stack
add_stack = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Stack
add forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe Stack
Stack.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Maybe Stack
Log.msg_stack
        add :: Stack -> Stack
add = Frame -> Stack -> Stack
Stack.add (ScoreTime -> ScoreTime -> Frame
Stack.Region ScoreTime
s ScoreTime
e) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame -> Stack -> Stack
Stack.add (TrackId -> Frame
Stack.Track TrackId
track_id)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame -> Stack -> Stack
Stack.add (BlockId -> Frame
Stack.Block BlockId
block_id)