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

-- | General utilities for sampler patches.
module Synth.Sampler.Patch.Lib.Util where
import qualified Control.Monad.Except as Except
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified GHC.Stack as Stack

import qualified Util.Maps as Maps
import qualified Util.Num as Num
import qualified Util.Seq as Seq

import qualified Cmd.Instrument.CUtil as CUtil
import qualified Cmd.Instrument.ImInst as ImInst
import qualified Derive.Attrs as Attrs
import qualified Instrument.Common as Common
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Synth.Sampler.Patch as Patch
import qualified Synth.Sampler.Sample as Sample
import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Note as Note
import qualified Synth.Shared.Thru as Thru
import qualified Synth.Shared.Signal as Signal

import           Global


-- * preprocess

nextsBy :: Eq key => (a -> key) -> [a] -> [(a, [a])]
nextsBy :: forall key a. Eq key => (a -> key) -> [a] -> [(a, [a])]
nextsBy a -> key
key [a]
xs = (a -> [a] -> (a, [a])) -> [a] -> [[a]] -> [(a, [a])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> [a] -> (a, [a])
extract [a]
xs (Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
drop Int
1 ([a] -> [[a]]
forall a. [a] -> [[a]]
List.tails [a]
xs))
    where extract :: a -> [a] -> (a, [a])
extract a
x [a]
xs = (a
x, (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
x) (key -> Bool) -> (a -> key) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> key
key) [a]
xs)

nexts :: [a] -> [(a, [a])]
nexts :: forall a. [a] -> [(a, [a])]
nexts [a]
xs = [a] -> [[a]] -> [(a, [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs (Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
drop Int
1 ([a] -> [[a]]
forall a. [a] -> [[a]]
List.tails [a]
xs))


-- * convert

-- ** pitch

symbolicPitch :: Except.MonadError Text m => Note.Note
    -> m (Either Pitch.Note Pitch.NoteNumber)
symbolicPitch :: forall (m :: * -> *).
MonadError Error m =>
Note -> m (Either Note NoteNumber)
symbolicPitch Note
note
    | Error -> Bool
Text.null (Note -> Error
Note.element Note
note) = NoteNumber -> Either Note NoteNumber
forall a b. b -> Either a b
Right (NoteNumber -> Either Note NoteNumber)
-> m NoteNumber -> m (Either Note NoteNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Note -> m NoteNumber
forall (m :: * -> *). MonadError Error m => Note -> m NoteNumber
initialPitch Note
note
    | Bool
otherwise = Either Note NoteNumber -> m (Either Note NoteNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Note NoteNumber -> m (Either Note NoteNumber))
-> Either Note NoteNumber -> m (Either Note NoteNumber)
forall a b. (a -> b) -> a -> b
$ Note -> Either Note NoteNumber
forall a b. a -> Either a b
Left (Note -> Either Note NoteNumber) -> Note -> Either Note NoteNumber
forall a b. (a -> b) -> a -> b
$ Error -> Note
Pitch.Note (Error -> Note) -> Error -> Note
forall a b. (a -> b) -> a -> b
$ Note -> Error
Note.element Note
note

initialPitch :: Except.MonadError Text m => Note.Note -> m Pitch.NoteNumber
initialPitch :: forall (m :: * -> *). MonadError Error m => Note -> m NoteNumber
initialPitch = Error -> Maybe NoteNumber -> m NoteNumber
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust Error
"no pitch" (Maybe NoteNumber -> m NoteNumber)
-> (Note -> Maybe NoteNumber) -> Note -> m NoteNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Maybe NoteNumber
Note.initialPitch

-- | Find a value (presumably a FileName) and pitch ratio for a simple patch
-- with a static NoteNumber mapping.
findPitchRatio :: Map Pitch.NoteNumber a -> Pitch.NoteNumber -> (a, Signal.Y)
findPitchRatio :: forall a. Map NoteNumber a -> NoteNumber -> (a, Y)
findPitchRatio Map NoteNumber a
nnToSample NoteNumber
nn = (a
fname, NoteNumber -> NoteNumber -> Y
Sample.pitchToRatio NoteNumber
sampleNn NoteNumber
nn)
    where
    (NoteNumber
sampleNn, a
fname) = (NoteNumber, a) -> Maybe (NoteNumber, a) -> (NoteNumber, a)
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> (NoteNumber, a)
forall a. HasCallStack => [Char] -> a
error [Char]
"findPitch: empty nnToSample") (Maybe (NoteNumber, a) -> (NoteNumber, a))
-> Maybe (NoteNumber, a) -> (NoteNumber, a)
forall a b. (a -> b) -> a -> b
$
        NoteNumber -> Map NoteNumber a -> Maybe (NoteNumber, a)
forall k v. (Ord k, Num k) => k -> Map k v -> Maybe (k, v)
Maps.lookupClosest NoteNumber
nn Map NoteNumber a
nnToSample

-- ** articulation

articulation :: Except.MonadError Text m => Common.AttributeMap a
    -> Attrs.Attributes -> m a
articulation :: forall (m :: * -> *) a.
MonadError Error m =>
AttributeMap a -> Attributes -> m a
articulation AttributeMap a
attributeMap Attributes
attrs =
    m a -> ((Attributes, a) -> m a) -> Maybe (Attributes, a) -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError (Error -> m a) -> Error -> m a
forall a b. (a -> b) -> a -> b
$ Error
"attributes not found: " Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Attributes -> Error
forall a. Pretty a => a -> Error
pretty Attributes
attrs)
        (a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> ((Attributes, a) -> a) -> (Attributes, a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes, a) -> a
forall a b. (a, b) -> b
snd) (Maybe (Attributes, a) -> m a) -> Maybe (Attributes, a) -> m a
forall a b. (a -> b) -> a -> b
$
    Attributes -> AttributeMap a -> Maybe (Attributes, a)
forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
Common.lookup_attributes Attributes
attrs AttributeMap a
attributeMap

articulationDefault :: a -> Common.AttributeMap a -> Attrs.Attributes -> a
articulationDefault :: forall a. a -> AttributeMap a -> Attributes -> a
articulationDefault a
deflt AttributeMap a
attributeMap  =
    a -> ((Attributes, a) -> a) -> Maybe (Attributes, a) -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
deflt (Attributes, a) -> a
forall a b. (a, b) -> b
snd (Maybe (Attributes, a) -> a)
-> (Attributes -> Maybe (Attributes, a)) -> Attributes -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes -> AttributeMap a -> Maybe (Attributes, a)
forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
`Common.lookup_attributes` AttributeMap a
attributeMap)

-- ** dynamic

-- | Standard dynamic ranges.
data Dynamic = PP | MP | MF | FF
    deriving (Dynamic -> Dynamic -> Bool
(Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Bool) -> Eq Dynamic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dynamic -> Dynamic -> Bool
$c/= :: Dynamic -> Dynamic -> Bool
== :: Dynamic -> Dynamic -> Bool
$c== :: Dynamic -> Dynamic -> Bool
Eq, Eq Dynamic
Eq Dynamic
-> (Dynamic -> Dynamic -> Ordering)
-> (Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Dynamic)
-> (Dynamic -> Dynamic -> Dynamic)
-> Ord Dynamic
Dynamic -> Dynamic -> Bool
Dynamic -> Dynamic -> Ordering
Dynamic -> Dynamic -> Dynamic
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Dynamic -> Dynamic -> Dynamic
$cmin :: Dynamic -> Dynamic -> Dynamic
max :: Dynamic -> Dynamic -> Dynamic
$cmax :: Dynamic -> Dynamic -> Dynamic
>= :: Dynamic -> Dynamic -> Bool
$c>= :: Dynamic -> Dynamic -> Bool
> :: Dynamic -> Dynamic -> Bool
$c> :: Dynamic -> Dynamic -> Bool
<= :: Dynamic -> Dynamic -> Bool
$c<= :: Dynamic -> Dynamic -> Bool
< :: Dynamic -> Dynamic -> Bool
$c< :: Dynamic -> Dynamic -> Bool
compare :: Dynamic -> Dynamic -> Ordering
$ccompare :: Dynamic -> Dynamic -> Ordering
Ord, Int -> Dynamic -> ShowS
[Dynamic] -> ShowS
Dynamic -> [Char]
(Int -> Dynamic -> ShowS)
-> (Dynamic -> [Char]) -> ([Dynamic] -> ShowS) -> Show Dynamic
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Dynamic] -> ShowS
$cshowList :: [Dynamic] -> ShowS
show :: Dynamic -> [Char]
$cshow :: Dynamic -> [Char]
showsPrec :: Int -> Dynamic -> ShowS
$cshowsPrec :: Int -> Dynamic -> ShowS
Show, ReadPrec [Dynamic]
ReadPrec Dynamic
Int -> ReadS Dynamic
ReadS [Dynamic]
(Int -> ReadS Dynamic)
-> ReadS [Dynamic]
-> ReadPrec Dynamic
-> ReadPrec [Dynamic]
-> Read Dynamic
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Dynamic]
$creadListPrec :: ReadPrec [Dynamic]
readPrec :: ReadPrec Dynamic
$creadPrec :: ReadPrec Dynamic
readList :: ReadS [Dynamic]
$creadList :: ReadS [Dynamic]
readsPrec :: Int -> ReadS Dynamic
$creadsPrec :: Int -> ReadS Dynamic
Read, Dynamic
Dynamic -> Dynamic -> Bounded Dynamic
forall a. a -> a -> Bounded a
maxBound :: Dynamic
$cmaxBound :: Dynamic
minBound :: Dynamic
$cminBound :: Dynamic
Bounded, Int -> Dynamic
Dynamic -> Int
Dynamic -> [Dynamic]
Dynamic -> Dynamic
Dynamic -> Dynamic -> [Dynamic]
Dynamic -> Dynamic -> Dynamic -> [Dynamic]
(Dynamic -> Dynamic)
-> (Dynamic -> Dynamic)
-> (Int -> Dynamic)
-> (Dynamic -> Int)
-> (Dynamic -> [Dynamic])
-> (Dynamic -> Dynamic -> [Dynamic])
-> (Dynamic -> Dynamic -> [Dynamic])
-> (Dynamic -> Dynamic -> Dynamic -> [Dynamic])
-> Enum Dynamic
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Dynamic -> Dynamic -> Dynamic -> [Dynamic]
$cenumFromThenTo :: Dynamic -> Dynamic -> Dynamic -> [Dynamic]
enumFromTo :: Dynamic -> Dynamic -> [Dynamic]
$cenumFromTo :: Dynamic -> Dynamic -> [Dynamic]
enumFromThen :: Dynamic -> Dynamic -> [Dynamic]
$cenumFromThen :: Dynamic -> Dynamic -> [Dynamic]
enumFrom :: Dynamic -> [Dynamic]
$cenumFrom :: Dynamic -> [Dynamic]
fromEnum :: Dynamic -> Int
$cfromEnum :: Dynamic -> Int
toEnum :: Int -> Dynamic
$ctoEnum :: Int -> Dynamic
pred :: Dynamic -> Dynamic
$cpred :: Dynamic -> Dynamic
succ :: Dynamic -> Dynamic
$csucc :: Dynamic -> Dynamic
Enum)
instance Pretty Dynamic where pretty :: Dynamic -> Error
pretty = Dynamic -> Error
forall a. Show a => a -> Error
showt

-- | Get patch-specific dyn category, and note dynamic.
dynamic :: (Bounded dyn, Enum dyn) => (dyn -> (Int, Int))
    -- ^ Returns velocity instead of dyn, and the lower bound is unnecessary,
    -- for compatibility.
    -> Signal.Y
    -- ^ Min dyn.  This is for normalized samples, where 0 gets this dyn.
    -> Note.Note -> (dyn, Signal.Y)
dynamic :: forall dyn.
(Bounded dyn, Enum dyn) =>
(dyn -> (Int, Int)) -> Y -> Note -> (dyn, Y)
dynamic dyn -> (Int, Int)
dynToRange Y
minDyn Note
note =
    ( (dyn, Y) -> dyn
forall a b. (a, b) -> a
fst ((dyn, Y) -> dyn) -> (dyn, Y) -> dyn
forall a b. (a -> b) -> a -> b
$ (dyn -> Y) -> Y -> (dyn, Y)
forall dyn. (Bounded dyn, Enum dyn) => (dyn -> Y) -> Y -> (dyn, Y)
findDynamic (Int -> Y
velToDyn (Int -> Y) -> (dyn -> Int) -> dyn -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (dyn -> (Int, Int)) -> dyn -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. dyn -> (Int, Int)
dynToRange) Y
dyn
    , Y -> Y -> Y -> Y
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Y
minDyn Y
1 Y
dyn
    )
    where dyn :: Y
dyn = Control -> Note -> Y
Note.initial0 Control
Control.dynamic Note
note

-- | Convert to (Dynamic, DistanceFromPrevDynamic)
findDynamic :: (Bounded dyn, Enum dyn) => (dyn -> Signal.Y)
    -> Signal.Y -> (dyn, Signal.Y)
findDynamic :: forall dyn. (Bounded dyn, Enum dyn) => (dyn -> Y) -> Y -> (dyn, Y)
findDynamic dyn -> Y
dynToRange Y
dyn = Y -> Y -> [(Y, dyn)] -> (dyn, Y)
forall {t} {a}.
(Ord t, Fractional t) =>
t -> t -> [(t, a)] -> (a, t)
find Y
0 Y
dyn [(Y, dyn)]
rangeDynamics
    where
    find :: t -> t -> [(t, a)] -> (a, t)
find t
low t
val ((t
high, a
dyn) : [(t, a)]
rest)
        | [(t, a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(t, a)]
rest Bool -> Bool -> Bool
|| t
val t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
high = (a
dyn, t -> t -> t -> t
forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize t
low t
high t
val)
        | Bool
otherwise = t -> t -> [(t, a)] -> (a, t)
find t
high t
val [(t, a)]
rest
    find t
_ t
_ [] = [Char] -> (a, t)
forall a. HasCallStack => [Char] -> a
error [Char]
"empty rangeDynamics"
    rangeDynamics :: [(Y, dyn)]
rangeDynamics = (dyn -> Y) -> [dyn] -> [(Y, dyn)]
forall a k. (a -> k) -> [a] -> [(k, a)]
Seq.key_on dyn -> Y
dynToRange [dyn]
forall a. (Enum a, Bounded a) => [a]
enumAll

type Variation = Int

variation :: Variation -> Note.Note -> Variation
variation :: Int -> Note -> Int
variation Int
variations = Y -> Int
forall {a} {b}. (RealFrac a, Integral b) => a -> b
pick (Y -> Int) -> (Note -> Y) -> Note -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Note -> Y
Note.initial0 Control
Control.variation
    where pick :: a -> b
pick a
var = a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a
var a -> a -> a
forall a. Num a => a -> a -> a
* Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
variations Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

chooseVariation :: [a] -> Note.Note -> a
chooseVariation :: forall a. [a] -> Note -> a
chooseVariation [a]
as = [a] -> Y -> a
forall a. [a] -> Y -> a
pickVariation [a]
as (Y -> a) -> (Note -> Y) -> Note -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Note -> Y
Note.initial0 Control
Control.variation

pickVariation :: [a] -> Double -> a
pickVariation :: forall a. [a] -> Y -> a
pickVariation [a]
as Y
var =
    [a]
as [a] -> Int -> a
forall a. [a] -> Int -> a
!! Y -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Y -> Y -> Y -> Y
forall a. Ord a => a -> a -> a -> a
Num.clamp Y
0 Y
1 Y
var Y -> Y -> Y
forall a. Num a => a -> a -> a
* Int -> Y
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

-- | Pick from a list of dynamic variations.
pickDynamicVariation :: Double -> [a] -> Double -> Double -> a
pickDynamicVariation :: forall a. Y -> [a] -> Y -> Y -> a
pickDynamicVariation Y
variationRange [a]
samples Y
dyn Y
var =
    [a] -> Y -> a
forall a. [a] -> Y -> a
pickVariation [a]
samples (Y -> Y -> Y -> Y
forall a. Ord a => a -> a -> a -> a
Num.clamp Y
0 Y
1 (Y
dyn Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
var Y -> Y -> Y
forall a. Num a => a -> a -> a
* Y
variationRange))

-- | Scale dynamic for non-normalized samples, recorded with few dynamic
-- levels.  Since each sample already has its own dynamic level, if I do no
-- scaling, then there will be noticeable bumps as the dynamic thresholds
-- are crossed.  So I scale the dynamics of each one by an adjustment to smooth
-- the bumps.  But the result will be more bumpy if each sample covers a
-- different width of dynamic range, so I also scale the adjustment by
-- that width.
--
-- TODO I think it doesn't actually work though, I need to adjust manually
-- per-sample.
dynamicAutoScale :: (Signal.Y, Signal.Y) -> (Signal.Y, Signal.Y) -> Signal.Y
    -> Signal.Y
dynamicAutoScale :: (Y, Y) -> (Y, Y) -> Y -> Y
dynamicAutoScale (Y
minDyn, Y
maxDyn) (Y
low, Y
high) Y
dyn =
    Y -> Y -> Y -> Y
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Y
minDyn Y
maxDyn Y
biased
    where
    -- dyn should be in the (low, high) range already.
    pos :: Y
pos = Y -> Y -> Y -> Y
forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize Y
low Y
high Y
dyn
    -- bias the position toward the middle of the dyn range, depending on
    -- the dynamic width allocated to the sample.
    biased :: Y
biased = Y -> Y -> Y -> Y
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Y
0.5 Y
pos (Y
high Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
low)

dynToVel :: Signal.Y -> Int
dynToVel :: Y -> Int
dynToVel = Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
Num.clamp Int
1 Int
127 (Int -> Int) -> (Y -> Int) -> Y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Y -> Int) -> (Y -> Y) -> Y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Y -> Y -> Y
forall a. Num a => a -> a -> a
*Y
127)

velToDyn :: Int -> Signal.Y
velToDyn :: Int -> Y
velToDyn = (Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/Y
127) (Y -> Y) -> (Int -> Y) -> Int -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Y
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- ** envelope

dynEnvelope :: Signal.Y -> RealTime.RealTime -> Note.Note -> Signal.Signal
dynEnvelope :: Y -> X -> Note -> Signal
dynEnvelope Y
minDyn X
releaseTime Note
note =
    Signal
env Signal -> Signal -> Signal
forall a. Semigroup a => a -> a -> a
<> [(X, Y)] -> Signal
forall {k} (kind :: k). [(X, Y)] -> Signal kind
Signal.from_pairs [(X
end, X -> Signal -> Y
forall {k} (kind :: k). X -> Signal kind -> Y
Signal.at X
end Signal
env), (X
end X -> X -> X
forall a. Num a => a -> a -> a
+ X
releaseTime, Y
0)]
    where
    end :: X
end = Note -> X
Note.end Note
note
    env :: Signal
env = Y -> Signal -> Signal
forall {k} (kind :: k). Y -> Signal kind -> Signal kind
Signal.scalar_scale Y
minDyn (Signal -> Signal) -> Signal -> Signal
forall a b. (a -> b) -> a -> b
$
        X -> Signal -> Signal
forall {k} (kind :: k). X -> Signal kind -> Signal kind
Signal.drop_before (Note -> X
Note.start Note
note) (Signal -> Signal) -> Signal -> Signal
forall a b. (a -> b) -> a -> b
$
        X -> Signal -> Signal
forall {k} (kind :: k). X -> Signal kind -> Signal kind
Signal.clip_after (Note -> X
Note.end Note
note) (Signal -> Signal) -> Signal -> Signal
forall a b. (a -> b) -> a -> b
$
        Signal -> Control -> Map Control Signal -> Signal
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Signal
forall a. Monoid a => a
mempty Control
Control.dynamic (Map Control Signal -> Signal) -> Map Control Signal -> Signal
forall a b. (a -> b) -> a -> b
$
        Note -> Map Control Signal
Note.controls Note
note

-- | Simple sustain-release envelope.
sustainRelease :: Signal.Y -> RealTime.RealTime -> Note.Note -> Signal.Signal
sustainRelease :: Y -> X -> Note -> Signal
sustainRelease Y
sustain X
releaseTime Note
note = [(X, Y)] -> Signal
forall {k} (kind :: k). [(X, Y)] -> Signal kind
Signal.from_pairs
    [ (Note -> X
Note.start Note
note, Y
sustain), (Note -> X
Note.end Note
note, Y
sustain)
    , (Note -> X
Note.end Note
note X -> X -> X
forall a. Num a => a -> a -> a
+ X
releaseTime, Y
0)
    ]

-- * thru

thru :: FilePath -> (Note.Note -> Patch.ConvertM Sample.Sample)
    -> ImInst.Code
thru :: [Char] -> (Note -> ConvertM Sample) -> Code
thru [Char]
sampleDir Note -> ConvertM Sample
convert = ThruFunction -> Code
ImInst.thru (ThruFunction -> Code) -> ThruFunction -> Code
forall a b. (a -> b) -> a -> b
$ [Char] -> (Note -> ConvertM Sample) -> ThruFunction
thruFunction [Char]
sampleDir Note -> ConvertM Sample
convert

imThruFunction :: FilePath -> (Note.Note -> Patch.ConvertM Sample.Sample)
    -> CUtil.Thru
imThruFunction :: [Char] -> (Note -> ConvertM Sample) -> Thru
imThruFunction [Char]
dir = ThruFunction -> Thru
CUtil.ImThru (ThruFunction -> Thru)
-> ((Note -> ConvertM Sample) -> ThruFunction)
-> (Note -> ConvertM Sample)
-> Thru
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> (Note -> ConvertM Sample) -> ThruFunction
thruFunction [Char]
dir

thruFunction :: FilePath -> (Note.Note -> Patch.ConvertM Sample.Sample)
    -> Thru.ThruFunction
thruFunction :: [Char] -> (Note -> ConvertM Sample) -> ThruFunction
thruFunction [Char]
sampleDir Note -> ConvertM Sample
convert = ([Play] -> Message) -> Either Error [Play] -> Either Error Message
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Play] -> Message
Thru.Plays (Either Error [Play] -> Either Error Message)
-> ([Note] -> Either Error [Play]) -> ThruFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note -> Either Error Play) -> [Note] -> Either Error [Play]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Note -> Either Error Play
note
    where
    note :: Note -> Either Error Play
note (Thru.Note NoteNumber
pitch Y
velocity Attributes
attrs Int
offset) = do
        (Sample
sample, [Msg]
_logs) <- ConvertM Sample -> Either Error (Sample, [Msg])
forall a. ConvertM a -> Either Error (a, [Msg])
Patch.runConvert (ConvertM Sample -> Either Error (Sample, [Msg]))
-> ConvertM Sample -> Either Error (Sample, [Msg])
forall a b. (a -> b) -> a -> b
$ Note -> ConvertM Sample
convert (Note -> ConvertM Sample) -> Note -> ConvertM Sample
forall a b. (a -> b) -> a -> b
$ (Error -> Instrument -> X -> X -> Note
Note.note Error
"" Instrument
"" X
0 X
1)
            { attributes :: Attributes
Note.attributes = Attributes
attrs
            , controls :: Map Control Signal
Note.controls = [(Control, Signal)] -> Map Control Signal
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ (Control
Control.pitch, Y -> Signal
forall {k} (kind :: k). Y -> Signal kind
Signal.constant (NoteNumber -> Y
Pitch.nn_to_double NoteNumber
pitch))
                , (Control
Control.dynamic, Y -> Signal
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
velocity)
                , (Control
Control.sampleStartOffset,
                    Y -> Signal
forall {k} (kind :: k). Y -> Signal kind
Signal.constant (Int -> Y
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset))
                ]
            }
        Play -> Either Error Play
forall (m :: * -> *) a. Monad m => a -> m a
return (Play -> Either Error Play) -> Play -> Either Error Play
forall a b. (a -> b) -> a -> b
$ [Char] -> Sample -> Play
Sample.toThru [Char]
sampleDir Sample
sample

-- * util

requireMap :: (Ord k, Show k) => Text -> Map k a -> k -> Patch.ConvertM a
requireMap :: forall k a. (Ord k, Show k) => Error -> Map k a -> k -> ConvertM a
requireMap Error
name Map k a
m k
k =
    Error -> Maybe a -> LogT (ExceptT Error Identity) a
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Error
"no " Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
name Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
": " Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> k -> Error
forall a. Show a => a -> Error
showt k
k) (Maybe a -> LogT (ExceptT Error Identity) a)
-> Maybe a -> LogT (ExceptT Error Identity) a
forall a b. (a -> b) -> a -> b
$ k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k a
m

enumAll :: (Enum a, Bounded a) => [a]
enumAll :: forall a. (Enum a, Bounded a) => [a]
enumAll = [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound]

findBelow :: Ord k => (a -> k) -> k -> [a] -> a
findBelow :: forall k a. Ord k => (a -> k) -> k -> [a] -> a
findBelow a -> k
_ k
_ [] = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"empty list"
findBelow a -> k
key k
val (a
x:[a]
xs) = a -> [a] -> a
go a
x [a]
xs
    where
    go :: a -> [a] -> a
go a
x0 (a
x:[a]
xs)
        | k
val k -> k -> Bool
forall a. Ord a => a -> a -> Bool
< a -> k
key a
x = a
x0
        | Bool
otherwise = a -> [a] -> a
go a
x [a]
xs
    go a
x0 [] = a
x0

showLower :: Show a => a -> String
showLower :: forall a. Show a => a -> [Char]
showLower = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower ShowS -> (a -> [Char]) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show

showtLower :: Show a => a -> Text
showtLower :: forall a. Show a => a -> Error
showtLower = [Char] -> Error
txt ([Char] -> Error) -> (a -> [Char]) -> a -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
showLower

assertLength :: (Stack.HasCallStack, Foldable t) => Int -> t a -> t a
assertLength :: forall (t :: * -> *) a.
(HasCallStack, Foldable t) =>
Int -> t a -> t a
assertLength Int
len t a
xs
    | t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len = t a
xs
    | Bool
otherwise = [Char] -> t a
forall a. HasCallStack => [Char] -> a
error ([Char] -> t a) -> [Char] -> t a
forall a b. (a -> b) -> a -> b
$ [Char]
"expected length " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
len [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
", but was "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs)