-- 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

module Derive.PSignal (
    PSignal, sig_scale_id
    , Scale(..), no_scale

    -- * construct / destruct
    , from_pairs, from_sample, from_segments
    , to_pairs, to_segments
    , constant
    , prepend
    , to_nn
    , unfoldr

    -- * query
    , null
    , at, at_negative, segment_at
    , interpolate
    , head, last
    -- , before
    -- , drop_at_after
    -- , drop_before_strict, drop_before_at, within

    -- * transform
    , drop_after, clip_after
    , drop_before, clip_before
    , shift
    , apply_controls, apply_control, apply_environ
    , map_y_linear

    -- ** hacks
    , drop_discontinuity_at

    -- * Pitch
    , Transposed, Pitch
    , RawPitch, PitchConfig(..)
    , symbolic_pitch
    , pitch_scale_id, pitch_transposers
    , pitch_scale, pitch_eval_nn, pitch_eval_note, pitch_config, pitch_controls
    , PitchError(..)
    , pitch, coerce
    , apply_config, apply, add_control, pitch_nn, pitch_note
    -- ** create
    , constant_pitch, nn_pitch
) where
import           Prelude hiding (head, last, null)
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

import qualified Util.Segment as Segment
import           Util.Segment (Sample(..))
import qualified Util.Seq as Seq

import qualified Derive.DeriveT as DeriveT
import           Derive.DeriveT
       (_signal, coerce, interpolate, pitch, pitch_nn, pitch_note, Pitch,
        Transposed, PSignal(..), RawPitch(..), Scale(..), PitchConfig(..),
        PitchError(..))
import qualified Derive.ScoreT as ScoreT

import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import           Global
import           Types


-- Signal imported from DeriveT.

-- | Set of transposers for the signal.  Transposers are documented in
-- 'pscale_transposers'.
--
-- A Signal can contain pitches from multiple scales, though I don't think this
-- should ever happen.  But if it does, the first pitch wins.
sig_transposers :: PSignal -> Set ScoreT.Control
sig_transposers :: PSignal -> Set Control
sig_transposers = Scale -> Set Control
pscale_transposers (Scale -> Set Control)
-> (PSignal -> Scale) -> PSignal -> Set Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Scale
sig_scale

-- | Get the scale id of the signal.
--
-- A PSignal can contain pitches from multiple scales, though I don't think this
-- should ever happen.  But if it does, the first pitch wins.
sig_scale_id :: PSignal -> Pitch.ScaleId
sig_scale_id :: PSignal -> ScaleId
sig_scale_id = Scale -> ScaleId
pscale_scale_id (Scale -> ScaleId) -> (PSignal -> Scale) -> PSignal -> ScaleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Scale
sig_scale

sig_scale :: PSignal -> Scale
sig_scale :: PSignal -> Scale
sig_scale = Scale -> (Sample Pitch -> Scale) -> Maybe (Sample Pitch) -> Scale
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Scale
no_scale (Pitch -> Scale
forall a. RawPitch a -> Scale
pitch_scale (Pitch -> Scale)
-> (Sample Pitch -> Pitch) -> Sample Pitch -> Scale
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample Pitch -> Pitch
forall y. Sample y -> y
sy) (Maybe (Sample Pitch) -> Scale)
-> (PSignal -> Maybe (Sample Pitch)) -> PSignal -> Scale
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Sample Pitch] -> Maybe (Sample Pitch)
forall a. [a] -> Maybe a
Seq.head ([Sample Pitch] -> Maybe (Sample Pitch))
-> (PSignal -> [Sample Pitch]) -> PSignal -> Maybe (Sample Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalS Vector Pitch -> [Sample Pitch]
forall (v :: * -> *) y.
Vector v (Sample y) =>
SignalS v y -> [Sample y]
Segment.to_samples
    (SignalS Vector Pitch -> [Sample Pitch])
-> (PSignal -> SignalS Vector Pitch) -> PSignal -> [Sample Pitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal

modify :: (Segment.Boxed Pitch -> Segment.Boxed Pitch) -> PSignal -> PSignal
modify :: (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal -> PSignal
modify SignalS Vector Pitch -> SignalS Vector Pitch
f = SignalS Vector Pitch -> PSignal
PSignal (SignalS Vector Pitch -> PSignal)
-> (PSignal -> SignalS Vector Pitch) -> PSignal -> PSignal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalS Vector Pitch -> SignalS Vector Pitch
f (SignalS Vector Pitch -> SignalS Vector Pitch)
-> (PSignal -> SignalS Vector Pitch)
-> PSignal
-> SignalS Vector Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal

no_scale :: Scale
no_scale :: Scale
no_scale = ScaleId -> Set Control -> Scale
Scale ScaleId
"no-scale" Set Control
forall a. Monoid a => a
mempty

-- * construct / destruct

from_pairs :: [(RealTime, Pitch)] -> PSignal
from_pairs :: [(RealTime, Pitch)] -> PSignal
from_pairs = SignalS Vector Pitch -> PSignal
PSignal (SignalS Vector Pitch -> PSignal)
-> ([(RealTime, Pitch)] -> SignalS Vector Pitch)
-> [(RealTime, Pitch)]
-> PSignal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealTime, Pitch)] -> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
[(RealTime, y)] -> SignalS v y
Segment.from_pairs

from_sample :: RealTime -> Pitch -> PSignal
from_sample :: RealTime -> Pitch -> PSignal
from_sample RealTime
x Pitch
y = [(RealTime, Pitch)] -> PSignal
from_pairs [(RealTime
x, Pitch
y)]

from_segments :: [Segment.Segment Pitch] -> PSignal
from_segments :: [Segment Pitch] -> PSignal
from_segments = SignalS Vector Pitch -> PSignal
PSignal (SignalS Vector Pitch -> PSignal)
-> ([Segment Pitch] -> SignalS Vector Pitch)
-> [Segment Pitch]
-> PSignal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Segment Pitch] -> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
[Segment y] -> SignalS v y
Segment.from_segments

to_pairs :: PSignal -> [(RealTime, Pitch)]
to_pairs :: PSignal -> [(RealTime, Pitch)]
to_pairs = SignalS Vector Pitch -> [(RealTime, Pitch)]
forall (v :: * -> *) y.
Vector v (Sample y) =>
SignalS v y -> [(RealTime, y)]
Segment.to_pairs (SignalS Vector Pitch -> [(RealTime, Pitch)])
-> (PSignal -> SignalS Vector Pitch)
-> PSignal
-> [(RealTime, Pitch)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal

to_samples :: PSignal -> [Segment.Sample Pitch]
to_samples :: PSignal -> [Sample Pitch]
to_samples = SignalS Vector Pitch -> [Sample Pitch]
forall (v :: * -> *) y.
Vector v (Sample y) =>
SignalS v y -> [Sample y]
Segment.to_samples (SignalS Vector Pitch -> [Sample Pitch])
-> (PSignal -> SignalS Vector Pitch) -> PSignal -> [Sample Pitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal

to_segments :: PSignal -> [Segment.Segment Pitch]
to_segments :: PSignal -> [Segment Pitch]
to_segments = SignalS Vector Pitch -> [Segment Pitch]
forall (v :: * -> *) y.
Vector v (Sample y) =>
SignalS v y -> [Segment y]
Segment.to_segments (SignalS Vector Pitch -> [Segment Pitch])
-> (PSignal -> SignalS Vector Pitch) -> PSignal -> [Segment Pitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal

constant :: Pitch -> PSignal
constant :: Pitch -> PSignal
constant = SignalS Vector Pitch -> PSignal
PSignal (SignalS Vector Pitch -> PSignal)
-> (Pitch -> SignalS Vector Pitch) -> Pitch -> PSignal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> SignalS Vector Pitch
forall (v :: * -> *) y. Vector v (Sample y) => y -> SignalS v y
Segment.constant

prepend :: PSignal -> PSignal -> PSignal
prepend :: PSignal -> PSignal -> PSignal
prepend PSignal
sig1 PSignal
sig2 = SignalS Vector Pitch -> PSignal
PSignal (SignalS Vector Pitch -> PSignal)
-> SignalS Vector Pitch -> PSignal
forall a b. (a -> b) -> a -> b
$
    Maybe (Pitch -> Pitch -> Bool)
-> Interpolate Pitch
-> SignalS Vector Pitch
-> SignalS Vector Pitch
-> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
Maybe (y -> y -> Bool)
-> Interpolate y -> SignalS v y -> SignalS v y -> SignalS v y
Segment.prepend Maybe (Pitch -> Pitch -> Bool)
forall a. Maybe a
Nothing Interpolate Pitch
interpolate (PSignal -> SignalS Vector Pitch
_signal PSignal
sig1) (PSignal -> SignalS Vector Pitch
_signal PSignal
sig2)

-- | Flatten a signal to a non-transposeable Signal.NoteNumber.
-- TODO I could probably avoid the intermediate list
to_nn :: PSignal -> (Signal.NoteNumber, [(RealTime, PitchError)])
to_nn :: PSignal -> (NoteNumber, [(RealTime, PitchError)])
to_nn = ([(RealTime, PitchError)], [(RealTime, Y)])
-> (NoteNumber, [(RealTime, PitchError)])
forall {k} {a} {kind :: k}.
Ord a =>
([a], [(RealTime, Y)]) -> (Signal kind, [a])
extract (([(RealTime, PitchError)], [(RealTime, Y)])
 -> (NoteNumber, [(RealTime, PitchError)]))
-> (PSignal -> ([(RealTime, PitchError)], [(RealTime, Y)]))
-> PSignal
-> (NoteNumber, [(RealTime, PitchError)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either (RealTime, PitchError) (RealTime, Y)]
-> ([(RealTime, PitchError)], [(RealTime, Y)])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers ([Either (RealTime, PitchError) (RealTime, Y)]
 -> ([(RealTime, PitchError)], [(RealTime, Y)]))
-> (PSignal -> [Either (RealTime, PitchError) (RealTime, Y)])
-> PSignal
-> ([(RealTime, PitchError)], [(RealTime, Y)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RealTime, Pitch) -> Either (RealTime, PitchError) (RealTime, Y))
-> [(RealTime, Pitch)]
-> [Either (RealTime, PitchError) (RealTime, Y)]
forall a b. (a -> b) -> [a] -> [b]
map (RealTime, Pitch) -> Either (RealTime, PitchError) (RealTime, Y)
forall {a} {a}. (a, RawPitch a) -> Either (a, PitchError) (a, Y)
eval ([(RealTime, Pitch)]
 -> [Either (RealTime, PitchError) (RealTime, Y)])
-> (PSignal -> [(RealTime, Pitch)])
-> PSignal
-> [Either (RealTime, PitchError) (RealTime, Y)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> [(RealTime, Pitch)]
to_pairs
    where
    extract :: ([a], [(RealTime, Y)]) -> (Signal kind, [a])
extract ([a]
errs, [(RealTime, Y)]
nns) = ([(RealTime, Y)] -> Signal kind
forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs [(RealTime, Y)]
nns, [a] -> [a]
forall a. Ord a => [a] -> [a]
Seq.unique_sort [a]
errs)
    eval :: (a, RawPitch a) -> Either (a, PitchError) (a, Y)
eval (a
x, RawPitch a
pitch) = case Transposed -> Either PitchError NoteNumber
pitch_nn (RawPitch a -> Transposed
forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
pitch) of
        Left PitchError
err -> (a, PitchError) -> Either (a, PitchError) (a, Y)
forall a b. a -> Either a b
Left (a
x, PitchError
err)
        Right (Pitch.NoteNumber Y
nn) -> (a, Y) -> Either (a, PitchError) (a, Y)
forall a b. b -> Either a b
Right (a
x, Y
nn)

unfoldr :: (state -> Maybe ((RealTime, Pitch), state)) -> state -> PSignal
unfoldr :: forall state.
(state -> Maybe ((RealTime, Pitch), state)) -> state -> PSignal
unfoldr state -> Maybe ((RealTime, Pitch), state)
gen state
state = SignalS Vector Pitch -> PSignal
PSignal (SignalS Vector Pitch -> PSignal)
-> SignalS Vector Pitch -> PSignal
forall a b. (a -> b) -> a -> b
$ (state -> Maybe ((RealTime, Pitch), state))
-> state -> SignalS Vector Pitch
forall (v :: * -> *) y state.
Vector v (Sample y) =>
(state -> Maybe ((RealTime, y), state)) -> state -> SignalS v y
Segment.unfoldr state -> Maybe ((RealTime, Pitch), state)
gen state
state

-- * query

null :: PSignal -> Bool
null :: PSignal -> Bool
null = SignalS Vector Pitch -> Bool
forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Bool
Segment.null (SignalS Vector Pitch -> Bool)
-> (PSignal -> SignalS Vector Pitch) -> PSignal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal

at :: RealTime -> PSignal -> Maybe Pitch
at :: RealTime -> PSignal -> Maybe Pitch
at RealTime
x = Interpolate Pitch
-> RealTime -> SignalS Vector Pitch -> Maybe Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
Interpolate y -> RealTime -> SignalS v y -> Maybe y
Segment.at Interpolate Pitch
interpolate RealTime
x (SignalS Vector Pitch -> Maybe Pitch)
-> (PSignal -> SignalS Vector Pitch) -> PSignal -> Maybe Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal

at_negative :: RealTime -> PSignal -> Maybe Pitch
at_negative :: RealTime -> PSignal -> Maybe Pitch
at_negative RealTime
x = Interpolate Pitch
-> RealTime -> SignalS Vector Pitch -> Maybe Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
Interpolate y -> RealTime -> SignalS v y -> Maybe y
Segment.at_negative Interpolate Pitch
interpolate RealTime
x (SignalS Vector Pitch -> Maybe Pitch)
-> (PSignal -> SignalS Vector Pitch) -> PSignal -> Maybe Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal

segment_at :: RealTime -> PSignal -> Maybe (Segment.Segment Pitch)
segment_at :: RealTime -> PSignal -> Maybe (Segment Pitch)
segment_at RealTime
x = RealTime -> SignalS Vector Pitch -> Maybe (Segment Pitch)
forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> SignalS v y -> Maybe (Segment y)
Segment.segment_at RealTime
x (SignalS Vector Pitch -> Maybe (Segment Pitch))
-> (PSignal -> SignalS Vector Pitch)
-> PSignal
-> Maybe (Segment Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal

head, last :: PSignal -> Maybe (RealTime, Pitch)
head :: PSignal -> Maybe (RealTime, Pitch)
head = SignalS Vector Pitch -> Maybe (RealTime, Pitch)
forall (v :: * -> *) y.
Vector v (Sample y) =>
SignalS v y -> Maybe (RealTime, y)
Segment.head (SignalS Vector Pitch -> Maybe (RealTime, Pitch))
-> (PSignal -> SignalS Vector Pitch)
-> PSignal
-> Maybe (RealTime, Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal
last :: PSignal -> Maybe (RealTime, Pitch)
last = SignalS Vector Pitch -> Maybe (RealTime, Pitch)
forall (v :: * -> *) y.
Vector v (Sample y) =>
SignalS v y -> Maybe (RealTime, y)
Segment.last (SignalS Vector Pitch -> Maybe (RealTime, Pitch))
-> (PSignal -> SignalS Vector Pitch)
-> PSignal
-> Maybe (RealTime, Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> SignalS Vector Pitch
_signal


-- * transform

drop_after, drop_before :: RealTime -> PSignal -> PSignal
drop_after :: RealTime -> PSignal -> PSignal
drop_after RealTime
x = (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal -> PSignal
modify ((SignalS Vector Pitch -> SignalS Vector Pitch)
 -> PSignal -> PSignal)
-> (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal
-> PSignal
forall a b. (a -> b) -> a -> b
$ RealTime -> SignalS Vector Pitch -> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> SignalS v y -> SignalS v y
Segment.drop_after RealTime
x
drop_before :: RealTime -> PSignal -> PSignal
drop_before RealTime
x = (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal -> PSignal
modify ((SignalS Vector Pitch -> SignalS Vector Pitch)
 -> PSignal -> PSignal)
-> (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal
-> PSignal
forall a b. (a -> b) -> a -> b
$ RealTime -> SignalS Vector Pitch -> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> SignalS v y -> SignalS v y
Segment.drop_before RealTime
x

clip_after, clip_before :: RealTime -> PSignal -> PSignal
clip_after :: RealTime -> PSignal -> PSignal
clip_after RealTime
x = (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal -> PSignal
modify ((SignalS Vector Pitch -> SignalS Vector Pitch)
 -> PSignal -> PSignal)
-> (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal
-> PSignal
forall a b. (a -> b) -> a -> b
$ Interpolate Pitch
-> RealTime -> SignalS Vector Pitch -> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
Interpolate y -> RealTime -> SignalS v y -> SignalS v y
Segment.clip_after Interpolate Pitch
interpolate RealTime
x
clip_before :: RealTime -> PSignal -> PSignal
clip_before RealTime
x = (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal -> PSignal
modify ((SignalS Vector Pitch -> SignalS Vector Pitch)
 -> PSignal -> PSignal)
-> (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal
-> PSignal
forall a b. (a -> b) -> a -> b
$ Interpolate Pitch
-> RealTime -> SignalS Vector Pitch -> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
Interpolate y -> RealTime -> SignalS v y -> SignalS v y
Segment.clip_before Interpolate Pitch
interpolate RealTime
x

shift :: RealTime -> PSignal -> PSignal
shift :: RealTime -> PSignal -> PSignal
shift RealTime
x = (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal -> PSignal
modify (RealTime -> SignalS Vector Pitch -> SignalS Vector Pitch
forall v. RealTime -> Signal v -> Signal v
Segment.shift RealTime
x)

type ControlMap = Map ScoreT.Control (ScoreT.Typed Signal.Control)

-- | Resample the signal according to the 'sig_transposers' and apply the given
-- controls to the signal.
--
-- Controls are /added/ so if this is not correct for a given control then
-- this will do the wrong thing.  Transpose signals should be additive so it'll
-- be ok as long as you only apply transposing signals and only apply the
-- complete ControlMap once at the end (i.e. "Perform.Midi.Convert").
{-# SCC apply_controls #-}
apply_controls :: ControlMap -> PSignal -> PSignal
apply_controls :: ControlMap -> PSignal -> PSignal
apply_controls ControlMap
cmap PSignal
psig = case [(RealTime, Pitch)] -> Maybe (RealTime, Pitch)
forall a. [a] -> Maybe a
Seq.head (PSignal -> [(RealTime, Pitch)]
to_pairs PSignal
psig) of
    Maybe (RealTime, Pitch)
Nothing -> PSignal
forall a. Monoid a => a
mempty
    Just (RealTime
start, Pitch
_) -> RealTime -> PSignal
make1 RealTime
start
    where
    make1 :: RealTime -> PSignal
make1 RealTime
start = [(RealTime, Pitch)] -> PSignal
from_pairs ([(RealTime, Pitch)] -> PSignal) -> [(RealTime, Pitch)] -> PSignal
forall a b. (a -> b) -> a -> b
$ [(RealTime, Pitch)] -> [(RealTime, Pitch)]
forall {a} {b}. Eq a => [(a, b)] -> [(a, b)]
drop1 ([(RealTime, Pitch)] -> [(RealTime, Pitch)])
-> [(RealTime, Pitch)] -> [(RealTime, Pitch)]
forall a b. (a -> b) -> a -> b
$
        ((RealTime, Maybe Pitch, [Y]) -> Maybe (RealTime, Pitch))
-> [(RealTime, Maybe Pitch, [Y])] -> [(RealTime, Pitch)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime, Maybe Pitch, [Y]) -> Maybe (RealTime, Pitch)
forall {b}.
(RealTime, Maybe Pitch, [Y]) -> Maybe (RealTime, RawPitch b)
make ([(RealTime, Maybe Pitch, [Y])] -> [(RealTime, Pitch)])
-> [(RealTime, Maybe Pitch, [Y])] -> [(RealTime, Pitch)]
forall a b. (a -> b) -> a -> b
$ [RealTime]
-> [Maybe Pitch] -> [[Y]] -> [(RealTime, Maybe Pitch, [Y])]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [RealTime]
xs [Maybe Pitch]
pitch_resamples [[Y]]
control_resamples
        where
        -- Discard transpose samples before the pitch starts.  The
        -- Signal.at_after below should ensure there is at most one of these,
        -- plus one for the transition from zero added by
        -- 'Segment.add_zero_transition'.
        make :: (RealTime, Maybe Pitch, [Y]) -> Maybe (RealTime, RawPitch b)
make (RealTime
_, Maybe Pitch
Nothing, [Y]
_) = Maybe (RealTime, RawPitch b)
forall a. Maybe a
Nothing
        make (RealTime
x, Just Pitch
pitch, [Y]
controls) = (RealTime, RawPitch b) -> Maybe (RealTime, RawPitch b)
forall a. a -> Maybe a
Just ((RealTime, RawPitch b) -> Maybe (RealTime, RawPitch b))
-> (RealTime, RawPitch b) -> Maybe (RealTime, RawPitch b)
forall a b. (a -> b) -> a -> b
$ (RealTime
x,) (RawPitch b -> (RealTime, RawPitch b))
-> RawPitch b -> (RealTime, RawPitch b)
forall a b. (a -> b) -> a -> b
$ Transposed -> RawPitch b
forall a b. RawPitch a -> RawPitch b
coerce (Transposed -> RawPitch b) -> Transposed -> RawPitch b
forall a b. (a -> b) -> a -> b
$ ControlValMap -> Pitch -> Transposed
apply ControlValMap
cmap Pitch
pitch
            where
            cmap :: ControlValMap
cmap = [(Control, Y)] -> ControlValMap
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([Control] -> [Y] -> [(Control, Y)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Control]
control_names [Y]
controls)
                ControlValMap -> ControlValMap -> ControlValMap
forall a. Semigroup a => a -> a -> a
<> RealTime -> ControlMap -> ControlValMap
controls_at RealTime
x ControlMap
non_transposers
        control_resamples :: [[Y]]
control_resamples
            | [[Sample Y]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [[Sample Y]]
control_samples = Int -> [Y] -> [[Y]]
forall a. Int -> a -> [a]
replicate ([RealTime] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RealTime]
xs) []
            | Bool
otherwise = [[Y]] -> [[Y]]
forall a. [[a]] -> [[a]]
Seq.rotate ([[Y]] -> [[Y]]) -> [[Y]] -> [[Y]]
forall a b. (a -> b) -> a -> b
$
                ([Sample Y] -> [Y]) -> [[Sample Y]] -> [[Y]]
forall a b. (a -> b) -> [a] -> [b]
map ([RealTime] -> [Sample Y] -> [Y]
Segment.resample_num [RealTime]
xs) [[Sample Y]]
control_samples
        pitch_resamples :: [Maybe Pitch]
pitch_resamples =
            Interpolate Pitch -> [RealTime] -> [Sample Pitch] -> [Maybe Pitch]
forall y. Interpolate y -> [RealTime] -> [Sample y] -> [Maybe y]
Segment.resample_maybe Interpolate Pitch
interpolate [RealTime]
xs ([Sample Pitch] -> [Maybe Pitch])
-> [Sample Pitch] -> [Maybe Pitch]
forall a b. (a -> b) -> a -> b
$ PSignal -> [Sample Pitch]
to_samples PSignal
psig
        control_samples :: [[Sample Y]]
control_samples =
            (Signal ControlSig -> [Sample Y])
-> [Signal ControlSig] -> [[Sample Y]]
forall a b. (a -> b) -> [a] -> [b]
map (Y -> [Sample Y] -> [Sample Y]
forall y. y -> [Sample y] -> [Sample y]
Segment.add_zero_transition Y
0 ([Sample Y] -> [Sample Y])
-> (Signal ControlSig -> [Sample Y])
-> Signal ControlSig
-> [Sample Y]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal ControlSig -> [Sample Y]
forall {k} (kind :: k). Signal kind -> [Sample Y]
Signal.to_samples
                    (Signal ControlSig -> [Sample Y])
-> (Signal ControlSig -> Signal ControlSig)
-> Signal ControlSig
-> [Sample Y]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Signal ControlSig -> Signal ControlSig
forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.drop_before RealTime
start)
                [Signal ControlSig]
control_signals
        (([Control]
control_names, [Signal ControlSig]
control_signals), ControlMap
non_transposers) =
            PSignal
-> ControlMap -> (([Control], [Signal ControlSig]), ControlMap)
unzip_controls PSignal
psig ControlMap
cmap

        xs :: [RealTime]
xs = [[RealTime]] -> [RealTime]
Segment.sample_xs ([RealTime]
pitch_xs [RealTime] -> [[RealTime]] -> [[RealTime]]
forall a. a -> [a] -> [a]
: [[RealTime]]
control_xs)
        pitch_xs :: [RealTime]
pitch_xs = (Sample Pitch -> RealTime) -> [Sample Pitch] -> [RealTime]
forall a b. (a -> b) -> [a] -> [b]
map Sample Pitch -> RealTime
forall y. Sample y -> RealTime
Segment.sx ([Sample Pitch] -> [RealTime]) -> [Sample Pitch] -> [RealTime]
forall a b. (a -> b) -> a -> b
$ PSignal -> [Sample Pitch]
to_samples PSignal
psig
        control_xs :: [[RealTime]]
control_xs = ([Sample Y] -> [RealTime]) -> [[Sample Y]] -> [[RealTime]]
forall a b. (a -> b) -> [a] -> [b]
map ((Sample Y -> RealTime) -> [Sample Y] -> [RealTime]
forall a b. (a -> b) -> [a] -> [b]
map Sample Y -> RealTime
forall y. Sample y -> RealTime
Signal.sx) [[Sample Y]]
control_samples
    -- If the control and pitch starts at the same place, I'll get an extra
    -- pre-transposed pitch.  It's just confusing clutter, especially if the
    -- transpose is invalid, at which point I'm just left with the original
    -- pitch.
    drop1 :: [(a, b)] -> [(a, b)]
drop1 ((a
x1, b
_) : xs :: [(a, b)]
xs@((a
x2, b
_) : [(a, b)]
_)) | a
x1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x2 = [(a, b)]
xs
    drop1 [(a, b)]
xs = [(a, b)]
xs

-- | Separate transposing from non-transposing controls.
--
-- This discards the ScoreT.Type, since 'apply' doesn't use that.  The
-- usual type distinctions like chromatic or diatonic instead get separate
-- controls.
unzip_controls :: PSignal -> ControlMap
    -> (([ScoreT.Control], [Signal.Control]), ControlMap)
unzip_controls :: PSignal
-> ControlMap -> (([Control], [Signal ControlSig]), ControlMap)
unzip_controls PSignal
psig ControlMap
cmap =
    ( ([Typed (Signal ControlSig)] -> [Signal ControlSig])
-> ([Control], [Typed (Signal ControlSig)])
-> ([Control], [Signal ControlSig])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Typed (Signal ControlSig) -> Signal ControlSig)
-> [Typed (Signal ControlSig)] -> [Signal ControlSig]
forall a b. (a -> b) -> [a] -> [b]
map Typed (Signal ControlSig) -> Signal ControlSig
forall a. Typed a -> a
ScoreT.typed_val) ([(Control, Typed (Signal ControlSig))]
-> ([Control], [Typed (Signal ControlSig)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Control, Typed (Signal ControlSig))]
transposers)
    , [(Control, Typed (Signal ControlSig))] -> ControlMap
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [(Control, Typed (Signal ControlSig))]
non_transposers
    )
    where
    ([(Control, Typed (Signal ControlSig))]
transposers, [(Control, Typed (Signal ControlSig))]
non_transposers) =
        ((Control, Typed (Signal ControlSig)) -> Bool)
-> [(Control, Typed (Signal ControlSig))]
-> ([(Control, Typed (Signal ControlSig))],
    [(Control, Typed (Signal ControlSig))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Control -> Set Control -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` PSignal -> Set Control
sig_transposers PSignal
psig) (Control -> Bool)
-> ((Control, Typed (Signal ControlSig)) -> Control)
-> (Control, Typed (Signal ControlSig))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Control, Typed (Signal ControlSig)) -> Control
forall a b. (a, b) -> a
fst) ([(Control, Typed (Signal ControlSig))]
 -> ([(Control, Typed (Signal ControlSig))],
     [(Control, Typed (Signal ControlSig))]))
-> [(Control, Typed (Signal ControlSig))]
-> ([(Control, Typed (Signal ControlSig))],
    [(Control, Typed (Signal ControlSig))])
forall a b. (a -> b) -> a -> b
$
        ControlMap -> [(Control, Typed (Signal ControlSig))]
forall k a. Map k a -> [(k, a)]
Map.toAscList ControlMap
cmap

-- | Not exported, use the one in Derive.Score instead.
controls_at :: RealTime -> ControlMap -> Map ScoreT.Control Signal.Y
controls_at :: RealTime -> ControlMap -> ControlValMap
controls_at RealTime
t = (Typed (Signal ControlSig) -> Y) -> ControlMap -> ControlValMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (RealTime -> Signal ControlSig -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
t (Signal ControlSig -> Y)
-> (Typed (Signal ControlSig) -> Signal ControlSig)
-> Typed (Signal ControlSig)
-> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed (Signal ControlSig) -> Signal ControlSig
forall a. Typed a -> a
ScoreT.typed_val)

-- | 'apply_controls' specialized for a single control.
apply_control :: ScoreT.Control -> ScoreT.Typed Signal.Control
    -> PSignal -> PSignal
apply_control :: Control -> Typed (Signal ControlSig) -> PSignal -> PSignal
apply_control Control
cont Typed (Signal ControlSig)
sig = ControlMap -> PSignal -> PSignal
apply_controls (Control -> Typed (Signal ControlSig) -> ControlMap
forall k a. k -> a -> Map k a
Map.singleton Control
cont Typed (Signal ControlSig)
sig)

-- | Apply an environ to all the pitches in the signal.  Unlike
-- 'apply_controls', this doesn't have to resample the signal.
{-# SCC apply_environ #-}
apply_environ :: DeriveT.Environ -> PSignal -> PSignal
apply_environ :: Environ -> PSignal -> PSignal
apply_environ Environ
env =
    (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal -> PSignal
modify ((SignalS Vector Pitch -> SignalS Vector Pitch)
 -> PSignal -> PSignal)
-> (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal
-> PSignal
forall a b. (a -> b) -> a -> b
$ (Pitch -> Pitch) -> SignalS Vector Pitch -> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
(y -> y) -> SignalS v y -> SignalS v y
Segment.map_y_linear ((Pitch -> Pitch) -> SignalS Vector Pitch -> SignalS Vector Pitch)
-> (Pitch -> Pitch) -> SignalS Vector Pitch -> SignalS Vector Pitch
forall a b. (a -> b) -> a -> b
$ PitchConfig -> Pitch -> Pitch
forall a b. PitchConfig -> RawPitch a -> RawPitch b
apply_config (Environ -> ControlValMap -> PitchConfig
PitchConfig Environ
env ControlValMap
forall a. Monoid a => a
mempty)

map_y_linear :: (Pitch -> Pitch) -> PSignal -> PSignal
map_y_linear :: (Pitch -> Pitch) -> PSignal -> PSignal
map_y_linear = (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal -> PSignal
modify ((SignalS Vector Pitch -> SignalS Vector Pitch)
 -> PSignal -> PSignal)
-> ((Pitch -> Pitch)
    -> SignalS Vector Pitch -> SignalS Vector Pitch)
-> (Pitch -> Pitch)
-> PSignal
-> PSignal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pitch -> Pitch) -> SignalS Vector Pitch -> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
(y -> y) -> SignalS v y -> SignalS v y
Segment.map_y_linear

-- ** hacks

drop_discontinuity_at :: RealTime -> PSignal -> PSignal
drop_discontinuity_at :: RealTime -> PSignal -> PSignal
drop_discontinuity_at RealTime
x = (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal -> PSignal
modify ((SignalS Vector Pitch -> SignalS Vector Pitch)
 -> PSignal -> PSignal)
-> (SignalS Vector Pitch -> SignalS Vector Pitch)
-> PSignal
-> PSignal
forall a b. (a -> b) -> a -> b
$ RealTime -> SignalS Vector Pitch -> SignalS Vector Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> SignalS v y -> SignalS v y
Segment.drop_discontinuity_at RealTime
x


-- * Pitch

-- | This is like pretty for pitch, but just shows the symbolic note name.
symbolic_pitch :: RawPitch a -> Text
symbolic_pitch :: forall a. RawPitch a -> Text
symbolic_pitch = (PitchError -> Text)
-> (Note -> Text) -> Either PitchError Note -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PitchError -> Text
forall a. Show a => a -> Text
showt Note -> Text
Pitch.note_text (Either PitchError Note -> Text)
-> (RawPitch a -> Either PitchError Note) -> RawPitch a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError Note
pitch_note (Transposed -> Either PitchError Note)
-> (RawPitch a -> Transposed)
-> RawPitch a
-> Either PitchError Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPitch a -> Transposed
forall a b. RawPitch a -> RawPitch b
coerce

pitch_scale_id :: RawPitch a -> Pitch.ScaleId
pitch_scale_id :: forall a. RawPitch a -> ScaleId
pitch_scale_id = Scale -> ScaleId
pscale_scale_id (Scale -> ScaleId)
-> (RawPitch a -> Scale) -> RawPitch a -> ScaleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPitch a -> Scale
forall a. RawPitch a -> Scale
pitch_scale

pitch_transposers :: Pitch -> Set ScoreT.Control
pitch_transposers :: Pitch -> Set Control
pitch_transposers = Scale -> Set Control
pscale_transposers (Scale -> Set Control) -> (Pitch -> Scale) -> Pitch -> Set Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Scale
forall a. RawPitch a -> Scale
pitch_scale

pitch_controls :: PitchConfig -> Map ScoreT.Control Signal.Y
pitch_controls :: PitchConfig -> ControlValMap
pitch_controls (PitchConfig Environ
_ ControlValMap
controls) = ControlValMap
controls

-- | Apply a config to a pitch.
apply_config :: PitchConfig -> RawPitch a -> RawPitch b
apply_config :: forall a b. PitchConfig -> RawPitch a -> RawPitch b
apply_config PitchConfig
c RawPitch a
pitch = RawPitch a
pitch { pitch_config :: PitchConfig
pitch_config = PitchConfig
c PitchConfig -> PitchConfig -> PitchConfig
forall a. Semigroup a => a -> a -> a
<> RawPitch a -> PitchConfig
forall a. RawPitch a -> PitchConfig
pitch_config RawPitch a
pitch }

-- | Apply just the controls part of a config to a pitch.
apply :: Map ScoreT.Control Signal.Y -> Pitch -> Transposed
apply :: ControlValMap -> Pitch -> Transposed
apply ControlValMap
controls
    | ControlValMap -> Bool
forall k a. Map k a -> Bool
Map.null ControlValMap
controls = Pitch -> Transposed
forall a b. RawPitch a -> RawPitch b
coerce
    | Bool
otherwise = PitchConfig -> Pitch -> Transposed
forall a b. PitchConfig -> RawPitch a -> RawPitch b
apply_config (Environ -> ControlValMap -> PitchConfig
PitchConfig Environ
forall a. Monoid a => a
mempty ControlValMap
controls)

add_control :: ScoreT.Control -> Double -> RawPitch a -> RawPitch a
add_control :: forall a. Control -> Y -> RawPitch a -> RawPitch a
add_control Control
control Y
val RawPitch a
pitch =
    RawPitch a
pitch { pitch_config :: PitchConfig
pitch_config = PitchConfig
config PitchConfig -> PitchConfig -> PitchConfig
forall a. Semigroup a => a -> a -> a
<> RawPitch a -> PitchConfig
forall a. RawPitch a -> PitchConfig
pitch_config RawPitch a
pitch }
    where config :: PitchConfig
config = Environ -> ControlValMap -> PitchConfig
PitchConfig Environ
forall a. Monoid a => a
mempty (Control -> Y -> ControlValMap
forall k a. k -> a -> Map k a
Map.singleton Control
control Y
val)

-- ** create

-- | Create a Pitch that only emits the given NoteNumber, and doesn't respond
-- to transposition.
constant_pitch :: Pitch.ScaleId -> Pitch.Note -> Pitch.NoteNumber -> Pitch
constant_pitch :: ScaleId -> Note -> NoteNumber -> Pitch
constant_pitch ScaleId
scale_id Note
note NoteNumber
nn =
    Scale
-> (PitchConfig -> Either PitchError NoteNumber)
-> (PitchConfig -> Either PitchError Note)
-> PitchConfig
-> Pitch
pitch (ScaleId -> Set Control -> Scale
Scale ScaleId
scale_id Set Control
forall a. Monoid a => a
mempty) (Either PitchError NoteNumber
-> PitchConfig -> Either PitchError NoteNumber
forall a b. a -> b -> a
const (NoteNumber -> Either PitchError NoteNumber
forall a b. b -> Either a b
Right NoteNumber
nn)) (Either PitchError Note -> PitchConfig -> Either PitchError Note
forall a b. a -> b -> a
const (Note -> Either PitchError Note
forall a b. b -> Either a b
Right Note
note)) PitchConfig
forall a. Monoid a => a
mempty

-- | Like 'constant_pitch', but easier to use, but uses no_scale, which means
-- the result will be unparseable.
nn_pitch :: Pitch.NoteNumber -> Pitch
nn_pitch :: NoteNumber -> Pitch
nn_pitch NoteNumber
nn =
    Scale
-> (PitchConfig -> Either PitchError NoteNumber)
-> (PitchConfig -> Either PitchError Note)
-> PitchConfig
-> Pitch
pitch Scale
no_scale (Either PitchError NoteNumber
-> PitchConfig -> Either PitchError NoteNumber
forall a b. a -> b -> a
const (NoteNumber -> Either PitchError NoteNumber
forall a b. b -> Either a b
Right NoteNumber
nn)) (Either PitchError Note -> PitchConfig -> Either PitchError Note
forall a b. a -> b -> a
const (Note -> Either PitchError Note
forall a b. b -> Either a b
Right (Text -> Note
Pitch.Note (NoteNumber -> Text
forall a. Pretty a => a -> Text
pretty NoteNumber
nn))))
        PitchConfig
forall a. Monoid a => a
mempty