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

{- | Utilities shared between drum patches.

    The base structure is that a drum has an enumeration of articulations,
    where each one is a directory of samples of increasing dynamics.  There
    are an arbitrary number of samples, which may or may not be normalized,
    which form a continuum, rather than having explicit dynamic groups.  Since
    there are no explicit variation samples, variation takes neighbor dynamics,
    where the variation range is defined per-patch.

    There is a 'Common.AttributeMap' mapping attrs to each articulation.
-}
module Synth.Sampler.Patch.Lib.Drum where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Tuple as Tuple
import qualified Data.Typeable as Typeable

import qualified GHC.Stack as Stack
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import           System.FilePath ((</>))

import qualified Text.Read as Read

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.Drums as Drums
import qualified Cmd.Instrument.ImInst as ImInst

import qualified Derive.Attrs as Attrs
import qualified Derive.Derive as Derive
import qualified Derive.Expr as Expr

import qualified Instrument.Common as Common
import qualified Perform.Im.Patch as Im.Patch
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime

import qualified Synth.Sampler.Patch as Patch
import qualified Synth.Sampler.Patch.Lib.Code as Code
import qualified Synth.Sampler.Patch.Lib.Util as Util
import qualified Synth.Sampler.Sample as Sample
import qualified Synth.Shared.Config as Config
import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Note as Note
import qualified Synth.Shared.Signal as Signal

import           Global


-- * patch

-- | Make a complete sampler patch with all the drum bits.
patch :: Ord art => FilePath -> Note.PatchName -> StrokeMap art
    -> ConvertMap art -> (Maybe art -> CUtil.CallConfig) -> Patch.Patch
patch :: forall art.
Ord art =>
[Char]
-> PatchName
-> StrokeMap art
-> ConvertMap art
-> (Maybe art -> CallConfig)
-> Patch
patch [Char]
dir PatchName
name StrokeMap art
strokeMap ConvertMap art
convertMap Maybe art -> CallConfig
configOf = (PatchName -> Patch
Patch.patch PatchName
name)
    { _dir :: [Char]
Patch._dir = [Char]
dir
    , _preprocess :: [Note] -> [Note]
Patch._preprocess =
        if Map art (Set art) -> Bool
forall k a. Map k a -> Bool
Map.null (StrokeMap art -> Map art (Set art)
forall art. StrokeMap art -> Map art (Set art)
_stops StrokeMap art
strokeMap) then [Note] -> [Note]
forall a. a -> a
id else StrokeMap art -> [Note] -> [Note]
forall art. Ord art => StrokeMap art -> [Note] -> [Note]
inferDuration StrokeMap art
strokeMap
    , _convert :: Note -> ConvertM Sample
Patch._convert = AttributeMap art -> ConvertMap art -> Note -> ConvertM Sample
forall art.
AttributeMap art -> ConvertMap art -> Note -> ConvertM Sample
convert (StrokeMap art -> AttributeMap art
forall art. StrokeMap art -> AttributeMap art
_attributeMap StrokeMap art
strokeMap) ConvertMap art
convertMap
    , _karyaPatch :: Patch
Patch._karyaPatch = [Char]
-> StrokeMap art
-> ConvertMap art
-> (Maybe art -> CallConfig)
-> [(Maybe Char, Symbol, Generator Note)]
-> Patch
forall art.
[Char]
-> StrokeMap art
-> ConvertMap art
-> (Maybe art -> CallConfig)
-> [(Maybe Char, Symbol, Generator Note)]
-> Patch
karyaPatch [Char]
dir StrokeMap art
strokeMap ConvertMap art
convertMap Maybe art -> CallConfig
configOf
        (StrokeMap art -> [(Maybe Char, Symbol, Generator Note)]
forall art. StrokeMap art -> [(Maybe Char, Symbol, Generator Note)]
_extraCalls StrokeMap art
strokeMap)
    , _allFilenames :: Set [Char]
Patch._allFilenames = ConvertMap art -> Set [Char]
forall art. ConvertMap art -> Set [Char]
_allFilenames ConvertMap art
convertMap
    }

-- | Make a patch with the drum-oriented code in there already.
karyaPatch :: FilePath -> StrokeMap art -> ConvertMap art
    -> (Maybe art -> CUtil.CallConfig)
    -> [(Maybe Char, Expr.Symbol, Derive.Generator Derive.Note)]
    -> ImInst.Patch
karyaPatch :: forall art.
[Char]
-> StrokeMap art
-> ConvertMap art
-> (Maybe art -> CallConfig)
-> [(Maybe Char, Symbol, Generator Note)]
-> Patch
karyaPatch [Char]
dir StrokeMap art
strokeMap ConvertMap art
convertMap Maybe art -> CallConfig
configOf [(Maybe Char, Symbol, Generator Note)]
extraCalls =
    [Stroke] -> Patch -> Patch
CUtil.im_drum_patch (((Stroke, Maybe art) -> Stroke)
-> [(Stroke, Maybe art)] -> [Stroke]
forall a b. (a -> b) -> [a] -> [b]
map (Stroke, Maybe art) -> Stroke
forall a b. (a, b) -> a
fst (StrokeMap art -> [(Stroke, Maybe art)]
forall art. StrokeMap art -> [(Stroke, Maybe art)]
_strokes StrokeMap art
strokeMap)) (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    Lens Patch Code
ImInst.code Lens Patch Code -> Code -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= Code
code (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    AttributeMap art -> Bool -> Patch
forall a. AttributeMap a -> Bool -> Patch
makePatch (StrokeMap art -> AttributeMap art
forall art. StrokeMap art -> AttributeMap art
_attributeMap StrokeMap art
strokeMap) (Maybe (art -> NoteNumber) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (ConvertMap art -> Maybe (art -> NoteNumber)
forall art. ConvertMap art -> Maybe (art -> NoteNumber)
_naturalNn ConvertMap art
convertMap))
    where
    extraCmds :: [(Char, Symbol)]
extraCmds = [(Char
char, Symbol
sym) | (Just Char
char, Symbol
sym, Generator Note
_) <- [(Maybe Char, Symbol, Generator Note)]
extraCalls]
    code :: Code
code = [(Char, Symbol)] -> Thru -> [(Stroke, CallConfig)] -> Code
CUtil.drum_code_cmd [(Char, Symbol)]
extraCmds Thru
thru
        [ (Stroke
stroke, CallConfig -> CallConfig
set (Maybe art -> CallConfig
configOf Maybe art
mbArt))
        | (Stroke
stroke, Maybe art
mbArt) <- StrokeMap art -> [(Stroke, Maybe art)]
forall art. StrokeMap art -> [(Stroke, Maybe art)]
_strokes StrokeMap art
strokeMap
        ]
        Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<> [(Symbol, Generator Note)] -> Code
ImInst.note_generators [(Symbol
sym, Generator Note
call) | (Maybe Char
_, Symbol
sym, Generator Note
call) <- [(Maybe Char, Symbol, Generator Note)]
extraCalls]
    set :: CallConfig -> CallConfig
set CallConfig
config = CallConfig
config { _transform :: NoteDeriver -> NoteDeriver
CUtil._transform = NoteDeriver -> NoteDeriver
forall a. Deriver a -> Deriver a
Code.withVariation }
    thru :: Thru
thru = [Char] -> (Note -> ConvertM Sample) -> Thru
Util.imThruFunction [Char]
dir
        (AttributeMap art -> ConvertMap art -> Note -> ConvertM Sample
forall art.
AttributeMap art -> ConvertMap art -> Note -> ConvertM Sample
convert (StrokeMap art -> AttributeMap art
forall art. StrokeMap art -> AttributeMap art
_attributeMap StrokeMap art
strokeMap) ConvertMap art
convertMap)

-- | Make an unconfigured patch, without code, in case it's too custom for
-- 'karyaPatch'.
makePatch :: Common.AttributeMap a -> Bool -> ImInst.Patch
makePatch :: forall a. AttributeMap a -> Bool -> Patch
makePatch AttributeMap a
attributeMap Bool
hasNaturalNn = Patch -> Patch
ImInst.make_patch (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ Patch
Im.Patch.patch
    { patch_controls :: Map Control PatchName
Im.Patch.patch_controls = [Map Control PatchName] -> Map Control PatchName
forall a. Monoid a => [a] -> a
mconcat
        [ Map Control PatchName
Control.supportDyn
        , Map Control PatchName
Control.supportVariation
        , if Bool
hasNaturalNn then Map Control PatchName
Control.supportPitch else Map Control PatchName
forall a. Monoid a => a
mempty
        ]
    , patch_attribute_map :: AttributeMap
Im.Patch.patch_attribute_map = () -> a -> ()
forall a b. a -> b -> a
const () (a -> ()) -> AttributeMap a -> AttributeMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttributeMap a
attributeMap
    }

-- * convert

-- | Arguments for the 'convert' function.
data ConvertMap art = ConvertMap {
    -- | Dyn from 0 to 1 will be scaled to this range.  If the samples are not
    -- normalized, and there are enough for a smooth curve, then (1, 1) should
    -- do.
    --
    -- TODO: if the samples are not normalized, I need a separate range for
    -- each sample, to smooth out the differences.
    forall art. ConvertMap art -> (Y, Y)
_dynRange :: (Signal.Y, Signal.Y)
    -- | If Just, use the note's pitch, assuming ratio=1 will be this pitch.
    ,  forall art. ConvertMap art -> Maybe (art -> NoteNumber)
_naturalNn :: Maybe (art -> Pitch.NoteNumber)
    -- | Time to mute at the end of a note.
    , forall art. ConvertMap art -> Maybe RealTime
_muteTime :: Maybe RealTime.RealTime
    -- | articulation -> dynamic -> variation -> (FilePath, (lowDyn, highDyn)).
    -- Returning the sample's dyn range was an attempt to tune dyn globally,
    -- but I think it doesn't work, see TODO above.
    , forall art.
ConvertMap art -> art -> Y -> Y -> ([Char], Maybe (Y, Y))
_getFilename :: art -> Signal.Y -> Signal.Y
        -> (FilePath, Maybe (Signal.Y, Signal.Y))
    , forall art. ConvertMap art -> Set [Char]
_allFilenames :: Set FilePath
    }

-- | Create a '_getFilename' with the strategy where each articulation has
-- a @[FilePath]@, sorted evenly over the dynamic range.
variableDynamic :: Show art =>
    -- | A note may pick a sample of this much dyn difference on either side.
    Signal.Y -> (art -> [FilePath])
    -> (art -> Signal.Y -> Signal.Y -> (FilePath, Maybe a))
variableDynamic :: forall art a.
Show art =>
Y -> (art -> [[Char]]) -> art -> Y -> Y -> ([Char], Maybe a)
variableDynamic Y
variationRange art -> [[Char]]
articulationSamples = \art
art Y
dyn Y
var ->
    (, Maybe a
forall a. Maybe a
Nothing) ([Char] -> ([Char], Maybe a)) -> [Char] -> ([Char], Maybe a)
forall a b. (a -> b) -> a -> b
$
    art -> [Char]
forall a. Show a => a -> [Char]
show art
art [Char] -> [Char] -> [Char]
</> Y -> [[Char]] -> Y -> Y -> [Char]
forall a. Y -> [a] -> Y -> Y -> a
Util.pickDynamicVariation Y
variationRange
        (art -> [[Char]]
articulationSamples art
art) Y
dyn (Y
varY -> Y -> Y
forall a. Num a => a -> a -> a
*Y
2 Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
1)

-- | '_allFilenames' for ConvertMaps that use 'variableDynamic' and
-- 'makeFileList'.
allFilenames :: (Stack.HasCallStack, Enum a, Bounded a, Show a)
    => Int -> (a -> [FilePath]) -> Set FilePath
allFilenames :: forall a.
(HasCallStack, Enum a, Bounded a, Show a) =>
Int -> (a -> [[Char]]) -> Set [Char]
allFilenames Int
len a -> [[Char]]
articulationSamples = Int -> Set [Char] -> Set [Char]
forall (t :: * -> *) a.
(HasCallStack, Foldable t) =>
Int -> t a -> t a
Util.assertLength Int
len (Set [Char] -> Set [Char]) -> Set [Char] -> Set [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList
    [ a -> [Char]
forall a. Show a => a -> [Char]
show a
art [Char] -> [Char] -> [Char]
</> [Char]
fname
    | a
art <- [a]
forall a. (Enum a, Bounded a) => [a]
Util.enumAll
    , [Char]
fname <- a -> [[Char]]
articulationSamples a
art
    ]

-- | Make a generic convert, suitable for drum type patches.
convert :: Common.AttributeMap art -> ConvertMap art -> Note.Note
    -> Patch.ConvertM Sample.Sample
convert :: forall art.
AttributeMap art -> ConvertMap art -> Note -> ConvertM Sample
convert AttributeMap art
attributeMap (ConvertMap (Y
minDyn, Y
maxDyn) Maybe (art -> NoteNumber)
naturalNn Maybe RealTime
muteTime art -> Y -> Y -> ([Char], Maybe (Y, Y))
getFilename
        Set [Char]
_allFilenames) =
    \Note
note -> do
        art
articulation <- AttributeMap art
-> Attributes -> LogT (ExceptT PatchName Identity) art
forall (m :: * -> *) a.
MonadError PatchName m =>
AttributeMap a -> Attributes -> m a
Util.articulation AttributeMap art
attributeMap (Note -> Attributes
Note.attributes Note
note)
        let dyn :: Y
dyn = Control -> Note -> Y
Note.initial0 Control
Control.dynamic Note
note
        let var :: Y
var = Y -> Maybe Y -> Y
forall a. a -> Maybe a -> a
fromMaybe Y
0 (Maybe Y -> Y) -> Maybe Y -> Y
forall a b. (a -> b) -> a -> b
$ Control -> Note -> Maybe Y
Note.initial Control
Control.variation Note
note
        let ([Char]
filename, Maybe (Y, Y)
mbDynRange) = art -> Y -> Y -> ([Char], Maybe (Y, Y))
getFilename art
articulation Y
dyn Y
var
        let noteDyn :: Y
noteDyn = case Maybe (Y, Y)
mbDynRange of
                Maybe (Y, Y)
Nothing -> Y -> Y -> Y -> Y
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Y
minDyn Y
maxDyn Y
dyn
                Just (Y, Y)
dynRange ->
                    (Y, Y) -> (Y, Y) -> Y -> Y
Util.dynamicAutoScale (Y
minDyn, Y
maxDyn) (Y, Y)
dynRange Y
dyn
        Y
ratio <- case Maybe (art -> NoteNumber)
naturalNn of
            Maybe (art -> NoteNumber)
Nothing -> Y -> LogT (ExceptT PatchName Identity) Y
forall (m :: * -> *) a. Monad m => a -> m a
return Y
1
            Just art -> NoteNumber
artNn -> NoteNumber -> NoteNumber -> Y
Sample.pitchToRatio (art -> NoteNumber
artNn art
articulation) (NoteNumber -> Y)
-> LogT (ExceptT PatchName Identity) NoteNumber
-> LogT (ExceptT PatchName Identity) Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                Note -> LogT (ExceptT PatchName Identity) NoteNumber
forall (m :: * -> *).
MonadError PatchName m =>
Note -> m NoteNumber
Util.initialPitch Note
note
        Sample -> ConvertM Sample
forall (m :: * -> *) a. Monad m => a -> m a
return (Sample -> ConvertM Sample) -> Sample -> ConvertM Sample
forall a b. (a -> b) -> a -> b
$ ([Char] -> Sample
Sample.make [Char]
filename)
            { envelope :: Signal
Sample.envelope = case Maybe RealTime
muteTime of
                Maybe RealTime
Nothing -> Y -> Signal
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
noteDyn
                Just RealTime
time -> Y -> RealTime -> Note -> Signal
Util.sustainRelease Y
noteDyn RealTime
time Note
note
            , ratios :: Signal
Sample.ratios = Y -> Signal
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
ratio
            }

-- * StrokeMap

-- | Describe a drum-like instrument.  This is just the data for the various
-- functions to construct the patch.
data StrokeMap art = StrokeMap {
    -- | Map each articulation to the articulations that stop it.
    forall art. StrokeMap art -> Map art (Set art)
_stops :: Map art (Set art)
    -- | Retain the Stroke to 'art' assocation so I can have it when generating
    -- the call for each stroke.
    , forall art. StrokeMap art -> [(Stroke, Maybe art)]
_strokes :: [(Drums.Stroke, Maybe art)]
    , forall art. StrokeMap art -> AttributeMap art
_attributeMap :: Common.AttributeMap art
    , forall art. StrokeMap art -> [(Maybe Char, Symbol, Generator Note)]
_extraCalls :: [(Maybe Char, Expr.Symbol, Derive.Generator Derive.Note)]
    } deriving (Int -> StrokeMap art -> [Char] -> [Char]
[StrokeMap art] -> [Char] -> [Char]
StrokeMap art -> [Char]
(Int -> StrokeMap art -> [Char] -> [Char])
-> (StrokeMap art -> [Char])
-> ([StrokeMap art] -> [Char] -> [Char])
-> Show (StrokeMap art)
forall art. Show art => Int -> StrokeMap art -> [Char] -> [Char]
forall art. Show art => [StrokeMap art] -> [Char] -> [Char]
forall art. Show art => StrokeMap art -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [StrokeMap art] -> [Char] -> [Char]
$cshowList :: forall art. Show art => [StrokeMap art] -> [Char] -> [Char]
show :: StrokeMap art -> [Char]
$cshow :: forall art. Show art => StrokeMap art -> [Char]
showsPrec :: Int -> StrokeMap art -> [Char] -> [Char]
$cshowsPrec :: forall art. Show art => Int -> StrokeMap art -> [Char] -> [Char]
Show)

-- | Like 'strokeMapTable', but for patches with only 'Stroke's.
strokeMapSimple :: Ord art => Drums.Stops
    -> [(Char, Expr.Symbol, Attrs.Attributes, art, Drums.Group)]
    -> StrokeMap art
strokeMapSimple :: forall art.
Ord art =>
Stops
-> [(Char, Symbol, Attributes, art, PatchName)] -> StrokeMap art
strokeMapSimple Stops
stops [(Char, Symbol, Attributes, art, PatchName)]
table = Stops -> [(Char, Symbol, Call art)] -> StrokeMap art
forall art.
Ord art =>
Stops -> [(Char, Symbol, Call art)] -> StrokeMap art
strokeMapTable Stops
stops
    [ (Char
key, Symbol
sym, Attributes -> art -> PatchName -> Call art
forall art. Attributes -> art -> PatchName -> Call art
Stroke Attributes
attrs art
art PatchName
group)
    | (Char
key, Symbol
sym, Attributes
attrs, art
art, PatchName
group) <- [(Char, Symbol, Attributes, art, PatchName)]
table
    ]

data Call art =
    -- | A call that doesn't correspond directly to Attributes.
    Call (Derive.Generator Derive.Note)
    -- | Emit a call that produces these Attributes, and cause the patch to
    -- assign those Attributes to the given articulation.
    | Stroke Attrs.Attributes art Drums.Group
    -- | Emit a call that produces these Attributes, with no articulation
    -- association.
    | Attr Attrs.Attributes

-- | Make a StrokeMap describing the keymap and call map of a drum-like patch.
strokeMapTable :: Ord art => Drums.Stops
    -> [(Char, Expr.Symbol, Call art)]
    -- ^ If Char == ' ', there is no key binding.  Symbol == "" means there
    -- is no call, but it still makes sense for 'Stroke', because it can make
    -- the patch respond to the given Attributes.
    -> StrokeMap art
strokeMapTable :: forall art.
Ord art =>
Stops -> [(Char, Symbol, Call art)] -> StrokeMap art
strokeMapTable Stops
stops [(Char, Symbol, Call art)]
table = StrokeMap
    { _stops :: Map art (Set art)
_stops =
        [(art, PatchName)] -> Stops -> Map art (Set art)
forall art.
Ord art =>
[(art, PatchName)] -> Stops -> Map art (Set art)
stopMap [(art
art, PatchName
group) | (Char
_, Symbol
_, Stroke Attributes
_ art
art PatchName
group) <- [(Char, Symbol, Call art)]
table] Stops
stops
    , _strokes :: [(Stroke, Maybe art)]
_strokes = [(Stroke, Maybe art)]
strokes
    , _attributeMap :: AttributeMap art
_attributeMap = [(Attributes, art)] -> AttributeMap art
forall a. [(Attributes, a)] -> AttributeMap a
Common.attribute_map ([(Attributes, art)] -> AttributeMap art)
-> [(Attributes, art)] -> AttributeMap art
forall a b. (a -> b) -> a -> b
$
        [ (Attributes
attrs, art
art)
        | (Char
_, Symbol
_, Call art
call) <- [(Char, Symbol, Call art)]
table
        , Just Attributes
attrs <- [Call art -> Maybe Attributes
forall {art}. Call art -> Maybe Attributes
attrsOf Call art
call], Just art
art <- [Call art -> Maybe art
forall {a}. Call a -> Maybe a
artOf Call art
call]
        ]
    , _extraCalls :: [(Maybe Char, Symbol, Generator Note)]
_extraCalls =
        [ (if Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' then Maybe Char
forall a. Maybe a
Nothing else Char -> Maybe Char
forall a. a -> Maybe a
Just Char
char, Symbol
sym, Generator Note
call)
        | (Char
char, Symbol
sym, Call Generator Note
call) <- [(Char, Symbol, Call art)]
table
        ]
    }
    where
    strokes :: [(Stroke, Maybe art)]
strokes =
        [ (Char -> Symbol -> Attributes -> Stroke
makeStroke Char
key Symbol
sym Attributes
attrs, Call art -> Maybe art
forall {a}. Call a -> Maybe a
artOf Call art
call)
        | (Char
key, Symbol
sym, Call art
call) <- [(Char, Symbol, Call art)]
table
        , Just Attributes
attrs <- [Call art -> Maybe Attributes
forall {art}. Call art -> Maybe Attributes
attrsOf Call art
call]
        , Char
key Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' '
        ]
    attrsOf :: Call art -> Maybe Attributes
attrsOf (Call {}) = Maybe Attributes
forall a. Maybe a
Nothing
    attrsOf (Stroke Attributes
attrs art
_ PatchName
_) = Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just Attributes
attrs
    attrsOf (Attr Attributes
attrs) = Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just Attributes
attrs
    artOf :: Call a -> Maybe a
artOf (Stroke Attributes
_ a
art PatchName
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
art
    artOf Call a
_ = Maybe a
forall a. Maybe a
Nothing
    makeStroke :: Char -> Symbol -> Attributes -> Stroke
makeStroke Char
key Symbol
sym Attributes
attrs = Drums.Stroke
        { _name :: Symbol
_name = Symbol
sym
        , _attributes :: Attributes
_attributes = Attributes
attrs
        , _char :: Char
_char = Char
key
        , _dynamic :: Y
_dynamic = Y
1
        -- Drums._group is for generating 'stopMap' from just Strokes, but
        -- I'm generating it separately here.
        , _group :: PatchName
_group = PatchName
""
        }

addAttributeMap :: Common.AttributeMap art -> StrokeMap art -> StrokeMap art
addAttributeMap :: forall art. AttributeMap art -> StrokeMap art -> StrokeMap art
addAttributeMap AttributeMap art
attrs StrokeMap art
strokeMap =
    StrokeMap art
strokeMap { _attributeMap :: AttributeMap art
_attributeMap = AttributeMap art
attrs AttributeMap art -> AttributeMap art -> AttributeMap art
forall a. Semigroup a => a -> a -> a
<> StrokeMap art -> AttributeMap art
forall art. StrokeMap art -> AttributeMap art
_attributeMap StrokeMap art
strokeMap }

-- | Set dynamic for Attrs.soft and remove it.
replaceSoft :: Signal.Y -> StrokeMap art -> StrokeMap art
replaceSoft :: forall art. Y -> StrokeMap art -> StrokeMap art
replaceSoft Y
dyn StrokeMap art
strokeMap =
    StrokeMap art
strokeMap { _strokes :: [(Stroke, Maybe art)]
_strokes = ((Stroke, Maybe art) -> (Stroke, Maybe art))
-> [(Stroke, Maybe art)] -> [(Stroke, Maybe art)]
forall a b. (a -> b) -> [a] -> [b]
map ((Stroke -> Stroke) -> (Stroke, Maybe art) -> (Stroke, Maybe art)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Stroke -> Stroke
replace) (StrokeMap art -> [(Stroke, Maybe art)]
forall art. StrokeMap art -> [(Stroke, Maybe art)]
_strokes StrokeMap art
strokeMap) }
    where
    replace :: Stroke -> Stroke
replace Stroke
stroke = Stroke
stroke
        { _attributes :: Attributes
Drums._attributes = Attributes -> Attributes -> Attributes
Attrs.remove Attributes
Attrs.soft Attributes
attrs
        , _dynamic :: Y
Drums._dynamic = if Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs Attributes
Attrs.soft then Y
dyn else Y
1
        }
        where attrs :: Attributes
attrs = Stroke -> Attributes
Drums._attributes Stroke
stroke

-- | Make a StrokeMap from separate strokes and AttributeMap.  This happens
-- when instruments parts are factored apart, due to having both MIDI and
-- im versions.
strokeMap :: Ord art => Drums.Stops -> [Drums.Stroke]
    -> Common.AttributeMap art -> StrokeMap art
strokeMap :: forall art.
Ord art =>
Stops -> [Stroke] -> AttributeMap art -> StrokeMap art
strokeMap Stops
stops [Stroke]
strokes AttributeMap art
attributeMap = StrokeMap
    { _stops :: Map art (Set art)
_stops = [(art, PatchName)] -> Stops -> Map art (Set art)
forall art.
Ord art =>
[(art, PatchName)] -> Stops -> Map art (Set art)
stopMap [(art, PatchName)]
artToGroup Stops
stops
    , _strokes :: [(Stroke, Maybe art)]
_strokes = [Stroke] -> [Maybe art] -> [(Stroke, Maybe art)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Stroke]
strokes ((Stroke -> Maybe art) -> [Stroke] -> [Maybe art]
forall a b. (a -> b) -> [a] -> [b]
map Stroke -> Maybe art
strokeToArt [Stroke]
strokes)
    , _attributeMap :: AttributeMap art
_attributeMap = AttributeMap art
attributeMap
    , _extraCalls :: [(Maybe Char, Symbol, Generator Note)]
_extraCalls = []
    }
    where
    -- This is awkward because I want to preserve the art, but unlike
    -- 'strokeMapTable', I can't guarantee a 1:1 attr:art mapping.
    strokeToArt :: Stroke -> Maybe art
strokeToArt Stroke
attr = ((Attributes, art) -> art) -> Maybe (Attributes, art) -> Maybe art
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Attributes, art) -> art
forall a b. (a, b) -> b
snd
        (Maybe (Attributes, art) -> Maybe art)
-> (Stroke -> Maybe (Attributes, art)) -> Stroke -> Maybe art
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes -> AttributeMap art -> Maybe (Attributes, art)
forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
`Common.lookup_attributes` AttributeMap art
attributeMap)
        (Attributes -> Maybe (Attributes, art))
-> (Stroke -> Attributes) -> Stroke -> Maybe (Attributes, art)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stroke -> Attributes
Drums._attributes (Stroke -> Maybe art) -> Stroke -> Maybe art
forall a b. (a -> b) -> a -> b
$ Stroke
attr
    artToGroup :: [(art, PatchName)]
artToGroup = do
        Stroke
stroke <- [Stroke]
strokes
        art
art <- [art]
-> ((Attributes, art) -> [art]) -> Maybe (Attributes, art) -> [art]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((art -> [art] -> [art]
forall a. a -> [a] -> [a]
:[]) (art -> [art])
-> ((Attributes, art) -> art) -> (Attributes, art) -> [art]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes, art) -> art
forall a b. (a, b) -> b
snd) (Maybe (Attributes, art) -> [art])
-> Maybe (Attributes, art) -> [art]
forall a b. (a -> b) -> a -> b
$
            Attributes -> AttributeMap art -> Maybe (Attributes, art)
forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
Common.lookup_attributes (Stroke -> Attributes
Drums._attributes Stroke
stroke) AttributeMap art
attributeMap
        (art, PatchName) -> [(art, PatchName)]
forall (m :: * -> *) a. Monad m => a -> m a
return (art
art, Stroke -> PatchName
Drums._group Stroke
stroke)

stopMap :: Ord art => [(art, Drums.Group)]
    -> [(Drums.Group, [Drums.Group])] -> Map art (Set art)
stopMap :: forall art.
Ord art =>
[(art, PatchName)] -> Stops -> Map art (Set art)
stopMap [(art, PatchName)]
artToGroup Stops
closedOpens =
    [(art, Set art)] -> Map art (Set art)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(art, Set art)] -> Map art (Set art))
-> [(art, Set art)] -> Map art (Set art)
forall a b. (a -> b) -> a -> b
$ ((art, Set art) -> Bool) -> [(art, Set art)] -> [(art, Set art)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((art, Set art) -> Bool) -> (art, Set art) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set art -> Bool
forall a. Set a -> Bool
Set.null (Set art -> Bool)
-> ((art, Set art) -> Set art) -> (art, Set art) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (art, Set art) -> Set art
forall a b. (a, b) -> b
snd) ([(art, Set art)] -> [(art, Set art)])
-> [(art, Set art)] -> [(art, Set art)]
forall a b. (a -> b) -> a -> b
$
        ((art, PatchName) -> (art, Set art))
-> [(art, PatchName)] -> [(art, Set art)]
forall a b. (a -> b) -> [a] -> [b]
map ((PatchName -> Set art) -> (art, PatchName) -> (art, Set art)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatchName -> Set art
groupToStops) [(art, PatchName)]
artToGroup
    where
    groupToStops :: PatchName -> Set art
groupToStops =
        [art] -> Set art
forall a. Ord a => [a] -> Set a
Set.fromList ([art] -> Set art) -> (PatchName -> [art]) -> PatchName -> Set art
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatchName -> [art]) -> [PatchName] -> [art]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map PatchName [art] -> PatchName -> [art]
forall k a. (Ord k, Monoid a) => Map k a -> k -> a
Maps.getM Map PatchName [art]
toArts) ([PatchName] -> [art])
-> (PatchName -> [PatchName]) -> PatchName -> [art]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PatchName [PatchName] -> PatchName -> [PatchName]
forall k a. (Ord k, Monoid a) => Map k a -> k -> a
Maps.getM Map PatchName [PatchName]
toStops
    toArts :: Map PatchName [art]
toArts = [(PatchName, art)] -> Map PatchName [art]
forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap (((art, PatchName) -> (PatchName, art))
-> [(art, PatchName)] -> [(PatchName, art)]
forall a b. (a -> b) -> [a] -> [b]
map (art, PatchName) -> (PatchName, art)
forall a b. (a, b) -> (b, a)
Tuple.swap [(art, PatchName)]
artToGroup)
    toStops :: Map PatchName [PatchName]
toStops = [(PatchName, PatchName)] -> Map PatchName [PatchName]
forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap
        [ (PatchName
open, PatchName
closed)
        | (PatchName
closed, [PatchName]
opens) <- Stops
closedOpens, PatchName
open <- [PatchName]
opens
        ]

-- * inferDuration

-- | Notes ring until stopped by their stop note.
inferDuration :: Ord art => StrokeMap art -> [Note.Note] -> [Note.Note]
inferDuration :: forall art. Ord art => StrokeMap art -> [Note] -> [Note]
inferDuration StrokeMap art
strokeMap = ((Note, [Note]) -> Note) -> [(Note, [Note])] -> [Note]
forall a b. (a -> b) -> [a] -> [b]
map (Note, [Note]) -> Note
infer ([(Note, [Note])] -> [Note])
-> ([Note] -> [(Note, [Note])]) -> [Note] -> [Note]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Note] -> [(Note, [Note])]
forall a. [a] -> [(a, [a])]
Util.nexts
    where
    infer :: (Note, [Note]) -> Note
infer (Note
note, [Note]
nexts) = Note
note
        { duration :: RealTime
Note.duration = StrokeMap art -> Note -> [Note] -> RealTime
forall art. Ord art => StrokeMap art -> Note -> [Note] -> RealTime
inferEnd StrokeMap art
strokeMap Note
note [Note]
nexts RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- Note -> RealTime
Note.start Note
note }

inferEnd :: Ord art => StrokeMap art -> Note.Note -> [Note.Note]
    -> RealTime.RealTime
inferEnd :: forall art. Ord art => StrokeMap art -> Note -> [Note] -> RealTime
inferEnd StrokeMap art
strokeMap Note
note [Note]
nexts =
    case (Note -> Bool) -> [Note] -> Maybe Note
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Bool -> (art -> Bool) -> Maybe art -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (art -> Set art -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set art
stops) (Maybe art -> Bool) -> (Note -> Maybe art) -> Note -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Maybe art
noteArt) [Note]
nexts of
        Maybe Note
Nothing -> RealTime
Sample.forever
        Just Note
stop -> Note -> RealTime
Note.start Note
stop
    where
    stops :: Set art
stops = Set art -> (art -> Set art) -> Maybe art -> Set art
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set art
forall a. Monoid a => a
mempty (Map art (Set art) -> art -> Set art
forall k a. (Ord k, Monoid a) => Map k a -> k -> a
Maps.getM (StrokeMap art -> Map art (Set art)
forall art. StrokeMap art -> Map art (Set art)
_stops StrokeMap art
strokeMap)) (Note -> Maybe art
noteArt Note
note)
    noteArt :: Note -> Maybe art
noteArt = ((Attributes, art) -> art) -> Maybe (Attributes, art) -> Maybe art
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Attributes, art) -> art
forall a b. (a, b) -> b
snd (Maybe (Attributes, art) -> Maybe art)
-> (Note -> Maybe (Attributes, art)) -> Note -> Maybe art
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes -> AttributeMap art -> Maybe (Attributes, art)
forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
`Common.lookup_attributes` AttributeMap art
attributeMap)
        (Attributes -> Maybe (Attributes, art))
-> (Note -> Attributes) -> Note -> Maybe (Attributes, art)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Attributes
Note.attributes
    attributeMap :: AttributeMap art
attributeMap = StrokeMap art -> AttributeMap art
forall art. StrokeMap art -> AttributeMap art
_attributeMap StrokeMap art
strokeMap

-- * file list

-- | Generate haskell code for an Articulation -> [FilePath] function.
--
-- This expects a subdirectory for each articulation, whose name is the same
-- as the Articulation constructor, and sorts it on the last numeric
-- dash-separated field.
--
-- This could be done with TH but it's constant so it's simpler to copy paste
-- into the source.
makeFileList :: FilePath -> [FilePath] -> String -> IO ()
makeFileList :: [Char] -> [[Char]] -> [Char] -> IO ()
makeFileList [Char]
dir [[Char]]
articulations [Char]
variableName = do
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
variableName [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" :: Articulation -> [FilePath]"
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
variableName [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" = \\case"
    [[Char]] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
articulations (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
art -> do
        [[Char]]
fns <- ([Char] -> Int) -> [[Char]] -> [[Char]]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on [Char] -> Int
filenameSortKey ([[Char]] -> [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            [Char] -> IO [[Char]]
Directory.listDirectory ([Char]
Config.unsafeSamplerRoot [Char] -> [Char] -> [Char]
</> [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
art)
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
indent [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
art [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" ->"
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
indent2 [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"[ " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show ([[Char]] -> [Char]
forall a. [a] -> a
head [[Char]]
fns)
        ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\[Char]
fn -> [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
indent2 [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
fn) ([[Char]] -> [[Char]]
forall a. [a] -> [a]
tail [[Char]]
fns)
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
indent2 [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"]"
    where
    indent :: [Char]
indent = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
4 Char
' '
    indent2 :: [Char]
indent2 = [Char]
indent [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
indent

filenameSortKey :: FilePath -> Int
filenameSortKey :: [Char] -> Int
filenameSortKey [Char]
fname =
    Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char] -> Int) -> [Char] -> Int
forall a b. (a -> b) -> a -> b
$ [Char]
"can't parse " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
fname) ([Char] -> Maybe Int
parse [Char]
fname)
    where
    parse :: [Char] -> Maybe Int
parse = [Int] -> Maybe Int
forall a. [a] -> Maybe a
Seq.head ([Int] -> Maybe Int) -> ([Char] -> [Int]) -> [Char] -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Maybe Int) -> [[Char]] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
Read.readMaybe ([[Char]] -> [Int]) -> ([Char] -> [[Char]]) -> [Char] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [[Char]]
forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a)
Seq.split [Char]
"-"
        ([Char] -> [[Char]]) -> ([Char] -> [Char]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
FilePath.dropExtension

-- | Emit haskell code for a function from an Enum to lists.
enumFunction
    :: (Typeable.Typeable a, Show a, Typeable.Typeable b, Pretty b)
    => String -> [(a, [b])] -> [String]
enumFunction :: forall a b.
(Typeable a, Show a, Typeable b, Pretty b) =>
[Char] -> [(a, [b])] -> [[Char]]
enumFunction [Char]
name abs :: [(a, [b])]
abs@((a
a0, [b]
b0) : [(a, [b])]
_) =
    [ [Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" :: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf a
a0)
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TypeRep -> [Char]
forall a. Show a => a -> [Char]
show ([b] -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf [b]
b0)
    , [Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" = \\case"
    ] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ((a, [b]) -> [[Char]]) -> [(a, [b])] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Char]] -> [[Char]]
indent ([[Char]] -> [[Char]])
-> ((a, [b]) -> [[Char]]) -> (a, [b]) -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [b]) -> [[Char]]
forall {a} {a}. (Show a, Pretty a) => (a, [a]) -> [[Char]]
makeCase) [(a, [b])]
abs
    where
    makeCase :: (a, [a]) -> [[Char]]
makeCase (a
a, [a]
bs) = a -> [Char]
forall a. Show a => a -> [Char]
show a
a [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" ->"
        [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
indent (([Char] -> [Char]) -> ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
Seq.map_head_tail ([Char]
"[ "<>) ([Char]
", "<>) ((a -> [Char]) -> [a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [Char]
forall a. Pretty a => a -> [Char]
prettys [a]
bs) [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"]"])
    indent :: [[Char]] -> [[Char]]
indent = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
4 Char
' ' <>)
enumFunction [Char]
name [(a, [b])]
_ = [Char] -> [[Char]]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char]
"function has no values: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name