-- 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.Log as Log
import qualified Util.Seq as Seq
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_ = (a -> b) -> Stream a -> Stream b
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 (Stream Event -> Stream Event)
-> (Stream a -> Stream Event) -> Stream a -> Stream Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Event) -> Stream a -> Stream Event
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 =
    ([LEvent b] -> Stream b)
-> (state, [LEvent b]) -> (state, Stream b)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [LEvent b] -> Stream b
forall a. [LEvent a] -> Stream a
Stream.from_sorted_list ((state, [LEvent b]) -> (state, Stream b))
-> (Stream a -> (state, [LEvent b]))
-> Stream a
-> (state, Stream b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (state -> LEvent a -> (state, LEvent b))
-> state -> [LEvent a] -> (state, [LEvent b])
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 ([LEvent a] -> (state, [LEvent b]))
-> (Stream a -> [LEvent a]) -> Stream a -> (state, [LEvent b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream a -> [LEvent a]
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, Msg -> LEvent b
forall a. Msg -> LEvent a
LEvent.Log Msg
log)
    go state
state (LEvent.Event a
event) = b -> LEvent b
forall a. a -> LEvent a
LEvent.Event (b -> LEvent b) -> (state, b) -> (state, LEvent b)
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 = ([Stream Event] -> Stream Event)
-> (state, [Stream Event]) -> (state, Stream Event)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Stream Event] -> Stream Event
Stream.merge_asc_lists ((state, [Stream Event]) -> (state, Stream Event))
-> (Stream a -> (state, [Stream Event]))
-> Stream a
-> (state, Stream Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (state -> a -> (state, [Event]))
-> state -> Stream a -> (state, [Stream Event])
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 = (state -> LEvent a -> (state, Stream b))
-> state -> [LEvent a] -> (state, [Stream b])
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 ([LEvent a] -> (state, [Stream b]))
-> (Stream a -> [LEvent a]) -> Stream a -> (state, [Stream b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream a -> [LEvent a]
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, [Msg] -> Stream b
forall a. [Msg] -> Stream a
Stream.from_logs [Msg
log])
        go state
state (LEvent.Event a
event) =
            [b] -> Stream b
forall a. [a] -> Stream a
Stream.from_sorted_events ([b] -> Stream b) -> (state, [b]) -> (state, Stream b)
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 = (state -> a -> (state, [Event]))
-> state -> Stream a -> (state, Stream Event)
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 ([Stream Event] -> Stream Event)
-> (Stream a -> [Stream Event]) -> Stream a -> Stream Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LEvent [Event] -> Stream Event)
-> [LEvent [Event]] -> [Stream Event]
forall a b. (a -> b) -> [a] -> [b]
map LEvent [Event] -> Stream Event
forall {a}. LEvent [a] -> Stream a
flatten ([LEvent [Event]] -> [Stream Event])
-> (Stream a -> [LEvent [Event]]) -> Stream a -> [Stream Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream [Event] -> [LEvent [Event]]
forall a. Stream a -> [LEvent a]
Stream.to_list (Stream [Event] -> [LEvent [Event]])
-> (Stream a -> Stream [Event]) -> Stream a -> [LEvent [Event]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [Event]) -> Stream a -> Stream [Event]
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) = [Msg] -> Stream a
forall a. [Msg] -> Stream a
Stream.from_logs [Msg
log]
    flatten (LEvent.Event [a]
events) = [a] -> Stream a
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_ = (a -> [Event]) -> Stream a -> Stream Event
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 = [Msg] -> Stream b -> Stream b
forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs (Stream b -> Stream b) -> Stream b -> Stream b
forall a b. (a -> b) -> a -> b
$ [b] -> Stream b
forall a. [a] -> Stream a
Stream.from_sorted_events ([a] -> [b]
f [a]
events)
    where ([a]
events, [Msg]
logs) = Stream a -> ([a], [Msg])
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 =
    [Msg] -> Stream b -> Stream b
forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs (Stream b -> Stream b) -> ([b] -> Stream b) -> [b] -> Stream b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> Stream b
forall a. [a] -> Stream a
Stream.from_sorted_events ([b] -> Stream b) -> f [b] -> f (Stream b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> f [b]
f [a]
events
    where ([a]
events, [Msg]
logs) = Stream a -> ([a], [Msg])
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 =
    ([LEvent b] -> Stream b)
-> Deriver State Error [LEvent b] -> Deriver State Error (Stream b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [LEvent b] -> Stream b
forall a. [LEvent a] -> Stream a
Stream.from_sorted_list (Deriver State Error [LEvent b] -> Deriver State Error (Stream b))
-> (Stream a -> Deriver State Error [LEvent b])
-> Stream a
-> Deriver State Error (Stream b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LEvent a -> Deriver State Error (Maybe (LEvent b)))
-> [LEvent a] -> Deriver State Error [LEvent b]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM LEvent a -> Deriver State Error (Maybe (LEvent b))
process ([LEvent a] -> Deriver State Error [LEvent b])
-> (Stream a -> [LEvent a])
-> Stream a
-> Deriver State Error [LEvent b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream a -> [LEvent a]
forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    process :: LEvent a -> Deriver State Error (Maybe (LEvent b))
process (LEvent.Log Msg
log) = Maybe (LEvent b) -> Deriver State Error (Maybe (LEvent b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (LEvent b) -> Deriver State Error (Maybe (LEvent b)))
-> Maybe (LEvent b) -> Deriver State Error (Maybe (LEvent b))
forall a b. (a -> b) -> a -> b
$ LEvent b -> Maybe (LEvent b)
forall a. a -> Maybe a
Just (LEvent b -> Maybe (LEvent b)) -> LEvent b -> Maybe (LEvent b)
forall a b. (a -> b) -> a -> b
$ Msg -> LEvent b
forall a. Msg -> LEvent a
LEvent.Log Msg
log
    process (LEvent.Event a
a) =
        Event
-> Deriver (LEvent b) -> Deriver State Error (Maybe (LEvent b))
forall a. Event -> Deriver a -> Deriver (Maybe a)
Derive.with_event (a -> Event
event_of a
a) (Deriver (LEvent b) -> Deriver State Error (Maybe (LEvent b)))
-> Deriver (LEvent b) -> Deriver State Error (Maybe (LEvent b))
forall a b. (a -> b) -> a -> b
$ b -> LEvent b
forall a. a -> LEvent a
LEvent.Event (b -> LEvent b) -> Deriver b -> Deriver (LEvent b)
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 =
    ((state, DList (LEvent b)) -> (state, Stream b))
-> Deriver State Error (state, DList (LEvent b))
-> Deriver State Error (state, Stream b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DList (LEvent b) -> Stream b)
-> (state, DList (LEvent b)) -> (state, Stream b)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([LEvent b] -> Stream b
forall a. [LEvent a] -> Stream a
Stream.from_sorted_list ([LEvent b] -> Stream b)
-> (DList (LEvent b) -> [LEvent b]) -> DList (LEvent b) -> Stream b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList (LEvent b) -> [LEvent b]
forall a. DList a -> [a]
DList.toList)) (Deriver State Error (state, DList (LEvent b))
 -> Deriver State Error (state, Stream b))
-> (Stream a -> Deriver State Error (state, DList (LEvent b)))
-> Stream a
-> Deriver State Error (state, Stream b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state
-> [LEvent a] -> Deriver State Error (state, DList (LEvent b))
go state
state
        ([LEvent a] -> Deriver State Error (state, DList (LEvent b)))
-> (Stream a -> [LEvent a])
-> Stream a
-> Deriver State Error (state, DList (LEvent b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream a -> [LEvent a]
forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    go :: state
-> [LEvent a] -> Deriver State Error (state, DList (LEvent b))
go state
state [] = (state, DList (LEvent b))
-> Deriver State Error (state, DList (LEvent b))
forall (m :: * -> *) a. Monad m => a -> m a
return (state
state, DList (LEvent b)
forall a. Monoid a => a
mempty)
    go state
state (LEvent.Log Msg
log : [LEvent a]
events) =
        (DList (LEvent b) -> DList (LEvent b))
-> (state, DList (LEvent b)) -> (state, DList (LEvent b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LEvent b -> DList (LEvent b) -> DList (LEvent b)
forall a. a -> DList a -> DList a
DList.cons (Msg -> LEvent b
forall a. Msg -> LEvent a
LEvent.Log Msg
log)) ((state, DList (LEvent b)) -> (state, DList (LEvent b)))
-> Deriver State Error (state, DList (LEvent b))
-> Deriver State Error (state, DList (LEvent b))
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) <- (state, [b]) -> Maybe (state, [b]) -> (state, [b])
forall a. a -> Maybe a -> a
fromMaybe (state
state, []) (Maybe (state, [b]) -> (state, [b]))
-> Deriver State Error (Maybe (state, [b])) -> Deriver (state, [b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Event
-> Deriver (state, [b]) -> Deriver State Error (Maybe (state, [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
        (state, DList (LEvent b))
-> Deriver State Error (state, DList (LEvent b))
forall (m :: * -> *) a. Monad m => a -> m a
return (state
final, [LEvent b] -> DList (LEvent b)
forall a. [a] -> DList a
DList.fromList ((b -> LEvent b) -> [b] -> [LEvent b]
forall a b. (a -> b) -> [a] -> [b]
map b -> LEvent b
forall a. a -> LEvent a
LEvent.Event [b]
output) DList (LEvent b) -> DList (LEvent b) -> DList (LEvent b)
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 =
    ((state, [[LEvent Event]]) -> (state, Stream Event))
-> Deriver State Error (state, [[LEvent Event]])
-> Deriver State Error (state, Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[LEvent Event]] -> Stream Event)
-> (state, [[LEvent Event]]) -> (state, Stream Event)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[LEvent Event]] -> Stream Event
merge) (Deriver State Error (state, [[LEvent Event]])
 -> Deriver State Error (state, Stream Event))
-> (Stream a -> Deriver State Error (state, [[LEvent Event]]))
-> Stream a
-> Deriver State Error (state, Stream Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (state -> LEvent a -> Deriver State Error (state, [LEvent Event]))
-> state
-> [LEvent a]
-> Deriver State Error (state, [[LEvent Event]])
forall (m :: * -> *) state x y.
Monad m =>
(state -> x -> m (state, y)) -> state -> [x] -> m (state, [y])
Seq.mapAccumLM state -> LEvent a -> Deriver State Error (state, [LEvent Event])
go state
state ([LEvent a] -> Deriver State Error (state, [[LEvent Event]]))
-> (Stream a -> [LEvent a])
-> Stream a
-> Deriver State Error (state, [[LEvent Event]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream a -> [LEvent a]
forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    merge :: [[LEvent Event]] -> Stream Event
merge = [Stream Event] -> Stream Event
Stream.merge_asc_lists ([Stream Event] -> Stream Event)
-> ([[LEvent Event]] -> [Stream Event])
-> [[LEvent Event]]
-> Stream Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([LEvent Event] -> Stream Event)
-> [[LEvent Event]] -> [Stream Event]
forall a b. (a -> b) -> [a] -> [b]
map [LEvent Event] -> Stream Event
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) =
        (state, [LEvent Event])
-> ((state, [Event]) -> (state, [LEvent Event]))
-> Maybe (state, [Event])
-> (state, [LEvent Event])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (state
state, []) (([Event] -> [LEvent Event])
-> (state, [Event]) -> (state, [LEvent Event])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Event -> LEvent Event) -> [Event] -> [LEvent Event]
forall a b. (a -> b) -> [a] -> [b]
map Event -> LEvent Event
forall a. a -> LEvent a
LEvent.Event)) (Maybe (state, [Event]) -> (state, [LEvent Event]))
-> Deriver State Error (Maybe (state, [Event]))
-> Deriver State Error (state, [LEvent Event])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Event
-> Deriver (state, [Event])
-> Deriver State Error (Maybe (state, [Event]))
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) = (state, [LEvent Event])
-> Deriver State Error (state, [LEvent Event])
forall (m :: * -> *) a. Monad m => a -> m a
return (state
state, [Msg -> LEvent Event
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 = (((), Stream b) -> Stream b)
-> Deriver State Error ((), Stream b)
-> Deriver State Error (Stream b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((), Stream b) -> Stream b
forall a b. (a, b) -> b
snd (Deriver State Error ((), Stream b)
 -> Deriver State Error (Stream b))
-> (Stream a -> Deriver State Error ((), Stream b))
-> Stream a
-> Deriver State Error (Stream b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Event)
-> (() -> a -> Deriver ((), [b]))
-> ()
-> Stream a
-> Deriver State Error ((), Stream b)
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 -> (,) () ([b] -> ((), [b])) -> Deriver [b] -> Deriver ((), [b])
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 =
    (((), Stream Event) -> Stream Event)
-> Deriver State Error ((), Stream Event) -> Deriver (Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((), Stream Event) -> Stream Event
forall a b. (a, b) -> b
snd (Deriver State Error ((), Stream Event) -> Deriver (Stream Event))
-> (Stream a -> Deriver State Error ((), Stream Event))
-> Stream a
-> Deriver (Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> Event)
-> (() -> a -> Deriver ((), [Event]))
-> ()
-> Stream a
-> Deriver State Error ((), Stream Event)
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 -> (,) () ([Event] -> ((), [Event]))
-> Deriver [Event] -> Deriver ((), [Event])
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 = (LEvent a -> Deriver (Stream Event))
-> [LEvent a] -> Deriver (Stream Event)
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM LEvent a -> Deriver (Stream Event)
go ([LEvent a] -> Deriver (Stream Event))
-> (Stream a -> [LEvent a]) -> Stream a -> Deriver (Stream Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream a -> [LEvent a]
forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    go :: LEvent a -> Deriver (Stream Event)
go (LEvent.Log Msg
log) = Stream Event -> Deriver (Stream Event)
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream Event -> Deriver (Stream Event))
-> Stream Event -> Deriver (Stream Event)
forall a b. (a -> b) -> a -> b
$ [Msg] -> Stream Event
forall a. [Msg] -> Stream a
Stream.from_logs [Msg
log]
    go (LEvent.Event a
a) = Stream Event -> Maybe (Stream Event) -> Stream Event
forall a. a -> Maybe a -> a
fromMaybe Stream Event
forall a. Monoid a => a
mempty (Maybe (Stream Event) -> Stream Event)
-> Deriver State Error (Maybe (Stream Event))
-> Deriver (Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Event
-> Deriver (Stream Event)
-> Deriver State Error (Maybe (Stream Event))
forall a. Event -> Deriver a -> Deriver (Maybe a)
Derive.with_event (a -> Event
event_of a
a) (a -> Deriver (Stream Event)
f a
a)

-- * 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 = (Instrument -> Set Instrument -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Instrument
set) (Instrument -> Bool) -> (Event -> Instrument) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Score.event_instrument
    where set :: Set Instrument
set = [Instrument] -> Set Instrument
forall a. Ord a => [a] -> Set a
Set.fromList [Instrument]
wanted

-- ** unthreaded state

control :: (ScoreT.Typed Signal.Y -> a) -> DeriveT.ControlRef
    -> Stream Score.Event -> Derive.Deriver [a]
control :: forall a.
(Typed Y -> a) -> ControlRef -> Stream Event -> Deriver [a]
control Typed Y -> a
f ControlRef
c Stream Event
events = do
    TypedFunction
sig <- ControlRef -> Deriver TypedFunction
Typecheck.to_typed_function ControlRef
c
    [a] -> Deriver [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Deriver [a]) -> [a] -> Deriver [a]
forall a b. (a -> b) -> a -> b
$ (Event -> a) -> [Event] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Typed Y -> a
f (Typed Y -> a) -> (Event -> Typed Y) -> Event -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypedFunction
sig TypedFunction -> (Event -> RealTime) -> Event -> Typed Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start) (Stream Event -> [Event]
forall a. Stream a -> [a]
Stream.events_of Stream Event
events)

time_control :: DeriveT.ControlRef -> Stream Score.Event
    -> Derive.Deriver [RealTime]
time_control :: ControlRef -> Stream Event -> Deriver [RealTime]
time_control = (Typed Y -> RealTime)
-> ControlRef -> Stream Event -> Deriver [RealTime]
forall a.
(Typed Y -> a) -> ControlRef -> Stream Event -> Deriver [a]
control (Y -> RealTime
RealTime.seconds (Y -> RealTime) -> (Typed Y -> Y) -> Typed Y -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val)

-- | Take a typed signal to RealTime durations.
duration_control :: Typecheck.TimeType -> DeriveT.ControlRef
    -> Stream Score.Event -> Derive.Deriver [RealTime]
duration_control :: TimeType -> ControlRef -> Stream Event -> Deriver [RealTime]
duration_control TimeType
default_type ControlRef
control Stream Event
events = do
    (Function
sig, TimeType
time) <- TimeType -> ControlRef -> Deriver (Function, TimeType)
Call.to_time_function TimeType
default_type ControlRef
control
    let starts :: [RealTime]
starts = (Event -> RealTime) -> [Event] -> [RealTime]
forall a b. (a -> b) -> [a] -> [b]
map Event -> RealTime
Score.event_start (Stream Event -> [Event]
forall a. Stream a -> [a]
Stream.events_of Stream Event
events)
    case TimeType
time of
        TimeType
Typecheck.Real -> [RealTime] -> Deriver [RealTime]
forall (m :: * -> *) a. Monad m => a -> m a
return ([RealTime] -> Deriver [RealTime])
-> [RealTime] -> Deriver [RealTime]
forall a b. (a -> b) -> a -> b
$ (RealTime -> RealTime) -> [RealTime] -> [RealTime]
forall a b. (a -> b) -> [a] -> [b]
map (Y -> RealTime
RealTime.seconds (Y -> RealTime) -> Function -> RealTime -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
sig) [RealTime]
starts
        TimeType
Typecheck.Score ->
            (RealTime -> Deriver State Error RealTime)
-> [RealTime] -> Deriver [RealTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\RealTime
t -> RealTime -> ScoreTime -> Deriver State Error RealTime
forall t1 t2.
(Time t1, Time t2) =>
t1 -> t2 -> Deriver State Error RealTime
Call.real_duration RealTime
t (Y -> ScoreTime
ScoreTime.from_double (Function
sig 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 = (([a], [a], a) -> ([a], a, [a]))
-> Stream ([a], [a], a) -> Stream ([a], a, [a])
forall a b. (a -> b) -> Stream a -> Stream b
emap1_ (\([a]
ps, [a]
ns, a
e) -> ([a]
ps, a
e, [a]
ns)) (Stream ([a], [a], a) -> Stream ([a], a, [a]))
-> Stream ([a], [a], a) -> Stream ([a], a, [a])
forall a b. (a -> b) -> a -> b
$
    ([a] -> [[a]])
-> ([a] -> [[a]]) -> Stream a -> Stream ([a], [a], a)
forall a b c.
([a] -> [b]) -> ([a] -> [c]) -> Stream a -> Stream (b, c, a)
Stream.zip3_on [a] -> [[a]]
forall a. [a] -> [[a]]
prevs [a] -> [[a]]
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 = (([a], a, [a]) -> (Maybe a, a, Maybe a))
-> Stream ([a], a, [a]) -> Stream (Maybe a, a, Maybe a)
forall a b. (a -> b) -> Stream a -> Stream b
emap1_ ([a], a, [a]) -> (Maybe a, a, Maybe a)
extract (Stream ([a], a, [a]) -> Stream (Maybe a, a, Maybe a))
-> (Stream a -> Stream ([a], a, [a]))
-> Stream a
-> Stream (Maybe a, a, Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream a -> Stream ([a], a, [a])
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 = [a] -> Maybe a
forall a. [a] -> Maybe a
Seq.head ([a] -> Maybe a) -> ([a] -> [a]) -> [a] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((key -> key -> Bool
forall a. Eq a => a -> a -> Bool
== a -> key
key a
e) (key -> Bool) -> (a -> key) -> a -> Bool
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 = (([a], a) -> (a, [a])) -> Stream ([a], a) -> Stream (a, [a])
forall a b. (a -> b) -> Stream a -> Stream b
emap1_ ([a], a) -> (a, [a])
extract (Stream ([a], a) -> Stream (a, [a]))
-> (Stream a -> Stream ([a], a)) -> Stream a -> Stream (a, [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [[a]]) -> Stream a -> Stream ([a], a)
forall a b. ([a] -> [b]) -> Stream a -> Stream (b, a)
Stream.zip_on [a] -> [[a]]
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 = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((key -> key -> Bool
forall a. Eq a => a -> a -> Bool
== a -> key
key a
e) (key -> Bool) -> (a -> key) -> a -> Bool
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 = ((Maybe a, a, Maybe a) -> (a, Maybe a))
-> Stream (Maybe a, a, Maybe a) -> Stream (a, Maybe a)
forall a b. (a -> b) -> Stream a -> Stream b
emap1_ (Maybe a, a, Maybe a) -> (a, Maybe a)
forall {a} {a} {b}. (a, a, b) -> (a, b)
extract (Stream (Maybe a, a, Maybe a) -> Stream (a, Maybe a))
-> (Stream a -> Stream (Maybe a, a, Maybe a))
-> Stream a
-> Stream (a, Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a)
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 = ((Maybe a, a, Maybe a) -> (Maybe a, a))
-> Stream (Maybe a, a, Maybe a) -> Stream (Maybe a, a)
forall a b. (a -> b) -> Stream a -> Stream b
emap1_ (Maybe a, a, Maybe a) -> (Maybe a, a)
forall {a} {b} {c}. (a, b, c) -> (a, b)
extract (Stream (Maybe a, a, Maybe a) -> Stream (Maybe a, a))
-> (Stream a -> Stream (Maybe a, a, Maybe a))
-> Stream a
-> Stream (Maybe a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a)
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
    , Text -> Environ -> Maybe Text
forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.hand (Environ -> Maybe Text) -> Environ -> Maybe Text
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
    , Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Environ -> Maybe Int
forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.voice (Environ -> Maybe Int) -> Environ -> Maybe Int
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 = Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. [a] -> [[a]]
List.tails

-- | Extract previous events.
prevs :: [a] -> [[a]]
prevs :: forall a. [a] -> [[a]]
prevs = ([a] -> a -> [a]) -> [a] -> [a] -> [[a]]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl ((a -> [a] -> [a]) -> [a] -> a -> [a]
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 = (a -> Stream a -> Deriver (Stream a))
-> Stream a -> Deriver (Stream a)
forall a.
(a -> Stream a -> Deriver (Stream a))
-> Stream a -> Deriver (Stream a)
map_head_tail ((a -> Stream a -> Deriver (Stream a))
 -> Stream a -> Deriver (Stream a))
-> (a -> Stream a -> Deriver (Stream a))
-> Stream a
-> Deriver (Stream a)
forall a b. (a -> b) -> a -> b
$ \a
e Stream a
es -> do
    a
e <- a -> Deriver a
f a
e
    Stream a -> Deriver (Stream a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream a -> Deriver (Stream a)) -> Stream a -> Deriver (Stream a)
forall a b. (a -> b) -> a -> b
$ [LEvent a] -> Stream a
forall a. [LEvent a] -> Stream a
Stream.from_sorted_list ([LEvent a] -> Stream a) -> [LEvent a] -> Stream a
forall a b. (a -> b) -> a -> b
$ a -> LEvent a
forall a. a -> LEvent a
LEvent.Event a
e LEvent a -> [LEvent a] -> [LEvent a]
forall a. a -> [a] -> [a]
: Stream a -> [LEvent 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 ([LEvent a] -> Deriver (Stream a))
-> (Stream a -> [LEvent a]) -> Stream a -> Deriver (Stream a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream a -> [LEvent a]
forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    go :: [LEvent a] -> Deriver (Stream a)
go [] = Stream a -> Deriver (Stream a)
forall (m :: * -> *) a. Monad m => a -> m a
return Stream a
forall a. Stream a
Stream.empty
    go (LEvent.Log Msg
log : [LEvent a]
rest) = Msg -> Stream a -> Stream a
forall a. Msg -> Stream a -> Stream a
Stream.merge_log Msg
log (Stream a -> Stream a) -> Deriver (Stream a) -> Deriver (Stream a)
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 ([LEvent a] -> Stream a
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) <- ([Control] -> Control) -> ([Control], [Msg]) -> (Control, [Msg])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Control] -> Control
forall a. Monoid a => [a] -> a
mconcat (([Control], [Msg]) -> (Control, [Msg]))
-> (Stream Control -> ([Control], [Msg]))
-> Stream Control
-> (Control, [Msg])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream Control -> ([Control], [Msg])
forall a. Stream a -> ([a], [Msg])
Stream.partition (Stream Control -> (Control, [Msg]))
-> ControlDeriver -> Deriver State Error (Control, [Msg])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlDeriver
deriver
    let range :: (RealTime, RealTime)
range = case (Control -> Maybe (RealTime, Y)
forall {k} (kind :: k). Signal kind -> Maybe (RealTime, Y)
Signal.head Control
sig, Control -> Maybe (RealTime, Y)
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)
    (Control, (RealTime, RealTime), [Msg])
-> Deriver (Control, (RealTime, RealTime), [Msg])
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) <- ([PSignal] -> PSignal) -> ([PSignal], [Msg]) -> (PSignal, [Msg])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [PSignal] -> PSignal
forall a. Monoid a => [a] -> a
mconcat (([PSignal], [Msg]) -> (PSignal, [Msg]))
-> (Stream PSignal -> ([PSignal], [Msg]))
-> Stream PSignal
-> (PSignal, [Msg])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream PSignal -> ([PSignal], [Msg])
forall a. Stream a -> ([a], [Msg])
Stream.partition (Stream PSignal -> (PSignal, [Msg]))
-> PitchDeriver -> Deriver State Error (PSignal, [Msg])
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)
    (PSignal, (RealTime, RealTime), [Msg])
-> Deriver (PSignal, (RealTime, RealTime), [Msg])
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) <- Deriver (Stream sig) -> Deriver (sig, [Msg])
forall sig.
Monoid sig =>
Deriver (Stream sig) -> Deriver (sig, [Msg])
derive_signal Deriver (Stream sig)
deriver
    Stream sig -> Deriver (Stream sig)
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream sig -> Deriver (Stream sig))
-> Stream sig -> Deriver (Stream sig)
forall a b. (a -> b) -> a -> b
$ [LEvent sig] -> Stream sig
forall a. [LEvent a] -> Stream a
Stream.from_sorted_list ([LEvent sig] -> Stream sig) -> [LEvent sig] -> Stream sig
forall a b. (a -> b) -> a -> b
$
        sig -> LEvent sig
forall a. a -> LEvent a
LEvent.Event (sig -> sig
f sig
sig) LEvent sig -> [LEvent sig] -> [LEvent sig]
forall a. a -> [a] -> [a]
: (Msg -> LEvent sig) -> [Msg] -> [LEvent sig]
forall a b. (a -> b) -> [a] -> [b]
map Msg -> LEvent sig
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) <- Stream sig -> ([sig], [Msg])
forall a. Stream a -> ([a], [Msg])
Stream.partition (Stream sig -> ([sig], [Msg]))
-> Deriver (Stream sig) -> Deriver State Error ([sig], [Msg])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream sig)
deriver
    (sig, [Msg]) -> Deriver (sig, [Msg])
forall (m :: * -> *) a. Monad m => a -> m a
return ([sig] -> sig
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 <- (Dynamic -> Dynamic) -> Deriver Dynamic
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Dynamic
forall a. a -> a
id
    Event -> Stream Event
forall a. a -> Stream a
Stream.from_event (Event -> Stream Event)
-> (Event -> Event) -> Event -> Stream Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> Event -> Event
delayed_event [Val]
event_args (Event -> Stream Event)
-> Deriver State Error Event -> Deriver (Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        PassedArgs a
-> Dynamic
-> RealTime
-> RealTime
-> Flags
-> Deriver State Error Event
forall a.
PassedArgs a
-> Dynamic
-> RealTime
-> RealTime
-> Flags
-> Deriver State Error Event
NoteUtil.make_event PassedArgs a
args Dynamic
dyn RealTime
start RealTime
0 Flags
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 ((Environ -> Environ) -> Event -> Event)
-> (Environ -> Environ) -> Event -> Event
forall a b. (a -> b) -> a -> b
$
    Text -> Val -> Environ -> Environ
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
    | [Frame] -> Maybe Frame
forall a. [a] -> Maybe a
Seq.head (Stack -> [Frame]
Stack.innermost (Event -> Stack
Score.event_stack Event
event))
            Maybe Frame -> Maybe Frame -> Bool
forall a. Eq a => a -> a -> Bool
== Frame -> Maybe Frame
forall a. a -> Maybe a
Just (Text -> Frame
Stack.Call Text
call) =
        Text -> Environ -> Maybe [Val]
forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.args (Event -> Environ
Score.event_environ Event
event)
    | Bool
otherwise = Maybe [Val]
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 Text -> a -> Environ -> Either Text Environ
forall a. ToVal a => Text -> a -> Environ -> Either Text Environ
Env.put_val_error Text
name a
val (Event -> Environ
Score.event_environ Event
event) of
        Left Text
err -> Text -> Either Text Event
forall a b. a -> Either a b
Left Text
err
        Right Environ
env -> Event -> Either Text Event
forall a b. b -> Either a b
Right (Event -> Either Text Event) -> Event -> Either Text Event
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 ((Environ -> Environ) -> Event -> Event)
-> (Environ -> Environ) -> Event -> Event
forall a b. (a -> b) -> a -> b
$ Text -> a -> Environ -> Environ
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 =
    (Msg -> Msg)
-> ((BlockId, TrackId, (ScoreTime, ScoreTime)) -> Msg -> Msg)
-> Maybe (BlockId, TrackId, (ScoreTime, ScoreTime))
-> Msg
-> Msg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Msg -> Msg
forall a. a -> a
id (BlockId, TrackId, (ScoreTime, ScoreTime)) -> Msg -> Msg
with_stack (Maybe (BlockId, TrackId, (ScoreTime, ScoreTime)) -> Msg -> Msg)
-> (Event -> Maybe (BlockId, TrackId, (ScoreTime, ScoreTime)))
-> Event
-> Msg
-> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Maybe (BlockId, TrackId, (ScoreTime, ScoreTime))
Stack.block_track_region_of (Stack -> Maybe (BlockId, TrackId, (ScoreTime, ScoreTime)))
-> (Event -> Stack)
-> Event
-> Maybe (BlockId, TrackId, (ScoreTime, ScoreTime))
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 = Stack -> Maybe Stack
forall a. a -> Maybe a
Just (Stack -> Maybe Stack) -> (Msg -> Stack) -> Msg -> Maybe Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Stack
add (Stack -> Stack) -> (Msg -> Stack) -> Msg -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Maybe Stack -> Stack
forall a. a -> Maybe a -> a
fromMaybe Stack
Stack.empty (Maybe Stack -> Stack) -> (Msg -> Maybe Stack) -> Msg -> Stack
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) (Stack -> Stack) -> (Stack -> Stack) -> Stack -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame -> Stack -> Stack
Stack.add (TrackId -> Frame
Stack.Track TrackId
track_id)
            (Stack -> Stack) -> (Stack -> Stack) -> Stack -> Stack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame -> Stack -> Stack
Stack.add (BlockId -> Frame
Stack.Block BlockId
block_id)