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

{-# LANGUAGE CPP #-}
-- | Convert solkattu to audio via karya score, and play it.
module Solkattu.Play (
    play_m
#ifdef TESTING
    , module Solkattu.Play
#endif
) where
import qualified Control.Concurrent.Async as Async
import qualified Control.Concurrent.MVar as MVar
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import           System.FilePath ((</>))

import qualified Util.Control as Control
import qualified Util.Log as Log
import qualified Util.Processes as Processes
import qualified Util.Lists as Lists

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Msg as Msg
import qualified Cmd.Performance as Performance

import qualified Derive.Controls as Controls
import qualified Derive.DeriveSaved as DeriveSaved
import qualified Derive.Expr as Expr
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal

import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Solkattu.Instrument.ToScore as ToScore
import qualified Solkattu.Korvai as Korvai
import qualified Solkattu.Realize as Realize
import qualified Solkattu.S as S
import qualified Solkattu.Solkattu as Solkattu
import qualified Solkattu.Tala as Tala
import qualified Solkattu.Talas as Talas

import qualified Synth.Sampler.PatchDb as Sampler.PatchDb
import qualified Synth.Shared.Config as Config
import qualified Ui.Block as Block
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.GenId as GenId
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global
import           Types


-- | Play mridangam realization for the korvai.
play_m :: RealTime -> Korvai.Korvai -> IO Bool
play_m :: RealTime -> Korvai -> IO Bool
play_m = forall stroke.
(Notation stroke, ToExpr (Stroke stroke), Ord stroke) =>
Instrument stroke
-> Qualified -> SynthName -> RealTime -> Korvai -> IO Bool
play_instrument Instrument Stroke
Korvai.IMridangam
    (SynthName -> SynthName -> Qualified
InstT.Qualified SynthName
"sampler" SynthName
"mridangam-d")
    SynthName
"# = (natural) | %dyn = .75"

play_instrument :: (Solkattu.Notation stroke,
        Expr.ToExpr (Realize.Stroke stroke), Ord stroke)
    => Korvai.Instrument stroke
    -> InstT.Qualified -> Text -> RealTime -> Korvai.Korvai -> IO Bool
play_instrument :: forall stroke.
(Notation stroke, ToExpr (Stroke stroke), Ord stroke) =>
Instrument stroke
-> Qualified -> SynthName -> RealTime -> Korvai -> IO Bool
play_instrument Instrument stroke
instrument Qualified
im_instrument SynthName
transform RealTime
akshara_dur Korvai
korvai = do
    State
state <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
SynthName -> m a
errorIO forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall stroke.
(Notation stroke, ToExpr (Stroke stroke), Ord stroke) =>
Instrument stroke
-> Qualified
-> SynthName
-> RealTime
-> Korvai
-> Either SynthName State
to_state Instrument stroke
instrument Qualified
im_instrument SynthName
transform RealTime
akshara_dur Korvai
korvai
    ([Process]
procs, [[Char]]
output_dirs) <- [Char] -> State -> IO ([Process], [[Char]])
derive_to_disk [Char]
"solkattu" State
state
    [Process] -> [[Char]] -> IO Bool
play_procs [Process]
procs [[Char]]
output_dirs

play_procs :: [Performance.Process] -> [FilePath] -> IO Bool
play_procs :: [Process] -> [[Char]] -> IO Bool
play_procs [] [[Char]]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- I think this shouldn't happen?
play_procs [Process]
procs [[Char]]
output_dirs = do
    MVar ()
ready <- forall a. IO (MVar a)
MVar.newEmptyMVar
    forall (m :: * -> *).
(HasCallStack, LogMonad m) =>
SynthName -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ SynthName
"start render: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty [Process]
procs
    Async Bool
rendering <- forall a. IO a -> IO (Async a)
Async.async forall a b. (a -> b) -> a -> b
$
        IO () -> Set Instrument -> Set Process -> IO Bool
Performance.wait_for_subprocesses (forall a. MVar a -> a -> IO ()
MVar.putMVar MVar ()
ready ())
            (forall a. a -> Set a
Set.singleton Instrument
inst_name)
            (forall a. Ord a => [a] -> Set a
Set.fromList [Process]
procs)
    forall (m :: * -> *).
(HasCallStack, LogMonad m) =>
SynthName -> m ()
Log.debug SynthName
"wait for ready"
    forall a. MVar a -> IO a
MVar.takeMVar MVar ()
ready
    forall (m :: * -> *).
(HasCallStack, LogMonad m) =>
SynthName -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ [SynthName] -> SynthName
Text.unwords forall a b. (a -> b) -> a -> b
$
        SynthName
"%" forall a. a -> [a] -> [a]
: SynthName
"build/opt/stream_audio" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map [Char] -> SynthName
txt [[Char]]
output_dirs
    [Char] -> [[Char]] -> IO ()
Processes.call [Char]
"build/opt/stream_audio" [[Char]]
output_dirs
    forall a. Async a -> IO a
Async.wait Async Bool
rendering

-- | Derive the Ui.State and write the im parts to disk.
derive_to_disk :: FilePath -> Ui.State -> IO ([Performance.Process], [FilePath])
derive_to_disk :: [Char] -> State -> IO ([Process], [[Char]])
derive_to_disk [Char]
score_path State
ui_state = do
    State
cmd_state <- IO State
load_cmd_state
    BlockId
block_id <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
SynthName -> m a
errorIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> SynthName
pretty) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall a. State -> StateId a -> Either Error a
Ui.eval State
ui_state forall (m :: * -> *). M m => m BlockId
Ui.get_root_id
    let (Vector Event
events, [Msg]
logs) = State -> State -> BlockId -> (Vector Event, [Msg])
derive State
cmd_state State
ui_state BlockId
block_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>Priority
Log.Debug) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Priority
Log.msg_priority) [Msg]
logs
    let im_config :: Config
im_config = Config -> Config
Cmd.config_im (State -> Config
Cmd.state_config State
cmd_state)
        lookup_inst :: Instrument -> Maybe ResolvedInstrument
lookup_inst = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State -> Instrument -> Either SynthName ResolvedInstrument
Cmd.state_lookup_instrument State
ui_state State
cmd_state
    ([Process]
procs, Vector Event
non_im) <- Config
-> (Instrument -> Maybe ResolvedInstrument)
-> [Char]
-> RealTime
-> RealTime
-> BlockId
-> Vector Event
-> IO ([Process], Vector Event)
Performance.evaluate_im Config
im_config Instrument -> Maybe ResolvedInstrument
lookup_inst [Char]
score_path
        RealTime
0 RealTime
1 BlockId
block_id Vector Event
events
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector Event
non_im) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *).
(HasCallStack, LogMonad m) =>
SynthName -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ SynthName
"non-im events: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SynthName
pretty Vector Event
non_im
    Config
config <- IO Config
Config.getConfig
    let out_dir :: Instrument -> [Char]
out_dir Instrument
inst = [Char] -> [Char] -> BlockId -> [Char]
Config.outputDirectory (Config -> [Char]
Config.imDir Config
config) [Char]
score_path
            BlockId
block_id [Char] -> [Char] -> [Char]
</> SynthName -> [Char]
untxt (Instrument -> SynthName
ScoreT.instrument_name Instrument
inst)
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( [Process]
procs
        , [Instrument -> [Char]
out_dir Instrument
inst_name, Instrument -> [Char]
out_dir Instrument
metronome_name]
        )

derive :: Cmd.State -> Ui.State -> BlockId
    -> (Vector.Vector Score.Event, [Log.Msg])
derive :: State -> State -> BlockId -> (Vector Event, [Msg])
derive State
cmd_state State
ui_state BlockId
block_id =
    (Performance -> Vector Event
Msg.perf_events Performance
perf, [Msg]
logs forall a. [a] -> [a] -> [a]
++ Performance -> [Msg]
Msg.perf_logs Performance
perf)
    where (Performance
perf, [Msg]
logs) = State -> State -> BlockId -> (Performance, [Msg])
Performance.derive State
ui_state State
cmd_state BlockId
block_id

load_cmd_state :: IO Cmd.State
load_cmd_state :: IO State
load_cmd_state = Config -> State
Cmd.initial_state forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InstrumentDb -> IO Config
DeriveSaved.cmd_config InstrumentDb
db
    where db :: InstrumentDb
db = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall code. [SynthDecl code] -> (Db code, [SynthName])
Inst.db [SynthDecl InstrumentCode
Sampler.PatchDb.synth]


-- * to_state

-- | Realize and convert to Ui.State.
to_state :: (Solkattu.Notation stroke, Expr.ToExpr (Realize.Stroke stroke),
        Ord stroke)
    => Korvai.Instrument stroke
    -> InstT.Qualified -> Text -> RealTime -> Korvai.Korvai
    -> Either Text Ui.State
to_state :: forall stroke.
(Notation stroke, ToExpr (Stroke stroke), Ord stroke) =>
Instrument stroke
-> Qualified
-> SynthName
-> RealTime
-> Korvai
-> Either SynthName State
to_state Instrument stroke
instrument Qualified
im_instrument SynthName
transform RealTime
akshara_dur_ Korvai
korvai = do
    [Realized stroke]
results <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall stroke.
(Notation stroke, Ord stroke) =>
Instrument stroke -> Korvai -> [Either SynthName (Realized stroke)]
Korvai.realize Instrument stroke
instrument Korvai
korvai
    let ([Flat stroke]
strokes, [[Warning]]
_warnings) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip [Realized stroke]
results
    -- Leave the warnings for the realize call.
    let notes :: NoteTrack
notes = forall stroke g.
ToScore stroke -> TrackTime -> [Flat g (Note stroke)] -> NoteTrack
to_note_track (forall stroke.
ToExpr (Stroke stroke) =>
Instrument stroke -> ToScore stroke
Korvai.instToScore Instrument stroke
instrument) TrackTime
akshara_dur
            [Flat stroke]
strokes
    let end :: TrackTime
end = case NoteTrack
notes of
            NoteTrack Instrument
_ Events
events Controls
_ -> Events -> TrackTime
Events.time_end Events
events
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Pretty a => a -> SynthName
pretty forall a b. (a -> b) -> a -> b
$ Qualified -> SynthName -> [[Track]] -> Either Error State
make_state Qualified
im_instrument SynthName
transform forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map NoteTrack -> [Track]
make_tracks
        [ NoteTrack
notes
        , Instrument
-> [(TrackTime, TrackTime, SynthName, Double)] -> NoteTrack
make_track Instrument
metronome_name forall a b. (a -> b) -> a -> b
$
            Tala
-> TrackTime
-> TrackTime
-> [(TrackTime, TrackTime, SynthName, Double)]
tala_metronome (Korvai -> Tala
Korvai.korvaiTala Korvai
korvai) TrackTime
akshara_dur TrackTime
end
        ]
    where
    akshara_dur :: TrackTime
akshara_dur = RealTime -> TrackTime
RealTime.to_score RealTime
akshara_dur_

make_state :: InstT.Qualified -> Text -> [[Track.Track]]
    -> Either Ui.Error Ui.State
make_state :: Qualified -> SynthName -> [[Track]] -> Either Error State
make_state Qualified
instrument SynthName
transform [[Track]]
track_groups = forall a. State -> StateId a -> Either Error State
Ui.exec State
Ui.empty forall a b. (a -> b) -> a -> b
$ do
    Id
bid <- forall (m :: * -> *). M m => Maybe BlockId -> m Id
GenId.block_id forall a. Maybe a
Nothing
    let title :: SynthName
title = SynthName -> [SynthName] -> SynthName
Text.intercalate SynthName
" | " 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
. SynthName -> Bool
Text.null)
            [ SynthName
"inst = " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> SynthName
ShowVal.show_val Instrument
inst_name
            , SynthName
transform
            , SynthName
"scale = just-r"
            , SynthName
"key = d-maj"
            -- , "just-base = (hz (<-#))"
            -- Mridangam claims (natural) is 62.1, but it sounds more like 62.5
            -- TODO fix this
            , SynthName
"just-base = (hz 62.5)"
            ]
    BlockId
bid <- forall (m :: * -> *).
M m =>
Id -> SynthName -> [Track] -> m BlockId
Ui.create_block Id
bid SynthName
title []
    forall (m :: * -> *). M m => BlockId -> m ()
Ui.set_root_id BlockId
bid
    [TrackId]
tids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Track]]
track_groups) forall a b. (a -> b) -> a -> b
$ \Track
t -> do
        Id
tid <- forall (m :: * -> *). M m => BlockId -> m Id
GenId.track_id BlockId
bid
        forall (m :: * -> *). M m => Id -> Track -> m TrackId
Ui.create_track Id
tid Track
t
    forall (m :: * -> *). M m => BlockId -> TrackNum -> Track -> m ()
Ui.insert_track BlockId
bid TrackNum
0 forall a b. (a -> b) -> a -> b
$ TracklikeId -> TrackNum -> Track
Block.track (RulerId -> TracklikeId
Block.RId RulerId
Ui.no_ruler) TrackNum
40
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => BlockId -> TrackNum -> Track -> m ()
Ui.insert_track BlockId
bid TrackNum
999 forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackId -> Track
block_track) [TrackId]
tids
    -- Ui.set_skeleton bid $ Skeleton.make $ note_track_edges track_groups
    forall (m :: * -> *). M m => Instrument -> Qualified -> m ()
allocate Instrument
inst_name Qualified
instrument
    forall (m :: * -> *). M m => Instrument -> Qualified -> m ()
allocate Instrument
metronome_name (SynthName -> SynthName -> Qualified
InstT.Qualified SynthName
"sampler" SynthName
"metronome")
    where
    block_track :: TrackId -> Track
block_track TrackId
tid = TracklikeId -> TrackNum -> Track
Block.track (TrackId -> RulerId -> TracklikeId
Block.TId TrackId
tid RulerId
Ui.no_ruler) TrackNum
40

-- -- | TODO this is much like the one in Cmd.Load.Midi, and the one in
-- -- Cmd.Load.Mod.  I should have a common track creator.
-- note_track_edges :: [[a]] -> [Skeleton.Edge]
-- note_track_edges = concat . snd . List.mapAccumL edges 1
--     where
--     edges n tracks = (end, zip ns (drop 1 ns))
--         where
--         end = n + length tracks
--         ns = [n .. end-1]

metronome_name :: ScoreT.Instrument
metronome_name :: Instrument
metronome_name = Instrument
"metronome"

inst_name :: ScoreT.Instrument
inst_name :: Instrument
inst_name = Instrument
"instrument"

allocate :: Ui.M m => ScoreT.Instrument -> InstT.Qualified -> m ()
allocate :: forall (m :: * -> *). M m => Instrument -> Qualified -> m ()
allocate Instrument
inst Qualified
qualified = do
    let alloc :: Allocation
alloc = Qualified -> Backend -> Allocation
UiConfig.allocation Qualified
qualified Backend
UiConfig.Im
    -- I just trust that this is an im synth and it exists.
    -- Otherwise I need the inst db from Cmd.
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Lens Config (Map Instrument Allocation)
UiConfig.allocations_map forall f a. Lens f a -> (a -> a) -> f -> f
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Instrument
inst Allocation
alloc

-- * make_tracks

-- | This is the same as 'ModifyNotes.NoteTrack', so I can convert to one of
-- those, but I don't want to incur the dependency for just that type.
data NoteTrack = NoteTrack !ScoreT.Instrument !Events.Events !Controls
    deriving (NoteTrack -> NoteTrack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteTrack -> NoteTrack -> Bool
$c/= :: NoteTrack -> NoteTrack -> Bool
== :: NoteTrack -> NoteTrack -> Bool
$c== :: NoteTrack -> NoteTrack -> Bool
Eq, TrackNum -> NoteTrack -> [Char] -> [Char]
[NoteTrack] -> [Char] -> [Char]
NoteTrack -> [Char]
forall a.
(TrackNum -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [NoteTrack] -> [Char] -> [Char]
$cshowList :: [NoteTrack] -> [Char] -> [Char]
show :: NoteTrack -> [Char]
$cshow :: NoteTrack -> [Char]
showsPrec :: TrackNum -> NoteTrack -> [Char] -> [Char]
$cshowsPrec :: TrackNum -> NoteTrack -> [Char] -> [Char]
Show)
type Controls = Map Control Events.Events
data Control = Pitch Pitch.ScaleId | Control ScoreT.Control
    deriving (Control -> Control -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Control -> Control -> Bool
$c/= :: Control -> Control -> Bool
== :: Control -> Control -> Bool
$c== :: Control -> Control -> Bool
Eq, Eq Control
Control -> Control -> Bool
Control -> Control -> Ordering
Control -> Control -> Control
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 :: Control -> Control -> Control
$cmin :: Control -> Control -> Control
max :: Control -> Control -> Control
$cmax :: Control -> Control -> Control
>= :: Control -> Control -> Bool
$c>= :: Control -> Control -> Bool
> :: Control -> Control -> Bool
$c> :: Control -> Control -> Bool
<= :: Control -> Control -> Bool
$c<= :: Control -> Control -> Bool
< :: Control -> Control -> Bool
$c< :: Control -> Control -> Bool
compare :: Control -> Control -> Ordering
$ccompare :: Control -> Control -> Ordering
Ord, TrackNum -> Control -> [Char] -> [Char]
[Control] -> [Char] -> [Char]
Control -> [Char]
forall a.
(TrackNum -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Control] -> [Char] -> [Char]
$cshowList :: [Control] -> [Char] -> [Char]
show :: Control -> [Char]
$cshow :: Control -> [Char]
showsPrec :: TrackNum -> Control -> [Char] -> [Char]
$cshowsPrec :: TrackNum -> Control -> [Char] -> [Char]
Show)

make_tracks :: NoteTrack -> [Track.Track]
make_tracks :: NoteTrack -> [Track]
make_tracks (NoteTrack Instrument
inst Events
events Controls
controls) =
    SynthName -> Events -> Track
Track.track (Instrument -> SynthName
ParseTitle.instrument_to_title Instrument
inst) Events
events
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Control, Events) -> Track
control (forall k a. Map k a -> [(k, a)]
Map.toAscList Controls
controls)
    where control :: (Control, Events) -> Track
control (Control
c, Events
events) = SynthName -> Events -> Track
Track.track (Control -> SynthName
control_to_title Control
c) Events
events

control_to_title :: Control -> Text
control_to_title :: Control -> SynthName
control_to_title Control
control = case Control
control of
    Control Control
c -> Typed Control -> SynthName
ParseTitle.control_to_title forall a b. (a -> b) -> a -> b
$ forall a. a -> Typed a
ScoreT.untyped Control
c
    Pitch ScaleId
scale_id -> ScaleId -> SynthName
ParseTitle.scale_to_title ScaleId
scale_id

to_note_track :: ToScore.ToScore stroke -> TrackTime
    -> [S.Flat g (Realize.Note stroke)] -> NoteTrack
to_note_track :: forall stroke g.
ToScore stroke -> TrackTime -> [Flat g (Note stroke)] -> NoteTrack
to_note_track ToScore stroke
to_score TrackTime
akshara_dur [Flat g (Note stroke)]
strokes =
    Instrument -> Events -> Controls -> NoteTrack
NoteTrack Instrument
ScoreT.empty_instrument ([(Duration, Duration, SynthName)] -> Events
mk_events [(Duration, Duration, SynthName)]
notes) Controls
control_tracks
    where
    controls :: [(Text, [ToScore.Event])]
    ([(Duration, Duration, SynthName)]
notes, [(SynthName, [(Duration, Duration, SynthName)])]
controls) = forall stroke g.
ToScore stroke
-> [Flat g (Note stroke)]
-> ([(Duration, Duration, SynthName)],
    [(SynthName, [(Duration, Duration, SynthName)])])
ToScore.fromStrokes ToScore stroke
to_score [Flat g (Note stroke)]
strokes
    pitches :: [(Duration, Duration, SynthName)]
pitches = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SynthName
"*" [(SynthName, [(Duration, Duration, SynthName)])]
controls
    pitch_track :: Maybe (Control, Events)
pitch_track
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Duration, Duration, SynthName)]
pitches = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just (ScaleId -> Control
Pitch ScaleId
Pitch.empty_scale, [(Duration, Duration, SynthName)] -> Events
mk_events [(Duration, Duration, SynthName)]
pitches)
    control_tracks :: Controls
control_tracks = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe (Control, Events)
pitch_track forall a b. (a -> b) -> a -> b
$
        [ (Control -> Control
Control (SynthName -> Control
ScoreT.Control SynthName
control), [(Duration, Duration, SynthName)] -> Events
mk_events [(Duration, Duration, SynthName)]
events)
        | (SynthName
control, [(Duration, Duration, SynthName)]
events) <- [(SynthName, [(Duration, Duration, SynthName)])]
controls
        , SynthName
control forall a. Eq a => a -> a -> Bool
/= SynthName
"*"
        ]
    mk_events :: [(Duration, Duration, SynthName)] -> Events
mk_events = [Event] -> Events
Events.from_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (Real a, Real a) => (a, a, SynthName) -> Event
mk_event
    mk_event :: (a, a, SynthName) -> Event
mk_event (a
start, a
dur, SynthName
text) =
        TrackTime -> TrackTime -> SynthName -> Event
Event.event (forall a b. (Real a, Fractional b) => a -> b
realToFrac a
start forall a. Num a => a -> a -> a
* TrackTime
akshara_dur)
            (forall a b. (Real a, Fractional b) => a -> b
realToFrac a
dur forall a. Num a => a -> a -> a
* TrackTime
akshara_dur) SynthName
text

-- | This needs tala, akshara_dur, base pitch
--
-- I can either hardcode patterns for each tala, or write a generator.
--
-- TODO this is just [(start, dur, pitch, dyn)] -> [Track], which I should have
-- already.
tala_metronome :: Talas.Tala -> TrackTime -> TrackTime
    -> [(TrackTime, TrackTime, Text, Double)]
tala_metronome :: Tala
-> TrackTime
-> TrackTime
-> [(TrackTime, TrackTime, SynthName, Double)]
tala_metronome (Talas.Hindustani Tal
_) TrackTime
_ TrackTime
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"hindustani not implemented"
tala_metronome (Talas.Carnatic Tala
tala) TrackTime
akshara_dur TrackTime
end =
        forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(TrackTime
s, TrackTime
_, SynthName
_, Double
_) -> TrackTime
s forall a. Ord a => a -> a -> Bool
< TrackTime
end)
    [ (TrackTime
s, TrackTime
0, SynthName
pitch, Double
dyn)
    | (TrackTime
s, Just (SynthName
pitch, Double
dyn)) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ TrackTime
0 TrackTime
akshara_dur) (forall a. [a] -> [a]
cycle [Maybe (SynthName, Double)]
pattern)
    ]
    where
    pattern :: [Maybe (SynthName, Double)]
pattern = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Anga -> [Maybe (SynthName, Double)]
make (Tala -> [Anga]
Tala._angas Tala
tala)
    make :: Anga -> [Maybe (SynthName, Double)]
make = \case
        Tala.Clap TrackNum
n -> forall a. a -> Maybe a
Just (SynthName
clap, Double
1) forall a. a -> [a] -> [a]
: forall a. TrackNum -> a -> [a]
replicate (TrackNum
nforall a. Num a => a -> a -> a
-TrackNum
1) forall a. Maybe a
Nothing
        Tala.Wave TrackNum
n -> forall a. a -> Maybe a
Just (SynthName
wave, Double
0.75) forall a. a -> [a] -> [a]
: forall a. TrackNum -> a -> [a]
replicate (TrackNum
nforall a. Num a => a -> a -> a
-TrackNum
1) forall a. Maybe a
Nothing
        Anga
Tala.I -> forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            (SynthName
beat, Double
1) forall a. a -> [a] -> [a]
: forall a. TrackNum -> a -> [a]
replicate (Tala -> TrackNum
Tala._jati Tala
tala forall a. Num a => a -> a -> a
- TrackNum
1) (SynthName
beat, Double
0.85)
        Anga
Tala.O -> forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [(SynthName
clap, Double
1), (SynthName
wave, Double
1)]
        Anga
Tala.U -> forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [(SynthName
clap, Double
1)]
    clap :: SynthName
clap = SynthName
"3p"
    wave :: SynthName
wave = SynthName
"4p"
    beat :: SynthName
beat = SynthName
"4s"

make_track :: ScoreT.Instrument -> [(TrackTime, TrackTime, Text, Double)]
    -> NoteTrack
make_track :: Instrument
-> [(TrackTime, TrackTime, SynthName, Double)] -> NoteTrack
make_track Instrument
inst [(TrackTime, TrackTime, SynthName, Double)]
notes =
    Instrument -> Events -> Controls -> NoteTrack
NoteTrack Instrument
inst ([(TrackTime, TrackTime, SynthName)] -> Events
mk_events [(TrackTime, TrackTime, SynthName)]
events) (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Control, Events)
pitch_track, (Control, Events)
dyn_track])
    where
    pitch_track :: (Control, Events)
pitch_track = (ScaleId -> Control
Pitch ScaleId
Pitch.empty_scale, [(TrackTime, TrackTime, SynthName)] -> Events
mk_events [(TrackTime, TrackTime, SynthName)]
pitches)
    dyn_track :: (Control, Events)
dyn_track = (Control -> Control
Control Control
Controls.dynamic , [(TrackTime, TrackTime, SynthName)] -> Events
mk_events [(TrackTime, TrackTime, SynthName)]
dyns)
    events :: [(TrackTime, TrackTime, SynthName)]
events = [(TrackTime
s, TrackTime
d, SynthName
"") | (TrackTime
s, TrackTime
d, SynthName
_, Double
_) <- [(TrackTime, TrackTime, SynthName, Double)]
notes]
    pitches :: [(TrackTime, TrackTime, SynthName)]
pitches = [(TrackTime
s, TrackTime
0, SynthName
pitch) | (TrackTime
s, TrackTime
_, SynthName
pitch, Double
_) <- [(TrackTime, TrackTime, SynthName, Double)]
notes]
    dyns :: [(TrackTime, TrackTime, SynthName)]
dyns = [(TrackTime
s, TrackTime
0, forall a. ShowVal a => a -> SynthName
ShowVal.show_val Double
dyn) | (TrackTime
s, TrackTime
_, SynthName
_, Double
dyn) <- [(TrackTime, TrackTime, SynthName, Double)]
notes]
    mk_events :: [(TrackTime, TrackTime, SynthName)] -> Events
mk_events = [Event] -> Events
Events.from_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
Control.uncurry3 TrackTime -> TrackTime -> SynthName -> Event
Event.event)