-- Copyright 2014 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-process notes to add artifacts characteristic of wind instruments.
module Derive.C.Idiom.Wind (library, find_harmonic) where
import qualified Util.Lists as Lists
import qualified Derive.Args as Args
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Score as Score
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream

import qualified Perform.Pitch as Pitch

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
    [ (Symbol
"wind-idiom", Transformer Note
c_wind_idiom)
    ]

module_ :: Module.Module
module_ :: Module
module_ = Module
"idiom" forall a. Semigroup a => a -> a -> a
<> Module
"wind"

c_wind_idiom :: Derive.Transformer Derive.Note
c_wind_idiom :: Transformer Note
c_wind_idiom = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"wind-idiom"
    (Tags
Tags.postproc forall a. Semigroup a => a -> a -> a
<> Tags
Tags.inst)
    Doc
"Post-process events to play in a monophonic wind-like idiom.\
    \\nThis tweaks the ends of the pitch signals of notes depending on the\
    \ following note.  When a note is played, a (fundamental, harmonic) pair\
    \ is chosen that best fits it.  When a subsequent note is played, a new\
    \ pair is chosen for it.\
    \\nThe decay of the note will be shifted to the corresponding harmonic\
    \ of the the fundamental of the subsequent note.  If the fundamentals are\
    \ the same then the pitch will remain constant, of course."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser [Either NoteNumber Pitch]
fundamentals_env forall a b. (a -> b) -> a -> b
$ \[Either NoteNumber Pitch]
fundamentals PassedArgs Note
args Deriver (Stream Note)
deriver -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        [NoteNumber]
fundamentals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
            (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. Monad m => a -> m a
return (Transposed -> Deriver State Error NoteNumber
Pitches.pitch_nn forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start))
            [Either NoteNumber Pitch]
fundamentals
        Fundamentals -> Stream Note -> Deriver (Stream Note)
wind_idiom (forall a b. (a -> b) -> [a] -> [b]
map NoteNumber -> Hz
Pitch.nn_to_hz [NoteNumber]
fundamentals) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver (Stream Note)
deriver

type Fundamentals = [Pitch.Hz]

wind_idiom :: Fundamentals -> Stream.Stream Score.Event -> Derive.NoteDeriver
wind_idiom :: Fundamentals -> Stream Note -> Deriver (Stream Note)
wind_idiom Fundamentals
fundamentals = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Fundamentals -> (Maybe Note, Note) -> Note
process Fundamentals
fundamentals)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ([a] -> [b]) -> Stream a -> Stream (b, a)
Stream.zip_on (forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
Post.nexts)

fundamentals_env :: Sig.Parser [Either Pitch.NoteNumber PSignal.Pitch]
fundamentals_env :: Parser [Either NoteNumber Pitch]
fundamentals_env = forall a. (a -> Maybe Text) -> Parser a -> Parser a
Sig.check forall {t :: * -> *} {a} {a}.
(Foldable t, IsString a) =>
t a -> Maybe a
non_empty forall a b. (a -> b) -> a -> b
$
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"fundamentals" EnvironDefault
Sig.Unprefixed ([] :: [Pitch.NoteNumber])
        Doc
"Fundamentals for this instrument."
    where
    non_empty :: t a -> Maybe a
non_empty t a
xs
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
xs = forall a. a -> Maybe a
Just a
"fundamentals required"
        | Bool
otherwise = forall a. Maybe a
Nothing

-- | On each event, find the closest (fundamental, harmonic) for this pitch and
-- the next event's pitch.  On the next note's start time, shift the pitch to
-- same harmonic on the next note's fundamental.
process :: Fundamentals -> (Maybe Score.Event, Score.Event) -> Score.Event
process :: Fundamentals -> (Maybe Note, Note) -> Note
process Fundamentals
fundamentals (Maybe Note
maybe_next, Note
event) = forall a. a -> Maybe a -> a
fromMaybe Note
event forall a b. (a -> b) -> a -> b
$ do
    Note
next <- Maybe Note
maybe_next
    (Hz
next_fundamental, Int
_) <- Fundamentals -> Note -> Maybe (Hz, Int)
harmonic_of Fundamentals
fundamentals Note
next
    (Hz
_, Int
this_harmonic) <- Fundamentals -> Note -> Maybe (Hz, Int)
harmonic_of Fundamentals
fundamentals Note
event
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> Hz -> Note -> Note
tweak_pitch (Note -> RealTime
Score.event_start Note
next)
        (Hz
next_fundamental Hz -> Int -> Hz
*# Int
this_harmonic) Note
event

harmonic_of :: Fundamentals -> Score.Event -> Maybe (Pitch.Hz, Int)
harmonic_of :: Fundamentals -> Note -> Maybe (Hz, Int)
harmonic_of Fundamentals
fundamentals =
    Fundamentals -> Hz -> Maybe (Hz, Int)
find_harmonic Fundamentals
fundamentals forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteNumber -> Hz
Pitch.nn_to_hz forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Note -> Maybe NoteNumber
Score.initial_nn

find_harmonic :: Fundamentals -> Pitch.Hz -> Maybe (Pitch.Hz, Int)
find_harmonic :: Fundamentals -> Hz -> Maybe (Hz, Int)
find_harmonic Fundamentals
fundamentals Hz
hz = forall {b}. [(Hz, b)] -> Maybe b
closest forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Hz -> (Hz, (Hz, Int))
find Fundamentals
fundamentals
    where
    -- I always pick the closest match, but I also want a lower harmonic.
    -- Hopefully this doesn't matter in practice, since fundamentals generally
    -- aren't multiples of each other.
    closest :: [(Hz, b)] -> Maybe b
closest = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn (forall a. Num a => a -> a
abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
    find :: Hz -> (Hz, (Hz, Int))
find Hz
f = Int -> (Hz, (Hz, Int))
go Int
1
        where
        go :: Int -> (Hz, (Hz, Int))
go Int
harm
            | Hz
f Hz -> Int -> Hz
*# (Int
harmforall a. Num a => a -> a -> a
+Int
1) forall a. Num a => a -> a -> a
- Hz
eta forall a. Num a => a -> a -> a
* (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
harm forall a. Num a => a -> a -> a
+ Hz
1) forall a. Ord a => a -> a -> Bool
> Hz
hz =
                (Hz
hz forall a. Num a => a -> a -> a
- Hz
f Hz -> Int -> Hz
*# Int
harm, (Hz
f, Int
harm))
            | Bool
otherwise = Int -> (Hz, (Hz, Int))
go (Int
harmforall a. Num a => a -> a -> a
+Int
1)
    -- Hz is a little imprecise, so while I want to pick the closest harmonic
    -- below 'hz', I can pick one above if it's only a little above.  Also, any
    -- imprecision in the original fundamental will be multiplied with the
    -- harmonic, so I can multiply the eta too.
    eta :: Hz
eta = Hz
0.25

-- | Hz raised to the nth harmonic.
(*#) :: Pitch.Hz -> Int -> Pitch.Hz
Hz
fundamental *# :: Hz -> Int -> Hz
*# Int
harmonic = Hz
fundamental forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
harmonic

tweak_pitch :: RealTime -> Pitch.Hz -> Score.Event -> Score.Event
tweak_pitch :: RealTime -> Hz -> Note -> Note
tweak_pitch RealTime
pos Hz
hz Note
event =
    PSignal -> Note -> Note
Score.set_pitch (Note -> PSignal
Score.event_pitch Note
event forall a. Semigroup a => a -> a -> a
<> PSignal
tweak) Note
event
    where tweak :: PSignal
tweak = RealTime -> Pitch -> PSignal
PSignal.from_sample RealTime
pos (NoteNumber -> Pitch
PSignal.nn_pitch (Hz -> NoteNumber
Pitch.hz_to_nn Hz
hz))