-- 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
    , constant_val
    , prepend
    , ErrorText
    , 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.Lists as Lists
import qualified Util.Segment as Segment
import           Util.Segment (Sample(..))

import qualified Derive.DeriveT as DeriveT
import           Derive.DeriveT
    (PSignal(..), Pitch, PitchConfig(..), PitchError(..), RawPitch(..),
     Scale(..), Transposed, _signal, coerce, interpolate, pitch, pitch_nn,
     pitch_note)
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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Scale
sig_scale

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

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

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

-- * construct / destruct

from_pairs :: [(RealTime, Pitch)] -> PSignal
from_pairs :: [(RealTime, Pitch)] -> PSignal
from_pairs = Boxed Pitch -> PSignal
PSignal forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = Boxed Pitch -> PSignal
PSignal forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (v :: * -> *) y.
Vector v (Sample y) =>
SignalS v y -> [(RealTime, y)]
Segment.to_pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Boxed Pitch
_signal

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

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

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

constant_val :: PSignal -> Maybe Pitch
constant_val :: PSignal -> Maybe Pitch
constant_val = forall (v :: * -> *) a.
Vector v (Sample a) =>
SignalS v a -> Maybe a
Segment.constant_val forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Boxed Pitch
_signal

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

type ErrorText = Text

-- | Flatten a signal to a non-transposeable Signal.NoteNumber.
-- TODO I could probably avoid the intermediate list
to_nn :: PSignal -> (Signal.NoteNumber, [(RealTime, ErrorText)])
to_nn :: PSignal -> (NoteNumber, [(RealTime, ErrorText)])
to_nn = forall {k} {a} {kind :: k}.
Ord a =>
([a], [(RealTime, Y)]) -> (Signal kind, [a])
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (a, RawPitch a) -> Either (a, ErrorText) (a, Y)
eval 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) = (forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs [(RealTime, Y)]
nns, forall a. Ord a => [a] -> [a]
Lists.uniqueSort [a]
errs)
    eval :: (a, RawPitch a) -> Either (a, ErrorText) (a, Y)
eval (a
x, RawPitch a
pitch) = case Transposed -> Either PitchError NoteNumber
pitch_nn (forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
pitch) of
        Left PitchError
err -> forall a b. a -> Either a b
Left (a
x, forall a. RawPitch a -> PitchError -> ErrorText
DeriveT.detailed_error RawPitch a
pitch PitchError
err)
        Right (Pitch.NoteNumber Y
nn) -> 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 = Boxed Pitch -> PSignal
PSignal forall a b. (a -> b) -> a -> b
$ 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 = forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Bool
Segment.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Boxed Pitch
_signal

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

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

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

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


-- * transform

drop_after, drop_before :: RealTime -> PSignal -> PSignal
drop_after :: RealTime -> PSignal -> PSignal
drop_after RealTime
x = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal
modify forall a b. (a -> b) -> a -> b
$ 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 = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal
modify forall a b. (a -> b) -> a -> b
$ 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 = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal
modify forall a b. (a -> b) -> a -> b
$ 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 = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal
modify forall a b. (a -> b) -> a -> b
$ 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 = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal
modify (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 forall a. [a] -> Maybe a
Lists.head (PSignal -> [(RealTime, Pitch)]
to_pairs PSignal
psig) of
    Maybe (RealTime, Pitch)
Nothing -> 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 forall a b. (a -> b) -> a -> b
$ forall {a} {b}. Eq a => [(a, b)] -> [(a, b)]
drop1 forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b}.
(RealTime, Maybe Pitch, [Y]) -> Maybe (RealTime, RawPitch b)
make forall a b. (a -> b) -> a -> b
$ 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]
_) = forall a. Maybe a
Nothing
        make (RealTime
x, Just Pitch
pitch, [Y]
controls) =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (RealTime
x,) forall a b. (a -> b) -> a -> b
$ forall a b. RawPitch a -> RawPitch b
coerce forall a b. (a -> b) -> a -> b
$ ControlValMap -> Pitch -> Transposed
apply ControlValMap
cmap2 Pitch
pitch
            where
            cmap2 :: ControlValMap
cmap2 = forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList (forall a b. [a] -> [b] -> [(a, b)]
zip [Control]
control_names [Y]
controls)
                forall a. Semigroup a => a -> a -> a
<> RealTime -> ControlMap -> ControlValMap
controls_at RealTime
x ControlMap
non_transposers
        control_resamples :: [[Y]]
control_resamples
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null [[Sample Y]]
control_samples = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [RealTime]
xs) []
            | Bool
otherwise = forall a. [[a]] -> [[a]]
Lists.rotate forall a b. (a -> b) -> a -> b
$
                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 =
            forall y. Interpolate y -> [RealTime] -> [Sample y] -> [Maybe y]
Segment.resample_maybe Interpolate Pitch
interpolate [RealTime]
xs forall a b. (a -> b) -> a -> b
$ PSignal -> [Sample Pitch]
to_samples PSignal
psig
        control_samples :: [[Sample Y]]
control_samples =
            forall a b. (a -> b) -> [a] -> [b]
map (forall y. y -> [Sample y] -> [Sample y]
Segment.add_zero_transition Y
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Signal kind -> [Sample Y]
Signal.to_samples
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. a -> [a] -> [a]
: [[RealTime]]
control_xs)
        pitch_xs :: [RealTime]
pitch_xs = forall a b. (a -> b) -> [a] -> [b]
map forall y. Sample y -> RealTime
Segment.sx forall a b. (a -> b) -> a -> b
$ PSignal -> [Sample Pitch]
to_samples PSignal
psig
        control_xs :: [[RealTime]]
control_xs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map 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 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 =
    ( 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. Typed a -> a
ScoreT.val_of) (forall a b. [(a, b)] -> ([a], [b])
unzip [(Control, Typed (Signal ControlSig))]
transposers)
    , 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) =
        forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((forall a. Ord a => a -> Set a -> Bool
`Set.member` PSignal -> Set Control
sig_transposers PSignal
psig) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
        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 = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((forall {k} (kind :: k). Signal kind -> RealTime -> Y
`Signal.at` RealTime
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typed a -> a
ScoreT.val_of)

-- | '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 (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 =
    (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal
modify forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) y.
Vector v (Sample y) =>
(y -> y) -> SignalS v y -> SignalS v y
Segment.map_y_linear forall a b. (a -> b) -> a -> b
$ forall a b. PitchConfig -> RawPitch a -> RawPitch b
apply_config (Environ -> ControlValMap -> PitchConfig
PitchConfig Environ
env forall a. Monoid a => a
mempty)

map_y_linear :: (Pitch -> Pitch) -> PSignal -> PSignal
map_y_linear :: (Pitch -> Pitch) -> PSignal -> PSignal
map_y_linear = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal
modify forall a b. (a -> b) -> a -> b
$ 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 -> ErrorText
symbolic_pitch = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Show a => a -> ErrorText
showt Note -> ErrorText
Pitch.note_text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError Note
pitch_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Semigroup a => a -> a -> a
<> 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
    | forall k a. Map k a -> Bool
Map.null ControlValMap
controls = forall a b. RawPitch a -> RawPitch b
coerce
    | Bool
otherwise = forall a b. PitchConfig -> RawPitch a -> RawPitch b
apply_config (Environ -> ControlValMap -> PitchConfig
PitchConfig 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 forall a. Semigroup a => a -> a -> a
<> forall a. RawPitch a -> PitchConfig
pitch_config RawPitch a
pitch }
    where config :: PitchConfig
config = Environ -> ControlValMap -> PitchConfig
PitchConfig forall a. Monoid a => a
mempty (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 forall a. Monoid a => a
mempty) (forall a b. a -> b -> a
const (forall a b. b -> Either a b
Right NoteNumber
nn)) (forall a b. a -> b -> a
const (forall a b. b -> Either a b
Right Note
note)) 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 (forall a b. a -> b -> a
const (forall a b. b -> Either a b
Right NoteNumber
nn)) (forall a b. a -> b -> a
const (forall a b. b -> Either a b
Right (ErrorText -> Note
Pitch.Note (forall a. Pretty a => a -> ErrorText
pretty NoteNumber
nn))))
        forall a. Monoid a => a
mempty