-- Copyright 2013 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 DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{- | Calls for gangsa techniques.  Gangsa come in polos and sangsih pairs,
    and play either kotekan patterns or play unison or parallel parts.

    Kotekan patterns have a number of features in common.  They are all
    transpositions from a base pitch.  Rhythmically, they consist of notes with
    a constant duration, that line up at the end of an event's range, and the
    last duration is negative (i.e. implicit, depending on the next note).
    They use polos and sangsih and may switch patterns when the a kotekan speed
    threshold is passed.  Notes are also possibly muted.

    There are a number of ways this can be extended:

    - Use any attribute instead of just mute.
    - More instruments than just polos and sangsih.
    - Multiple kotekan thresholds.

    The first two are supported at the 'KotekanNote' level of abstraction.  For
    the others, I have to either directly use 'Note's or create a new
    abstraction:

    - Variable durations.
-}
module Derive.C.Bali.Gangsa where
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text

import qualified Util.CallStack as CallStack
import qualified Util.Doc as Doc
import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq

import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Bali.Gender as Gender
import qualified Derive.C.Post.Postproc as Postproc
import qualified Derive.Call as Call
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.StaticMacro as StaticMacro
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Flags as Flags
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale as Scale
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

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

import qualified Ui.Event as Event
import qualified Ui.Types as Types

import           Global
import           Types


library :: Library.Library
library :: Library
library = [Library] -> Library
forall a. Monoid a => [a] -> a
mconcat
    [ [(Symbol, Generator Note)] -> Library
forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
"norot", Bool -> Maybe Bool -> Generator Note
c_norot Bool
False Maybe Bool
forall a. Maybe a
Nothing)
        -- Alias for norot.  It's separate so I can rebind this locally.
        , (Symbol
"nt", Bool -> Maybe Bool -> Generator Note
c_norot Bool
False Maybe Bool
forall a. Maybe a
Nothing)
        , (Symbol
"nt-", Bool -> Maybe Bool -> Generator Note
c_norot Bool
False (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False))
        , (Symbol
"nt<", Bool -> Maybe Bool -> Generator Note
c_norot Bool
True Maybe Bool
forall a. Maybe a
Nothing)
        , (Symbol
"nt<-", Bool -> Maybe Bool -> Generator Note
c_norot Bool
True (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False))
        , (Symbol
"gnorot", Generator Note
c_gender_norot)
        , (Symbol
"k_\\", KotekanStyle -> KotekanPattern -> Generator Note
c_kotekan_irregular KotekanStyle
Pat (KotekanPattern -> Generator Note)
-> KotekanPattern -> Generator Note
forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
IrregularPattern -> KotekanPattern
irregular_pattern (IrregularPattern -> KotekanPattern)
-> IrregularPattern -> KotekanPattern
forall a b. (a -> b) -> a -> b
$
            IrregularPattern
            { ir_polos :: [Char]
ir_polos              = [Char]
"-11-1321"
            , ir_sangsih4 :: [Char]
ir_sangsih4           = [Char]
"-44-43-4"
            , ir_polos_ngotek :: [Char]
ir_polos_ngotek       = [Char]
"-11-1-21"
            , ir_sangsih_ngotek3 :: [Char]
ir_sangsih_ngotek3    = [Char]
"3-32-32-"
            , ir_sangsih_ngotek4 :: [Char]
ir_sangsih_ngotek4    = [Char]
"-44-43-4"
            })
        , (Symbol
"k-\\", KotekanStyle -> KotekanPattern -> Generator Note
c_kotekan_irregular KotekanStyle
Pat (KotekanPattern -> Generator Note)
-> KotekanPattern -> Generator Note
forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
IrregularPattern -> KotekanPattern
irregular_pattern (IrregularPattern -> KotekanPattern)
-> IrregularPattern -> KotekanPattern
forall a b. (a -> b) -> a -> b
$
            IrregularPattern
            { ir_polos :: [Char]
ir_polos              = [Char]
"211-1321"
            , ir_sangsih4 :: [Char]
ir_sangsih4           = [Char]
"-44-43-4"
            , ir_polos_ngotek :: [Char]
ir_polos_ngotek       = [Char]
"211-1-21"
            , ir_sangsih_ngotek3 :: [Char]
ir_sangsih_ngotek3    = [Char]
"3-32-32-"
            , ir_sangsih_ngotek4 :: [Char]
ir_sangsih_ngotek4    = [Char]
"-44-43-4"
            })
        , (Symbol
"k//\\\\", KotekanStyle -> KotekanPattern -> Generator Note
c_kotekan_irregular KotekanStyle
Pat (KotekanPattern -> Generator Note)
-> KotekanPattern -> Generator Note
forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
IrregularPattern -> KotekanPattern
irregular_pattern (IrregularPattern -> KotekanPattern)
-> IrregularPattern -> KotekanPattern
forall a b. (a -> b) -> a -> b
$
            IrregularPattern
            { ir_polos :: [Char]
ir_polos              = [Char]
"-123123213213123"
            , ir_sangsih4 :: [Char]
ir_sangsih4           = [Char]
"-423423243243423"
            , ir_polos_ngotek :: [Char]
ir_polos_ngotek       = [Char]
"-12-12-21-21-12-"
            , ir_sangsih_ngotek3 :: [Char]
ir_sangsih_ngotek3    = [Char]
"3-23-232-32-3-23"
            , ir_sangsih_ngotek4 :: [Char]
ir_sangsih_ngotek4    = [Char]
"-4-34-3-43-434-3"
            })
        -- There are two ways to play k\\, either 21321321 or 31321321.  The
        -- first one is irregular since sangsih starts on 2 but there's no
        -- unison polos.
        , (Symbol
"k\\\\", KotekanStyle -> KotekanPattern -> Generator Note
c_kotekan_irregular KotekanStyle
Telu (KotekanPattern -> Generator Note)
-> KotekanPattern -> Generator Note
forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
IrregularPattern -> KotekanPattern
irregular_pattern (IrregularPattern -> KotekanPattern)
-> IrregularPattern -> KotekanPattern
forall a b. (a -> b) -> a -> b
$
            IrregularPattern
            { ir_polos :: [Char]
ir_polos              = [Char]
"21321321"
            , ir_sangsih4 :: [Char]
ir_sangsih4           = [Char]
"24324324"
            , ir_polos_ngotek :: [Char]
ir_polos_ngotek       = [Char]
"-1-21-21"
            , ir_sangsih_ngotek3 :: [Char]
ir_sangsih_ngotek3    = [Char]
"2-32-32-"
            , ir_sangsih_ngotek4 :: [Char]
ir_sangsih_ngotek4    = [Char]
"-43-43-4"
            })
        , (Symbol
"k//", KotekanStyle -> KotekanPattern -> Generator Note
c_kotekan_irregular KotekanStyle
Telu (KotekanPattern -> Generator Note)
-> KotekanPattern -> Generator Note
forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
IrregularPattern -> KotekanPattern
irregular_pattern (IrregularPattern -> KotekanPattern)
-> IrregularPattern -> KotekanPattern
forall a b. (a -> b) -> a -> b
$
            IrregularPattern
            { ir_polos :: [Char]
ir_polos              = [Char]
"23123123"
            , ir_sangsih4 :: [Char]
ir_sangsih4           = [Char]
"20120120"
            , ir_polos_ngotek :: [Char]
ir_polos_ngotek       = [Char]
"-3-23-23"
            , ir_sangsih_ngotek3 :: [Char]
ir_sangsih_ngotek3    = [Char]
"2-12-12-"
            , ir_sangsih_ngotek4 :: [Char]
ir_sangsih_ngotek4    = [Char]
"-01-01-0"
            })
        , (Symbol
"k\\\\2", Bool -> Maybe Text -> KotekanStyle -> Generator Note
c_kotekan_regular Bool
False (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"-1-21-21") KotekanStyle
Telu)
        , (Symbol
"k//2",   Bool -> Maybe Text -> KotekanStyle -> Generator Note
c_kotekan_regular Bool
False (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"-2-12-12") KotekanStyle
Telu)
        -- This is k// but with sangsih above.
        -- TODO maybe a more natural way to express this would be to make k//
        -- understand sangsih=u?  But then I also need sangsih=d for k\\,
        -- irregular_pattern support for sangsih direction, and they both become
        -- irregular.
        , (Symbol
"k//^",   Bool -> Maybe Text -> KotekanStyle -> Generator Note
c_kotekan_regular Bool
False (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"2-12-12-") KotekanStyle
Telu)

        , (Symbol
"kotekan", Generator Note
c_kotekan_kernel)
        , (Symbol
"k", Bool -> Maybe Text -> KotekanStyle -> Generator Note
c_kotekan_regular Bool
False Maybe Text
forall a. Maybe a
Nothing KotekanStyle
Telu)
        , (Symbol
"k^", Bool -> Maybe Text -> KotekanStyle -> Generator Note
c_kotekan_regular Bool
True Maybe Text
forall a. Maybe a
Nothing KotekanStyle
Telu)
        , (Symbol
"ke", Generator Note
c_kotekan_explicit)
        ]
    , [(Symbol, Generator Note)] -> Library
forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators ([(Symbol, Generator Note)] -> Library)
-> [(Symbol, Generator Note)] -> Library
forall a b. (a -> b) -> a -> b
$ (Parser (Maybe Transpose) -> Generator Note)
-> [(Symbol, Generator Note)]
forall call. (Parser (Maybe Transpose) -> call) -> [(Symbol, call)]
Gender.ngoret_variations Parser (Maybe Transpose) -> Generator Note
c_ngoret
    , [(Symbol, Transformer Note)] -> Library
forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"i+", Module -> CallName -> Text -> Bool -> Doc -> Transformer Note
forall a d.
(ShowVal a, ToVal a, Taggable d) =>
Module -> CallName -> Text -> a -> Doc -> Transformer d
Make.environ_val Module
module_ CallName
"i+" Text
"initial" Bool
True
            Doc
"Kotekan calls will emit a note on the initial beat.")
        , (Symbol
"i-", Module -> CallName -> Text -> Bool -> Doc -> Transformer Note
forall a d.
(ShowVal a, ToVal a, Taggable d) =>
Module -> CallName -> Text -> a -> Doc -> Transformer d
Make.environ_val Module
module_ CallName
"i-" Text
"initial" Bool
False
            Doc
"Kotekan calls won't emit a note on the initial beat.")
        , (Symbol
"f-", Module -> CallName -> Text -> Bool -> Doc -> Transformer Note
forall a d.
(ShowVal a, ToVal a, Taggable d) =>
Module -> CallName -> Text -> a -> Doc -> Transformer d
Make.environ_val Module
module_ CallName
"f-" Text
"final" Bool
False
            Doc
"Kotekan calls won't emit a final note at the end time.")
        , (Symbol
"unison", Transformer Note
c_unison)
        , (Symbol
"noltol", Transformer Note
c_noltol)
        , (Symbol
"realize-gangsa", Transformer Note
c_realize_gangsa)
        , (Symbol
"realize-noltol", Transformer Note
c_realize_noltol)
        , (Symbol
"realize-ngoret", Module -> Transformer Note -> Transformer Note
forall f. Module -> Call f -> Call f
Derive.set_module Module
module_ Transformer Note
Gender.c_realize_ngoret)
        , (Symbol
"cancel-pasang", Transformer Note
c_cancel_pasang)
        ]
    , [(Symbol, Calls Note)] -> Library
forall d.
(ToLibrary (Generator d), ToLibrary (Transformer d)) =>
[(Symbol, Calls d)] -> Library
Library.both
        [ (Symbol
"nyog", Calls Note
c_nyogcag)
        , (Symbol
"kempyung", Calls Note
c_kempyung)
        , (Symbol
"k+", Calls Note
c_kempyung) -- short version for single notes
        , (Symbol
"p+", CallName -> Bool -> Bool -> Calls Note
c_derive_with CallName
"p+" Bool
True Bool
False)
        , (Symbol
"s+", CallName -> Bool -> Bool -> Calls Note
c_derive_with CallName
"s+" Bool
False Bool
True)
        , (Symbol
"ps+", CallName -> Bool -> Bool -> Calls Note
c_derive_with CallName
"ps+" Bool
True Bool
True)
        ]
    ]

module_ :: Module.Module
module_ :: Module
module_ = Module
"bali" Module -> Module -> Module
forall a. Semigroup a => a -> a -> a
<> Module
"gangsa"

c_derive_with :: Derive.CallName -> Bool -> Bool -> Library.Calls Derive.Note
c_derive_with :: CallName -> Bool -> Bool -> Calls Note
c_derive_with CallName
name Bool
with_polos Bool
with_sangsih =
    Module
-> CallName
-> Tags
-> Doc
-> Parser (Pasang Instrument)
-> (Pasang Instrument -> NoteDeriver -> NoteDeriver)
-> Calls Note
forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
module_ CallName
name Tags
Tags.inst
    Doc
"Derive the note with polos, sangsih, or both." Parser (Pasang Instrument)
pasang_env ((Pasang Instrument -> NoteDeriver -> NoteDeriver) -> Calls Note)
-> (Pasang Instrument -> NoteDeriver -> NoteDeriver) -> Calls Note
forall a b. (a -> b) -> a -> b
$
    \Pasang Instrument
pasang NoteDeriver
deriver -> [NoteDeriver] -> NoteDeriver
forall a. Monoid a => [a] -> a
mconcat ([NoteDeriver] -> NoteDeriver) -> [NoteDeriver] -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ [[NoteDeriver]] -> [NoteDeriver]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Instrument -> NoteDeriver -> NoteDeriver
forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang) NoteDeriver
deriver | Bool
with_polos]
        , [Instrument -> NoteDeriver -> NoteDeriver
forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang) NoteDeriver
deriver | Bool
with_sangsih]
        ]

-- * instrument postproc

-- | Variable mute for gangsa.  Intended for the 'Cmd.Cmd.inst_postproc' field.
-- This interprets 'Controls.mute' and turns it into either a @%mod@ control or
-- @mute_attr@.
mute_postproc :: Attrs.Attributes -> Score.Event -> (Score.Event, [Log.Msg])
mute_postproc :: Attributes -> Note -> (Note, [Msg])
mute_postproc Attributes
mute_attr Note
event = (,[]) (Note -> (Note, [Msg])) -> Note -> (Note, [Msg])
forall a b. (a -> b) -> a -> b
$
    case RealTime -> Control -> Note -> Maybe (Typed Y)
Score.control_at (Note -> RealTime
Score.event_start Note
event) Control
Controls.mute Note
event of
        Maybe (Typed Y)
Nothing -> Y -> Note -> Note
set_mod Y
0 Note
event
        Just Typed Y
tval
            | Y
mute Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
>= Y
threshold -> Attributes -> Note -> Note
Score.add_attributes Attributes
mute_attr Note
event
            | Y
mute Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
<= Y
0 -> Y -> Note -> Note
set_mod Y
0 Note
event
            -- The mod control goes from 1 (least muted) to 0 (most muted).
            -- Bias mod towards the higher values, since the most audible
            -- partial mutes are from .75--1.
            | Bool
otherwise -> Y -> Note -> Note
set_mod (Y
1 Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
muteY -> Y -> Y
forall a. Floating a => a -> a -> a
**Y
2) (Note -> Note) -> Note -> Note
forall a b. (a -> b) -> a -> b
$ RealTime -> Note -> Note
Score.set_duration RealTime
0 Note
event
            where
            mute :: Y
mute = Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val Typed Y
tval
    where
    set_mod :: Y -> Note -> Note
set_mod = Control -> Typed Control -> Note -> Note
Score.set_control Control
Controls.mod (Typed Control -> Note -> Note)
-> (Y -> Typed Control) -> Y -> Note -> Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Control -> Typed Control) -> (Y -> Control) -> Y -> Typed Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant
    -- Use the mute_attr above this threshold.
    threshold :: Y
threshold = Y
0.85

-- * ngoret

c_ngoret :: Sig.Parser (Maybe Pitch.Transpose) -> Derive.Generator Derive.Note
c_ngoret :: Parser (Maybe Transpose) -> Generator Note
c_ngoret = Module
-> Bool
-> Parser ControlRef
-> Parser (Maybe Transpose)
-> Generator Note
Gender.ngoret Module
module_ Bool
False (Parser ControlRef -> Parser (Maybe Transpose) -> Generator Note)
-> Parser ControlRef -> Parser (Maybe Transpose) -> Generator Note
forall a b. (a -> b) -> a -> b
$ ArgName -> ControlRef -> Doc -> Parser ControlRef
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"damp"
    (Control -> Y -> Type -> ControlRef
Sig.typed_control Control
"ngoret-damp" Y
0.15 Type
ScoreT.Real)
    Doc
"Time that the grace note overlaps with this one. So the total\
    \ duration is time+damp, though it will be clipped to the\
    \ end of the current note."

-- * patterns

-- | There are 4 ways to realize a kotekan:
--
-- 1. Undivided.  Since it's undivided it could be unison or kempyung.
-- 2. Slow but divided.  Play all the notes, but sangsih and polos are kempyung
-- on the outer notes.
-- 3, 4. Ngotek, in telu and pat versions.
data KotekanPattern = KotekanPattern {
    KotekanPattern -> [Maybe Int]
kotekan_telu :: ![Maybe Pitch.Step]
    , KotekanPattern -> [Maybe Int]
kotekan_pat :: ![Maybe Pitch.Step]
    , KotekanPattern -> Pasang [Maybe Int]
kotekan_interlock_telu :: !(Pasang [Maybe Pitch.Step])
    , KotekanPattern -> Pasang [Maybe Int]
kotekan_interlock_pat :: !(Pasang [Maybe Pitch.Step])
    } deriving (KotekanPattern -> KotekanPattern -> Bool
(KotekanPattern -> KotekanPattern -> Bool)
-> (KotekanPattern -> KotekanPattern -> Bool) -> Eq KotekanPattern
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KotekanPattern -> KotekanPattern -> Bool
$c/= :: KotekanPattern -> KotekanPattern -> Bool
== :: KotekanPattern -> KotekanPattern -> Bool
$c== :: KotekanPattern -> KotekanPattern -> Bool
Eq, Int -> KotekanPattern -> ShowS
[KotekanPattern] -> ShowS
KotekanPattern -> [Char]
(Int -> KotekanPattern -> ShowS)
-> (KotekanPattern -> [Char])
-> ([KotekanPattern] -> ShowS)
-> Show KotekanPattern
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [KotekanPattern] -> ShowS
$cshowList :: [KotekanPattern] -> ShowS
show :: KotekanPattern -> [Char]
$cshow :: KotekanPattern -> [Char]
showsPrec :: Int -> KotekanPattern -> ShowS
$cshowsPrec :: Int -> KotekanPattern -> ShowS
Show)

instance Pretty KotekanPattern where
    format :: KotekanPattern -> Doc
format (KotekanPattern [Maybe Int]
telu [Maybe Int]
pat Pasang [Maybe Int]
itelu Pasang [Maybe Int]
ipat) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"KotekanPattern"
        [ (Text
"telu", [Maybe Int] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Maybe Int]
telu)
        , (Text
"pat", [Maybe Int] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Maybe Int]
pat)
        , (Text
"interlock_telu", Pasang [Maybe Int] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Pasang [Maybe Int]
itelu)
        , (Text
"interlock_pat", Pasang [Maybe Int] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Pasang [Maybe Int]
ipat)
        ]

data Pasang a = Pasang {
    forall a. Pasang a -> a
polos :: a
    , forall a. Pasang a -> a
sangsih :: a
    } deriving (Pasang a -> Pasang a -> Bool
(Pasang a -> Pasang a -> Bool)
-> (Pasang a -> Pasang a -> Bool) -> Eq (Pasang a)
forall a. Eq a => Pasang a -> Pasang a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pasang a -> Pasang a -> Bool
$c/= :: forall a. Eq a => Pasang a -> Pasang a -> Bool
== :: Pasang a -> Pasang a -> Bool
$c== :: forall a. Eq a => Pasang a -> Pasang a -> Bool
Eq, Int -> Pasang a -> ShowS
[Pasang a] -> ShowS
Pasang a -> [Char]
(Int -> Pasang a -> ShowS)
-> (Pasang a -> [Char]) -> ([Pasang a] -> ShowS) -> Show (Pasang a)
forall a. Show a => Int -> Pasang a -> ShowS
forall a. Show a => [Pasang a] -> ShowS
forall a. Show a => Pasang a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Pasang a] -> ShowS
$cshowList :: forall a. Show a => [Pasang a] -> ShowS
show :: Pasang a -> [Char]
$cshow :: forall a. Show a => Pasang a -> [Char]
showsPrec :: Int -> Pasang a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Pasang a -> ShowS
Show)

instance Pretty a => Pretty (Pasang a) where
    format :: Pasang a -> Doc
format (Pasang a
polos a
sangsih) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Pasang"
        [ (Text
"polos", a -> Doc
forall a. Pretty a => a -> Doc
Pretty.format a
polos)
        , (Text
"sangsih", a -> Doc
forall a. Pretty a => a -> Doc
Pretty.format a
sangsih)
        ]

data Realization a = Realization {
    forall a. Realization a -> a
interlocking :: a
    , forall a. Realization a -> a
non_interlocking :: a
    } deriving (Realization a -> Realization a -> Bool
(Realization a -> Realization a -> Bool)
-> (Realization a -> Realization a -> Bool) -> Eq (Realization a)
forall a. Eq a => Realization a -> Realization a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Realization a -> Realization a -> Bool
$c/= :: forall a. Eq a => Realization a -> Realization a -> Bool
== :: Realization a -> Realization a -> Bool
$c== :: forall a. Eq a => Realization a -> Realization a -> Bool
Eq, Int -> Realization a -> ShowS
[Realization a] -> ShowS
Realization a -> [Char]
(Int -> Realization a -> ShowS)
-> (Realization a -> [Char])
-> ([Realization a] -> ShowS)
-> Show (Realization a)
forall a. Show a => Int -> Realization a -> ShowS
forall a. Show a => [Realization a] -> ShowS
forall a. Show a => Realization a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Realization a] -> ShowS
$cshowList :: forall a. Show a => [Realization a] -> ShowS
show :: Realization a -> [Char]
$cshow :: forall a. Show a => Realization a -> [Char]
showsPrec :: Int -> Realization a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Realization a -> ShowS
Show)

instance Pretty a => Pretty (Realization a) where
    format :: Realization a -> Doc
format (Realization a
inter a
non_inter) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Realization"
        [ (Text
"interlocking", a -> Doc
forall a. Pretty a => a -> Doc
Pretty.format a
inter)
        , (Text
"non_interlocking", a -> Doc
forall a. Pretty a => a -> Doc
Pretty.format a
non_inter)
        ]

data IrregularPattern = IrregularPattern
    { IrregularPattern -> [Char]
ir_polos :: [Char]
    , IrregularPattern -> [Char]
ir_sangsih4 :: [Char]
    , IrregularPattern -> [Char]
ir_polos_ngotek :: [Char]
    , IrregularPattern -> [Char]
ir_sangsih_ngotek3 :: [Char]
    , IrregularPattern -> [Char]
ir_sangsih_ngotek4 :: [Char]
    } deriving (Int -> IrregularPattern -> ShowS
[IrregularPattern] -> ShowS
IrregularPattern -> [Char]
(Int -> IrregularPattern -> ShowS)
-> (IrregularPattern -> [Char])
-> ([IrregularPattern] -> ShowS)
-> Show IrregularPattern
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [IrregularPattern] -> ShowS
$cshowList :: [IrregularPattern] -> ShowS
show :: IrregularPattern -> [Char]
$cshow :: IrregularPattern -> [Char]
showsPrec :: Int -> IrregularPattern -> ShowS
$cshowsPrec :: Int -> IrregularPattern -> ShowS
Show)

irregular_pattern :: CallStack.Stack => IrregularPattern -> KotekanPattern
irregular_pattern :: HasCallStack => IrregularPattern -> KotekanPattern
irregular_pattern (IrregularPattern {[Char]
ir_sangsih_ngotek4 :: [Char]
ir_sangsih_ngotek3 :: [Char]
ir_polos_ngotek :: [Char]
ir_sangsih4 :: [Char]
ir_polos :: [Char]
ir_sangsih_ngotek4 :: IrregularPattern -> [Char]
ir_sangsih_ngotek3 :: IrregularPattern -> [Char]
ir_polos_ngotek :: IrregularPattern -> [Char]
ir_sangsih4 :: IrregularPattern -> [Char]
ir_polos :: IrregularPattern -> [Char]
..}) = KotekanPattern
    { kotekan_telu :: [Maybe Int]
kotekan_telu = [Char] -> [Maybe Int]
parse1 [Char]
ir_polos
    , kotekan_pat :: [Maybe Int]
kotekan_pat = [Char] -> [Maybe Int]
parse1 [Char]
ir_sangsih4
    , kotekan_interlock_telu :: Pasang [Maybe Int]
kotekan_interlock_telu = Pasang
        { polos :: [Maybe Int]
polos = [Char] -> [Maybe Int]
parse1 [Char]
ir_polos_ngotek, sangsih :: [Maybe Int]
sangsih = [Char] -> [Maybe Int]
parse1 [Char]
ir_sangsih_ngotek3 }
    , kotekan_interlock_pat :: Pasang [Maybe Int]
kotekan_interlock_pat = Pasang
        { polos :: [Maybe Int]
polos = [Char] -> [Maybe Int]
parse1 [Char]
ir_polos_ngotek, sangsih :: [Maybe Int]
sangsih = [Char] -> [Maybe Int]
parse1 [Char]
ir_sangsih_ngotek4 }
    }
    where
    -- TODO the CallStack.Stack doesn't actually work because all these
    -- functions would have to have it too.
    parse1 :: [Char] -> [Maybe Int]
parse1 = HasCallStack => Int -> [Char] -> [Maybe Int]
Int -> [Char] -> [Maybe Int]
parse_pattern Int
destination ([Char] -> [Maybe Int]) -> ShowS -> [Char] -> [Maybe Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall {t :: * -> *} {a}. (Foldable t, Show (t a)) => t a -> t a
check
    check :: t a -> t a
check t a
ns
        | t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ns Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ir_polos = t a
ns
        | Bool
otherwise = Text -> t a
forall a. HasCallStack => Text -> a
errorStack (Text -> t a) -> Text -> t a
forall a b. (a -> b) -> a -> b
$ Text
"not same length as polos: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> t a -> Text
forall a. Show a => a -> Text
showt t a
ns
    destination :: Int
destination = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Text -> Int
forall a. HasCallStack => Text -> a
errorStack Text
"no final pitch") (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
        [Int] -> Maybe Int
forall a. [a] -> Maybe a
Seq.last ([Int] -> Maybe Int) -> [Int] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
Maybe.catMaybes ([Maybe Int] -> [Int]) -> [Maybe Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Int -> [Char] -> [Maybe Int]
Int -> [Char] -> [Maybe Int]
parse_pattern Int
0 [Char]
ir_polos

parse_pattern :: CallStack.Stack => Pitch.Step -> [Char] -> [Maybe Pitch.Step]
parse_pattern :: HasCallStack => Int -> [Char] -> [Maybe Int]
parse_pattern Int
destination = (Char -> Maybe Int) -> [Char] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
destination) (Maybe Int -> Maybe Int)
-> (Char -> Maybe Int) -> Char -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Maybe Int
parse1)
    where
    parse1 :: Char -> Maybe Int
parse1 Char
'-' = Maybe Int
forall a. Maybe a
Nothing
    parse1 Char
c = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Text -> Int
forall a. HasCallStack => Text -> a
errorStack (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ Text
"not a digit: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
forall a. Show a => a -> Text
showt Char
c) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
        Char -> Maybe Int
Num.readDigit Char
c

kotekan_pattern :: KotekanPattern -> KotekanStyle -> Pasang ScoreT.Instrument
    -> Cycle
kotekan_pattern :: KotekanPattern -> KotekanStyle -> Pasang Instrument -> Cycle
kotekan_pattern KotekanPattern
pattern KotekanStyle
style Pasang Instrument
pasang = Realization
    { interlocking :: [[KotekanNote]]
interlocking = [[(Maybe Instrument, Int)]] -> [[KotekanNote]]
realize (Realization [[(Maybe Instrument, Int)]]
-> [[(Maybe Instrument, Int)]]
forall a. Realization a -> a
interlocking Realization [[(Maybe Instrument, Int)]]
realization)
    , non_interlocking :: [[KotekanNote]]
non_interlocking = [[(Maybe Instrument, Int)]] -> [[KotekanNote]]
realize (Realization [[(Maybe Instrument, Int)]]
-> [[(Maybe Instrument, Int)]]
forall a. Realization a -> a
non_interlocking Realization [[(Maybe Instrument, Int)]]
realization)
    }
    where
    realization :: Realization [[(Maybe Instrument, Int)]]
realization = KotekanStyle
-> Pasang Instrument
-> KotekanPattern
-> Realization [[(Maybe Instrument, Int)]]
pattern_steps KotekanStyle
style Pasang Instrument
pasang KotekanPattern
pattern
    realize :: [[(Maybe Instrument, Int)]] -> [[KotekanNote]]
realize = ([(Maybe Instrument, Int)] -> [KotekanNote])
-> [[(Maybe Instrument, Int)]] -> [[KotekanNote]]
forall a b. (a -> b) -> [a] -> [b]
map (((Maybe Instrument, Int) -> KotekanNote)
-> [(Maybe Instrument, Int)] -> [KotekanNote]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe Instrument -> Int -> KotekanNote)
-> (Maybe Instrument, Int) -> KotekanNote
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Instrument -> Int -> KotekanNote
kotekan_note))

pattern_steps :: KotekanStyle -> Pasang ScoreT.Instrument -> KotekanPattern
    -> Realization [[(Maybe ScoreT.Instrument, Pitch.Step)]]
pattern_steps :: KotekanStyle
-> Pasang Instrument
-> KotekanPattern
-> Realization [[(Maybe Instrument, Int)]]
pattern_steps KotekanStyle
style Pasang Instrument
pasang (KotekanPattern [Maybe Int]
telu [Maybe Int]
pat Pasang [Maybe Int]
itelu Pasang [Maybe Int]
ipat) = Realization
    { interlocking :: [[(Maybe Instrument, Int)]]
interlocking = case KotekanStyle
style of
        KotekanStyle
Telu -> Pasang [Maybe Int] -> [[(Maybe Instrument, Int)]]
forall {a}. Pasang [Maybe a] -> [[(Maybe Instrument, a)]]
interlocking Pasang [Maybe Int]
itelu
        KotekanStyle
Pat -> Pasang [Maybe Int] -> [[(Maybe Instrument, Int)]]
forall {a}. Pasang [Maybe a] -> [[(Maybe Instrument, a)]]
interlocking Pasang [Maybe Int]
ipat
    , non_interlocking :: [[(Maybe Instrument, Int)]]
non_interlocking = case KotekanStyle
style of
        KotekanStyle
Telu -> (Maybe Int -> [(Maybe Instrument, Int)])
-> [Maybe Int] -> [[(Maybe Instrument, Int)]]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Instrument -> Maybe Int -> [(Maybe Instrument, Int)]
forall {t} {a}. t -> Maybe a -> [(t, a)]
realize Maybe Instrument
forall a. Maybe a
Nothing) [Maybe Int]
telu
        KotekanStyle
Pat -> Pasang [Maybe Int] -> [[(Maybe Instrument, Int)]]
forall {a}. Pasang [Maybe a] -> [[(Maybe Instrument, a)]]
interlocking (Pasang { polos :: [Maybe Int]
polos = [Maybe Int]
telu, sangsih :: [Maybe Int]
sangsih = [Maybe Int]
pat })
    }
    where
    realize :: t -> Maybe a -> [(t, a)]
realize t
inst Maybe a
n = [(t, a)] -> (a -> [(t, a)]) -> Maybe a -> [(t, a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((t, a) -> [(t, a)] -> [(t, a)]
forall a. a -> [a] -> [a]
:[]) ((t, a) -> [(t, a)]) -> (a -> (t, a)) -> a -> [(t, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t
inst,)) Maybe a
n
    interlocking :: Pasang [Maybe a] -> [[(Maybe Instrument, a)]]
interlocking Pasang [Maybe a]
part =
        [ Maybe Instrument -> Maybe a -> [(Maybe Instrument, a)]
forall {t} {a}. t -> Maybe a -> [(t, a)]
realize (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang)) Maybe a
p [(Maybe Instrument, a)]
-> [(Maybe Instrument, a)] -> [(Maybe Instrument, a)]
forall a. [a] -> [a] -> [a]
++ Maybe Instrument -> Maybe a -> [(Maybe Instrument, a)]
forall {t} {a}. t -> Maybe a -> [(t, a)]
realize (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang)) Maybe a
s
        | (Maybe a
p, Maybe a
s) <- [Maybe a] -> [Maybe a] -> [(Maybe a, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Pasang [Maybe a] -> [Maybe a]
forall a. Pasang a -> a
polos Pasang [Maybe a]
part) (Pasang [Maybe a] -> [Maybe a]
forall a. Pasang a -> a
sangsih Pasang [Maybe a]
part)
        ]

-- ** norot

-- | Initially I implemented this as a postproc, but it now seems to me that
-- it would be more convenient as a generator.  In any case, as a postproc it
-- gets really complicated.
c_norot :: Bool -> Maybe Bool -> Derive.Generator Derive.Note
c_norot :: Bool -> Maybe Bool -> Generator Note
c_norot Bool
start_prepare Maybe Bool
prepare =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"norot" Tags
Tags.inst
    Doc
"Emit the basic norot pattern. Normally it will prepare for the next\
    \ pitch if it touches the next note, the `nt-` variant will suppress that.\
    \ The `nt<` variant will also emit a preparation at the note's start."
    (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ Parser
  (NorotStyle, ScoreTime, ControlRef, Maybe Pitch, Pasang Instrument,
   (Maybe Bool, Bool))
-> ((NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
     Pasang Instrument, (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,,,)
    (NorotStyle
 -> ScoreTime
 -> ControlRef
 -> Maybe Pitch
 -> Pasang Instrument
 -> (Maybe Bool, Bool)
 -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
     Pasang Instrument, (Maybe Bool, Bool)))
-> Parser NorotStyle
-> Parser
     (ScoreTime
      -> ControlRef
      -> Maybe Pitch
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> NorotStyle -> Doc -> Parser NorotStyle
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"style" NorotStyle
Default Doc
"Norot style."
    Parser
  (ScoreTime
   -> ControlRef
   -> Maybe Pitch
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser ScoreTime
-> Parser
     (ControlRef
      -> Maybe Pitch
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env Parser
  (ControlRef
   -> Maybe Pitch
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser ControlRef
-> Parser
     (Maybe Pitch
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ControlRef
kotekan_env Parser
  (Maybe Pitch
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Maybe Pitch)
-> Parser
     (Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Pitch)
instrument_top_env Parser
  (Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Pasang Instrument)
-> Parser
     ((Maybe Bool, Bool)
      -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env
    Parser
  ((Maybe Bool, Bool)
   -> (NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Maybe Bool, Bool)
-> Parser
     (NorotStyle, ScoreTime, ControlRef, Maybe Pitch, Pasang Instrument,
      (Maybe Bool, Bool))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env
    ) (((NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
   Pasang Instrument, (Maybe Bool, Bool))
  -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> ((NorotStyle, ScoreTime, ControlRef, Maybe Pitch,
     Pasang Instrument, (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \(NorotStyle
style, ScoreTime
note_dur, ControlRef
kotekan, Maybe Pitch
inst_top, Pasang Instrument
pasang, (Maybe Bool
initial, Bool
final))
    -> GeneratorF Note -> GeneratorF Note
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting (GeneratorF Note -> GeneratorF Note)
-> GeneratorF Note -> GeneratorF Note
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Maybe Pitch
next_pitch <- PassedArgs Note -> Maybe Bool -> Deriver (Maybe Pitch)
forall a. PassedArgs a -> Maybe Bool -> Deriver (Maybe Pitch)
infer_prepare PassedArgs Note
args Maybe Bool
prepare
        Maybe Pitch
cur_pitch <- RealTime -> Deriver (Maybe Pitch)
Derive.pitch_at (RealTime -> Deriver (Maybe Pitch))
-> Deriver State Error RealTime -> Deriver (Maybe Pitch)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PassedArgs Note -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_start PassedArgs Note
args
        Scale
scale <- Deriver Scale
Call.get_scale
        ScoreTime -> Bool
under_threshold <- ControlRef -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function ControlRef
kotekan ScoreTime
note_dur
        let get_steps :: Transposed -> Pasang (Int, Int)
get_steps = Scale
-> Maybe Pitch -> NorotStyle -> Transposed -> Pasang (Int, Int)
norot_steps Scale
scale Maybe Pitch
inst_top NorotStyle
style
        let sustain_cycle :: Transposed -> Cycle
sustain_cycle = NorotStyle -> Pasang Instrument -> Pasang (Int, Int) -> Cycle
gangsa_norot NorotStyle
style Pasang Instrument
pasang (Pasang (Int, Int) -> Cycle)
-> (Transposed -> Pasang (Int, Int)) -> Transposed -> Cycle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Pasang (Int, Int)
get_steps
            prepare_cycle :: Transposed -> Cycle
prepare_cycle = NorotStyle -> Pasang Instrument -> Pasang (Int, Int) -> Cycle
gangsa_norot_prepare NorotStyle
style Pasang Instrument
pasang (Pasang (Int, Int) -> Cycle)
-> (Transposed -> Pasang (Int, Int)) -> Transposed -> Cycle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Pasang (Int, Int)
get_steps
        let initial_final :: (Bool, Bool)
initial_final =
                ( Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (PassedArgs Note -> Orientation
forall a. PassedArgs a -> Orientation
Args.orientation PassedArgs Note
args Orientation -> Orientation -> Bool
forall a. Eq a => a -> a -> Bool
== Orientation
Types.Positive) Maybe Bool
initial
                , Bool
final
                )
        Bool
-> (Transposed -> Cycle)
-> (Transposed -> Cycle)
-> (ScoreTime -> Bool)
-> Maybe Pitch
-> Maybe Pitch
-> ScoreTime
-> (Bool, Bool)
-> (ScoreTime, ScoreTime)
-> NoteDeriver
norot Bool
start_prepare Transposed -> Cycle
sustain_cycle Transposed -> Cycle
prepare_cycle ScoreTime -> Bool
under_threshold
            Maybe Pitch
cur_pitch Maybe Pitch
next_pitch ScoreTime
note_dur (Bool, Bool)
initial_final (PassedArgs Note -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Note
args)

norot :: Bool -> (PSignal.Transposed -> Cycle) -> (PSignal.Transposed -> Cycle)
    -> (ScoreTime -> Bool) -> Maybe PSignal.Pitch -> Maybe PSignal.Pitch
    -> ScoreTime -> (Bool, Bool) -> (ScoreTime, ScoreTime)
    -> Derive.NoteDeriver
norot :: Bool
-> (Transposed -> Cycle)
-> (Transposed -> Cycle)
-> (ScoreTime -> Bool)
-> Maybe Pitch
-> Maybe Pitch
-> ScoreTime
-> (Bool, Bool)
-> (ScoreTime, ScoreTime)
-> NoteDeriver
norot Bool
start_prepare Transposed -> Cycle
sustain_cycle Transposed -> Cycle
prepare_cycle ScoreTime -> Bool
under_threshold
        Maybe Pitch
cur_pitch Maybe Pitch
next_pitch
        ScoreTime
note_dur (Bool, Bool)
initial_final (ScoreTime
start, ScoreTime
end) = do
    RealTime
real_start <- ScoreTime -> Deriver State Error RealTime
forall a. Time a => a -> Deriver State Error RealTime
Derive.real ScoreTime
start
    (Maybe PitchedCycle, Maybe PitchedCycle, Maybe PitchedCycle)
cycles <- Bool
-> (Transposed -> Cycle)
-> (Transposed -> Cycle)
-> Maybe Pitch
-> Maybe Pitch
-> RealTime
-> Deriver
     (Maybe PitchedCycle, Maybe PitchedCycle, Maybe PitchedCycle)
norot_sequence Bool
start_prepare Transposed -> Cycle
sustain_cycle Transposed -> Cycle
prepare_cycle
        Maybe Pitch
cur_pitch Maybe Pitch
next_pitch RealTime
real_start
    let notes :: [[Note NoteDeriver]]
notes = ScoreTime
-> ScoreTime
-> (Bool, Bool)
-> [[Note NoteDeriver]]
-> [[Note NoteDeriver]]
forall a.
ScoreTime -> ScoreTime -> (Bool, Bool) -> [[Note a]] -> [[Note a]]
apply_initial_final ScoreTime
start ScoreTime
end (Bool, Bool)
initial_final ([[Note NoteDeriver]] -> [[Note NoteDeriver]])
-> [[Note NoteDeriver]] -> [[Note NoteDeriver]]
forall a b. (a -> b) -> a -> b
$
            (ScoreTime -> Bool)
-> ScoreTime
-> ScoreTime
-> ScoreTime
-> (Maybe PitchedCycle, Maybe PitchedCycle, Maybe PitchedCycle)
-> [[Note NoteDeriver]]
realize_norot ScoreTime -> Bool
under_threshold ScoreTime
note_dur ScoreTime
start ScoreTime
end (Maybe PitchedCycle, Maybe PitchedCycle, Maybe PitchedCycle)
cycles
    (NoteDeriver -> NoteDeriver) -> [Note NoteDeriver] -> NoteDeriver
forall a. (a -> NoteDeriver) -> [Note a] -> NoteDeriver
realize_notes NoteDeriver -> NoteDeriver
forall a. a -> a
id ([[Note NoteDeriver]] -> [Note NoteDeriver]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Note NoteDeriver]]
notes)

apply_initial_final :: ScoreTime -> ScoreTime -> (Bool, Bool) -> [[Note a]]
    -> [[Note a]]
apply_initial_final :: forall a.
ScoreTime -> ScoreTime -> (Bool, Bool) -> [[Note a]] -> [[Note a]]
apply_initial_final ScoreTime
start ScoreTime
end (Bool
initial, Bool
final) =
    ([Note a] -> [Note a]) -> [[Note a]] -> [[Note a]]
forall a. (a -> a) -> [a] -> [a]
Seq.map_last [Note a] -> [Note a]
forall {a}. [Note a] -> [Note a]
modify_final
    ([[Note a]] -> [[Note a]])
-> ([[Note a]] -> [[Note a]]) -> [[Note a]] -> [[Note a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
initial then [[Note a]] -> [[Note a]]
forall a. a -> a
id else ([Note a] -> Bool) -> [[Note a]] -> [[Note a]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Note a -> Bool) -> [Note a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
<=ScoreTime
start) (ScoreTime -> Bool) -> (Note a -> ScoreTime) -> Note a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note a -> ScoreTime
forall a. Note a -> ScoreTime
note_start)))
    where
    modify_final :: [Note a] -> [Note a]
modify_final [Note a]
notes
        | Bool
final Bool -> Bool -> Bool
&& (Note a -> Bool) -> [Note a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
>=ScoreTime
end) (ScoreTime -> Bool) -> (Note a -> ScoreTime) -> Note a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note a -> ScoreTime
forall a. Note a -> ScoreTime
note_start) [Note a]
notes =
            (Note a -> Note a) -> [Note a] -> [Note a]
forall a b. (a -> b) -> [a] -> [b]
map (Flags -> Note a -> Note a
forall a. Flags -> Note a -> Note a
add_flag (Flags
Flags.infer_duration Flags -> Flags -> Flags
forall a. Semigroup a => a -> a -> a
<> Flags
final_flag)) [Note a]
notes
        | Bool
otherwise = []

-- | Realize the output of 'norot_sequence'.
realize_norot :: (ScoreTime -> Bool) -> ScoreTime -> ScoreTime -> ScoreTime
    -> (Maybe PitchedCycle, Maybe PitchedCycle, Maybe PitchedCycle)
    -> [[Note Derive.NoteDeriver]]
realize_norot :: (ScoreTime -> Bool)
-> ScoreTime
-> ScoreTime
-> ScoreTime
-> (Maybe PitchedCycle, Maybe PitchedCycle, Maybe PitchedCycle)
-> [[Note NoteDeriver]]
realize_norot ScoreTime -> Bool
under_threshold ScoreTime
note_dur ScoreTime
initial_start ScoreTime
exact_end
        (Maybe PitchedCycle
prepare_this, Maybe PitchedCycle
sustain, Maybe PitchedCycle
prepare_next) =
    ((Pitch, (ScoreTime, [KotekanNote])) -> [Note NoteDeriver])
-> [(Pitch, (ScoreTime, [KotekanNote]))] -> [[Note NoteDeriver]]
forall a b. (a -> b) -> [a] -> [b]
map (Pitch, (ScoreTime, [KotekanNote])) -> [Note NoteDeriver]
realize ([(Pitch, (ScoreTime, [KotekanNote]))] -> [[Note NoteDeriver]])
-> ([(Pitch, (ScoreTime, [KotekanNote]))]
    -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
-> [[Note NoteDeriver]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Pitch, (ScoreTime, [KotekanNote]))]
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall {a} {b}. [(a, (ScoreTime, b))] -> [(a, (ScoreTime, b))]
trim ([(Pitch, (ScoreTime, [KotekanNote]))] -> [[Note NoteDeriver]])
-> [(Pitch, (ScoreTime, [KotekanNote]))] -> [[Note NoteDeriver]]
forall a b. (a -> b) -> a -> b
$ [[(Pitch, (ScoreTime, [KotekanNote]))]]
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        -- This is the initial note, which may be dropped.
        [ Maybe PitchedCycle
-> (PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just Maybe PitchedCycle
sustain ((PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
 -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> (PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall a b. (a -> b) -> a -> b
$ \(PitchedCycle Pitch
pitch Cycle
cycle) ->
            -- There should never be an empty cycle, but might as well be safe.
            Maybe [KotekanNote]
-> ([KotekanNote] -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just ([[KotekanNote]] -> Maybe [KotekanNote]
forall a. [a] -> Maybe a
Seq.last (Cycle -> ScoreTime -> [[KotekanNote]]
forall {a}. Realization a -> ScoreTime -> a
get_cycle Cycle
cycle ScoreTime
initial_start)) (([KotekanNote] -> [(Pitch, (ScoreTime, [KotekanNote]))])
 -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> ([KotekanNote] -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall a b. (a -> b) -> a -> b
$ \[KotekanNote]
notes ->
                [(Pitch
pitch, (ScoreTime
initial_t, [KotekanNote]
notes))]
        , Maybe PitchedCycle
-> (PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just Maybe PitchedCycle
prepare_this ((PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
 -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> (PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall a b. (a -> b) -> a -> b
$ \(PitchedCycle Pitch
pitch Cycle
cycle) ->
            Pitch
-> Cycle -> ScoreTime -> [(Pitch, (ScoreTime, [KotekanNote]))]
forall {t} {b}.
t -> Realization [b] -> ScoreTime -> [(t, (ScoreTime, b))]
one_cycle Pitch
pitch Cycle
cycle ScoreTime
this_t
        , Maybe PitchedCycle
-> (PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just Maybe PitchedCycle
sustain ((PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
 -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> (PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall a b. (a -> b) -> a -> b
$ \(PitchedCycle Pitch
pitch Cycle
cycle) ->
            ((ScoreTime, [KotekanNote]) -> (Pitch, (ScoreTime, [KotekanNote])))
-> [(ScoreTime, [KotekanNote])]
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall a b. (a -> b) -> [a] -> [b]
map (Pitch
pitch,) ([(ScoreTime, [KotekanNote])]
 -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(ScoreTime, [KotekanNote])]
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall a b. (a -> b) -> a -> b
$ (ScoreTime -> [[KotekanNote]])
-> [ScoreTime] -> [(ScoreTime, [KotekanNote])]
forall t a. (t -> [a]) -> [t] -> [(t, a)]
cycles (Cycle -> ScoreTime -> [[KotekanNote]]
forall {a}. Realization a -> ScoreTime -> a
get_cycle Cycle
cycle) ([ScoreTime] -> [(ScoreTime, [KotekanNote])])
-> [ScoreTime] -> [(ScoreTime, [KotekanNote])]
forall a b. (a -> b) -> a -> b
$
                ScoreTime -> ScoreTime -> ScoreTime -> [ScoreTime]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.range' ScoreTime
sustain_t ScoreTime
next_t ScoreTime
note_dur
        , Maybe PitchedCycle
-> (PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just Maybe PitchedCycle
prepare_next ((PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
 -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> (PitchedCycle -> [(Pitch, (ScoreTime, [KotekanNote]))])
-> [(Pitch, (ScoreTime, [KotekanNote]))]
forall a b. (a -> b) -> a -> b
$ \(PitchedCycle Pitch
pitch Cycle
cycle) ->
            Pitch
-> Cycle -> ScoreTime -> [(Pitch, (ScoreTime, [KotekanNote]))]
forall {t} {b}.
t -> Realization [b] -> ScoreTime -> [(t, (ScoreTime, b))]
one_cycle Pitch
pitch Cycle
cycle ScoreTime
next_t
        ]
        -- TODO should I throw an error if I wanted a pitch but couldn't get
        -- it?  I could make a NoteDeriver that throws when evaluated.
    {- i = initial, t = prepare_this, s = sustain, n = prepare_next
        0 1 2 3 4
        1 3 3 4 3
        i n-----n                s = (1, 1), n = (1, 5)

        0 1 2 3 4
        1 2 1 2 1                s = (1, 5)
        i s-----s

        0 1 2 3 4 5 6 7 8
        1 1 1 2 1 3 3 4 3
        i t-----t n-----n        t = (1, 5), s = (5, 5), n = (5, 9)

        0 1 2 3 4 5 6 7 8 9 a
        1 1 1 2 1 2 1 3 3 4 3
        i t-----t s-s n-----n    t = (1, 5), s = (5, 7), n = (7, 11)

        0 1 2 3 4 5 6 7 8 9 a b c d e f 10
        1 1 1 2 1 3 3 4 3 3 3 4 3 4 3 4 3
        |-nt< ----------->|-nt< -------->
        i t-----t n-----n t-----t s-----s
    -}
    where
    on_just :: Maybe a -> (a -> [a]) -> [a]
on_just Maybe a
val a -> [a]
f = [a] -> (a -> [a]) -> Maybe a -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] a -> [a]
f Maybe a
val
    -- This is just sequencing the 4 sections, where sustain is stretchy, but
    -- it's complicated because they align to the end.  I'd lay them out
    -- forwards and then shift back, but the times need to be accurate for
    -- get_cycle.
    initial_t :: ScoreTime
initial_t = ScoreTime -> ScoreTime -> ScoreTime
forall a. Ord a => a -> a -> a
min ScoreTime
initial_start (ScoreTime
this_t ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
note_dur)
    this_t :: ScoreTime
this_t = ScoreTime -> ScoreTime -> ScoreTime
forall a. Ord a => a -> a -> a
min ScoreTime
start ScoreTime
next_t
    sustain_t :: ScoreTime
sustain_t = ScoreTime
start ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ if Maybe PitchedCycle -> Bool
forall a. Maybe a -> Bool
Maybe.isJust Maybe PitchedCycle
prepare_this then ScoreTime
prep_dur else ScoreTime
0
    next_t :: ScoreTime
next_t = ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- if Maybe PitchedCycle -> Bool
forall a. Maybe a -> Bool
Maybe.isJust Maybe PitchedCycle
prepare_next then ScoreTime
prep_dur else ScoreTime
0
    -- Negative orientation means the logical start and end are shifted forward
    -- by one step.
    start :: ScoreTime
start = ScoreTime
initial_start ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ ScoreTime
note_dur
    end :: ScoreTime
end = ScoreTime
exact_end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ ScoreTime
note_dur

    trim :: [(a, (ScoreTime, b))] -> [(a, (ScoreTime, b))]
trim = ((a, (ScoreTime, b)) -> Bool)
-> [(a, (ScoreTime, b))] -> [(a, (ScoreTime, b))]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
<=ScoreTime
exact_end) (ScoreTime -> Bool)
-> ((a, (ScoreTime, b)) -> ScoreTime)
-> (a, (ScoreTime, b))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScoreTime, b) -> ScoreTime
forall a b. (a, b) -> a
fst ((ScoreTime, b) -> ScoreTime)
-> ((a, (ScoreTime, b)) -> (ScoreTime, b))
-> (a, (ScoreTime, b))
-> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, (ScoreTime, b)) -> (ScoreTime, b)
forall a b. (a, b) -> b
snd)
        ([(a, (ScoreTime, b))] -> [(a, (ScoreTime, b))])
-> ([(a, (ScoreTime, b))] -> [(a, (ScoreTime, b))])
-> [(a, (ScoreTime, b))]
-> [(a, (ScoreTime, b))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, (ScoreTime, b)) -> Bool)
-> [(a, (ScoreTime, b))] -> [(a, (ScoreTime, b))]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
<ScoreTime
initial_start) (ScoreTime -> Bool)
-> ((a, (ScoreTime, b)) -> ScoreTime)
-> (a, (ScoreTime, b))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScoreTime, b) -> ScoreTime
forall a b. (a, b) -> a
fst ((ScoreTime, b) -> ScoreTime)
-> ((a, (ScoreTime, b)) -> (ScoreTime, b))
-> (a, (ScoreTime, b))
-> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, (ScoreTime, b)) -> (ScoreTime, b)
forall a b. (a, b) -> b
snd)
    one_cycle :: t -> Realization [b] -> ScoreTime -> [(t, (ScoreTime, b))]
one_cycle t
pitch Realization [b]
cycle ScoreTime
start = ((ScoreTime, b) -> (t, (ScoreTime, b)))
-> [(ScoreTime, b)] -> [(t, (ScoreTime, b))]
forall a b. (a -> b) -> [a] -> [b]
map (t
pitch,) ([(ScoreTime, b)] -> [(t, (ScoreTime, b))])
-> [(ScoreTime, b)] -> [(t, (ScoreTime, b))]
forall a b. (a -> b) -> a -> b
$ [ScoreTime] -> [b] -> [(ScoreTime, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ScoreTime -> ScoreTime -> [ScoreTime]
forall a. Num a => a -> a -> [a]
Seq.range_ ScoreTime
start ScoreTime
note_dur)
        (Realization [b] -> ScoreTime -> [b]
forall {a}. Realization a -> ScoreTime -> a
get_cycle Realization [b]
cycle ScoreTime
start)
    get_cycle :: Realization a -> ScoreTime -> a
get_cycle Realization a
cycle ScoreTime
t
        | ScoreTime -> Bool
under_threshold ScoreTime
t = Realization a -> a
forall a. Realization a -> a
interlocking Realization a
cycle
        | Bool
otherwise = Realization a -> a
forall a. Realization a -> a
non_interlocking Realization a
cycle
    prep_dur :: ScoreTime
prep_dur = ScoreTime
note_dur ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
* ScoreTime
4

    realize :: (PSignal.Pitch, (ScoreTime, [KotekanNote]))
        -> [Note Derive.NoteDeriver]
    realize :: (Pitch, (ScoreTime, [KotekanNote])) -> [Note NoteDeriver]
realize (Pitch
pitch, (ScoreTime
t, [KotekanNote]
chord)) = (KotekanNote -> Note NoteDeriver)
-> [KotekanNote] -> [Note NoteDeriver]
forall a b. (a -> b) -> [a] -> [b]
map (ScoreTime -> Pitch -> KotekanNote -> Note NoteDeriver
make_note ScoreTime
t Pitch
pitch) [KotekanNote]
chord
    make_note :: ScoreTime -> Pitch -> KotekanNote -> Note NoteDeriver
make_note ScoreTime
t Pitch
pitch KotekanNote
note = Note
        { note_start :: ScoreTime
note_start = ScoreTime
t
        , note_duration :: ScoreTime
note_duration = ScoreTime
note_dur
        , note_flags :: Flags
note_flags = Flags
forall a. Monoid a => a
mempty
        , note_data :: NoteDeriver
note_data = Pitch -> KotekanNote -> NoteDeriver
realize_note Pitch
pitch KotekanNote
note
        }
    realize_note :: Pitch -> KotekanNote -> NoteDeriver
realize_note Pitch
pitch (KotekanNote Maybe Instrument
inst Int
steps Bool
muted) =
        (NoteDeriver -> NoteDeriver)
-> (Instrument -> NoteDeriver -> NoteDeriver)
-> Maybe Instrument
-> NoteDeriver
-> NoteDeriver
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NoteDeriver -> NoteDeriver
forall a. a -> a
id Instrument -> NoteDeriver -> NoteDeriver
forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Maybe Instrument
inst (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
        -- TODO the kind of muting should be configurable.  Or, rather I should
        -- dispatch to a zero dur note call, which will pick up whatever form
        -- of mute is configured.
        -- TODO I'm using 'm' for that now, right?
        (if Bool
muted then Attributes -> NoteDeriver -> NoteDeriver
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.mute else NoteDeriver -> NoteDeriver
forall a. a -> a
id) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
        Pitch -> NoteDeriver
Call.pitched_note (Int -> Pitch -> Pitch
forall a. Int -> RawPitch a -> RawPitch a
Pitches.transpose_d Int
steps Pitch
pitch)

-- | Figure out the appropriate cycles for each norot phase.  There are
-- 3 phases: an optional preparation for the current pitch, a variable length
-- sustain, and an optional preparation for the next pitch.
norot_sequence :: Bool
    -> (PSignal.Transposed -> Cycle) -> (PSignal.Transposed -> Cycle)
    -> Maybe PSignal.Pitch -> Maybe PSignal.Pitch -> RealTime
    -> Derive.Deriver (Maybe PitchedCycle, Maybe PitchedCycle,
        Maybe PitchedCycle)
norot_sequence :: Bool
-> (Transposed -> Cycle)
-> (Transposed -> Cycle)
-> Maybe Pitch
-> Maybe Pitch
-> RealTime
-> Deriver
     (Maybe PitchedCycle, Maybe PitchedCycle, Maybe PitchedCycle)
norot_sequence Bool
start_prepare Transposed -> Cycle
sustain_cycle Transposed -> Cycle
prepare_cycle Maybe Pitch
cur_pitch Maybe Pitch
next_pitch
        RealTime
start = do
    -- It's ok for there to be no current pitch, because the sustain might
    -- not be played at all.  But if there's no pitch at all it's probably
    -- better to throw an error than silently emit no notes.
    Bool -> Deriver State Error () -> Deriver State Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Maybe Pitch -> Bool) -> [Maybe Pitch] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Pitch -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing [Maybe Pitch
cur_pitch, Maybe Pitch
next_pitch]) (Deriver State Error () -> Deriver State Error ())
-> Deriver State Error () -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$
        Text -> Deriver State Error ()
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"no current pitch and no next pitch"
    Maybe PitchedCycle
prepare_this <- case (Bool
start_prepare, Maybe Pitch
cur_pitch) of
        (Bool
True, Just Pitch
pitch) -> do
            Transposed
pitch_t <- RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start Pitch
pitch
            Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle))
-> Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle)
forall a b. (a -> b) -> a -> b
$ PitchedCycle -> Maybe PitchedCycle
forall a. a -> Maybe a
Just (PitchedCycle -> Maybe PitchedCycle)
-> PitchedCycle -> Maybe PitchedCycle
forall a b. (a -> b) -> a -> b
$ Pitch -> Cycle -> PitchedCycle
PitchedCycle Pitch
pitch (Transposed -> Cycle
prepare_cycle Transposed
pitch_t)
        (Bool, Maybe Pitch)
_ -> Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PitchedCycle
forall a. Maybe a
Nothing
    Maybe PitchedCycle
sustain <- case Maybe Pitch
cur_pitch of
        Maybe Pitch
Nothing -> Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PitchedCycle
forall a. Maybe a
Nothing
        Just Pitch
pitch -> do
            Transposed
pitch_t <- RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start Pitch
pitch
            Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle))
-> Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle)
forall a b. (a -> b) -> a -> b
$ PitchedCycle -> Maybe PitchedCycle
forall a. a -> Maybe a
Just (PitchedCycle -> Maybe PitchedCycle)
-> PitchedCycle -> Maybe PitchedCycle
forall a b. (a -> b) -> a -> b
$ Pitch -> Cycle -> PitchedCycle
PitchedCycle Pitch
pitch (Transposed -> Cycle
sustain_cycle Transposed
pitch_t)
    Maybe PitchedCycle
prepare_next <- case Maybe Pitch
next_pitch of
        Maybe Pitch
Nothing -> Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PitchedCycle
forall a. Maybe a
Nothing
        Just Pitch
next -> do
            Transposed
next_t <- RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start Pitch
next
            Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle))
-> Maybe PitchedCycle -> Deriver State Error (Maybe PitchedCycle)
forall a b. (a -> b) -> a -> b
$ PitchedCycle -> Maybe PitchedCycle
forall a. a -> Maybe a
Just (PitchedCycle -> Maybe PitchedCycle)
-> PitchedCycle -> Maybe PitchedCycle
forall a b. (a -> b) -> a -> b
$ Pitch -> Cycle -> PitchedCycle
PitchedCycle Pitch
next (Transposed -> Cycle
prepare_cycle Transposed
next_t)
    (Maybe PitchedCycle, Maybe PitchedCycle, Maybe PitchedCycle)
-> Deriver
     (Maybe PitchedCycle, Maybe PitchedCycle, Maybe PitchedCycle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PitchedCycle
prepare_this, Maybe PitchedCycle
sustain, Maybe PitchedCycle
prepare_next)

data PitchedCycle = PitchedCycle !PSignal.Pitch !Cycle

-- | Figure out parameters for the sustain and prepare phases.
-- Why is this SO COMPLICATED.
--
-- TODO this is still used by Reyong.  If I can simplify reyong norot too
-- then I can get rid of it.
prepare_sustain :: Bool -> ScoreTime -> (Maybe Bool, Bool)
    -> Types.Orientation -> (ScoreTime, ScoreTime)
    -> (Maybe ((Bool, Bool), (ScoreTime, ScoreTime)),
        Maybe ((Bool, Bool), (ScoreTime, ScoreTime)))
prepare_sustain :: Bool
-> ScoreTime
-> (Maybe Bool, Bool)
-> Orientation
-> (ScoreTime, ScoreTime)
-> (Maybe ((Bool, Bool), (ScoreTime, ScoreTime)),
    Maybe ((Bool, Bool), (ScoreTime, ScoreTime)))
prepare_sustain Bool
has_prepare ScoreTime
note_dur (Maybe Bool
maybe_initial, Bool
final) Orientation
orient
        (ScoreTime
start, ScoreTime
end) =
    (Maybe ((Bool, Bool), (ScoreTime, ScoreTime))
sustain, Maybe ((Bool, Bool), (ScoreTime, ScoreTime))
prepare)
    where
    sustain :: Maybe ((Bool, Bool), (ScoreTime, ScoreTime))
sustain
        | Bool
has_sustain =
            ((Bool, Bool), (ScoreTime, ScoreTime))
-> Maybe ((Bool, Bool), (ScoreTime, ScoreTime))
forall a. a -> Maybe a
Just ((Bool
initial, if Bool
has_prepare then Bool
False else Bool
final),
                (ScoreTime
start, ScoreTime
sustain_end))
        | Bool
otherwise = Maybe ((Bool, Bool), (ScoreTime, ScoreTime))
forall a. Maybe a
Nothing
        where
        initial :: Bool
initial = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Orientation
orient Orientation -> Orientation -> Bool
forall a. Eq a => a -> a -> Bool
== Orientation
Types.Positive) Maybe Bool
maybe_initial
        sustain_end :: ScoreTime
sustain_end = ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- if Bool
has_prepare then ScoreTime
prepare_dur else ScoreTime
0
    prepare :: Maybe ((Bool, Bool), (ScoreTime, ScoreTime))
prepare
        | Bool
has_prepare =
            ((Bool, Bool), (ScoreTime, ScoreTime))
-> Maybe ((Bool, Bool), (ScoreTime, ScoreTime))
forall a. a -> Maybe a
Just ((Bool
True, Bool
final), (ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
prepare_dur, ScoreTime
end))
        | Bool
otherwise = Maybe ((Bool, Bool), (ScoreTime, ScoreTime))
forall a. Maybe a
Nothing
    dur :: ScoreTime
dur = ScoreTime
end ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
start
    -- False if all the time is taken up by the prepare.
    -- Default to no initial if this is immediately going into a prepare.  This
    -- is so I can use a 'nt>' for just prepare but line it up on the beat.
    -- I don't actually need this if I expect a plain 'nt>' to be negative.
    has_sustain :: Bool
has_sustain = Bool -> Bool
not Bool
has_prepare
        Bool -> Bool -> Bool
|| (ScoreTime
dur ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
> ScoreTime
prepare_dur1
            Bool -> Bool -> Bool
|| ScoreTime
dur ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
> ScoreTime
prepare_dur Bool -> Bool -> Bool
&& Maybe Bool
maybe_initial Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
    prepare_dur :: ScoreTime
prepare_dur = ScoreTime
note_dur ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
* ScoreTime
3
    prepare_dur1 :: ScoreTime
prepare_dur1 = ScoreTime
note_dur ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
* ScoreTime
4

infer_prepare :: Derive.PassedArgs a -> Maybe Bool
    -- ^ True to prepare, False to not, Nothing to prepare if this note touches
    -- the next one.
    -> Derive.Deriver (Maybe PSignal.Pitch)
infer_prepare :: forall a. PassedArgs a -> Maybe Bool -> Deriver (Maybe Pitch)
infer_prepare PassedArgs a
_ (Just Bool
False) = Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pitch
forall a. Maybe a
Nothing
infer_prepare PassedArgs a
args (Just Bool
True) = PassedArgs a -> Deriver (Maybe Pitch)
forall a. PassedArgs a -> Deriver (Maybe Pitch)
Args.lookup_next_pitch PassedArgs a
args
infer_prepare PassedArgs a
args Maybe Bool
Nothing
    | PassedArgs a -> Maybe ScoreTime
forall a. PassedArgs a -> Maybe ScoreTime
Args.next_start PassedArgs a
args Maybe ScoreTime -> Maybe ScoreTime -> Bool
forall a. Eq a => a -> a -> Bool
/= ScoreTime -> Maybe ScoreTime
forall a. a -> Maybe a
Just (Event -> ScoreTime
Event.max (PassedArgs a -> Event
forall a. PassedArgs a -> Event
Args.event PassedArgs a
args)) =
        Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pitch
forall a. Maybe a
Nothing
    | Bool
otherwise = PassedArgs a -> Deriver (Maybe Pitch)
forall a. PassedArgs a -> Deriver (Maybe Pitch)
Args.lookup_next_pitch PassedArgs a
args

gangsa_norot :: NorotStyle -> Pasang ScoreT.Instrument
    -> Pasang (Pitch.Step, Pitch.Step) -> Cycle
gangsa_norot :: NorotStyle -> Pasang Instrument -> Pasang (Int, Int) -> Cycle
gangsa_norot NorotStyle
style Pasang Instrument
pasang Pasang (Int, Int)
steps = Realization
    { interlocking :: [[KotekanNote]]
interlocking = (KotekanNote -> [KotekanNote]) -> [KotekanNote] -> [[KotekanNote]]
forall a b. (a -> b) -> [a] -> [b]
map (KotekanNote -> [KotekanNote] -> [KotekanNote]
forall a. a -> [a] -> [a]
:[]) [Int -> KotekanNote
s ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
pstep), Int -> KotekanNote
p ((Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
pstep)]
    , non_interlocking :: [[KotekanNote]]
non_interlocking = case NorotStyle
style of
        NorotStyle
Default -> (Int -> [KotekanNote]) -> [Int] -> [[KotekanNote]]
forall a b. (a -> b) -> [a] -> [b]
map ((KotekanNote -> [KotekanNote] -> [KotekanNote]
forall a. a -> [a] -> [a]
:[]) (KotekanNote -> [KotekanNote])
-> (Int -> KotekanNote) -> Int -> [KotekanNote]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> KotekanNote
both) [(Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
pstep, (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
pstep]
        NorotStyle
Diamond ->
            [ [Int -> KotekanNote
p ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
pstep), Int -> KotekanNote
s ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
sstep)]
            , [Int -> KotekanNote
p ((Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
pstep), Int -> KotekanNote
s ((Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
sstep)]
            ]
    }
    where
    both :: Int -> KotekanNote
both = Maybe Instrument -> Int -> KotekanNote
kotekan_note Maybe Instrument
forall a. Maybe a
Nothing
    p :: Int -> KotekanNote
p = Maybe Instrument -> Int -> KotekanNote
kotekan_note (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang))
    s :: Int -> KotekanNote
s = Maybe Instrument -> Int -> KotekanNote
kotekan_note (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang))
    pstep :: (Int, Int)
pstep = Pasang (Int, Int) -> (Int, Int)
forall a. Pasang a -> a
polos Pasang (Int, Int)
steps
    sstep :: (Int, Int)
sstep = Pasang (Int, Int) -> (Int, Int)
forall a. Pasang a -> a
sangsih Pasang (Int, Int)
steps

gangsa_norot_prepare :: NorotStyle -> Pasang ScoreT.Instrument
    -> Pasang (Pitch.Step, Pitch.Step) -> Cycle
gangsa_norot_prepare :: NorotStyle -> Pasang Instrument -> Pasang (Int, Int) -> Cycle
gangsa_norot_prepare NorotStyle
style Pasang Instrument
pasang Pasang (Int, Int)
steps = Realization
    { interlocking :: [[KotekanNote]]
interlocking =
        [ [Int -> KotekanNote
p Int
p2, Int -> KotekanNote
s Int
p2]
        , [Int -> KotekanNote
p Int
p2, Int -> KotekanNote
s Int
p2]
        , [Int -> KotekanNote
s Int
p1]
        , [Int -> KotekanNote
p Int
p2]
        ]
    , non_interlocking :: [[KotekanNote]]
non_interlocking = case NorotStyle
style of
        NorotStyle
Default -> (KotekanNote -> [KotekanNote]) -> [KotekanNote] -> [[KotekanNote]]
forall a b. (a -> b) -> [a] -> [b]
map (KotekanNote -> [KotekanNote] -> [KotekanNote]
forall a. a -> [a] -> [a]
:[]) [KotekanNote -> KotekanNote
muted_note (Int -> KotekanNote
both Int
p2), Int -> KotekanNote
both Int
p2, Int -> KotekanNote
both Int
p1, Int -> KotekanNote
both Int
p2]
        NorotStyle
Diamond ->
            [ (KotekanNote -> KotekanNote) -> [KotekanNote] -> [KotekanNote]
forall a b. (a -> b) -> [a] -> [b]
map KotekanNote -> KotekanNote
muted_note [Int -> KotekanNote
p Int
p2, Int -> KotekanNote
s Int
s2]
            , [Int -> KotekanNote
p Int
p2, Int -> KotekanNote
s Int
s2]
            , [Int -> KotekanNote
p Int
p1, Int -> KotekanNote
s Int
s1]
            , [Int -> KotekanNote
p Int
p2, Int -> KotekanNote
s Int
s2]
            ]
    }
    where
    both :: Int -> KotekanNote
both = Maybe Instrument -> Int -> KotekanNote
kotekan_note Maybe Instrument
forall a. Maybe a
Nothing
    p :: Int -> KotekanNote
p = Maybe Instrument -> Int -> KotekanNote
kotekan_note (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang))
    s :: Int -> KotekanNote
s = Maybe Instrument -> Int -> KotekanNote
kotekan_note (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang))
    (Int
p1, Int
p2) = Pasang (Int, Int) -> (Int, Int)
forall a. Pasang a -> a
polos Pasang (Int, Int)
steps
    (Int
s1, Int
s2) = Pasang (Int, Int) -> (Int, Int)
forall a. Pasang a -> a
sangsih Pasang (Int, Int)
steps

norot_steps :: Scale.Scale -> Maybe Pitch.Pitch -> NorotStyle
    -> PSignal.Transposed
    -- ^ this is to figure out if the sangsih part will be in range
    -> Pasang (Pitch.Step, Pitch.Step)
norot_steps :: Scale
-> Maybe Pitch -> NorotStyle -> Transposed -> Pasang (Int, Int)
norot_steps Scale
scale Maybe Pitch
inst_top NorotStyle
style Transposed
pitch
    | Int -> Bool
out_of_range Int
1 = Pasang { polos :: (Int, Int)
polos = (-Int
1, Int
0), sangsih :: (Int, Int)
sangsih = (-Int
1, Int
0) }
    | Bool
otherwise = case NorotStyle
style of
        NorotStyle
Diamond -> Pasang { polos :: (Int, Int)
polos = (Int
1, Int
0), sangsih :: (Int, Int)
sangsih = (-Int
1, Int
0) }
        -- Sangsih is only used if non-interlocking and using Diamond style.
        -- So the snd pair should be ignored.
        NorotStyle
Default -> Pasang { polos :: (Int, Int)
polos = (Int
1, Int
0), sangsih :: (Int, Int)
sangsih = (Int
1, Int
0) }
    where
    out_of_range :: Int -> Bool
out_of_range Int
steps = Scale -> Maybe Pitch -> Transposed -> Bool
note_too_high Scale
scale Maybe Pitch
inst_top (Transposed -> Bool) -> Transposed -> Bool
forall a b. (a -> b) -> a -> b
$
        Int -> Transposed -> Transposed
forall a. Int -> RawPitch a -> RawPitch a
Pitches.transpose_d Int
steps Transposed
pitch

c_gender_norot :: Derive.Generator Derive.Note
c_gender_norot :: Generator Note
c_gender_norot = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"gender-norot" Tags
Tags.inst
    Doc
"Gender-style norot."
    (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ Parser
  (ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool))
-> ((ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    (ScoreTime
 -> ControlRef
 -> Pasang Instrument
 -> (Maybe Bool, Bool)
 -> (ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool)))
-> Parser ScoreTime
-> Parser
     (ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ScoreTime
dur_env Parser
  (ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool)))
-> Parser ControlRef
-> Parser
     (Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ControlRef
kotekan_env Parser
  (Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Pasang Instrument)
-> Parser
     ((Maybe Bool, Bool)
      -> (ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env Parser
  ((Maybe Bool, Bool)
   -> (ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Maybe Bool, Bool)
-> Parser
     (ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env)
    (((ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool))
  -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> ((ScoreTime, ControlRef, Pasang Instrument, (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \(ScoreTime
dur, ControlRef
kotekan, Pasang Instrument
pasang, (Maybe Bool, Bool)
initial_final) -> GeneratorF Note -> GeneratorF Note
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting (GeneratorF Note -> GeneratorF Note)
-> GeneratorF Note -> GeneratorF Note
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Pitch
pitch <- PassedArgs Note -> Deriver Pitch
forall a. PassedArgs a -> Deriver Pitch
get_pitch PassedArgs Note
args
        ScoreTime -> Bool
under_threshold <- ControlRef -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function ControlRef
kotekan ScoreTime
dur
        PassedArgs Note
-> (Maybe Bool, Bool)
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
forall a.
PassedArgs a
-> (Maybe Bool, Bool)
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
realize_kotekan_pattern_args PassedArgs Note
args (Maybe Bool, Bool)
initial_final
            ScoreTime
dur Pitch
pitch ScoreTime -> Bool
under_threshold Repeat
Repeat (Pasang Instrument -> Cycle
gender_norot Pasang Instrument
pasang)

gender_norot :: Pasang ScoreT.Instrument -> Cycle
gender_norot :: Pasang Instrument -> Cycle
gender_norot Pasang Instrument
pasang = Realization
    { interlocking :: [[KotekanNote]]
interlocking = [[Int -> KotekanNote
s Int
1], [Int -> KotekanNote
p Int
0], [Int -> KotekanNote
s Int
1], [Int -> KotekanNote
p Int
0]]
    , non_interlocking :: [[KotekanNote]]
non_interlocking =
        [ [Int -> KotekanNote
p (-Int
1), Int -> KotekanNote
s Int
1]
        , [Int -> KotekanNote
p (-Int
2), Int -> KotekanNote
s Int
0]
        , [Int -> KotekanNote
p (-Int
1), Int -> KotekanNote
s Int
1]
        , if Bool
include_unison then [Int -> KotekanNote
p Int
0, Int -> KotekanNote
s Int
0] else [Int -> KotekanNote
s Int
0]
        ]
    }
    where
    include_unison :: Bool
include_unison = Bool
True -- TODO chance based on signal
    p :: Int -> KotekanNote
p = Maybe Instrument -> Int -> KotekanNote
kotekan_note (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang))
    s :: Int -> KotekanNote
s = Maybe Instrument -> Int -> KotekanNote
kotekan_note (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang))

-- * kotekan

kotekan_doc :: Doc.Doc
kotekan_doc :: Doc
kotekan_doc =
    Doc
"Kotekan calls perform a pattern with `inst-polos` and `inst-sangsih`.\
    \ They line up at the end of the event but may also emit a note at the\
    \ start of the event, so use `cancel-pasang` to cancel the extra notes.\
    \ Ngubeng kotekan is naturally suited to positive duration, while majalan\
    \ is suited to negative duration."

c_kotekan_irregular :: KotekanStyle -> KotekanPattern
    -> Derive.Generator Derive.Note
c_kotekan_irregular :: KotekanStyle -> KotekanPattern -> Generator Note
c_kotekan_irregular KotekanStyle
default_style KotekanPattern
pattern =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"kotekan" Tags
Tags.inst
    (Doc
"Render a kotekan pattern where both polos and sangsih are explicitly\
    \ specified. This is for irregular patterns.\n" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
kotekan_doc)
    (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ Parser
  (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
   (Maybe Bool, Bool))
-> ((KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
     (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,,)
    (KotekanStyle
 -> ScoreTime
 -> ControlRef
 -> Pasang Instrument
 -> (Maybe Bool, Bool)
 -> (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
     (Maybe Bool, Bool)))
-> Parser KotekanStyle
-> Parser
     (ScoreTime
      -> ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
          (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KotekanStyle -> Parser KotekanStyle
style_arg KotekanStyle
default_style
    Parser
  (ScoreTime
   -> ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
       (Maybe Bool, Bool)))
-> Parser ScoreTime
-> Parser
     (ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
          (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env Parser
  (ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
       (Maybe Bool, Bool)))
-> Parser ControlRef
-> Parser
     (Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
          (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ControlRef
kotekan_env Parser
  (Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
       (Maybe Bool, Bool)))
-> Parser (Pasang Instrument)
-> Parser
     ((Maybe Bool, Bool)
      -> (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
          (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env Parser
  ((Maybe Bool, Bool)
   -> (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
       (Maybe Bool, Bool)))
-> Parser (Maybe Bool, Bool)
-> Parser
     (KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
      (Maybe Bool, Bool))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env
    ) (((KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
   (Maybe Bool, Bool))
  -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> ((KotekanStyle, ScoreTime, ControlRef, Pasang Instrument,
     (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \(KotekanStyle
style, ScoreTime
dur, ControlRef
kotekan, Pasang Instrument
pasang, (Maybe Bool, Bool)
initial_final) ->
    GeneratorF Note -> GeneratorF Note
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting (GeneratorF Note -> GeneratorF Note)
-> GeneratorF Note -> GeneratorF Note
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Pitch
pitch <- PassedArgs Note -> Deriver Pitch
forall a. PassedArgs a -> Deriver Pitch
get_pitch PassedArgs Note
args
        ScoreTime -> Bool
under_threshold <- ControlRef -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function ControlRef
kotekan ScoreTime
dur
        PassedArgs Note
-> (Maybe Bool, Bool)
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
forall a.
PassedArgs a
-> (Maybe Bool, Bool)
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
realize_kotekan_pattern_args PassedArgs Note
args (Maybe Bool, Bool)
initial_final
            ScoreTime
dur Pitch
pitch ScoreTime -> Bool
under_threshold Repeat
Repeat
            (KotekanPattern -> KotekanStyle -> Pasang Instrument -> Cycle
kotekan_pattern KotekanPattern
pattern KotekanStyle
style Pasang Instrument
pasang)

-- ** regular

c_kotekan_kernel :: Derive.Generator Derive.Note
c_kotekan_kernel :: Generator Note
c_kotekan_kernel =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"kotekan" Tags
Tags.inst
    (Doc
"Render a kotekan pattern from a kernel. The sangsih part is inferred.\n"
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
kotekan_doc)
    (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ Parser
  (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
   Pasang Instrument, (Maybe Bool, Bool))
-> ((Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
     Pasang Instrument, (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,,,,,,)
    (Int
 -> KotekanStyle
 -> UpDown
 -> Bool
 -> Text
 -> ScoreTime
 -> ControlRef
 -> Pasang Instrument
 -> (Maybe Bool, Bool)
 -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
     Pasang Instrument, (Maybe Bool, Bool)))
-> Parser Int
-> Parser
     (KotekanStyle
      -> UpDown
      -> Bool
      -> Text
      -> ScoreTime
      -> ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Int -> Doc -> Parser Int
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"rotation" Int
0 Doc
"Rotate kernel to make a different pattern."
    Parser
  (KotekanStyle
   -> UpDown
   -> Bool
   -> Text
   -> ScoreTime
   -> ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser KotekanStyle
-> Parser
     (UpDown
      -> Bool
      -> Text
      -> ScoreTime
      -> ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KotekanStyle -> Parser KotekanStyle
style_arg KotekanStyle
Telu
    Parser
  (UpDown
   -> Bool
   -> Text
   -> ScoreTime
   -> ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser UpDown
-> Parser
     (Bool
      -> Text
      -> ScoreTime
      -> ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> UpDown -> Doc -> Parser UpDown
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.defaulted_env ArgName
"sangsih" EnvironDefault
Sig.Both UpDown
Call.Up
        Doc
"Whether sangsih is above or below polos."
    Parser
  (Bool
   -> Text
   -> ScoreTime
   -> ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser Bool
-> Parser
     (Text
      -> ScoreTime
      -> ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Bool -> Doc -> Parser Bool
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"invert" EnvironDefault
Sig.Prefixed Bool
False Doc
"Flip the pattern upside down."
    Parser
  (Text
   -> ScoreTime
   -> ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser Text
-> Parser
     (ScoreTime
      -> ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Doc -> Parser Text
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"kernel" EnvironDefault
Sig.Both Doc
kernel_doc
    Parser
  (ScoreTime
   -> ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser ScoreTime
-> Parser
     (ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env Parser
  (ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser ControlRef
-> Parser
     (Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ControlRef
kotekan_env Parser
  (Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Pasang Instrument)
-> Parser
     ((Maybe Bool, Bool)
      -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env Parser
  ((Maybe Bool, Bool)
   -> (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Maybe Bool, Bool)
-> Parser
     (Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
      Pasang Instrument, (Maybe Bool, Bool))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env
    ) (((Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
   Pasang Instrument, (Maybe Bool, Bool))
  -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> ((Int, KotekanStyle, UpDown, Bool, Text, ScoreTime, ControlRef,
     Pasang Instrument, (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \(Int
rotation, KotekanStyle
style, UpDown
sangsih_above, Bool
inverted, Text
kernel_s, ScoreTime
dur, ControlRef
kotekan,
        Pasang Instrument
pasang, (Maybe Bool, Bool)
initial_final) ->
    GeneratorF Note -> GeneratorF Note
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting (GeneratorF Note -> GeneratorF Note)
-> GeneratorF Note -> GeneratorF Note
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Kernel
kernel <- (Text -> Text) -> Either Text Kernel -> Deriver Kernel
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right Text -> Text
forall a. a -> a
id (Either Text Kernel -> Deriver Kernel)
-> Either Text Kernel -> Deriver Kernel
forall a b. (a -> b) -> a -> b
$ [Char] -> Either Text Kernel
make_kernel (Text -> [Char]
untxt Text
kernel_s)
        Pitch
pitch <- PassedArgs Note -> Deriver Pitch
forall a. PassedArgs a -> Deriver Pitch
get_pitch PassedArgs Note
args
        ScoreTime -> Bool
under_threshold <- ControlRef -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function ControlRef
kotekan ScoreTime
dur
        let cycle :: Cycle
cycle = Bool
-> UpDown -> KotekanStyle -> Pasang Instrument -> Kernel -> Cycle
realize_kernel Bool
inverted UpDown
sangsih_above KotekanStyle
style Pasang Instrument
pasang
                (Int -> Kernel -> Kernel
forall a. Int -> [a] -> [a]
rotate Int
rotation Kernel
kernel)
        PassedArgs Note
-> (Maybe Bool, Bool)
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
forall a.
PassedArgs a
-> (Maybe Bool, Bool)
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
realize_kotekan_pattern_args PassedArgs Note
args (Maybe Bool, Bool)
initial_final ScoreTime
dur Pitch
pitch
            ScoreTime -> Bool
under_threshold Repeat
Repeat Cycle
cycle

-- | For regular kotekan, the sangsih can be automatically derived from the
-- polos.
c_kotekan_regular :: Bool -> Maybe Text -> KotekanStyle
    -> Derive.Generator Derive.Note
c_kotekan_regular :: Bool -> Maybe Text -> KotekanStyle -> Generator Note
c_kotekan_regular Bool
invert Maybe Text
maybe_kernel KotekanStyle
default_style =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"kotekan" Tags
Tags.inst
    (Doc
"Render a kotekan pattern from a kernel representing the polos.\
    \ The sangsih is inferred.\n" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
kotekan_doc)
    (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ Parser
  (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
   Pasang Instrument, (Maybe Bool, Bool))
-> ((Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
     Pasang Instrument, (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,,,,)
    (Text
 -> KotekanStyle
 -> Maybe UpDown
 -> ScoreTime
 -> ControlRef
 -> Pasang Instrument
 -> (Maybe Bool, Bool)
 -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
     Pasang Instrument, (Maybe Bool, Bool)))
-> Parser Text
-> Parser
     (KotekanStyle
      -> Maybe UpDown
      -> ScoreTime
      -> ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> (Text -> Parser Text) -> Maybe Text -> Parser Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ArgName -> EnvironDefault -> Doc -> Parser Text
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"kernel" EnvironDefault
Sig.Both Doc
kernel_doc) Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
maybe_kernel
    Parser
  (KotekanStyle
   -> Maybe UpDown
   -> ScoreTime
   -> ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser KotekanStyle
-> Parser
     (Maybe UpDown
      -> ScoreTime
      -> ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KotekanStyle -> Parser KotekanStyle
style_arg KotekanStyle
default_style
    Parser
  (Maybe UpDown
   -> ScoreTime
   -> ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Maybe UpDown)
-> Parser
     (ScoreTime
      -> ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName
-> EnvironDefault -> Maybe UpDown -> Doc -> Parser (Maybe UpDown)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.defaulted_env ArgName
"sangsih" EnvironDefault
Sig.Both Maybe UpDown
forall a. Maybe a
Nothing
        Doc
"Whether sangsih is above or below polos. If not given, sangsih will\
        \ be above if the polos ends on a low note or rest, below otherwise."
    Parser
  (ScoreTime
   -> ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser ScoreTime
-> Parser
     (ControlRef
      -> Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env Parser
  (ControlRef
   -> Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser ControlRef
-> Parser
     (Pasang Instrument
      -> (Maybe Bool, Bool)
      -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ControlRef
kotekan_env Parser
  (Pasang Instrument
   -> (Maybe Bool, Bool)
   -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Pasang Instrument)
-> Parser
     ((Maybe Bool, Bool)
      -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
          Pasang Instrument, (Maybe Bool, Bool)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env Parser
  ((Maybe Bool, Bool)
   -> (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
       Pasang Instrument, (Maybe Bool, Bool)))
-> Parser (Maybe Bool, Bool)
-> Parser
     (Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
      Pasang Instrument, (Maybe Bool, Bool))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env
    ) (((Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
   Pasang Instrument, (Maybe Bool, Bool))
  -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> ((Text, KotekanStyle, Maybe UpDown, ScoreTime, ControlRef,
     Pasang Instrument, (Maybe Bool, Bool))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \(Text
kernel_s, KotekanStyle
style, Maybe UpDown
sangsih_dir, ScoreTime
dur, ControlRef
kotekan, Pasang Instrument
pasang, (Maybe Bool, Bool)
initial_final) ->
    GeneratorF Note -> GeneratorF Note
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting (GeneratorF Note -> GeneratorF Note)
-> GeneratorF Note -> GeneratorF Note
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Kernel
kernel <- (Text -> Text) -> Either Text Kernel -> Deriver Kernel
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right Text -> Text
forall a. a -> a
id (Either Text Kernel -> Deriver Kernel)
-> Either Text Kernel -> Deriver Kernel
forall a b. (a -> b) -> a -> b
$ [Char] -> Either Text Kernel
make_kernel (Text -> [Char]
untxt Text
kernel_s)
        let sangsih_above :: UpDown
sangsih_above = UpDown -> Maybe UpDown -> UpDown
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Kernel -> UpDown
infer_sangsih Bool
invert Kernel
kernel) Maybe UpDown
sangsih_dir
        Pitch
pitch <- PassedArgs Note -> Deriver Pitch
forall a. PassedArgs a -> Deriver Pitch
get_pitch PassedArgs Note
args
        ScoreTime -> Bool
under_threshold <- ControlRef -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function ControlRef
kotekan ScoreTime
dur
        let cycle :: Cycle
cycle = Bool
-> UpDown -> KotekanStyle -> Pasang Instrument -> Kernel -> Cycle
realize_kernel Bool
invert UpDown
sangsih_above KotekanStyle
style Pasang Instrument
pasang Kernel
kernel
        PassedArgs Note
-> (Maybe Bool, Bool)
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
forall a.
PassedArgs a
-> (Maybe Bool, Bool)
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
realize_kotekan_pattern_args PassedArgs Note
args (Maybe Bool, Bool)
initial_final
            ScoreTime
dur Pitch
pitch ScoreTime -> Bool
under_threshold Repeat
Repeat Cycle
cycle
    where
    infer_sangsih :: Bool -> Kernel -> UpDown
infer_sangsih Bool
invert Kernel
kernel = (if Bool
invert then UpDown -> UpDown
flip else UpDown -> UpDown
forall a. a -> a
id) (UpDown -> UpDown) -> UpDown -> UpDown
forall a b. (a -> b) -> a -> b
$
        case Kernel -> Maybe Atom
forall a. [a] -> Maybe a
Seq.last Kernel
kernel of
            Just Atom
High -> UpDown
Call.Down
            Maybe Atom
_ -> UpDown
Call.Up
    flip :: UpDown -> UpDown
flip UpDown
Call.Up = UpDown
Call.Down
    flip UpDown
Call.Down = UpDown
Call.Up

c_kotekan_explicit :: Derive.Generator Derive.Note
c_kotekan_explicit :: Generator Note
c_kotekan_explicit =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"kotekan" Tags
Tags.inst
    Doc
"Render a kotekan pattern from explicit polos and sangsih parts."
    (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ Parser (Text, Text, ScoreTime, Pasang Instrument)
-> ((Text, Text, ScoreTime, Pasang Instrument) -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    (Text
 -> Text
 -> ScoreTime
 -> Pasang Instrument
 -> (Text, Text, ScoreTime, Pasang Instrument))
-> Parser Text
-> Parser
     (Text
      -> ScoreTime
      -> Pasang Instrument
      -> (Text, Text, ScoreTime, Pasang Instrument))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Doc -> Parser Text
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"polos" Doc
"Polos part."
    Parser
  (Text
   -> ScoreTime
   -> Pasang Instrument
   -> (Text, Text, ScoreTime, Pasang Instrument))
-> Parser Text
-> Parser
     (ScoreTime
      -> Pasang Instrument -> (Text, Text, ScoreTime, Pasang Instrument))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Doc -> Parser Text
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"sangsih" Doc
"Sangsih part."
    Parser
  (ScoreTime
   -> Pasang Instrument -> (Text, Text, ScoreTime, Pasang Instrument))
-> Parser ScoreTime
-> Parser
     (Pasang Instrument -> (Text, Text, ScoreTime, Pasang Instrument))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env Parser
  (Pasang Instrument -> (Text, Text, ScoreTime, Pasang Instrument))
-> Parser (Pasang Instrument)
-> Parser (Text, Text, ScoreTime, Pasang Instrument)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env
    ) (((Text, Text, ScoreTime, Pasang Instrument) -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> ((Text, Text, ScoreTime, Pasang Instrument) -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \(Text
polos_s, Text
sangsih_s, ScoreTime
dur, Pasang Instrument
pasang) -> GeneratorF Note -> GeneratorF Note
forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting (GeneratorF Note -> GeneratorF Note)
-> GeneratorF Note -> GeneratorF Note
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        let (Int
expected, ScoreTime
frac) = ScoreTime -> (Int, ScoreTime)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (PassedArgs Note -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args ScoreTime -> ScoreTime -> ScoreTime
forall a. Fractional a => a -> a -> a
/ ScoreTime
dur)
        Bool -> Deriver State Error () -> Deriver State Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScoreTime
frac ScoreTime -> ScoreTime -> Bool
forall a. Eq a => a -> a -> Bool
/= ScoreTime
0) (Deriver State Error () -> Deriver State Error ())
-> Deriver State Error () -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Text -> Deriver State Error ()
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver State Error ()) -> Text -> Deriver State Error ()
forall a b. (a -> b) -> a -> b
$ Text
"event " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScoreTime -> Text
forall a. Show a => a -> Text
showt (PassedArgs Note -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not evenly divisble by kotekan dur " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScoreTime -> Text
forall a. Show a => a -> Text
showt ScoreTime
dur
        [Maybe Int]
polos_steps <- Text -> Int -> Text -> Deriver [Maybe Int]
parse Text
"polos" Int
expected Text
polos_s
        [Maybe Int]
sangsih_steps <- Text -> Int -> Text -> Deriver [Maybe Int]
parse Text
"sangsih" Int
expected Text
sangsih_s
        Pitch
pitch <- PassedArgs Note -> Deriver Pitch
forall a. PassedArgs a -> Deriver Pitch
get_pitch PassedArgs Note
args
        let realize :: [Maybe Int] -> Instrument -> NoteDeriver
realize = (ScoreTime, ScoreTime)
-> ScoreTime -> Pitch -> [Maybe Int] -> Instrument -> NoteDeriver
realize_explicit (PassedArgs Note -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Note
args) ScoreTime
dur Pitch
pitch
        [Maybe Int] -> Instrument -> NoteDeriver
realize [Maybe Int]
polos_steps (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang)
            NoteDeriver -> NoteDeriver -> NoteDeriver
forall a. Semigroup a => a -> a -> a
<> [Maybe Int] -> Instrument -> NoteDeriver
realize [Maybe Int]
sangsih_steps (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang)
    where
    parse :: Text -> Int -> Text -> Deriver [Maybe Int]
parse Text
name Int
expected Text
part_
        | Text -> Int
Text.length Text
part Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
expected =
            Text -> Deriver [Maybe Int]
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver [Maybe Int]) -> Text -> Deriver [Maybe Int]
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": expected length of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
expected
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but was " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt (Text -> Int
Text.length Text
part)
        | Bool
otherwise = (Text -> Text) -> Either Text [Maybe Int] -> Deriver [Maybe Int]
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
part Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":")<>) (Either Text [Maybe Int] -> Deriver [Maybe Int])
-> Either Text [Maybe Int] -> Deriver [Maybe Int]
forall a b. (a -> b) -> a -> b
$
            (Char -> Either Text (Maybe Int))
-> [Char] -> Either Text [Maybe Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> Either Text (Maybe Int)
parse1 (Text -> [Char]
untxt Text
part)
        where part :: Text
part = (Char -> Bool) -> Text -> Text
Text.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'k') Text
part_
    parse1 :: Char -> Either Text (Maybe Int)
parse1 Char
'-' = Maybe Int -> Either Text (Maybe Int)
forall a b. b -> Either a b
Right Maybe Int
forall a. Maybe a
Nothing
    parse1 Char
c = Either Text (Maybe Int)
-> (Int -> Either Text (Maybe Int))
-> Maybe Int
-> Either Text (Maybe Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text (Maybe Int)
forall a b. a -> Either a b
Left (Text -> Either Text (Maybe Int))
-> Text -> Either Text (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Text
"expected digit or '-': " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
forall a. Show a => a -> Text
showt Char
c)
        (Maybe Int -> Either Text (Maybe Int)
forall a b. b -> Either a b
Right (Maybe Int -> Either Text (Maybe Int))
-> (Int -> Maybe Int) -> Int -> Either Text (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just) (Char -> Maybe Int
Num.readDigit Char
c)

realize_explicit :: (ScoreTime, ScoreTime) -> ScoreTime -> PSignal.Pitch
    -> [Maybe Pitch.Step] -> ScoreT.Instrument -> Derive.NoteDeriver
realize_explicit :: (ScoreTime, ScoreTime)
-> ScoreTime -> Pitch -> [Maybe Int] -> Instrument -> NoteDeriver
realize_explicit (ScoreTime
start, ScoreTime
end) ScoreTime
dur Pitch
pitch [Maybe Int]
notes Instrument
inst = [NoteDeriver] -> NoteDeriver
forall a. Monoid a => [a] -> a
mconcat
    [ ScoreTime -> ScoreTime -> NoteDeriver -> NoteDeriver
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
t ScoreTime
dur (ScoreTime -> Int -> NoteDeriver
note ScoreTime
t Int
transpose)
    | (ScoreTime
t, Just Int
transpose) <- [ScoreTime] -> [Maybe Int] -> [(ScoreTime, Maybe Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([ScoreTime] -> [ScoreTime]
forall a. [a] -> [a]
tail (ScoreTime -> ScoreTime -> [ScoreTime]
forall a. Num a => a -> a -> [a]
Seq.range_ ScoreTime
start ScoreTime
dur)) [Maybe Int]
notes
    ]
    where
    note :: ScoreTime -> Int -> NoteDeriver
note ScoreTime
t Int
transpose =
        (if ScoreTime
t ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ScoreTime
end then Flags -> NoteDeriver -> NoteDeriver
Call.add_flags (Flags
Flags.infer_duration Flags -> Flags -> Flags
forall a. Semigroup a => a -> a -> a
<> Flags
final_flag)
            else NoteDeriver -> NoteDeriver
forall a. a -> a
id) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
        Instrument -> NoteDeriver -> NoteDeriver
forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Instrument
inst (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
        Pitch -> NoteDeriver
Call.pitched_note (Int -> Pitch -> Pitch
forall a. Int -> RawPitch a -> RawPitch a
Pitches.transpose_d Int
transpose Pitch
pitch)

kernel_doc :: Doc.Doc
kernel_doc :: Doc
kernel_doc = Doc
"Polos part in transposition steps.\
    \ This will be normalized to end on the destination pitch.\
    \ It should consist of `-`, `1`, and `2`. You can start with `k` to\
    \ avoid needing quotes. Starting with `k` will also require the length to\
    \ be a multiple of 4."

realize_kernel :: Bool -> Call.UpDown -> KotekanStyle
    -> Pasang ScoreT.Instrument -> Kernel -> Cycle
realize_kernel :: Bool
-> UpDown -> KotekanStyle -> Pasang Instrument -> Kernel -> Cycle
realize_kernel Bool
inverted UpDown
sangsih_above KotekanStyle
style Pasang Instrument
pasang Kernel
kernel =
    Cycle -> Cycle
end_on_zero (Cycle -> Cycle) -> Cycle -> Cycle
forall a b. (a -> b) -> a -> b
$ Kernel -> UpDown -> KotekanStyle -> Pasang Instrument -> Cycle
kernel_to_pattern
        ((if Bool
inverted then Kernel -> Kernel
invert else Kernel -> Kernel
forall a. a -> a
id) Kernel
kernel) UpDown
sangsih_above KotekanStyle
style Pasang Instrument
pasang

-- *** implementation

realize_kotekan_pattern_args :: Derive.PassedArgs a -> (Maybe Bool, Bool)
    -> ScoreTime -> PSignal.Pitch -> (ScoreTime -> Bool) -> Repeat -> Cycle
    -> Derive.NoteDeriver
realize_kotekan_pattern_args :: forall a.
PassedArgs a
-> (Maybe Bool, Bool)
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
realize_kotekan_pattern_args PassedArgs a
args (Maybe Bool, Bool)
initial_final =
    (Bool, Bool)
-> (ScoreTime, ScoreTime)
-> Orientation
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
realize_kotekan_pattern (PassedArgs a -> (Maybe Bool, Bool) -> (Bool, Bool)
forall a. PassedArgs a -> (Maybe Bool, Bool) -> (Bool, Bool)
infer_initial PassedArgs a
args (Maybe Bool, Bool)
initial_final)
        (PassedArgs a -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs a
args) (PassedArgs a -> Orientation
forall a. PassedArgs a -> Orientation
Args.orientation PassedArgs a
args)

-- | Take a Cycle, which is an abstract description of a pattern via
-- 'KotekanNote's, to real notes in a NoteDeriver.
realize_kotekan_pattern :: (Bool, Bool) -- ^ include (initial, final)
    -> (ScoreTime, ScoreTime) -> Types.Orientation -> ScoreTime -> PSignal.Pitch
    -> (ScoreTime -> Bool) -> Repeat -> Cycle -> Derive.NoteDeriver
realize_kotekan_pattern :: (Bool, Bool)
-> (ScoreTime, ScoreTime)
-> Orientation
-> ScoreTime
-> Pitch
-> (ScoreTime -> Bool)
-> Repeat
-> Cycle
-> NoteDeriver
realize_kotekan_pattern (Bool, Bool)
initial_final (ScoreTime
start, ScoreTime
end) Orientation
orientation ScoreTime
dur Pitch
pitch
        ScoreTime -> Bool
under_threshold Repeat
repeat Cycle
cycle =
    (KotekanNote -> NoteDeriver) -> [Note KotekanNote] -> NoteDeriver
forall a. (a -> NoteDeriver) -> [Note a] -> NoteDeriver
realize_notes KotekanNote -> NoteDeriver
realize ([Note KotekanNote] -> NoteDeriver)
-> [Note KotekanNote] -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
        Repeat
-> Orientation
-> (Bool, Bool)
-> ScoreTime
-> ScoreTime
-> ScoreTime
-> (ScoreTime -> [[KotekanNote]])
-> [Note KotekanNote]
forall a.
Repeat
-> Orientation
-> (Bool, Bool)
-> ScoreTime
-> ScoreTime
-> ScoreTime
-> (ScoreTime -> [[a]])
-> [Note a]
realize_pattern Repeat
repeat Orientation
orientation (Bool, Bool)
initial_final ScoreTime
start ScoreTime
end ScoreTime
dur ScoreTime -> [[KotekanNote]]
get_cycle
    where
    get_cycle :: ScoreTime -> [[KotekanNote]]
get_cycle ScoreTime
t
        | ScoreTime -> Bool
under_threshold ScoreTime
t = Cycle -> [[KotekanNote]]
forall a. Realization a -> a
interlocking Cycle
cycle
        | Bool
otherwise = Cycle -> [[KotekanNote]]
forall a. Realization a -> a
non_interlocking Cycle
cycle
    realize :: KotekanNote -> NoteDeriver
realize (KotekanNote Maybe Instrument
inst Int
steps Bool
muted) =
        (NoteDeriver -> NoteDeriver)
-> (Instrument -> NoteDeriver -> NoteDeriver)
-> Maybe Instrument
-> NoteDeriver
-> NoteDeriver
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NoteDeriver -> NoteDeriver
forall a. a -> a
id Instrument -> NoteDeriver -> NoteDeriver
forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Maybe Instrument
inst (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
        -- TODO the kind of muting should be configurable.  Or, rather I should
        -- dispatch to a zero dur note call, which will pick up whatever form
        -- of mute is configured.
        -- TODO I'm using 'm' for that now, right?
        (if Bool
muted then Attributes -> NoteDeriver -> NoteDeriver
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.mute else NoteDeriver -> NoteDeriver
forall a. a -> a
id) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
        Pitch -> NoteDeriver
Call.pitched_note (Int -> Pitch -> Pitch
forall a. Int -> RawPitch a -> RawPitch a
Pitches.transpose_d Int
steps Pitch
pitch)
    -- TODO It should no longer be necessary to strip flags from
    -- 'Call.pitched_note', because "" only puts flags on if the event is
    -- at the end of the track, and that shouldn't happen for these.  Still,
    -- Call.pitched_note should use a lower level note call that doesn't do
    -- things like that.

type Kernel = [Atom]
data Atom = Gap -- ^ a gap in the kotekan pattern
    | Rest -- ^ a rest will be filled in by the other part
    | Low | High
    deriving (Atom -> Atom -> Bool
(Atom -> Atom -> Bool) -> (Atom -> Atom -> Bool) -> Eq Atom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Atom -> Atom -> Bool
$c/= :: Atom -> Atom -> Bool
== :: Atom -> Atom -> Bool
$c== :: Atom -> Atom -> Bool
Eq, Eq Atom
Eq Atom
-> (Atom -> Atom -> Ordering)
-> (Atom -> Atom -> Bool)
-> (Atom -> Atom -> Bool)
-> (Atom -> Atom -> Bool)
-> (Atom -> Atom -> Bool)
-> (Atom -> Atom -> Atom)
-> (Atom -> Atom -> Atom)
-> Ord Atom
Atom -> Atom -> Bool
Atom -> Atom -> Ordering
Atom -> Atom -> Atom
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 :: Atom -> Atom -> Atom
$cmin :: Atom -> Atom -> Atom
max :: Atom -> Atom -> Atom
$cmax :: Atom -> Atom -> Atom
>= :: Atom -> Atom -> Bool
$c>= :: Atom -> Atom -> Bool
> :: Atom -> Atom -> Bool
$c> :: Atom -> Atom -> Bool
<= :: Atom -> Atom -> Bool
$c<= :: Atom -> Atom -> Bool
< :: Atom -> Atom -> Bool
$c< :: Atom -> Atom -> Bool
compare :: Atom -> Atom -> Ordering
$ccompare :: Atom -> Atom -> Ordering
Ord, Int -> Atom -> ShowS
Kernel -> ShowS
Atom -> [Char]
(Int -> Atom -> ShowS)
-> (Atom -> [Char]) -> (Kernel -> ShowS) -> Show Atom
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: Kernel -> ShowS
$cshowList :: Kernel -> ShowS
show :: Atom -> [Char]
$cshow :: Atom -> [Char]
showsPrec :: Int -> Atom -> ShowS
$cshowsPrec :: Int -> Atom -> ShowS
Show)

instance Pretty Atom where
    format :: Atom -> Doc
format = Char -> Doc
Pretty.char (Char -> Doc) -> (Atom -> Char) -> Atom -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Atom -> Char
to_char
    formatList :: Kernel -> Doc
formatList Kernel
cs =
        Doc
"make_kernel \"" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Pretty.text ([Char] -> Text
txt ((Atom -> Char) -> Kernel -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Atom -> Char
to_char Kernel
cs)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\""

make_kernel :: [Char] -> Either Text Kernel
make_kernel :: [Char] -> Either Text Kernel
make_kernel (Char
'k':[Char]
cs)
    | [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
cs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 =
        Text -> Either Text Kernel
forall a b. a -> Either a b
Left (Text -> Either Text Kernel) -> Text -> Either Text Kernel
forall a b. (a -> b) -> a -> b
$ Text
"kernel's length " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
cs)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a multiple of 4: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
showt [Char]
cs
    | Bool
otherwise = (Char -> Either Text Atom) -> [Char] -> Either Text Kernel
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> Either Text Atom
from_char [Char]
cs
make_kernel [Char]
cs = (Char -> Either Text Atom) -> [Char] -> Either Text Kernel
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> Either Text Atom
from_char [Char]
cs

from_char :: Char -> Either Text Atom
from_char :: Char -> Either Text Atom
from_char Char
c = case Char
c of
    Char
'_' -> Atom -> Either Text Atom
forall a b. b -> Either a b
Right Atom
Gap
    Char
'-' -> Atom -> Either Text Atom
forall a b. b -> Either a b
Right Atom
Rest
    Char
'1' -> Atom -> Either Text Atom
forall a b. b -> Either a b
Right Atom
Low
    Char
'2' -> Atom -> Either Text Atom
forall a b. b -> Either a b
Right Atom
High
    Char
_ -> Text -> Either Text Atom
forall a b. a -> Either a b
Left (Text -> Either Text Atom) -> Text -> Either Text Atom
forall a b. (a -> b) -> a -> b
$ Text
"kernel must be one of `_-12`, but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
forall a. Show a => a -> Text
showt Char
c

to_char :: Atom -> Char
to_char :: Atom -> Char
to_char Atom
c = case Atom
c of
    Atom
Gap -> Char
'_'
    Atom
Rest -> Char
'-'
    Atom
Low -> Char
'1'
    Atom
High -> Char
'2'

-- | Make both parts end on zero by subtracting the pitch of the final
-- non-interlocking note.
end_on_zero :: Cycle -> Cycle
end_on_zero :: Cycle -> Cycle
end_on_zero Cycle
realization = Realization
    { interlocking :: [[KotekanNote]]
interlocking = Int -> [[KotekanNote]] -> [[KotekanNote]]
add (-Int
steps) (Cycle -> [[KotekanNote]]
forall a. Realization a -> a
interlocking Cycle
realization)
    , non_interlocking :: [[KotekanNote]]
non_interlocking = Int -> [[KotekanNote]] -> [[KotekanNote]]
add (-Int
steps) (Cycle -> [[KotekanNote]]
forall a. Realization a -> a
non_interlocking Cycle
realization)
    }
    where
    add :: Int -> [[KotekanNote]] -> [[KotekanNote]]
add Int
steps = ([KotekanNote] -> [KotekanNote])
-> [[KotekanNote]] -> [[KotekanNote]]
forall a b. (a -> b) -> [a] -> [b]
map (([KotekanNote] -> [KotekanNote])
 -> [[KotekanNote]] -> [[KotekanNote]])
-> ([KotekanNote] -> [KotekanNote])
-> [[KotekanNote]]
-> [[KotekanNote]]
forall a b. (a -> b) -> a -> b
$ (KotekanNote -> KotekanNote) -> [KotekanNote] -> [KotekanNote]
forall a b. (a -> b) -> [a] -> [b]
map ((KotekanNote -> KotekanNote) -> [KotekanNote] -> [KotekanNote])
-> (KotekanNote -> KotekanNote) -> [KotekanNote] -> [KotekanNote]
forall a b. (a -> b) -> a -> b
$ \KotekanNote
note ->
        KotekanNote
note { note_steps :: Int
note_steps = Int
steps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ KotekanNote -> Int
note_steps KotekanNote
note }
    steps :: Int
steps = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ do
        KotekanNote
final : [KotekanNote]
_ <- [[KotekanNote]] -> Maybe [KotekanNote]
forall a. [a] -> Maybe a
Seq.last (Cycle -> [[KotekanNote]]
forall a. Realization a -> a
non_interlocking Cycle
realization)
        Int -> Maybe Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ KotekanNote -> Int
note_steps KotekanNote
final

kernel_to_pattern :: Kernel -> Call.UpDown -> KotekanStyle
    -> Pasang ScoreT.Instrument -> Cycle
kernel_to_pattern :: Kernel -> UpDown -> KotekanStyle -> Pasang Instrument -> Cycle
kernel_to_pattern Kernel
kernel UpDown
sangsih_above KotekanStyle
kotekan_style Pasang Instrument
pasang = Realization
    { interlocking :: [[KotekanNote]]
interlocking = (Atom -> [KotekanNote]) -> Kernel -> [[KotekanNote]]
forall a b. (a -> b) -> [a] -> [b]
map Atom -> [KotekanNote]
interlock Kernel
kernel
    , non_interlocking :: [[KotekanNote]]
non_interlocking = (Atom -> [KotekanNote]) -> Kernel -> [[KotekanNote]]
forall a b. (a -> b) -> [a] -> [b]
map Atom -> [KotekanNote]
non_interlock Kernel
kernel
    }
    where
    interlock :: Atom -> [KotekanNote]
interlock Atom
atom = case (UpDown
sangsih_above, KotekanStyle
kotekan_style) of
        (UpDown
Call.Up, KotekanStyle
Telu) -> case Atom
atom of
            Atom
Gap -> []
            Atom
Rest -> [Int -> KotekanNote
s Int
2]
            Atom
Low -> [Int -> KotekanNote
p Int
0]
            Atom
High -> [Int -> KotekanNote
p Int
1, Int -> KotekanNote
s Int
1]
        (UpDown
Call.Up, KotekanStyle
Pat) -> case Atom
atom of
            Atom
Gap -> []
            Atom
Rest -> [Int -> KotekanNote
s Int
2]
            Atom
Low -> [Int -> KotekanNote
p Int
0, Int -> KotekanNote
s Int
3]
            Atom
High -> [Int -> KotekanNote
p Int
1]
        (UpDown
Call.Down, KotekanStyle
Telu) -> case Atom
atom of
            Atom
Gap -> []
            Atom
Rest -> [Int -> KotekanNote
s (-Int
1)]
            Atom
Low -> [Int -> KotekanNote
p Int
0, Int -> KotekanNote
s Int
0]
            Atom
High -> [Int -> KotekanNote
p Int
1]
        (UpDown
Call.Down, KotekanStyle
Pat) -> case Atom
atom of
            Atom
Gap -> []
            Atom
Rest -> [Int -> KotekanNote
s (-Int
1)]
            Atom
Low -> [Int -> KotekanNote
p Int
0]
            Atom
High -> [Int -> KotekanNote
p Int
1, Int -> KotekanNote
s (-Int
2)]
    non_interlock :: Atom -> [KotekanNote]
non_interlock Atom
atom = case (UpDown
sangsih_above, KotekanStyle
kotekan_style) of
        (UpDown
Call.Up, KotekanStyle
Telu) -> case Atom
atom of
            Atom
Gap -> []
            Atom
Rest -> [Int -> KotekanNote
both Int
2]
            Atom
Low -> [Int -> KotekanNote
both Int
0]
            Atom
High -> [Int -> KotekanNote
both Int
1]
        (UpDown
Call.Up, KotekanStyle
Pat) -> case Atom
atom of
            Atom
Gap -> []
            Atom
Rest -> [Int -> KotekanNote
p Int
2, Int -> KotekanNote
s Int
2]
            Atom
Low -> [Int -> KotekanNote
p Int
0, Int -> KotekanNote
s Int
3]
            Atom
High -> [Int -> KotekanNote
p Int
1, Int -> KotekanNote
s Int
1]
        (UpDown
Call.Down, KotekanStyle
Telu) -> case Atom
atom of
            Atom
Gap -> []
            Atom
Rest -> [Int -> KotekanNote
both (-Int
1)]
            Atom
Low -> [Int -> KotekanNote
both Int
0]
            Atom
High -> [Int -> KotekanNote
both Int
1]
        (UpDown
Call.Down, KotekanStyle
Pat) -> case Atom
atom of
            Atom
Gap -> []
            Atom
Rest -> [Int -> KotekanNote
p (-Int
1), Int -> KotekanNote
s (-Int
1)]
            Atom
Low -> [Int -> KotekanNote
p Int
0, Int -> KotekanNote
s Int
0]
            Atom
High -> [Int -> KotekanNote
p Int
1, Int -> KotekanNote
s (-Int
2)]
    p :: Int -> KotekanNote
p = Maybe Instrument -> Int -> KotekanNote
kotekan_note (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang))
    s :: Int -> KotekanNote
s = Maybe Instrument -> Int -> KotekanNote
kotekan_note (Instrument -> Maybe Instrument
forall a. a -> Maybe a
Just (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang))
    both :: Int -> KotekanNote
both = Maybe Instrument -> Int -> KotekanNote
kotekan_note Maybe Instrument
forall a. Maybe a
Nothing

rotate :: Int -> [a] -> [a]
rotate :: forall a. Int -> [a] -> [a]
rotate Int
n [a]
xs = [[a]] -> [[a]]
forall a. [a] -> [a]
cycle ([a] -> [[a]]
forall a. [a] -> [[a]]
rotations [a]
xs) [[a]] -> Int -> [a]
forall a. [a] -> Int -> a
!! Int
n

rotations :: [a] -> [[a]]
rotations :: forall a. [a] -> [[a]]
rotations [a]
xs = [a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [[a]]
forall {a}. [a] -> [a] -> [[a]]
go [a]
xs ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs)
    where
    go :: [a] -> [a] -> [[a]]
go [] [a]
_ = []
    go [a]
_ [a
_] = []
    go [a]
_ [] = []
    go [a]
xs (a
z:[a]
zs) = [a]
p [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [[a]]
go [a]
p [a]
zs
        where p :: [a]
p = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
len (a
z a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)
    len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs

invert :: Kernel -> Kernel
invert :: Kernel -> Kernel
invert = (Atom -> Atom) -> Kernel -> Kernel
forall a b. (a -> b) -> [a] -> [b]
map ((Atom -> Atom) -> Kernel -> Kernel)
-> (Atom -> Atom) -> Kernel -> Kernel
forall a b. (a -> b) -> a -> b
$ \case
    Atom
Gap -> Atom
Gap
    Atom
Rest -> Atom
Rest
    Atom
High -> Atom
Low
    Atom
Low -> Atom
High

-- *** all kernels

-- | Find a kernel as a rotation or inversion of one of the standard ones.
find_kernel :: Kernel -> Maybe (Kernel, Bool, Int)
find_kernel :: Kernel -> Maybe (Kernel, Bool, Int)
find_kernel Kernel
kernel = Kernel
-> [(Kernel, (Kernel, Bool, Int))] -> Maybe (Kernel, Bool, Int)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Kernel
kernel [(Kernel, (Kernel, Bool, Int))]
variants
    where
    variants :: [(Kernel, (Kernel, Bool, Int))]
variants =
        [ (Kernel
variant, (Kernel
kernel, Bool
inverted, Int
rotation))
        | Kernel
kernel <- [Kernel]
all_kernels
        , (Kernel
variant, (Bool
inverted, Int
rotation)) <- Kernel -> [(Kernel, (Bool, Int))]
variations Kernel
kernel
        ]
    all_kernels :: [Kernel]
all_kernels = [Kernel
kernel_12_1_21, Kernel
kernel_1_21_21, Kernel
kernel_2_21_21]
    Right Kernel
kernel_12_1_21 = [Char] -> Either Text Kernel
make_kernel [Char]
"-12-1-21"
    Right Kernel
kernel_1_21_21 = [Char] -> Either Text Kernel
make_kernel [Char]
"-1-21-21"
    Right Kernel
kernel_2_21_21 = [Char] -> Either Text Kernel
make_kernel [Char]
"-2-21-21"

    variations :: Kernel -> [(Kernel, (Bool, Int))]
    variations :: Kernel -> [(Kernel, (Bool, Int))]
variations Kernel
kernel_ = ((Kernel, (Bool, Int)) -> Kernel)
-> [(Kernel, (Bool, Int))] -> [(Kernel, (Bool, Int))]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.unique_on (Kernel, (Bool, Int)) -> Kernel
forall a b. (a, b) -> a
fst
        [ (Kernel
variant, (Bool
inverted, Int
rotate))
        | (Bool
inverted, Kernel
kernel) <- [(Bool
False, Kernel
kernel_), (Bool
True, Kernel -> Kernel
invert Kernel
kernel_)]
        , (Int
rotate, Kernel
variant) <- [Int] -> [Kernel] -> [(Int, Kernel)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (Kernel -> [Kernel]
forall a. [a] -> [[a]]
rotations Kernel
kernel)
        ]

-- ** implementation

data Repeat = Repeat | Once deriving (Int -> Repeat -> ShowS
[Repeat] -> ShowS
Repeat -> [Char]
(Int -> Repeat -> ShowS)
-> (Repeat -> [Char]) -> ([Repeat] -> ShowS) -> Show Repeat
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Repeat] -> ShowS
$cshowList :: [Repeat] -> ShowS
show :: Repeat -> [Char]
$cshow :: Repeat -> [Char]
showsPrec :: Int -> Repeat -> ShowS
$cshowsPrec :: Int -> Repeat -> ShowS
Show)
instance Pretty Repeat where pretty :: Repeat -> Text
pretty = Repeat -> Text
forall a. Show a => a -> Text
showt

-- | (interlocking pattern, non-interlocking pattern)
--
-- Each list represents coincident notes.  [] is a rest.
type Cycle = Realization [[KotekanNote]]

data Note a = Note {
    forall a. Note a -> ScoreTime
note_start :: !ScoreTime
    , forall a. Note a -> ScoreTime
note_duration :: !ScoreTime
    -- | Used for 'final_flag'.
    , forall a. Note a -> Flags
note_flags :: !Flags.Flags
    , forall a. Note a -> a
note_data :: !a
    } deriving ((forall a b. (a -> b) -> Note a -> Note b)
-> (forall a b. a -> Note b -> Note a) -> Functor Note
forall a b. a -> Note b -> Note a
forall a b. (a -> b) -> Note a -> Note b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Note b -> Note a
$c<$ :: forall a b. a -> Note b -> Note a
fmap :: forall a b. (a -> b) -> Note a -> Note b
$cfmap :: forall a b. (a -> b) -> Note a -> Note b
Functor, Int -> Note a -> ShowS
[Note a] -> ShowS
Note a -> [Char]
(Int -> Note a -> ShowS)
-> (Note a -> [Char]) -> ([Note a] -> ShowS) -> Show (Note a)
forall a. Show a => Int -> Note a -> ShowS
forall a. Show a => [Note a] -> ShowS
forall a. Show a => Note a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Note a] -> ShowS
$cshowList :: forall a. Show a => [Note a] -> ShowS
show :: Note a -> [Char]
$cshow :: forall a. Show a => Note a -> [Char]
showsPrec :: Int -> Note a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Note a -> ShowS
Show)

instance Pretty a => Pretty (Note a) where
    format :: Note a -> Doc
format (Note ScoreTime
start ScoreTime
dur Flags
flags a
d) = (ScoreTime, ScoreTime, Flags, a) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (ScoreTime
start, ScoreTime
dur, Flags
flags, a
d)

add_flag :: Flags.Flags -> Note a -> Note a
add_flag :: forall a. Flags -> Note a -> Note a
add_flag Flags
flag Note a
n = Note a
n { note_flags :: Flags
note_flags = Flags
flag Flags -> Flags -> Flags
forall a. Semigroup a => a -> a -> a
<> Note a -> Flags
forall a. Note a -> Flags
note_flags Note a
n }

-- | High level description of a note.  This goes into Note before it becomes
-- a Derive.NoteDeriver.
data KotekanNote = KotekanNote {
    -- | If Nothing, retain the instrument in scope.  Presumably it will be
    -- later split into polos and sangsih by a @unison@ or @kempyung@ call.
    KotekanNote -> Maybe Instrument
note_instrument :: !(Maybe ScoreT.Instrument)
    , KotekanNote -> Int
note_steps :: !Pitch.Step
    , KotekanNote -> Bool
note_muted :: !Bool
    } deriving (Int -> KotekanNote -> ShowS
[KotekanNote] -> ShowS
KotekanNote -> [Char]
(Int -> KotekanNote -> ShowS)
-> (KotekanNote -> [Char])
-> ([KotekanNote] -> ShowS)
-> Show KotekanNote
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [KotekanNote] -> ShowS
$cshowList :: [KotekanNote] -> ShowS
show :: KotekanNote -> [Char]
$cshow :: KotekanNote -> [Char]
showsPrec :: Int -> KotekanNote -> ShowS
$cshowsPrec :: Int -> KotekanNote -> ShowS
Show)

instance Pretty KotekanNote where
    format :: KotekanNote -> Doc
format (KotekanNote Maybe Instrument
inst Int
steps Bool
muted) =
        (Maybe Instrument, Int, Text) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Maybe Instrument
inst, Int
steps, if Bool
muted then Text
"+mute" else Text
"+open" :: Text)

kotekan_note :: Maybe ScoreT.Instrument -> Pitch.Step -> KotekanNote
kotekan_note :: Maybe Instrument -> Int -> KotekanNote
kotekan_note Maybe Instrument
inst Int
steps = KotekanNote
    { note_instrument :: Maybe Instrument
note_instrument = Maybe Instrument
inst
    , note_steps :: Int
note_steps = Int
steps
    , note_muted :: Bool
note_muted = Bool
False
    }

muted_note :: KotekanNote -> KotekanNote
muted_note :: KotekanNote -> KotekanNote
muted_note KotekanNote
note = KotekanNote
note { note_muted :: Bool
note_muted = Bool
True }

under_threshold_function :: DeriveT.ControlRef -> ScoreTime
    -> Derive.Deriver (ScoreTime -> Bool) -- ^ say if a note at this time
    -- with the given duration would be under the kotekan threshold
under_threshold_function :: ControlRef -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function ControlRef
kotekan ScoreTime
dur = do
    ScoreTime -> RealTime
to_real <- Deriver (ScoreTime -> RealTime)
Derive.real_function
    Function
kotekan <- ControlRef -> Deriver Function
Call.to_function ControlRef
kotekan
    (ScoreTime -> Bool) -> Deriver (ScoreTime -> Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ScoreTime -> Bool) -> Deriver (ScoreTime -> Bool))
-> (ScoreTime -> Bool) -> Deriver (ScoreTime -> Bool)
forall a b. (a -> b) -> a -> b
$ \ScoreTime
t ->
        let real :: RealTime
real = ScoreTime -> RealTime
to_real ScoreTime
t
        in ScoreTime -> RealTime
to_real (ScoreTime
tScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ScoreTime
dur) RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
real RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
< Y -> RealTime
RealTime.seconds (Function
kotekan RealTime
real)

-- | Repeatedly call a cycle generating function to create notes.  The result
-- will presumably be passed to 'realize_notes' to convert the notes into
-- NoteDerivers.
realize_pattern :: Repeat -- ^ Once will just call get_cycle at the start
    -- time.  Repeat will start the cycle at t+1 because t is the initial, so
    -- it's the end of the cycle.
    -> Types.Orientation -- ^ align to start or end
    -> (Bool, Bool)
    -> ScoreTime -> ScoreTime -> ScoreTime
    -> (ScoreTime -> [[a]]) -- ^ Get one cycle of notes, starting at the time.
    -> [Note a]
realize_pattern :: forall a.
Repeat
-> Orientation
-> (Bool, Bool)
-> ScoreTime
-> ScoreTime
-> ScoreTime
-> (ScoreTime -> [[a]])
-> [Note a]
realize_pattern Repeat
repeat Orientation
orientation (Bool
initial, Bool
final) ScoreTime
start ScoreTime
end ScoreTime
dur ScoreTime -> [[a]]
get_cycle =
    case Repeat
repeat of
        Repeat
Once -> ((ScoreTime, [a]) -> [Note a]) -> [(ScoreTime, [a])] -> [Note a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ScoreTime, [a]) -> [Note a]
forall {a}. (ScoreTime, [a]) -> [Note a]
realize ([(ScoreTime, [a])] -> [Note a]) -> [(ScoreTime, [a])] -> [Note a]
forall a b. (a -> b) -> a -> b
$
            (if Orientation
orientation Orientation -> Orientation -> Bool
forall a. Eq a => a -> a -> Bool
== Orientation
Types.Positive then [ScoreTime] -> [[a]] -> [(ScoreTime, [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip else [ScoreTime] -> [[a]] -> [(ScoreTime, [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip_end)
                (ScoreTime -> ScoreTime -> ScoreTime -> [ScoreTime]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.range ScoreTime
start ScoreTime
end ScoreTime
dur) (ScoreTime -> [[a]]
get_cycle ScoreTime
start)
        Repeat
Repeat -> ((ScoreTime, [a]) -> [Note a]) -> [(ScoreTime, [a])] -> [Note a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ScoreTime, [a]) -> [Note a]
forall {a}. (ScoreTime, [a]) -> [Note a]
realize [(ScoreTime, [a])]
pairs
    where
    pairs :: [(ScoreTime, [a])]
pairs = case Orientation
orientation of
        Orientation
Types.Positive -> (ScoreTime -> [[a]]) -> [ScoreTime] -> [(ScoreTime, [a])]
forall t a. (t -> [a]) -> [t] -> [(t, a)]
cycles ScoreTime -> [[a]]
wrapped [ScoreTime]
ts
        Orientation
Types.Negative -> (ScoreTime -> [[a]]) -> [ScoreTime] -> [(ScoreTime, [a])]
forall t a. (t -> [a]) -> [t] -> [(t, a)]
cycles_end ScoreTime -> [[a]]
get_cycle [ScoreTime]
ts
        where ts :: [ScoreTime]
ts = ScoreTime -> ScoreTime -> ScoreTime -> [ScoreTime]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.range ScoreTime
start ScoreTime
end ScoreTime
dur
    -- Since cycles are end-weighted, I have to get the end of a cycle if an
    -- initial note is wanted.
    wrapped :: ScoreTime -> [[a]]
wrapped ScoreTime
t
        | ScoreTime
t ScoreTime -> ScoreTime -> Bool
forall a. Eq a => a -> a -> Bool
== ScoreTime
start = [[a]] -> ([a] -> [[a]]) -> Maybe [a] -> [[a]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[]) ([[a]] -> Maybe [a]
forall a. [a] -> Maybe a
Seq.last [[a]]
ns)
        | Bool
otherwise = [[a]]
ns
        where ns :: [[a]]
ns = ScoreTime -> [[a]]
get_cycle ScoreTime
t
    realize :: (ScoreTime, [a]) -> [Note a]
realize (ScoreTime
t, [a]
chord)
        | ScoreTime
t ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ScoreTime
end = if Bool
final
            then (Note a -> Note a) -> [Note a] -> [Note a]
forall a b. (a -> b) -> [a] -> [b]
map (Flags -> Note a -> Note a
forall a. Flags -> Note a -> Note a
add_flag (Flags
Flags.infer_duration Flags -> Flags -> Flags
forall a. Semigroup a => a -> a -> a
<> Flags
final_flag)) [Note a]
ns
            else []
        | ScoreTime
t ScoreTime -> ScoreTime -> Bool
forall a. Eq a => a -> a -> Bool
== ScoreTime
start = if Bool
initial then [Note a]
ns else []
        | Bool
otherwise = [Note a]
ns
        where ns :: [Note a]
ns = (a -> Note a) -> [a] -> [Note a]
forall a b. (a -> b) -> [a] -> [b]
map (ScoreTime -> ScoreTime -> Flags -> a -> Note a
forall a. ScoreTime -> ScoreTime -> Flags -> a -> Note a
Note ScoreTime
t ScoreTime
dur Flags
forall a. Monoid a => a
mempty) [a]
chord

-- | Pair each @t@ with an @a@, asking the function for more @a@s as needed.
cycles :: (t -> [a]) -> [t] -> [(t, a)]
cycles :: forall t a. (t -> [a]) -> [t] -> [(t, a)]
cycles t -> [a]
get_cycle = [t] -> [(t, a)]
go
    where
    go :: [t] -> [(t, a)]
go [] = []
    go (t
t:[t]
ts) = case Either [t] [a]
rest of
        Left [t]
ts -> [(t, a)]
pairs [(t, a)] -> [(t, a)] -> [(t, a)]
forall a. [a] -> [a] -> [a]
++ [t] -> [(t, a)]
go [t]
ts
        Right [a]
_ -> [(t, a)]
pairs
        where ([(t, a)]
pairs, Either [t] [a]
rest) = [t] -> [a] -> ([(t, a)], Either [t] [a])
forall a b. [a] -> [b] -> ([(a, b)], Either [a] [b])
Seq.zip_remainder (t
tt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
ts) (t -> [a]
get_cycle t
t)

-- | This is like 'cycles', but the last cycle is aligned to the end of the
-- @t@s, chopping off the front of the cycle if necessary.
cycles_end :: (t -> [a]) -> [t] -> [(t, a)]
cycles_end :: forall t a. (t -> [a]) -> [t] -> [(t, a)]
cycles_end t -> [a]
get_cycle = ([(t, a)], [a]) -> [(t, a)]
forall {a} {b}. ([(a, b)], [b]) -> [(a, b)]
shift (([(t, a)], [a]) -> [(t, a)])
-> ([t] -> ([(t, a)], [a])) -> [t] -> [(t, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t] -> ([(t, a)], [a])
go
    where
    shift :: ([(a, b)], [b]) -> [(a, b)]
shift ([(a, b)]
pairs, [b]
rest_ns) = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
ts (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
rest_ns) [b]
ns [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b]
rest_ns)
        where ([a]
ts, [b]
ns) = [(a, b)] -> ([a], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a, b)]
pairs
    go :: [t] -> ([(t, a)], [a])
go [] = ([], [])
    go (t
t:[t]
ts) = case Either [t] [a]
rest of
        Left [t]
ts -> ([(t, a)] -> [(t, a)]) -> ([(t, a)], [a]) -> ([(t, a)], [a])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([(t, a)]
pairs++) ([t] -> ([(t, a)], [a])
go [t]
ts)
        Right [a]
ns -> ([(t, a)]
pairs, [a]
ns)
        where ([(t, a)]
pairs, Either [t] [a]
rest) = [t] -> [a] -> ([(t, a)], Either [t] [a])
forall a b. [a] -> [b] -> ([(a, b)], Either [a] [b])
Seq.zip_remainder (t
tt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
ts) (t -> [a]
get_cycle t
t)

-- | Like 'zip', but two sequences are aligned at at their ends, instead of
-- their starts.
zip_end :: [a] -> [b] -> [(a, b)]
zip_end :: forall a b. [a] -> [b] -> [(a, b)]
zip_end [a]
xs [b]
ys = [(a, b)] -> [(a, b)]
forall a. [a] -> [a]
reverse ([a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs) ([b] -> [b]
forall a. [a] -> [a]
reverse [b]
ys))

-- | Turn Notes into a NoteDeriver.
realize_notes :: (a -> Derive.NoteDeriver) -> [Note a] -> Derive.NoteDeriver
realize_notes :: forall a. (a -> NoteDeriver) -> [Note a] -> NoteDeriver
realize_notes a -> NoteDeriver
realize = (Note a -> NoteDeriver) -> [Note a] -> NoteDeriver
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap ((Note a -> NoteDeriver) -> [Note a] -> NoteDeriver)
-> (Note a -> NoteDeriver) -> [Note a] -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ \(Note ScoreTime
start ScoreTime
dur Flags
flags a
note) ->
    ScoreTime -> ScoreTime -> NoteDeriver -> NoteDeriver
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
dur (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Flags -> NoteDeriver -> NoteDeriver
Call.add_flags Flags
flags (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ a -> NoteDeriver
realize a
note

-- | Style for non-interlocking norot.  Interlocking norot is always the upper
-- neighbor (or lower on the top key).
data NorotStyle =
    -- | Norot is emitted as the current instrument, which should be converted
    -- into kempyung or unison by a postproc.
    Default
    -- | Norot in the diamond pattern, where sangsih goes down.
    | Diamond
    deriving (NorotStyle
NorotStyle -> NorotStyle -> Bounded NorotStyle
forall a. a -> a -> Bounded a
maxBound :: NorotStyle
$cmaxBound :: NorotStyle
minBound :: NorotStyle
$cminBound :: NorotStyle
Bounded, NorotStyle -> NorotStyle -> Bool
(NorotStyle -> NorotStyle -> Bool)
-> (NorotStyle -> NorotStyle -> Bool) -> Eq NorotStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NorotStyle -> NorotStyle -> Bool
$c/= :: NorotStyle -> NorotStyle -> Bool
== :: NorotStyle -> NorotStyle -> Bool
$c== :: NorotStyle -> NorotStyle -> Bool
Eq, Int -> NorotStyle
NorotStyle -> Int
NorotStyle -> [NorotStyle]
NorotStyle -> NorotStyle
NorotStyle -> NorotStyle -> [NorotStyle]
NorotStyle -> NorotStyle -> NorotStyle -> [NorotStyle]
(NorotStyle -> NorotStyle)
-> (NorotStyle -> NorotStyle)
-> (Int -> NorotStyle)
-> (NorotStyle -> Int)
-> (NorotStyle -> [NorotStyle])
-> (NorotStyle -> NorotStyle -> [NorotStyle])
-> (NorotStyle -> NorotStyle -> [NorotStyle])
-> (NorotStyle -> NorotStyle -> NorotStyle -> [NorotStyle])
-> Enum NorotStyle
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: NorotStyle -> NorotStyle -> NorotStyle -> [NorotStyle]
$cenumFromThenTo :: NorotStyle -> NorotStyle -> NorotStyle -> [NorotStyle]
enumFromTo :: NorotStyle -> NorotStyle -> [NorotStyle]
$cenumFromTo :: NorotStyle -> NorotStyle -> [NorotStyle]
enumFromThen :: NorotStyle -> NorotStyle -> [NorotStyle]
$cenumFromThen :: NorotStyle -> NorotStyle -> [NorotStyle]
enumFrom :: NorotStyle -> [NorotStyle]
$cenumFrom :: NorotStyle -> [NorotStyle]
fromEnum :: NorotStyle -> Int
$cfromEnum :: NorotStyle -> Int
toEnum :: Int -> NorotStyle
$ctoEnum :: Int -> NorotStyle
pred :: NorotStyle -> NorotStyle
$cpred :: NorotStyle -> NorotStyle
succ :: NorotStyle -> NorotStyle
$csucc :: NorotStyle -> NorotStyle
Enum, Int -> NorotStyle -> ShowS
[NorotStyle] -> ShowS
NorotStyle -> [Char]
(Int -> NorotStyle -> ShowS)
-> (NorotStyle -> [Char])
-> ([NorotStyle] -> ShowS)
-> Show NorotStyle
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NorotStyle] -> ShowS
$cshowList :: [NorotStyle] -> ShowS
show :: NorotStyle -> [Char]
$cshow :: NorotStyle -> [Char]
showsPrec :: Int -> NorotStyle -> ShowS
$cshowsPrec :: Int -> NorotStyle -> ShowS
Show)

instance ShowVal.ShowVal NorotStyle
instance Typecheck.Typecheck NorotStyle

data KotekanStyle = Telu | Pat deriving (KotekanStyle
KotekanStyle -> KotekanStyle -> Bounded KotekanStyle
forall a. a -> a -> Bounded a
maxBound :: KotekanStyle
$cmaxBound :: KotekanStyle
minBound :: KotekanStyle
$cminBound :: KotekanStyle
Bounded, KotekanStyle -> KotekanStyle -> Bool
(KotekanStyle -> KotekanStyle -> Bool)
-> (KotekanStyle -> KotekanStyle -> Bool) -> Eq KotekanStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KotekanStyle -> KotekanStyle -> Bool
$c/= :: KotekanStyle -> KotekanStyle -> Bool
== :: KotekanStyle -> KotekanStyle -> Bool
$c== :: KotekanStyle -> KotekanStyle -> Bool
Eq, Int -> KotekanStyle
KotekanStyle -> Int
KotekanStyle -> [KotekanStyle]
KotekanStyle -> KotekanStyle
KotekanStyle -> KotekanStyle -> [KotekanStyle]
KotekanStyle -> KotekanStyle -> KotekanStyle -> [KotekanStyle]
(KotekanStyle -> KotekanStyle)
-> (KotekanStyle -> KotekanStyle)
-> (Int -> KotekanStyle)
-> (KotekanStyle -> Int)
-> (KotekanStyle -> [KotekanStyle])
-> (KotekanStyle -> KotekanStyle -> [KotekanStyle])
-> (KotekanStyle -> KotekanStyle -> [KotekanStyle])
-> (KotekanStyle -> KotekanStyle -> KotekanStyle -> [KotekanStyle])
-> Enum KotekanStyle
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: KotekanStyle -> KotekanStyle -> KotekanStyle -> [KotekanStyle]
$cenumFromThenTo :: KotekanStyle -> KotekanStyle -> KotekanStyle -> [KotekanStyle]
enumFromTo :: KotekanStyle -> KotekanStyle -> [KotekanStyle]
$cenumFromTo :: KotekanStyle -> KotekanStyle -> [KotekanStyle]
enumFromThen :: KotekanStyle -> KotekanStyle -> [KotekanStyle]
$cenumFromThen :: KotekanStyle -> KotekanStyle -> [KotekanStyle]
enumFrom :: KotekanStyle -> [KotekanStyle]
$cenumFrom :: KotekanStyle -> [KotekanStyle]
fromEnum :: KotekanStyle -> Int
$cfromEnum :: KotekanStyle -> Int
toEnum :: Int -> KotekanStyle
$ctoEnum :: Int -> KotekanStyle
pred :: KotekanStyle -> KotekanStyle
$cpred :: KotekanStyle -> KotekanStyle
succ :: KotekanStyle -> KotekanStyle
$csucc :: KotekanStyle -> KotekanStyle
Enum, Int -> KotekanStyle -> ShowS
[KotekanStyle] -> ShowS
KotekanStyle -> [Char]
(Int -> KotekanStyle -> ShowS)
-> (KotekanStyle -> [Char])
-> ([KotekanStyle] -> ShowS)
-> Show KotekanStyle
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [KotekanStyle] -> ShowS
$cshowList :: [KotekanStyle] -> ShowS
show :: KotekanStyle -> [Char]
$cshow :: KotekanStyle -> [Char]
showsPrec :: Int -> KotekanStyle -> ShowS
$cshowsPrec :: Int -> KotekanStyle -> ShowS
Show)
instance ShowVal.ShowVal KotekanStyle
instance Typecheck.Typecheck KotekanStyle

-- * postproc

c_unison :: Derive.Transformer Derive.Note
c_unison :: Transformer Note
c_unison = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF Note)
-> Transformer Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"unison" Tags
Tags.postproc
    Doc
"Split part into unison polos and sangsih. Emit only polos if\
    \ `only=polos` and only sangsih if `only=sangsih`."
    (WithArgDoc (TransformerF Note) -> Transformer Note)
-> WithArgDoc (TransformerF Note) -> Transformer Note
forall a b. (a -> b) -> a -> b
$ Parser (Pasang Instrument)
-> (Pasang Instrument -> TransformerF Note)
-> WithArgDoc (TransformerF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser (Pasang Instrument)
pasang_env ((Pasang Instrument -> TransformerF Note)
 -> WithArgDoc (TransformerF Note))
-> (Pasang Instrument -> TransformerF Note)
-> WithArgDoc (TransformerF Note)
forall a b. (a -> b) -> a -> b
$ \Pasang Instrument
pasang PassedArgs Note
_args NoteDeriver
deriver -> do
        Instrument
inst <- Deriver Instrument
Call.get_instrument
        Pasang (Instrument, Instrument)
pasang <- (Instrument, Instrument)
-> (Instrument, Instrument) -> Pasang (Instrument, Instrument)
forall a. a -> a -> Pasang a
Pasang ((Instrument, Instrument)
 -> (Instrument, Instrument) -> Pasang (Instrument, Instrument))
-> Deriver State Error (Instrument, Instrument)
-> Deriver
     State
     Error
     ((Instrument, Instrument) -> Pasang (Instrument, Instrument))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Deriver State Error (Instrument, Instrument)
Derive.get_instrument (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang)
            Deriver
  State
  Error
  ((Instrument, Instrument) -> Pasang (Instrument, Instrument))
-> Deriver State Error (Instrument, Instrument)
-> Deriver State Error (Pasang (Instrument, Instrument))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Instrument -> Deriver State Error (Instrument, Instrument)
Derive.get_instrument (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang)
        (Note -> [Note]) -> Stream Note -> Stream Note
forall a. (a -> [Note]) -> Stream a -> Stream Note
Post.emap_asc_ (Instrument -> Pasang (Instrument, Instrument) -> Note -> [Note]
unison Instrument
inst Pasang (Instrument, Instrument)
pasang) (Stream Note -> Stream Note) -> NoteDeriver -> NoteDeriver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NoteDeriver
deriver
    where
    unison :: Instrument -> Pasang (Instrument, Instrument) -> Note -> [Note]
unison Instrument
inst Pasang (Instrument, Instrument)
pasang Note
event
        | Note -> Instrument
Score.event_instrument Note
event Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
== Instrument
inst = [(Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set Pasang (Instrument, Instrument) -> (Instrument, Instrument)
forall a. Pasang a -> a
polos, (Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set Pasang (Instrument, Instrument) -> (Instrument, Instrument)
forall a. Pasang a -> a
sangsih]
        | Bool
otherwise = [Note
event]
        where
        msg :: Text
msg = Text
"unison from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst
        set :: (Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set Pasang (Instrument, Instrument) -> (Instrument, Instrument)
role = HasCallStack => Text -> Note -> Note
Text -> Note -> Note
Score.add_log Text
msg (Note -> Note) -> Note -> Note
forall a b. (a -> b) -> a -> b
$ (Instrument, Instrument) -> Note -> Note
Post.set_instrument (Pasang (Instrument, Instrument) -> (Instrument, Instrument)
role Pasang (Instrument, Instrument)
pasang) Note
event

-- | I could do this in two different ways:  Eval normally, then eval with
-- +kempyung, and make instrument note call understand it.  Or, postproc,
-- transpose, and check if the nn is above a limit.  The first one would let
-- the instrument choose how it wants to interpret +kempyung while letting this
-- call remain generic, but let's face it, it only really means one thing.  The
-- second seems a little simpler since it doesn't need a cooperating note call.
--
-- So postproc it is.
c_kempyung :: Library.Calls Derive.Note
c_kempyung :: Calls Note
c_kempyung = Module
-> CallName
-> Tags
-> Doc
-> Parser (Maybe Pitch, Pasang Instrument)
-> ((Maybe Pitch, Pasang Instrument) -> NoteDeriver -> NoteDeriver)
-> Calls Note
forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
module_ CallName
"kempyung" Tags
Tags.postproc
    Doc
"Split part into kempyung, with `polos-inst` below and `sangsih-inst`\
    \ above. If the sangsih would go out of range, it's forced into unison."
    ((,)
    (Maybe Pitch
 -> Pasang Instrument -> (Maybe Pitch, Pasang Instrument))
-> Parser (Maybe Pitch)
-> Parser (Pasang Instrument -> (Maybe Pitch, Pasang Instrument))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe Pitch)
instrument_top_env Parser (Pasang Instrument -> (Maybe Pitch, Pasang Instrument))
-> Parser (Pasang Instrument)
-> Parser (Maybe Pitch, Pasang Instrument)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env
    ) (((Maybe Pitch, Pasang Instrument) -> NoteDeriver -> NoteDeriver)
 -> Calls Note)
-> ((Maybe Pitch, Pasang Instrument) -> NoteDeriver -> NoteDeriver)
-> Calls Note
forall a b. (a -> b) -> a -> b
$ \(Maybe Pitch
maybe_top, Pasang Instrument
pasang) NoteDeriver
deriver -> do
        Instrument
pasang_inst <- Deriver Instrument
Call.get_instrument
        Pasang (Instrument, Instrument)
pasang <- (Instrument, Instrument)
-> (Instrument, Instrument) -> Pasang (Instrument, Instrument)
forall a. a -> a -> Pasang a
Pasang ((Instrument, Instrument)
 -> (Instrument, Instrument) -> Pasang (Instrument, Instrument))
-> Deriver State Error (Instrument, Instrument)
-> Deriver
     State
     Error
     ((Instrument, Instrument) -> Pasang (Instrument, Instrument))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Deriver State Error (Instrument, Instrument)
Derive.get_instrument (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang)
            Deriver
  State
  Error
  ((Instrument, Instrument) -> Pasang (Instrument, Instrument))
-> Deriver State Error (Instrument, Instrument)
-> Deriver State Error (Pasang (Instrument, Instrument))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Instrument -> Deriver State Error (Instrument, Instrument)
Derive.get_instrument (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang)
        Scale
scale <- Deriver Scale
Call.get_scale
        let too_high :: Note -> Bool
too_high = Scale -> Maybe Pitch -> Note -> Bool
pitch_too_high Scale
scale Maybe Pitch
maybe_top
        (Note -> [Note]) -> Stream Note -> Stream Note
forall a. (a -> [Note]) -> Stream a -> Stream Note
Post.emap_asc_ ((Note -> Bool)
-> Instrument -> Pasang (Instrument, Instrument) -> Note -> [Note]
kempyung Note -> Bool
too_high Instrument
pasang_inst Pasang (Instrument, Instrument)
pasang) (Stream Note -> Stream Note) -> NoteDeriver -> NoteDeriver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NoteDeriver
deriver
    where
    kempyung :: (Note -> Bool)
-> Instrument -> Pasang (Instrument, Instrument) -> Note -> [Note]
kempyung Note -> Bool
too_high Instrument
pasang_inst Pasang (Instrument, Instrument)
pasang Note
event
        | Note -> Instrument
Score.event_instrument Note
event Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
== Instrument
pasang_inst =
            [ Text
-> (Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set (Text
"low kempyung from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
pasang_inst) Pasang (Instrument, Instrument) -> (Instrument, Instrument)
forall a. Pasang a -> a
polos
            , (Note -> Bool) -> Note -> Note
transpose Note -> Bool
too_high (Note -> Note) -> Note -> Note
forall a b. (a -> b) -> a -> b
$
                Text
-> (Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set (Text
"high kempyung from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
pasang_inst) Pasang (Instrument, Instrument) -> (Instrument, Instrument)
forall a. Pasang a -> a
sangsih
            ]
        | Bool
otherwise = [Note
event]
        where
        set :: Text
-> (Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set Text
msg Pasang (Instrument, Instrument) -> (Instrument, Instrument)
role =
            HasCallStack => Text -> Note -> Note
Text -> Note -> Note
Score.add_log Text
msg (Note -> Note) -> Note -> Note
forall a b. (a -> b) -> a -> b
$ (Instrument, Instrument) -> Note -> Note
Post.set_instrument (Pasang (Instrument, Instrument) -> (Instrument, Instrument)
role Pasang (Instrument, Instrument)
pasang) Note
event
    transpose :: (Note -> Bool) -> Note -> Note
transpose Note -> Bool
too_high Note
event
        | Note -> Bool
too_high Note
transposed = Note
event
        | Bool
otherwise = Note
transposed
        where
        transposed :: Note
transposed = Note
event
            { event_pitch :: Pitch
Score.event_pitch =
                -- TODO it's not really linear, but these pitches should be
                -- constant anyway.
                (Pitch -> Pitch) -> Pitch -> Pitch
PSignal.map_y_linear (Transpose -> Pitch -> Pitch
forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose (Y -> Transpose
Pitch.Diatonic Y
3))
                    (Note -> Pitch
Score.event_pitch Note
event)
            }

c_nyogcag :: Library.Calls Derive.Note
c_nyogcag :: Calls Note
c_nyogcag = Module
-> CallName
-> Tags
-> Doc
-> Parser (Pasang Instrument)
-> (Pasang Instrument -> NoteDeriver -> NoteDeriver)
-> Calls Note
forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
module_ CallName
"nyog" Tags
Tags.postproc
    Doc
"Nyog cag style. Split a single part into polos and sangsih parts by\
    \ assigning polos and sangsih to alternating notes."
    Parser (Pasang Instrument)
pasang_env ((Pasang Instrument -> NoteDeriver -> NoteDeriver) -> Calls Note)
-> (Pasang Instrument -> NoteDeriver -> NoteDeriver) -> Calls Note
forall a b. (a -> b) -> a -> b
$ \Pasang Instrument
pasang NoteDeriver
deriver -> do
        Instrument
inst <- Deriver Instrument
Call.get_instrument
        Pasang (Instrument, Instrument)
pasang <- (Instrument, Instrument)
-> (Instrument, Instrument) -> Pasang (Instrument, Instrument)
forall a. a -> a -> Pasang a
Pasang ((Instrument, Instrument)
 -> (Instrument, Instrument) -> Pasang (Instrument, Instrument))
-> Deriver State Error (Instrument, Instrument)
-> Deriver
     State
     Error
     ((Instrument, Instrument) -> Pasang (Instrument, Instrument))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Deriver State Error (Instrument, Instrument)
Derive.get_instrument (Pasang Instrument -> Instrument
forall a. Pasang a -> a
polos Pasang Instrument
pasang)
            Deriver
  State
  Error
  ((Instrument, Instrument) -> Pasang (Instrument, Instrument))
-> Deriver State Error (Instrument, Instrument)
-> Deriver State Error (Pasang (Instrument, Instrument))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Instrument -> Deriver State Error (Instrument, Instrument)
Derive.get_instrument (Pasang Instrument -> Instrument
forall a. Pasang a -> a
sangsih Pasang Instrument
pasang)
        (Bool, Stream Note) -> Stream Note
forall a b. (a, b) -> b
snd ((Bool, Stream Note) -> Stream Note)
-> (Stream Note -> (Bool, Stream Note))
-> Stream Note
-> Stream Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Note -> (Bool, [Note]))
-> Bool -> Stream Note -> (Bool, Stream Note)
forall state a.
(state -> a -> (state, [Note]))
-> state -> Stream a -> (state, Stream Note)
Post.emap_asc (Instrument
-> Pasang (Instrument, Instrument)
-> Bool
-> Note
-> (Bool, [Note])
nyogcag Instrument
inst Pasang (Instrument, Instrument)
pasang) Bool
True (Stream Note -> Stream Note) -> NoteDeriver -> NoteDeriver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NoteDeriver
deriver

nyogcag :: ScoreT.Instrument -> Pasang (ScoreT.Instrument, Derive.Instrument)
    -> Bool -> Score.Event -> (Bool, [Score.Event])
nyogcag :: Instrument
-> Pasang (Instrument, Instrument)
-> Bool
-> Note
-> (Bool, [Note])
nyogcag Instrument
pasang_inst Pasang (Instrument, Instrument)
pasang Bool
is_polos Note
event =
    ( Bool
next_is_polos
    , if Instrument
event_inst Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
== Instrument
pasang_inst then [Note -> Note
with_inst Note
event] else [Note
event]
    )
    where
    next_is_polos :: Bool
next_is_polos
        | Instrument
event_inst Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
== Instrument
pasang_inst = Bool -> Bool
not Bool
is_polos
        | Instrument
event_inst Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
== (Instrument, Instrument) -> Instrument
forall a b. (a, b) -> a
fst (Pasang (Instrument, Instrument) -> (Instrument, Instrument)
forall a. Pasang a -> a
polos Pasang (Instrument, Instrument)
pasang) = Bool
False
        | Instrument
event_inst Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
== (Instrument, Instrument) -> Instrument
forall a b. (a, b) -> a
fst (Pasang (Instrument, Instrument) -> (Instrument, Instrument)
forall a. Pasang a -> a
sangsih Pasang (Instrument, Instrument)
pasang) = Bool
True
        | Bool
otherwise = Bool
is_polos
    event_inst :: Instrument
event_inst = Note -> Instrument
Score.event_instrument Note
event
    with_inst :: Note -> Note
with_inst =
        (Instrument, Instrument) -> Note -> Note
Post.set_instrument (if Bool
is_polos then Pasang (Instrument, Instrument) -> (Instrument, Instrument)
forall a. Pasang a -> a
polos Pasang (Instrument, Instrument)
pasang else Pasang (Instrument, Instrument) -> (Instrument, Instrument)
forall a. Pasang a -> a
sangsih Pasang (Instrument, Instrument)
pasang)

-- * realize calls

c_realize_gangsa :: Derive.Transformer Derive.Note
c_realize_gangsa :: Transformer Note
c_realize_gangsa = Text -> Either Text (Transformer Note) -> Transformer Note
forall a. HasCallStack => Text -> Either Text a -> a
StaticMacro.check Text
"c_realize_gangsa" (Either Text (Transformer Note) -> Transformer Note)
-> Either Text (Transformer Note) -> Transformer Note
forall a b. (a -> b) -> a -> b
$
    Module
-> CallName
-> Tags
-> Doc
-> [Call (Transformer Note)]
-> Either Text (Transformer Note)
forall d.
CallableExpr d =>
Module
-> CallName
-> Tags
-> Doc
-> [Call (Transformer d)]
-> Either Text (Transformer d)
StaticMacro.transformer Module
module_ CallName
"realize-gangsa" Tags
Tags.postproc Doc
doc
        [ Transformer Note -> [Arg] -> Call (Transformer Note)
forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
c_realize_noltol []
        , Transformer Note -> [Arg] -> Call (Transformer Note)
forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
c_cancel_pasang [Arg
StaticMacro.Var]
        , Transformer Note -> [Arg] -> Call (Transformer Note)
forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
Gender.c_realize_ngoret []
        ]
    where doc :: Doc
doc = Doc
"Combine the gangsa realize calls in the right order."

-- | (noltol-time, kotekan-dur, damp-dyn)
type NoltolArg = (RealTime, RealTime, Signal.Y)

noltol_arg :: Text
noltol_arg :: Text
noltol_arg = Text
"noltol"

c_noltol :: Derive.Transformer Derive.Note
c_noltol :: Transformer Note
c_noltol = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF Note)
-> Transformer Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"noltol" Tags
Tags.delayed
    Doc
"Play the transformed notes in noltol style. If the space between\
    \ notes of the same (instrument, hand) is above a threshold,\
    \ end the note with a `+mute`d copy of itself. This only happens if\
    \ the duration of the note is at or below the `kotekan-dur`."
    (WithArgDoc (TransformerF Note) -> Transformer Note)
-> WithArgDoc (TransformerF Note) -> Transformer Note
forall a b. (a -> b) -> a -> b
$ Parser (ControlRef, Y, ScoreTime)
-> ((ControlRef, Y, ScoreTime) -> TransformerF Note)
-> WithArgDoc (TransformerF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ((,,)
    (ControlRef -> Y -> ScoreTime -> (ControlRef, Y, ScoreTime))
-> Parser ControlRef
-> Parser (Y -> ScoreTime -> (ControlRef, Y, ScoreTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> ControlRef -> Doc -> Parser ControlRef
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"time" (Control -> Y -> ControlRef
Sig.control Control
"noltol" Y
0.1)
        Doc
"Play noltol if the time available exceeds this threshold."
    Parser (Y -> ScoreTime -> (ControlRef, Y, ScoreTime))
-> Parser Y -> Parser (ScoreTime -> (ControlRef, Y, ScoreTime))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"damp-dyn" Y
0.65 Doc
"Damped notes are multiplied by this dyn."
    Parser (ScoreTime -> (ControlRef, Y, ScoreTime))
-> Parser ScoreTime -> Parser (ControlRef, Y, ScoreTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env
    ) (((ControlRef, Y, ScoreTime) -> TransformerF Note)
 -> WithArgDoc (TransformerF Note))
-> ((ControlRef, Y, ScoreTime) -> TransformerF Note)
-> WithArgDoc (TransformerF Note)
forall a b. (a -> b) -> a -> b
$ \(ControlRef
threshold, Y
damp_dyn, ScoreTime
max_dur) PassedArgs Note
args NoteDeriver
deriver -> do
        RealTime
max_dur <- ScoreTime -> ScoreTime -> Deriver State Error RealTime
forall t1 t2.
(Time t1, Time t2) =>
t1 -> t2 -> Deriver State Error RealTime
Call.real_duration (PassedArgs Note -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) ScoreTime
max_dur
        Stream Note
events <- NoteDeriver
deriver
        [RealTime]
times <- ControlRef -> Stream Note -> Deriver [RealTime]
Post.time_control ControlRef
threshold Stream Note
events
        Stream Note -> NoteDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream Note -> NoteDeriver) -> Stream Note -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ ((RealTime, Note) -> Note)
-> Stream (RealTime, Note) -> Stream Note
forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Y -> RealTime -> (RealTime, Note) -> Note
put Y
damp_dyn RealTime
max_dur) (Stream (RealTime, Note) -> Stream Note)
-> Stream (RealTime, Note) -> Stream Note
forall a b. (a -> b) -> a -> b
$ [RealTime] -> Stream Note -> Stream (RealTime, Note)
forall a x. [a] -> Stream x -> Stream (a, x)
Stream.zip [RealTime]
times Stream Note
events
        where
        put :: Y -> RealTime -> (RealTime, Note) -> Note
put Y
damp_dyn RealTime
max_dur (RealTime
threshold, Note
event) =
            Text -> NoltolArg -> Note -> Note
forall a. Typeable a => Text -> a -> Note -> Note
Score.put_arg Text
noltol_arg
                ((RealTime
threshold, RealTime
max_dur, Y
damp_dyn) :: NoltolArg) Note
event

c_realize_noltol :: Derive.Transformer Score.Event
c_realize_noltol :: Transformer Note
c_realize_noltol = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF Note)
-> Transformer Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"realize-noltol"
    Tags
Tags.realize_delayed Doc
"Perform the annotations added by `noltol`."
    (WithArgDoc (TransformerF Note) -> Transformer Note)
-> WithArgDoc (TransformerF Note) -> Transformer Note
forall a b. (a -> b) -> a -> b
$ TransformerF Note -> WithArgDoc (TransformerF Note)
forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t (TransformerF Note -> WithArgDoc (TransformerF Note))
-> TransformerF Note -> WithArgDoc (TransformerF Note)
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_args NoteDeriver
deriver -> Stream Note -> NoteDeriver
realize_noltol_call (Stream Note -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NoteDeriver
deriver

realize_noltol_call :: Stream.Stream Score.Event -> Derive.NoteDeriver
realize_noltol_call :: Stream Note -> NoteDeriver
realize_noltol_call =
    ((Note, Maybe Note) -> Note)
-> ((Note, Maybe Note) -> NoteDeriver)
-> Stream (Note, Maybe Note)
-> NoteDeriver
forall a.
(a -> Note) -> (a -> NoteDeriver) -> Stream a -> NoteDeriver
Post.emap_s_ (Note, Maybe Note) -> Note
forall a b. (a, b) -> a
fst (Note, Maybe Note) -> NoteDeriver
realize (Stream (Note, Maybe Note) -> NoteDeriver)
-> (Stream Note -> Stream (Note, Maybe Note))
-> Stream Note
-> NoteDeriver
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note -> Instrument) -> Stream Note -> Stream (Note, Maybe Note)
forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (a, Maybe a)
Post.next_by Note -> Instrument
Score.event_instrument
    where
    realize :: (Note, Maybe Note) -> NoteDeriver
realize (Note
event, Maybe Note
next) = do
        (Note
event, Maybe NoltolArg
maybe_arg) <- (Text -> Text)
-> Either Text (Note, Maybe NoltolArg)
-> Deriver (Note, Maybe NoltolArg)
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right Text -> Text
forall a. a -> a
id (Either Text (Note, Maybe NoltolArg)
 -> Deriver (Note, Maybe NoltolArg))
-> Either Text (Note, Maybe NoltolArg)
-> Deriver (Note, Maybe NoltolArg)
forall a b. (a -> b) -> a -> b
$
            Text -> Note -> Either Text (Note, Maybe NoltolArg)
forall a. Typeable a => Text -> Note -> Either Text (Note, Maybe a)
Score.take_arg Text
noltol_arg Note
event
        case Maybe NoltolArg
maybe_arg of
            Maybe NoltolArg
Nothing -> Stream Note -> NoteDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream Note -> NoteDeriver) -> Stream Note -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Note -> Stream Note
forall a. a -> Stream a
Stream.from_event Note
event
            Just NoltolArg
arg -> NoltolArg -> Note -> Maybe Note -> NoteDeriver
realize_noltol NoltolArg
arg Note
event Maybe Note
next

-- | If the next note of the same instrument is below a threshold, the note's
-- off time is replaced with a +mute.
realize_noltol :: NoltolArg -> Score.Event -> Maybe Score.Event
    -> Derive.NoteDeriver
realize_noltol :: NoltolArg -> Note -> Maybe Note -> NoteDeriver
realize_noltol (RealTime
threshold, RealTime
max_dur, Y
damp_dyn) Note
event Maybe Note
next =
    Stream Note -> NoteDeriver
forall (m :: * -> *) a. Monad m => a -> m a
return (Note -> Stream Note
forall a. a -> Stream a
Stream.from_event Note
event) NoteDeriver -> NoteDeriver -> NoteDeriver
forall a. Semigroup a => a -> a -> a
<> NoteDeriver
muted
    where
    muted :: NoteDeriver
muted
        | Bool
should_noltol = do
            ScoreTime
start <- RealTime -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Derive.score (Note -> RealTime
Score.event_end Note
event)
            Pitch
pitch <- Text -> Maybe Pitch -> Deriver Pitch
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no pitch" (Maybe Pitch -> Deriver Pitch) -> Maybe Pitch -> Deriver Pitch
forall a b. (a -> b) -> a -> b
$
                RealTime -> Note -> Maybe Pitch
Score.pitch_at (Note -> RealTime
Score.event_start Note
event) Note
event
            -- I used to copy the note and apply +mute, but this is low level
            -- and wouldn't take the instrument's zero-dur config.  Also it
            -- meant that integration would come out with +mute.
            Instrument -> NoteDeriver -> NoteDeriver
forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument (Note -> Instrument
Score.event_instrument Note
event) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
                Pitch -> NoteDeriver -> NoteDeriver
forall a. Pitch -> Deriver a -> Deriver a
Call.with_pitch Pitch
pitch (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
                Y -> NoteDeriver -> NoteDeriver
forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
damp_dyn (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
                ScoreTime -> ScoreTime -> NoteDeriver -> NoteDeriver
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
0 NoteDeriver
Call.note
        | Bool
otherwise = NoteDeriver
forall a. Monoid a => a
mempty
    should_noltol :: Bool
should_noltol =
        Note -> RealTime
Score.event_duration Note
event RealTime -> RealTime -> Bool
RealTime.<= RealTime
max_dur
        Bool -> Bool -> Bool
&& Bool -> (Note -> Bool) -> Maybe Note -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= RealTime
threshold) (RealTime -> Bool) -> (Note -> RealTime) -> Note -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> RealTime
space) Maybe Note
next
    space :: Note -> RealTime
space Note
next = Note -> RealTime
Score.event_start Note
next RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_end Note
event

-- ** cancel-pasang

c_cancel_pasang :: Derive.Transformer Derive.Note
c_cancel_pasang :: Transformer Note
c_cancel_pasang = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF Note)
-> Transformer Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"cancel-pasang" Tags
Tags.postproc
    Doc
"This is like the `cancel` call, except it also knows how to cancel out\
    \ pasang instruments such that adjacent kotekan calls can have initial and\
    \ final notes, but won't get doubled notes."
    (WithArgDoc (TransformerF Note) -> Transformer Note)
-> WithArgDoc (TransformerF Note) -> Transformer Note
forall a b. (a -> b) -> a -> b
$ Cancel
-> Key (Either Instrument (Instrument, Instrument), Maybe Text)
-> WithArgDoc (TransformerF Note)
forall key.
Ord key =>
Cancel -> Key key -> WithArgDoc (TransformerF Note)
Postproc.make_cancel Cancel
cancel_strong_final Key (Either Instrument (Instrument, Instrument), Maybe Text)
pasang_key

-- | Kotekan ends with a final, which cancels normal, but loses to strong.
-- This is like 'Postproc.cancel_strong_weak', except it adds 'final_flag',
-- so I can have the end of a kotekan override, but still be overidden
-- with an explicit strong note.
cancel_strong_final :: [Score.Event] -> Either Text [Score.Event]
cancel_strong_final :: Cancel
cancel_strong_final [Note]
events
    | Bool -> Bool
not ([Note] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
strongs) = [Note] -> Cancel
forall {a}. [Note] -> [Note] -> Either a [Note]
merge [Note]
strongs ([Note]
finals [Note] -> [Note] -> [Note]
forall a. [a] -> [a] -> [a]
++ [Note]
rest)
    | Bool -> Bool
not ([Note] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
finals) = [Note] -> Cancel
forall {a}. [Note] -> [Note] -> Either a [Note]
merge [Note]
finals [Note]
rest
    | Bool -> Bool
not ([Note] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
normals) = [Note] -> Cancel
forall {a}. [Note] -> [Note] -> Either a [Note]
merge [Note]
normals [Note]
weaks
    | Bool
otherwise = Cancel
forall a b. b -> Either a b
Right [Note]
weaks
    where
    ([Note]
strongs, [Note]
finals, [Note]
rest) = (Note -> Bool)
-> (Note -> Bool) -> [Note] -> ([Note], [Note], [Note])
forall a. (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a], [a])
Seq.partition2
        (Flags -> Note -> Bool
Score.has_flags Flags
Flags.strong) (Flags -> Note -> Bool
Score.has_flags Flags
final_flag) [Note]
events
    ([Note]
weaks, [Note]
normals) = (Note -> Bool) -> [Note] -> ([Note], [Note])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (Flags -> Note -> Bool
Score.has_flags Flags
Flags.weak) [Note]
events
    merge :: [Note] -> [Note] -> Either a [Note]
merge [Note]
strongs [Note]
weaks =
        [Note] -> Either a [Note]
forall a b. b -> Either a b
Right [Note -> [Note] -> Note
Postproc.infer_duration_merged Note
strong [Note]
weaks | Note
strong <- [Note]
strongs]

-- | Match any of polos, sangsih, and pasang to each other.  Since polos and
-- sangsih together are considered one voice, a sangsih start is note end for
-- a polos note.
pasang_key :: Postproc.Key
    (Either ScoreT.Instrument (ScoreT.Instrument, ScoreT.Instrument),
        Maybe Text)
pasang_key :: Key (Either Instrument (Instrument, Instrument), Maybe Text)
pasang_key Note
e = (Either Instrument (Instrument, Instrument)
inst, Text -> Maybe Text
forall {a}. Typecheck a => Text -> Maybe a
get Text
EnvKey.hand)
    where
    inst :: Either Instrument (Instrument, Instrument)
inst = case (Text -> Maybe Instrument
forall {a}. Typecheck a => Text -> Maybe a
get Text
inst_polos, Text -> Maybe Instrument
forall {a}. Typecheck a => Text -> Maybe a
get Text
inst_sangsih) of
        (Just Instrument
p, Just Instrument
s) -> (Instrument, Instrument)
-> Either Instrument (Instrument, Instrument)
forall a b. b -> Either a b
Right (Instrument
p, Instrument
s)
        (Maybe Instrument, Maybe Instrument)
_ -> Instrument -> Either Instrument (Instrument, Instrument)
forall a b. a -> Either a b
Left (Note -> Instrument
Score.event_instrument Note
e)
    get :: Text -> Maybe a
get Text
k = Text -> Environ -> Maybe a
forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
k (Note -> Environ
Score.event_environ Note
e)

-- * implementation

-- | Get pitch for a kotekan call.
get_pitch :: Derive.PassedArgs a -> Derive.Deriver PSignal.Pitch
get_pitch :: forall a. PassedArgs a -> Deriver Pitch
get_pitch = PassedArgs a -> Deriver Pitch
forall a. PassedArgs a -> Deriver Pitch
Call.get_pitch_here

style_arg :: KotekanStyle -> Sig.Parser KotekanStyle
style_arg :: KotekanStyle -> Parser KotekanStyle
style_arg KotekanStyle
deflt = ArgName
-> EnvironDefault -> KotekanStyle -> Doc -> Parser KotekanStyle
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.defaulted_env ArgName
"style" EnvironDefault
Sig.Both KotekanStyle
deflt Doc
"Kotekan style."

dur_env :: Sig.Parser ScoreTime
dur_env :: Parser ScoreTime
dur_env = ArgName -> EnvironDefault -> Quoted -> Doc -> Parser ScoreTime
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> Quoted -> Doc -> Parser a
Sig.environ_quoted ArgName
"kotekan-dur" EnvironDefault
Sig.Unprefixed
    (Symbol -> [Val] -> Quoted
DeriveT.quoted Symbol
"ts" [Text -> Val
DeriveT.str Text
"s"]) Doc
"Duration of derived notes."

kotekan_env :: Sig.Parser DeriveT.ControlRef
kotekan_env :: Parser ControlRef
kotekan_env =
    ArgName -> EnvironDefault -> ControlRef -> Doc -> Parser ControlRef
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"kotekan" EnvironDefault
Sig.Unprefixed (Y -> ControlRef
DeriveT.constant_control Y
0.15)
        Doc
"If note durations are below this, divide the parts between polos and\
        \ sangsih."

infer_initial_final_env :: Sig.Parser (Maybe Bool, Bool)
infer_initial_final_env :: Parser (Maybe Bool, Bool)
infer_initial_final_env = (,)
    (Maybe Bool -> Bool -> (Maybe Bool, Bool))
-> Parser (Maybe Bool) -> Parser (Bool -> (Maybe Bool, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName
-> EnvironDefault -> Maybe Bool -> Doc -> Parser (Maybe Bool)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"initial" EnvironDefault
Sig.Unprefixed Maybe Bool
forall a. Maybe a
Nothing
        Doc
"If true, include an initial note, which is the same as the final note.\
        \ This is suitable for the start of a sequence of kotekan calls.\
        \ If not given, infer false for negative duration, true for positive."
    Parser (Bool -> (Maybe Bool, Bool))
-> Parser Bool -> Parser (Maybe Bool, Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Bool -> Doc -> Parser Bool
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"final" EnvironDefault
Sig.Unprefixed Bool
True
        Doc
"If true, include the final note, at the event end."

infer_initial :: Derive.PassedArgs a -> (Maybe Bool, Bool) -> (Bool, Bool)
infer_initial :: forall a. PassedArgs a -> (Maybe Bool, Bool) -> (Bool, Bool)
infer_initial PassedArgs a
args =
    (Maybe Bool -> Bool) -> (Maybe Bool, Bool) -> (Bool, Bool)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Maybe Bool -> Bool) -> (Maybe Bool, Bool) -> (Bool, Bool))
-> (Maybe Bool -> Bool) -> (Maybe Bool, Bool) -> (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Event -> Bool
Event.is_negative (PassedArgs a -> Event
forall a. PassedArgs a -> Event
Args.event PassedArgs a
args))

initial_final_env :: Sig.Parser (Bool, Bool)
initial_final_env :: Parser (Bool, Bool)
initial_final_env = (,)
    (Bool -> Bool -> (Bool, Bool))
-> Parser Bool -> Parser (Bool -> (Bool, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> EnvironDefault -> Bool -> Doc -> Parser Bool
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"initial" EnvironDefault
Sig.Unprefixed Bool
True
        Doc
"If true, include an initial note, which is the same as the final note.\
        \ This is suitable for the start of a sequence of kotekan calls.\
        \ If not given, infer false for negative duration, true for positive."
    Parser (Bool -> (Bool, Bool)) -> Parser Bool -> Parser (Bool, Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Bool -> Doc -> Parser Bool
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"final" EnvironDefault
Sig.Unprefixed Bool
True
        Doc
"If true, include the final note, at the event end."

instrument_top_env :: Sig.Parser (Maybe Pitch.Pitch)
instrument_top_env :: Parser (Maybe Pitch)
instrument_top_env = Text -> Maybe Pitch -> Doc -> Parser (Maybe Pitch)
forall a. (Typecheck a, ShowVal a) => Text -> a -> Doc -> Parser a
Sig.environ_key Text
EnvKey.instrument_top Maybe Pitch
forall a. Maybe a
Nothing
    Doc
"Top pitch this instrument can play. Normally the instrument sets\
    \ it via the instrument environ."

note_too_high :: Scale.Scale -> Maybe Pitch.Pitch -> PSignal.Transposed -> Bool
note_too_high :: Scale -> Maybe Pitch -> Transposed -> Bool
note_too_high Scale
scale Maybe Pitch
maybe_top Transposed
pitchv = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
    Pitch
top <- Maybe Pitch
maybe_top
    Note
note <- (PitchError -> Maybe Note)
-> (Note -> Maybe Note) -> Either PitchError Note -> Maybe Note
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Note -> PitchError -> Maybe Note
forall a b. a -> b -> a
const Maybe Note
forall a. Maybe a
Nothing) Note -> Maybe Note
forall a. a -> Maybe a
Just (Either PitchError Note -> Maybe Note)
-> Either PitchError Note -> Maybe Note
forall a b. (a -> b) -> a -> b
$ Transposed -> Either PitchError Note
PSignal.pitch_note Transposed
pitchv
    Pitch
pitch <- (PitchError -> Maybe Pitch)
-> (Pitch -> Maybe Pitch) -> Either PitchError Pitch -> Maybe Pitch
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Pitch -> PitchError -> Maybe Pitch
forall a b. a -> b -> a
const Maybe Pitch
forall a. Maybe a
Nothing) Pitch -> Maybe Pitch
forall a. a -> Maybe a
Just (Either PitchError Pitch -> Maybe Pitch)
-> Either PitchError Pitch -> Maybe Pitch
forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
forall a. Monoid a => a
mempty Note
note
    Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Pitch
pitch Pitch -> Pitch -> Bool
forall a. Ord a => a -> a -> Bool
> Pitch
top

pitch_too_high :: Scale.Scale -> Maybe Pitch.Pitch -> Score.Event -> Bool
pitch_too_high :: Scale -> Maybe Pitch -> Note -> Bool
pitch_too_high Scale
scale Maybe Pitch
maybe_top =
    Bool -> (Transposed -> Bool) -> Maybe Transposed -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Scale -> Maybe Pitch -> Transposed -> Bool
note_too_high Scale
scale Maybe Pitch
maybe_top) (Maybe Transposed -> Bool)
-> (Note -> Maybe Transposed) -> Note -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Maybe Transposed
Score.initial_pitch

pasang_env :: Sig.Parser (Pasang ScoreT.Instrument)
pasang_env :: Parser (Pasang Instrument)
pasang_env = Instrument -> Instrument -> Pasang Instrument
forall a. a -> a -> Pasang a
Pasang
    (Instrument -> Instrument -> Pasang Instrument)
-> Parser Instrument -> Parser (Instrument -> Pasang Instrument)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> EnvironDefault -> Doc -> Parser Instrument
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ (Text -> ArgName
Derive.ArgName Text
inst_polos)
        EnvironDefault
Sig.Unprefixed Doc
"Polos instrument."
    Parser (Instrument -> Pasang Instrument)
-> Parser Instrument -> Parser (Pasang Instrument)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Doc -> Parser Instrument
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ (Text -> ArgName
Derive.ArgName Text
inst_sangsih)
        EnvironDefault
Sig.Unprefixed Doc
"Sangsih instrument."

inst_polos :: Env.Key
inst_polos :: Text
inst_polos = Text
"inst-polos"

inst_sangsih :: Env.Key
inst_sangsih :: Text
inst_sangsih = Text
"inst-sangsih"

final_flag :: Flags.Flags
final_flag :: Flags
final_flag = Text -> Flags
Flags.flag Text
"final"