-- 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.Lists as Lists
import qualified Util.Maps as Maps
import qualified Util.Num as Num

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 forall k a. Map k a -> Bool
Map.null (forall art. StrokeMap art -> Map art (Set art)
_stops StrokeMap art
strokeMap) then forall a. a -> a
id else forall art. Ord art => StrokeMap art -> [Note] -> [Note]
inferDuration StrokeMap art
strokeMap
    , _convert :: Note -> ConvertM Sample
Patch._convert = forall art.
AttributeMap art -> ConvertMap art -> Note -> ConvertM Sample
convert (forall art. StrokeMap art -> AttributeMap art
_attributeMap StrokeMap art
strokeMap) ConvertMap art
convertMap
    , _karyaPatch :: Patch
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
        (forall art. StrokeMap art -> [(Maybe Char, Symbol, Generator Note)]
_extraCalls StrokeMap art
strokeMap)
    , _allFilenames :: Set [Char]
Patch._allFilenames = 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 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall art. StrokeMap art -> [(Stroke, Maybe art)]
_strokes StrokeMap art
strokeMap)) forall a b. (a -> b) -> a -> b
$
    Lens Patch Code
ImInst.code forall f a. Lens f a -> a -> f -> f
#= Code
code forall a b. (a -> b) -> a -> b
$
    forall a. AttributeMap a -> Bool -> Patch
makePatch (forall art. StrokeMap art -> AttributeMap art
_attributeMap StrokeMap art
strokeMap) (forall a. Maybe a -> Bool
Maybe.isJust (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) <- forall art. StrokeMap art -> [(Stroke, Maybe art)]
_strokes StrokeMap art
strokeMap
        ]
        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 = forall a. Deriver a -> Deriver a
Code.withVariation }
    thru :: Thru
thru = [Char] -> (Note -> ConvertM Sample) -> Thru
Util.imThruFunction [Char]
dir
        (forall art.
AttributeMap art -> ConvertMap art -> Note -> ConvertM Sample
convert (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 forall a b. (a -> b) -> a -> b
$ Patch
Im.Patch.patch
    { patch_controls :: Map Control PatchName
Im.Patch.patch_controls = 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 forall a. Monoid a => a
mempty
        ]
    , patch_attribute_map :: AttributeMap
Im.Patch.patch_attribute_map = forall a b. a -> b -> a
const () 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 ->
    (, forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
    forall a. Show a => a -> [Char]
show art
art [Char] -> [Char] -> [Char]
</> forall a. Y -> [a] -> Y -> Y -> a
Util.pickDynamicVariation Y
variationRange
        (art -> [[Char]]
articulationSamples art
art) Y
dyn (Y
varforall a. Num a => a -> a -> a
*Y
2 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 = forall (t :: * -> *) a.
(HasCallStack, Foldable t) =>
Int -> t a -> t a
Util.assertLength Int
len forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList
    [ forall a. Show a => a -> [Char]
show a
art [Char] -> [Char] -> [Char]
</> [Char]
fname
    | a
art <- 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 <- 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 = forall a. a -> Maybe a -> a
fromMaybe Y
0 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 -> 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 -> 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall (m :: * -> *).
MonadError PatchName m =>
Note -> m NoteNumber
Util.initialPitch Note
note
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> 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 = 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]
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 = forall art.
Ord art =>
Stops -> [(Char, Symbol, Call art)] -> StrokeMap art
strokeMapTable Stops
stops
    [ (Char
key, Symbol
sym, 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 =
        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 = forall a. [(Attributes, a)] -> AttributeMap a
Common.attribute_map forall a b. (a -> b) -> a -> b
$
        [ (Attributes
attrs, art
art)
        | (Char
_, Symbol
_, Call art
call) <- [(Char, Symbol, Call art)]
table
        , Just Attributes
attrs <- [forall {art}. Call art -> Maybe Attributes
attrsOf Call art
call], Just art
art <- [forall {a}. Call a -> Maybe a
artOf Call art
call]
        ]
    , _extraCalls :: [(Maybe Char, Symbol, Generator Note)]
_extraCalls =
        [ (if Char
char forall a. Eq a => a -> a -> Bool
== Char
' ' then forall a. Maybe a
Nothing else 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, 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 <- [forall {art}. Call art -> Maybe Attributes
attrsOf Call art
call]
        , Char
key forall a. Eq a => a -> a -> Bool
/= Char
' '
        ]
    attrsOf :: Call art -> Maybe Attributes
attrsOf (Call {}) = forall a. Maybe a
Nothing
    attrsOf (Stroke Attributes
attrs art
_ PatchName
_) = forall a. a -> Maybe a
Just Attributes
attrs
    attrsOf (Attr Attributes
attrs) = forall a. a -> Maybe a
Just Attributes
attrs
    artOf :: Call a -> Maybe a
artOf (Stroke Attributes
_ a
art PatchName
_) = forall a. a -> Maybe a
Just a
art
    artOf Call 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 forall a. Semigroup a => a -> a -> a
<> 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Stroke -> Stroke
replace) (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 = forall art.
Ord art =>
[(art, PatchName)] -> Stops -> Map art (Set art)
stopMap [(art, PatchName)]
artToGroup Stops
stops
    , _strokes :: [(Stroke, Maybe art)]
_strokes = forall a b. [a] -> [b] -> [(a, b)]
zip [Stroke]
strokes (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 = 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 a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
`Common.lookup_attributes` AttributeMap art
attributeMap)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stroke -> Attributes
Drums._attributes forall a b. (a -> b) -> a -> b
$ Stroke
attr
    artToGroup :: [(art, PatchName)]
artToGroup = do
        Stroke
stroke <- [Stroke]
strokes
        art
art <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
            forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
Common.lookup_attributes (Stroke -> Attributes
Drums._attributes Stroke
stroke) AttributeMap art
attributeMap
        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 =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (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 =
        forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall k a. (Ord k, Monoid a) => Map k a -> k -> a
Maps.getM Map PatchName [art]
toArts) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. (Ord k, Monoid a) => Map k a -> k -> a
Maps.getM Map PatchName [PatchName]
toStops
    toArts :: Map PatchName [art]
toArts = forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
Tuple.swap [(art, PatchName)]
artToGroup)
    toStops :: Map PatchName [PatchName]
toStops = 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 = forall a b. (a -> b) -> [a] -> [b]
map (Note, [Note]) -> Note
infer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, [a])]
Util.nexts
    where
    infer :: (Note, [Note]) -> Note
infer (Note
note, [Note]
nexts) = Note
note
        { duration :: RealTime
Note.duration = forall art. Ord art => StrokeMap art -> Note -> [Note] -> RealTime
inferEnd StrokeMap art
strokeMap Note
note [Note]
nexts 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set art
stops) 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall k a. (Ord k, Monoid a) => Map k a -> k -> a
Maps.getM (forall art. StrokeMap art -> Map art (Set art)
_stops StrokeMap art
strokeMap)) (Note -> Maybe art
noteArt Note
note)
    noteArt :: Note -> Maybe art
noteArt = 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 a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
`Common.lookup_attributes` AttributeMap art
attributeMap)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Attributes
Note.attributes
    attributeMap :: AttributeMap art
attributeMap = 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 forall a b. (a -> b) -> a -> b
$ [Char]
variableName forall a. Semigroup a => a -> a -> a
<> [Char]
" :: Articulation -> [FilePath]"
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
variableName forall a. Semigroup a => a -> a -> a
<> [Char]
" = \\case"
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
articulations forall a b. (a -> b) -> a -> b
$ \[Char]
art -> do
        [[Char]]
fns <- forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn [Char] -> Int
filenameSortKey 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 forall a b. (a -> b) -> a -> b
$ [Char]
indent forall a. Semigroup a => a -> a -> a
<> [Char]
art forall a. Semigroup a => a -> a -> a
<> [Char]
" ->"
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
indent2 forall a. Semigroup a => a -> a -> a
<> [Char]
"[ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a. [a] -> a
head [[Char]]
fns)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\[Char]
fn -> [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
indent2 forall a. Semigroup a => a -> a -> a
<> [Char]
", " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
fn) (forall a. [a] -> [a]
tail [[Char]]
fns)
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
indent2 forall a. Semigroup a => a -> a -> a
<> [Char]
"]"
    where
    indent :: [Char]
indent = forall a. Int -> a -> [a]
replicate Int
4 Char
' '
    indent2 :: [Char]
indent2 = [Char]
indent forall a. Semigroup a => a -> a -> a
<> [Char]
indent

filenameSortKey :: FilePath -> Int
filenameSortKey :: [Char] -> Int
filenameSortKey [Char]
fname =
    forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"can't parse " forall a. Semigroup a => a -> a -> a
<> [Char]
fname) ([Char] -> Maybe Int
parse [Char]
fname)
    where
    parse :: [Char] -> Maybe Int
parse = forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. Read a => [Char] -> Maybe a
Read.readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a)
Lists.split [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 forall a. Semigroup a => a -> a -> a
<> [Char]
" :: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
Typeable.typeOf a
a0)
        forall a. Semigroup a => a -> a -> a
<> [Char]
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
Typeable.typeOf [b]
b0)
    , [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
" = \\case"
    ] forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Char]] -> [[Char]]
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}. (Show a, Pretty a) => (a, [a]) -> [[Char]]
makeCase) [(a, [b])]
abs
    where
    makeCase :: (a, [a]) -> [[Char]]
makeCase (a
a, [a]
bs) = forall a. Show a => a -> [Char]
show a
a forall a. Semigroup a => a -> a -> a
<> [Char]
" ->"
        forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
indent (forall a b. (a -> b) -> (a -> b) -> [a] -> [b]
Lists.mapHeadTail ([Char]
"[ "<>) ([Char]
", "<>) (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> [Char]
prettys [a]
bs) forall a. [a] -> [a] -> [a]
++ [[Char]
"]"])
    indent :: [[Char]] -> [[Char]]
indent = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> a -> [a]
replicate Int
4 Char
' ' <>)
enumFunction [Char]
name [(a, [b])]
_ = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"function has no values: " forall a. Semigroup a => a -> a -> a
<> [Char]
name