-- Copyright 2014 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Calls for Balinese instruments.
module Cmd.Instrument.Bali where
import qualified Data.List as List

import qualified Util.Doc as Doc
import qualified Cmd.Cmd as Cmd
import qualified Cmd.InputNote as InputNote
import qualified Cmd.Instrument.MidiInst as MidiInst
import qualified Cmd.MidiThru as MidiThru
import qualified Cmd.Perf as Perf
import qualified Cmd.Selection as Selection

import qualified Derive.Args as Args
import qualified Derive.C.Bali.Gangsa as Gangsa
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.Call as Call
import qualified Derive.Call.Sub as Sub
import qualified Derive.Derive as Derive
import qualified Derive.Eval as Eval
import qualified Derive.Instrument.DUtil as DUtil
import qualified Derive.Scale as Scale
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Symbols as Symbols

import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import Global
import Types


pasang_msg :: Text
pasang_msg :: Text
pasang_msg = Text
"must be realized via `unison`, `kempyung`, `k`, &co"

-- | Emit events for both polos and sangsih.
pasang_code :: MidiInst.Code
pasang_code :: Code
pasang_code = ThruFunction -> Code
MidiInst.thru ThruFunction
pasang_thru

-- | Dispatch MIDI through to both polos and sangsih instruments.
pasang_thru :: Cmd.ThruFunction
pasang_thru :: ThruFunction
pasang_thru Scale
scale Attributes
_attrs Input
input = do
    (BlockId, Maybe TrackId)
track <- forall (m :: * -> *). M m => m (BlockId, Maybe TrackId)
Selection.track
    Maybe Instrument
polos <- forall (m :: * -> *) a.
(M m, Typecheck a) =>
(BlockId, Maybe TrackId) -> Text -> m (Maybe a)
Perf.lookup_val (BlockId, Maybe TrackId)
track Text
Gangsa.inst_polos
    Maybe Instrument
sangsih <- forall (m :: * -> *) a.
(M m, Typecheck a) =>
(BlockId, Maybe TrackId) -> Text -> m (Maybe a)
Perf.lookup_val (BlockId, Maybe TrackId)
track Text
Gangsa.inst_sangsih
    [Thru]
p_thru <- case Maybe Instrument
polos of
        Maybe Instrument
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just Instrument
inst -> do
            Attributes
attrs <- forall (m :: * -> *). M m => Instrument -> m Attributes
Cmd.get_instrument_attributes Instrument
inst
            Instrument -> ThruFunction
MidiThru.for_instrument Instrument
inst Scale
scale Attributes
attrs Input
input
    [Thru]
s_thru <- case Maybe Instrument
sangsih of
        Maybe Instrument
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just Instrument
inst -> do
            Attributes
attrs <- forall (m :: * -> *). M m => Instrument -> m Attributes
Cmd.get_instrument_attributes Instrument
inst
            Instrument -> ThruFunction
MidiThru.for_instrument Instrument
inst Scale
scale Attributes
attrs forall a b. (a -> b) -> a -> b
$
                forall x. Octave -> GenericInput x -> GenericInput x
InputNote.offset_note_id Octave
1 Input
input
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Thru]
p_thru forall a. [a] -> [a] -> [a]
++ [Thru]
s_thru

zero_dur_mute :: Signal.Y -> MidiInst.Code
zero_dur_mute :: Y -> Code
zero_dur_mute Y
dyn = Doc
-> (NoteArgs -> NoteDeriver -> NoteDeriver)
-> (NoteArgs -> NoteDeriver)
-> Code
zero_dur_mute_with Doc
"" (\NoteArgs
_ -> forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
dyn)
    (Config -> NoteArgs -> NoteDeriver
Note.default_note Config
Note.use_attributes)

gangsa_note :: Signal.Y -> Maybe Scale.Range -> MidiInst.Code
gangsa_note :: Y -> Maybe Range -> Code
gangsa_note Y
dyn Maybe Range
maybe_range = Doc
-> (NoteArgs -> NoteDeriver -> NoteDeriver)
-> (NoteArgs -> NoteDeriver)
-> Code
zero_dur_mute_with (Maybe Range -> Doc
doc Maybe Range
maybe_range)
    (\NoteArgs
_ -> forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
dyn)
    forall a b. (a -> b) -> a -> b
$ \NoteArgs
args -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Range
top -> forall a. Range -> ScoreTime -> Deriver a -> Deriver a
wrap Range
top (forall a. PassedArgs a -> ScoreTime
Args.start NoteArgs
args)) Maybe Range
maybe_range forall a b. (a -> b) -> a -> b
$
        Config -> NoteArgs -> NoteDeriver
Note.default_note Config
Note.use_attributes NoteArgs
args
    where
    doc :: Maybe Range -> Doc
doc Maybe Range
Nothing = Doc
""
    doc (Just (Scale.Range Pitch
bottom Pitch
top)) =
        Doc
" Any pitch below " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty Pitch
bottom forall a. Semigroup a => a -> a -> a
<> Doc
" or above "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty Pitch
top forall a. Semigroup a => a -> a -> a
<> Doc
" will be transposed down by octaves until it\
        \ fits in the instrument's range."

zero_dur_mute_with :: Doc.Doc
    -> (Derive.NoteArgs -> Derive.NoteDeriver -> Derive.NoteDeriver)
    -> (Derive.NoteArgs -> Derive.NoteDeriver)
    -> MidiInst.Code
zero_dur_mute_with :: Doc
-> (NoteArgs -> NoteDeriver -> NoteDeriver)
-> (NoteArgs -> NoteDeriver)
-> Code
zero_dur_mute_with Doc
doc NoteArgs -> NoteDeriver -> NoteDeriver
transform NoteArgs -> NoteDeriver
note =
    Generator Event -> Code
MidiInst.null_call forall a b. (a -> b) -> a -> b
$ CallName
-> Doc
-> (NoteArgs -> NoteDeriver)
-> (NoteArgs -> NoteDeriver)
-> Generator Event
DUtil.zero_duration CallName
"note"
        (Doc
"When the event has zero duration, dispatch to the "
            forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Symbol
Symbols.mute forall a. Semigroup a => a -> a -> a
<> Doc
" call." forall a. Semigroup a => a -> a -> a
<> Doc
doc)
        -- This only needs to invert if the transform needs it.  Otherwise,
        -- mute should do that.
        (forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \NoteArgs
args -> NoteArgs -> NoteDeriver -> NoteDeriver
transform NoteArgs
args forall a b. (a -> b) -> a -> b
$ NoteArgs -> NoteDeriver
reapply_mute NoteArgs
args)
        (forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting NoteArgs -> NoteDeriver
note)

reapply_mute :: Derive.NoteArgs -> Derive.NoteDeriver
reapply_mute :: NoteArgs -> NoteDeriver
reapply_mute NoteArgs
args = forall d.
CallableExpr d =>
Context d -> Symbol -> [Term] -> Deriver (Stream d)
Eval.reapply_call (forall a. PassedArgs a -> Context a
Args.context NoteArgs
args) Symbol
Symbols.mute []

wrap :: Scale.Range -> ScoreTime -> Derive.Deriver a -> Derive.Deriver a
wrap :: forall a. Range -> ScoreTime -> Deriver a -> Deriver a
wrap Range
range ScoreTime
start Deriver a
deriver = do
    (Note -> Maybe Pitch
parse_p, Pitch -> Maybe Note
show_p, Transposition -> Octave -> Pitch -> Maybe Pitch
_) <- Deriver
  (Note -> Maybe Pitch, Pitch -> Maybe Note,
   Transposition -> Octave -> Pitch -> Maybe Pitch)
Call.get_pitch_functions
    Pitch
from_pitch <- (Note -> Maybe Pitch) -> RealTime -> Deriver State Error Pitch
Call.get_parsed_pitch Note -> Maybe Pitch
parse_p forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    Transposed
to_pitch <- (Pitch -> Maybe Note) -> ScoreTime -> Pitch -> Deriver Transposed
Call.eval_pitch Pitch -> Maybe Note
show_p ScoreTime
start (Range -> Pitch -> Pitch
wrap_octaves Range
range Pitch
from_pitch)
    forall a. Transposed -> Deriver a -> Deriver a
Call.with_transposed_pitch Transposed
to_pitch Deriver a
deriver

wrap_octaves :: Scale.Range -> Pitch.Pitch -> Pitch.Pitch
wrap_octaves :: Range -> Pitch -> Pitch
wrap_octaves (Scale.Range Pitch
bottom Pitch
top) Pitch
pitch
    | Pitch
pitch forall a. Ord a => a -> a -> Bool
> Pitch
top = [Octave] -> Pitch
try [Pitch -> Octave
octave Pitch
top, Pitch -> Octave
octave Pitch
top forall a. Num a => a -> a -> a
- Octave
1]
    | Pitch
pitch forall a. Ord a => a -> a -> Bool
< Pitch
bottom = [Octave] -> Pitch
try [Pitch -> Octave
octave Pitch
bottom, Pitch -> Octave
octave Pitch
bottom forall a. Num a => a -> a -> a
+ Octave
1]
    | Bool
otherwise = Pitch
pitch
    where
    try :: [Octave] -> Pitch
try = forall a. a -> Maybe a -> a
fromMaybe Pitch
pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Pitch -> Bool
in_range
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Octave
oct -> Pitch
pitch { pitch_octave :: Octave
Pitch.pitch_octave = Octave
oct })
    octave :: Pitch -> Octave
octave = Pitch -> Octave
Pitch.pitch_octave
    in_range :: Pitch -> Bool
in_range Pitch
p = Pitch
bottom forall a. Ord a => a -> a -> Bool
<= Pitch
p Bool -> Bool -> Bool
&& Pitch
p forall a. Ord a => a -> a -> Bool
<= Pitch
top