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

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 = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
"norot", Bool -> Maybe Bool -> Generator Note
c_norot Bool
False 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 forall a. Maybe a
Nothing)
        , (Symbol
"nt-", Bool -> Maybe Bool -> Generator Note
c_norot Bool
False (forall a. a -> Maybe a
Just Bool
False))
        , (Symbol
"nt<", Bool -> Maybe Bool -> Generator Note
c_norot Bool
True forall a. Maybe a
Nothing)
        , (Symbol
"nt<-", Bool -> Maybe Bool -> Generator Note
c_norot Bool
True (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 forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
irregular_pattern 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 forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
irregular_pattern 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 forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
irregular_pattern 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 forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
irregular_pattern 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 forall a b. (a -> b) -> a -> b
$ HasCallStack => IrregularPattern -> KotekanPattern
irregular_pattern 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 (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 (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 (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 forall a. Maybe a
Nothing KotekanStyle
Telu)
        , (Symbol
"k^", Bool -> Maybe Text -> KotekanStyle -> Generator Note
c_kotekan_regular Bool
True forall a. Maybe a
Nothing KotekanStyle
Telu)
        , (Symbol
"ke", Generator Note
c_kotekan_explicit)
        ]
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators forall a b. (a -> b) -> a -> b
$ forall call. (Parser (Maybe Transpose) -> call) -> [(Symbol, call)]
Gender.ngoret_variations Parser (Maybe Transpose) -> Generator Note
c_ngoret
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"i+", 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-", 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-", 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", 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)
        ]
    , 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" 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 =
    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 forall a b. (a -> b) -> a -> b
$
    \Pasang Instrument
pasang NoteDeriver
deriver -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument (forall a. Pasang a -> a
polos Pasang Instrument
pasang) NoteDeriver
deriver | Bool
with_polos]
        , [forall d. Instrument -> Deriver d -> Deriver d
Derive.with_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 = (,[]) forall a b. (a -> b) -> a -> b
$
    case RealTime -> Control -> Note -> Maybe (Typed Double)
Score.control_at (Note -> RealTime
Score.event_start Note
event) Control
Controls.mute Note
event of
        Maybe (Typed Double)
Nothing -> Double -> Note -> Note
set_mod Double
0 Note
event
        Just Typed Double
tval
            | Double
mute forall a. Ord a => a -> a -> Bool
>= Double
threshold -> Attributes -> Note -> Note
Score.add_attributes Attributes
mute_attr Note
event
            | Double
mute forall a. Ord a => a -> a -> Bool
<= Double
0 -> Double -> Note -> Note
set_mod Double
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 -> Double -> Note -> Note
set_mod (Double
1 forall a. Num a => a -> a -> a
- Double
muteforall a. Floating a => a -> a -> a
**Double
2) forall a b. (a -> b) -> a -> b
$ RealTime -> Note -> Note
Score.set_duration RealTime
0 Note
event
            where
            mute :: Double
mute = forall a. Typed a -> a
ScoreT.val_of Typed Double
tval
    where
    set_mod :: Double -> Note -> Note
set_mod = Control -> Typed Control -> Note -> Note
Score.set_control Control
Controls.mod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Typed a
ScoreT.untyped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Double -> Signal kind
Signal.constant
    -- Use the mute_attr above this threshold.
    threshold :: Double
threshold = Double
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 RealTimeFunction
-> Parser (Maybe Transpose)
-> Generator Note
Gender.ngoret Module
module_ Bool
False forall a b. (a -> b) -> a -> b
$
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"damp" (RealTime
0.15 :: RealTime)
    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
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]
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", forall a. Pretty a => a -> Doc
Pretty.format [Maybe Int]
telu)
        , (Text
"pat", forall a. Pretty a => a -> Doc
Pretty.format [Maybe Int]
pat)
        , (Text
"interlock_telu", forall a. Pretty a => a -> Doc
Pretty.format Pasang [Maybe Int]
itelu)
        , (Text
"interlock_pat", 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
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
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", forall a. Pretty a => a -> Doc
Pretty.format a
polos)
        , (Text
"sangsih", 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
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
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", forall a. Pretty a => a -> Doc
Pretty.format a
inter)
        , (Text
"non_interlocking", 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]
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]
parse_pattern Int
destination forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *} {a}. (Foldable t, Show (t a)) => t a -> t a
check
    check :: t a -> t a
check t a
ns
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ns forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ir_polos = t a
ns
        | Bool
otherwise = forall a. HasCallStack => Text -> a
errorStack forall a b. (a -> b) -> a -> b
$ Text
"not same length as polos: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt t a
ns
    destination :: Int
destination = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => Text -> a
errorStack Text
"no final pitch") forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> Maybe a
Lists.last forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
Maybe.catMaybes forall a b. (a -> b) -> a -> b
$ HasCallStack => 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
subtract Int
destination) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Maybe Int
parse1)
    where
    parse1 :: Char -> Maybe Int
parse1 Char
'-' = forall a. Maybe a
Nothing
    parse1 Char
c = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => Text -> a
errorStack forall a b. (a -> b) -> a -> b
$ Text
"not a digit: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
c) 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 (forall a. Realization a -> a
interlocking Realization [[(Maybe Instrument, Int)]]
realization)
    , non_interlocking :: [[KotekanNote]]
non_interlocking = [[(Maybe Instrument, Int)]] -> [[KotekanNote]]
realize (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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (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 -> forall {a}. Pasang [Maybe a] -> [[(Maybe Instrument, a)]]
interlocking Pasang [Maybe Int]
itelu
        KotekanStyle
Pat -> 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 -> forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {a}. t -> Maybe a -> [(t, a)]
realize forall a. Maybe a
Nothing) [Maybe Int]
telu
        KotekanStyle
Pat -> 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t
inst,)) Maybe a
n
    interlocking :: Pasang [Maybe a] -> [[(Maybe Instrument, a)]]
interlocking Pasang [Maybe a]
part =
        [ forall {t} {a}. t -> Maybe a -> [(t, a)]
realize (forall a. a -> Maybe a
Just (forall a. Pasang a -> a
polos Pasang Instrument
pasang)) Maybe a
p forall a. [a] -> [a] -> [a]
++ forall {t} {a}. t -> Maybe a -> [(t, a)]
realize (forall a. a -> Maybe a
Just (forall a. Pasang a -> a
sangsih Pasang Instrument
pasang)) Maybe a
s
        | (Maybe a
p, Maybe a
s) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Pasang a -> a
polos Pasang [Maybe a]
part) (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 =
    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."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"style" NorotStyle
Default Doc
"Norot style."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (RealTime -> RealTime)
kotekan_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Pitch)
instrument_top_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env
    ) forall a b. (a -> b) -> a -> b
$ \(NorotStyle
style, ScoreTime
note_dur, RealTime -> RealTime
kotekan, Maybe Pitch
inst_top, Pasang Instrument
pasang, (Maybe Bool
initial, Bool
final))
    -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Maybe Pitch
next_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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        Scale
scale <- Deriver Scale
Call.get_scale
        ScoreTime -> Bool
under_threshold <- (RealTime -> RealTime) -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function RealTime -> RealTime
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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Pasang (Int, Int)
get_steps
        let initial_final :: (Bool, Bool)
initial_final =
                ( forall a. a -> Maybe a -> a
fromMaybe (forall a. PassedArgs a -> Orientation
Args.orientation PassedArgs Note
args 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 (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 <- forall a. Time a => a -> Deriver 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 = forall a.
ScoreTime -> ScoreTime -> (Bool, Bool) -> [[Note a]] -> [[Note a]]
apply_initial_final ScoreTime
start ScoreTime
end (Bool, Bool)
initial_final 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
    forall a. (a -> NoteDeriver) -> [Note a] -> NoteDeriver
realize_notes forall a. a -> a
id (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) =
    forall a. (a -> a) -> [a] -> [a]
Lists.mapLast forall {a}. [Note a] -> [Note a]
modify_final
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
initial then forall a. a -> a
id else forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Ord a => a -> a -> Bool
<=ScoreTime
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Note a -> ScoreTime
note_start)))
    where
    modify_final :: [Note a] -> [Note a]
modify_final [Note a]
notes
        | Bool
final Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Ord a => a -> a -> Bool
>=ScoreTime
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Note a -> ScoreTime
note_start) [Note a]
notes =
            forall a b. (a -> b) -> [a] -> [b]
map (forall a. Flags -> Note a -> Note a
add_flag (Flags
Flags.infer_duration 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) =
    forall a b. (a -> b) -> [a] -> [b]
map (Pitch, (ScoreTime, [KotekanNote])) -> [Note NoteDeriver]
realize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. [(a, (ScoreTime, b))] -> [(a, (ScoreTime, b))]
trim forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        -- This is the initial note, which may be dropped.
        [ forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just Maybe PitchedCycle
sustain 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.
            forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just (forall a. [a] -> Maybe a
Lists.last (forall {a}. Realization a -> ScoreTime -> a
get_cycle Cycle
cycle ScoreTime
initial_start)) forall a b. (a -> b) -> a -> b
$ \[KotekanNote]
notes ->
                [(Pitch
pitch, (ScoreTime
initial_t, [KotekanNote]
notes))]
        , forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just Maybe PitchedCycle
prepare_this forall a b. (a -> b) -> a -> b
$ \(PitchedCycle Pitch
pitch Cycle
cycle) ->
            forall {t} {b}.
t -> Realization [b] -> ScoreTime -> [(t, (ScoreTime, b))]
one_cycle Pitch
pitch Cycle
cycle ScoreTime
this_t
        , forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just Maybe PitchedCycle
sustain forall a b. (a -> b) -> a -> b
$ \(PitchedCycle Pitch
pitch Cycle
cycle) ->
            forall a b. (a -> b) -> [a] -> [b]
map (Pitch
pitch,) forall a b. (a -> b) -> a -> b
$ forall t a. (t -> [a]) -> [t] -> [(t, a)]
cycles (forall {a}. Realization a -> ScoreTime -> a
get_cycle Cycle
cycle) forall a b. (a -> b) -> a -> b
$
                forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.range' ScoreTime
sustain_t ScoreTime
next_t ScoreTime
note_dur
        , forall {a} {a}. Maybe a -> (a -> [a]) -> [a]
on_just Maybe PitchedCycle
prepare_next forall a b. (a -> b) -> a -> b
$ \(PitchedCycle Pitch
pitch Cycle
cycle) ->
            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 = 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 = forall a. Ord a => a -> a -> a
min ScoreTime
initial_start (ScoreTime
this_t forall a. Num a => a -> a -> a
- ScoreTime
note_dur)
    this_t :: ScoreTime
this_t = forall a. Ord a => a -> a -> a
min ScoreTime
start ScoreTime
next_t
    sustain_t :: ScoreTime
sustain_t = ScoreTime
start forall a. Num a => a -> a -> a
+ if 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 forall a. Num a => a -> a -> a
- if 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 forall a. Num a => a -> a -> a
+ ScoreTime
note_dur
    end :: ScoreTime
end = ScoreTime
exact_end forall a. Num a => a -> a -> a
+ ScoreTime
note_dur

    trim :: [(a, (ScoreTime, b))] -> [(a, (ScoreTime, b))]
trim = forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Ord a => a -> a -> Bool
<=ScoreTime
exact_end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<ScoreTime
initial_start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b. (a -> b) -> [a] -> [b]
map (t
pitch,) forall a b. (a -> b) -> a -> b
$
        forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ ScoreTime
start ScoreTime
note_dur) (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 = forall a. Realization a -> a
interlocking Realization a
cycle
        | Bool
otherwise = forall a. Realization a -> a
non_interlocking Realization a
cycle
    prep_dur :: ScoreTime
prep_dur = ScoreTime
note_dur 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)) = 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 = 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) =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Maybe Instrument
inst 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 forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.mute else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
        Pitch -> NoteDeriver
Call.pitched_note (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.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Maybe a -> Bool
Maybe.isNothing [Maybe Pitch
cur_pitch, Maybe Pitch
next_pitch]) forall a b. (a -> b) -> a -> b
$
        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
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Pitch -> Cycle -> PitchedCycle
PitchedCycle Pitch
pitch (Transposed -> Cycle
prepare_cycle Transposed
pitch_t)
        (Bool, Maybe Pitch)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Maybe PitchedCycle
sustain <- case Maybe Pitch
cur_pitch of
        Maybe Pitch
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just Pitch
pitch -> do
            Transposed
pitch_t <- RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start Pitch
pitch
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just Pitch
next -> do
            Transposed
next_t <- RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start Pitch
next
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Pitch -> Cycle -> PitchedCycle
PitchedCycle Pitch
next (Transposed -> Cycle
prepare_cycle Transposed
next_t)
    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 =
            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 = forall a. Maybe a
Nothing
        where
        initial :: Bool
initial = forall a. a -> Maybe a -> a
fromMaybe (Orientation
orient forall a. Eq a => a -> a -> Bool
== Orientation
Types.Positive) Maybe Bool
maybe_initial
        sustain_end :: ScoreTime
sustain_end = ScoreTime
end 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 =
            forall a. a -> Maybe a
Just ((Bool
True, Bool
final), (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
prepare_dur, ScoreTime
end))
        | Bool
otherwise = forall a. Maybe a
Nothing
    dur :: ScoreTime
dur = ScoreTime
end 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 forall a. Ord a => a -> a -> Bool
> ScoreTime
prepare_dur1
            Bool -> Bool -> Bool
|| ScoreTime
dur forall a. Ord a => a -> a -> Bool
> ScoreTime
prepare_dur Bool -> Bool -> Bool
&& Maybe Bool
maybe_initial forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True)
    prepare_dur :: ScoreTime
prepare_dur = ScoreTime
note_dur forall a. Num a => a -> a -> a
* ScoreTime
3
    prepare_dur1 :: ScoreTime
prepare_dur1 = ScoreTime
note_dur 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) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
infer_prepare PassedArgs a
args (Just Bool
True) = forall a. PassedArgs a -> Deriver (Maybe Pitch)
Args.lookup_next_pitch PassedArgs a
args
infer_prepare PassedArgs a
args Maybe Bool
Nothing
    | forall a. PassedArgs a -> Maybe ScoreTime
Args.next_start PassedArgs a
args forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just (Event -> ScoreTime
Event.max (forall a. PassedArgs a -> Event
Args.event PassedArgs a
args)) =
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    | Bool
otherwise = 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
:[]) [Int -> KotekanNote
s (forall a b. (a, b) -> a
fst (Int, Int)
pstep), Int -> KotekanNote
p (forall a b. (a, b) -> b
snd (Int, Int)
pstep)]
    , non_interlocking :: [[KotekanNote]]
non_interlocking = case NorotStyle
style of
        NorotStyle
Default -> forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> KotekanNote
both) [forall a b. (a, b) -> a
fst (Int, Int)
pstep, forall a b. (a, b) -> b
snd (Int, Int)
pstep]
        NorotStyle
Diamond ->
            [ [Int -> KotekanNote
p (forall a b. (a, b) -> a
fst (Int, Int)
pstep), Int -> KotekanNote
s (forall a b. (a, b) -> a
fst (Int, Int)
sstep)]
            , [Int -> KotekanNote
p (forall a b. (a, b) -> b
snd (Int, Int)
pstep), Int -> KotekanNote
s (forall a b. (a, b) -> b
snd (Int, Int)
sstep)]
            ]
    }
    where
    both :: Int -> KotekanNote
both = Maybe Instrument -> Int -> KotekanNote
kotekan_note forall a. Maybe a
Nothing
    p :: Int -> KotekanNote
p = Maybe Instrument -> Int -> KotekanNote
kotekan_note (forall a. a -> Maybe a
Just (forall a. Pasang a -> a
polos Pasang Instrument
pasang))
    s :: Int -> KotekanNote
s = Maybe Instrument -> Int -> KotekanNote
kotekan_note (forall a. a -> Maybe a
Just (forall a. Pasang a -> a
sangsih Pasang Instrument
pasang))
    pstep :: (Int, Int)
pstep = forall a. Pasang a -> a
polos Pasang (Int, Int)
steps
    sstep :: (Int, Int)
sstep = 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 -> forall a b. (a -> b) -> [a] -> [b]
map (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 ->
            [ 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 forall a. Maybe a
Nothing
    p :: Int -> KotekanNote
p = Maybe Instrument -> Int -> KotekanNote
kotekan_note (forall a. a -> Maybe a
Just (forall a. Pasang a -> a
polos Pasang Instrument
pasang))
    s :: Int -> KotekanNote
s = Maybe Instrument -> Int -> KotekanNote
kotekan_note (forall a. a -> Maybe a
Just (forall a. Pasang a -> a
sangsih Pasang Instrument
pasang))
    (Int
p1, Int
p2) = forall a. Pasang a -> a
polos Pasang (Int, Int)
steps
    (Int
s1, Int
s2) = 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 forall a b. (a -> b) -> a -> b
$
        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 = 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."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ScoreTime
dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (RealTime -> RealTime)
kotekan_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env)
    forall a b. (a -> b) -> a -> b
$ \(ScoreTime
dur, RealTime -> RealTime
kotekan, Pasang Instrument
pasang, (Maybe Bool, Bool)
initial_final) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Pitch
pitch <- forall a. PassedArgs a -> Deriver Pitch
get_pitch PassedArgs Note
args
        ScoreTime -> Bool
under_threshold <- (RealTime -> RealTime) -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function RealTime -> RealTime
kotekan ScoreTime
dur
        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 (forall a. a -> Maybe a
Just (forall a. Pasang a -> a
polos Pasang Instrument
pasang))
    s :: Int -> KotekanNote
s = Maybe Instrument -> Int -> KotekanNote
kotekan_note (forall a. a -> Maybe a
Just (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 =
    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" forall a. Semigroup a => a -> a -> a
<> Doc
kotekan_doc)
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KotekanStyle -> Parser KotekanStyle
style_arg KotekanStyle
default_style
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (RealTime -> RealTime)
kotekan_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env
    ) forall a b. (a -> b) -> a -> b
$ \(KotekanStyle
style, ScoreTime
dur, RealTime -> RealTime
kotekan, Pasang Instrument
pasang, (Maybe Bool, Bool)
initial_final) ->
    forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Pitch
pitch <- forall a. PassedArgs a -> Deriver Pitch
get_pitch PassedArgs Note
args
        ScoreTime -> Bool
under_threshold <- (RealTime -> RealTime) -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function RealTime -> RealTime
kotekan ScoreTime
dur
        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 =
    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"
        forall a. Semigroup a => a -> a -> a
<> Doc
kotekan_doc)
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,,,,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"rotation" (Double
0 :: Double)
        Doc
"Rotate kernel to make a different pattern."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KotekanStyle -> Parser KotekanStyle
style_arg KotekanStyle
Telu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"sangsih" EnvironDefault
Sig.Both UpDown
Call.Up
        Doc
"Whether sangsih is above or below polos."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"invert" EnvironDefault
Sig.Prefixed Bool
False Doc
"Flip the pattern upside down."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_environ ArgName
"kernel" EnvironDefault
Sig.Both Doc
kernel_doc
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (RealTime -> RealTime)
kotekan_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env
    ) forall a b. (a -> b) -> a -> b
$ \(Int
rotation, KotekanStyle
style, UpDown
sangsih_above, Bool
inverted, Text
kernel_s, ScoreTime
dur, RealTime -> RealTime
kotekan,
        Pasang Instrument
pasang, (Maybe Bool, Bool)
initial_final) ->
    forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Kernel
kernel <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [Char] -> Either Text Kernel
make_kernel (Text -> [Char]
untxt Text
kernel_s)
        Pitch
pitch <- forall a. PassedArgs a -> Deriver Pitch
get_pitch PassedArgs Note
args
        ScoreTime -> Bool
under_threshold <- (RealTime -> RealTime) -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function RealTime -> RealTime
kotekan ScoreTime
dur
        let cycle :: Cycle
cycle = UpDown -> KotekanStyle -> Pasang Instrument -> Kernel -> Cycle
realize_kernel UpDown
sangsih_above KotekanStyle
style Pasang Instrument
pasang
                ((if Bool
inverted then Kernel -> Kernel
invert else forall a. a -> a
id) (forall a. Int -> [a] -> [a]
rotate Int
rotation Kernel
kernel))
        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
inverted Maybe Text
maybe_kernel KotekanStyle
default_style =
    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" forall a. Semigroup a => a -> a -> a
<> Doc
kotekan_doc)
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"kernel" EnvironDefault
Sig.Both (Text
"k-12-1-21" :: Text) Doc
kernel_doc)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
maybe_kernel
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KotekanStyle -> Parser KotekanStyle
style_arg KotekanStyle
default_style
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"sangsih" EnvironDefault
Sig.Both (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        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."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (RealTime -> RealTime)
kotekan_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Bool, Bool)
infer_initial_final_env
    ) forall a b. (a -> b) -> a -> b
$ \(Text
kernel_s, KotekanStyle
style, Maybe UpDown
sangsih_dir, ScoreTime
dur, RealTime -> RealTime
kotekan, Pasang Instrument
pasang, (Maybe Bool, Bool)
initial_final) ->
    forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        Kernel
kernel <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id 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 = forall a. a -> Maybe a -> a
fromMaybe (Bool -> Kernel -> UpDown
infer_sangsih Bool
inverted Kernel
kernel)
                Maybe UpDown
sangsih_dir
        Pitch
pitch <- forall a. PassedArgs a -> Deriver Pitch
get_pitch PassedArgs Note
args
        ScoreTime -> Bool
under_threshold <- (RealTime -> RealTime) -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function RealTime -> RealTime
kotekan ScoreTime
dur
        let cycle :: Cycle
cycle = UpDown -> KotekanStyle -> Pasang Instrument -> Kernel -> Cycle
realize_kernel UpDown
sangsih_above KotekanStyle
style Pasang Instrument
pasang
                (if Bool
inverted then Kernel -> Kernel
invert Kernel
kernel else Kernel
kernel)
        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
inverted Kernel
kernel = (if Bool
inverted then UpDown -> UpDown
Call.invert else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
        case forall a. [a] -> Maybe a
Lists.last Kernel
kernel of
            Just Atom
High -> UpDown
Call.Down
            Maybe Atom
_ -> UpDown
Call.Up

c_kotekan_explicit :: Derive.Generator Derive.Note
c_kotekan_explicit :: Generator Note
c_kotekan_explicit =
    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."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"polos" Doc
"Polos part."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"sangsih" Doc
"Sangsih part."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env
    ) forall a b. (a -> b) -> a -> b
$ \(Text
polos_s, Text
sangsih_s, ScoreTime
dur, Pasang Instrument
pasang) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        let (Int
expected, ScoreTime
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args forall a. Fractional a => a -> a -> a
/ ScoreTime
dur)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScoreTime
frac forall a. Eq a => a -> a -> Bool
/= ScoreTime
0) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"event " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args)
            forall a. Semigroup a => a -> a -> a
<> Text
" not evenly divisble by kotekan dur " forall a. Semigroup a => a -> a -> a
<> 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 <- 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 (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Note
args) ScoreTime
dur Pitch
pitch
        [Maybe Int] -> Instrument -> NoteDeriver
realize [Maybe Int]
polos_steps (forall a. Pasang a -> a
polos Pasang Instrument
pasang)
            forall a. Semigroup a => a -> a -> a
<> [Maybe Int] -> Instrument -> NoteDeriver
realize [Maybe Int]
sangsih_steps (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 forall a. Eq a => a -> a -> Bool
/= Int
expected =
            forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
name forall a. Semigroup a => a -> a -> a
<> Text
": expected length of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
expected
                forall a. Semigroup a => a -> a -> a
<> Text
" but was " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Text -> Int
Text.length Text
part)
        | Bool
otherwise = forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right ((Text
part forall a. Semigroup a => a -> a -> a
<> Text
":")<>) forall a b. (a -> b) -> a -> b
$
            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 (forall a. Eq a => a -> a -> Bool
==Char
'k') Text
part_
    parse1 :: Char -> Either Text (Maybe Int)
parse1 Char
'-' = forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
    parse1 Char
c = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected digit or '-': " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Char
c)
        (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Monoid a => [a] -> a
mconcat
    [ 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) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
tail (forall a. Num a => a -> a -> [a]
Lists.range_ ScoreTime
start ScoreTime
dur)) [Maybe Int]
notes
    ]
    where
    note :: ScoreTime -> Int -> NoteDeriver
note ScoreTime
t Int
transpose =
        (if ScoreTime
t forall a. Ord a => a -> a -> Bool
>= ScoreTime
end then Flags -> NoteDeriver -> NoteDeriver
Call.add_flags (Flags
Flags.infer_duration forall a. Semigroup a => a -> a -> a
<> Flags
final_flag)
            else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
        forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Instrument
inst forall a b. (a -> b) -> a -> b
$
        Pitch -> NoteDeriver
Call.pitched_note (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 :: Call.UpDown -> KotekanStyle
    -> Pasang ScoreT.Instrument -> Kernel -> Cycle
realize_kernel :: UpDown -> KotekanStyle -> Pasang Instrument -> Kernel -> Cycle
realize_kernel UpDown
sangsih_above KotekanStyle
style Pasang Instrument
pasang Kernel
kernel =
    Cycle -> Cycle
end_on_zero forall a b. (a -> b) -> a -> b
$ Kernel -> UpDown -> KotekanStyle -> Pasang Instrument -> Cycle
kernel_to_pattern 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 (forall a. PassedArgs a -> (Maybe Bool, Bool) -> (Bool, Bool)
infer_initial PassedArgs a
args (Maybe Bool, Bool)
initial_final)
        (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs a
args) (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 =
    forall a. (a -> NoteDeriver) -> [Note a] -> NoteDeriver
realize_notes KotekanNote -> NoteDeriver
realize forall a b. (a -> b) -> a -> b
$
        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 = forall a. Realization a -> a
interlocking Cycle
cycle
        | Bool
otherwise = forall a. Realization a -> a
non_interlocking Cycle
cycle
    realize :: KotekanNote -> NoteDeriver
realize (KotekanNote Maybe Instrument
inst Int
steps Bool
muted) =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Maybe Instrument
inst 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 forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.mute else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
        Pitch -> NoteDeriver
Call.pitched_note (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
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
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]
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Atom -> Char
to_char
    formatList :: Kernel -> Doc
formatList Kernel
cs =
        Doc
"make_kernel \"" forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Pretty.text ([Char] -> Text
txt (forall a b. (a -> b) -> [a] -> [b]
map Atom -> Char
to_char Kernel
cs)) 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)
    | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
cs forall a. Integral a => a -> a -> a
`mod` Int
4 forall a. Eq a => a -> a -> Bool
/= Int
0 =
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"kernel's length " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
cs)
            forall a. Semigroup a => a -> a -> a
<> Text
" is not a multiple of 4: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Char]
cs
    | Bool
otherwise = 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 = 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
'_' -> forall a b. b -> Either a b
Right Atom
Gap
    Char
'-' -> forall a b. b -> Either a b
Right Atom
Rest
    Char
'1' -> forall a b. b -> Either a b
Right Atom
Low
    Char
'2' -> forall a b. b -> Either a b
Right Atom
High
    Char
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"kernel must be one of `_-12`, but got " forall a. Semigroup a => a -> a -> a
<> 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) (forall a. Realization a -> a
interlocking Cycle
realization)
    , non_interlocking :: [[KotekanNote]]
non_interlocking = Int -> [[KotekanNote]] -> [[KotekanNote]]
add (-Int
steps) (forall a. Realization a -> a
non_interlocking Cycle
realization)
    }
    where
    add :: Int -> [[KotekanNote]] -> [[KotekanNote]]
add Int
steps = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \KotekanNote
note ->
        KotekanNote
note { note_steps :: Int
note_steps = Int
steps forall a. Num a => a -> a -> a
+ KotekanNote -> Int
note_steps KotekanNote
note }
    steps :: Int
steps = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ do
        KotekanNote
final : [KotekanNote]
_ <- forall a. [a] -> Maybe a
Lists.last (forall a. Realization a -> a
non_interlocking Cycle
realization)
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a b. (a -> b) -> [a] -> [b]
map Atom -> [KotekanNote]
interlock Kernel
kernel
    , non_interlocking :: [[KotekanNote]]
non_interlocking = 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 (forall a. a -> Maybe a
Just (forall a. Pasang a -> a
polos Pasang Instrument
pasang))
    s :: Int -> KotekanNote
s = Maybe Instrument -> Int -> KotekanNote
kotekan_note (forall a. a -> Maybe a
Just (forall a. Pasang a -> a
sangsih Pasang Instrument
pasang))
    both :: Int -> KotekanNote
both = Maybe Instrument -> Int -> KotekanNote
kotekan_note forall a. Maybe a
Nothing

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

rotations :: [a] -> [[a]]
rotations :: forall a. [a] -> [[a]]
rotations [a]
xs = [a]
xs forall a. a -> [a] -> [a]
: forall {a}. [a] -> [a] -> [[a]]
go [a]
xs (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 forall a. a -> [a] -> [a]
: [a] -> [a] -> [[a]]
go [a]
p [a]
zs
        where p :: [a]
p = forall a. Int -> [a] -> [a]
take Int
len (a
z forall a. a -> [a] -> [a]
: [a]
xs)
    len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs

invert :: Kernel -> Kernel
invert :: Kernel -> Kernel
invert = forall a b. (a -> b) -> [a] -> [b]
map 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 = 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_ = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.uniqueOn 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) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (forall a. [a] -> [[a]]
rotations Kernel
kernel)
        ]

-- ** implementation

data Repeat = Repeat | Once deriving (Int -> Repeat -> ShowS
[Repeat] -> ShowS
Repeat -> [Char]
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 = 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 -> 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
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) = 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 forall a. Semigroup a => a -> a -> a
<> 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]
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) =
        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 :: (RealTime -> RealTime) -> 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 :: (RealTime -> RealTime) -> ScoreTime -> Deriver (ScoreTime -> Bool)
under_threshold_function RealTime -> RealTime
kotekan ScoreTime
dur = do
    ScoreTime -> RealTime
to_real <- Deriver (ScoreTime -> RealTime)
Derive.real_function
    forall (m :: * -> *) a. Monad m => a -> m a
return 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
tforall a. Num a => a -> a -> a
+ScoreTime
dur) forall a. Num a => a -> a -> a
- RealTime
real forall a. Ord a => a -> a -> Bool
< RealTime -> RealTime
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 -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. (ScoreTime, [a]) -> [Note a]
realize forall a b. (a -> b) -> a -> b
$
            (if Orientation
orientation forall a. Eq a => a -> a -> Bool
== Orientation
Types.Positive then forall a b. [a] -> [b] -> [(a, b)]
zip else forall a b. [a] -> [b] -> [(a, b)]
zip_end)
                (forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.range ScoreTime
start ScoreTime
end ScoreTime
dur) (ScoreTime -> [[a]]
get_cycle ScoreTime
start)
        Repeat
Repeat -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. (ScoreTime, [a]) -> [Note a]
realize [(ScoreTime, [a])]
pairs
    where
    pairs :: [(ScoreTime, [a])]
pairs = case Orientation
orientation of
        Orientation
Types.Positive -> forall t a. (t -> [a]) -> [t] -> [(t, a)]
cycles ScoreTime -> [[a]]
wrapped [ScoreTime]
ts
        Orientation
Types.Negative -> forall t a. (t -> [a]) -> [t] -> [(t, a)]
cycles_end ScoreTime -> [[a]]
get_cycle [ScoreTime]
ts
        where ts :: [ScoreTime]
ts = forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.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 forall a. Eq a => a -> a -> Bool
== ScoreTime
start = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) (forall a. [a] -> Maybe a
Lists.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 forall a. Ord a => a -> a -> Bool
>= ScoreTime
end = if Bool
final
            then forall a b. (a -> b) -> [a] -> [b]
map (forall a. Flags -> Note a -> Note a
add_flag (Flags
Flags.infer_duration forall a. Semigroup a => a -> a -> a
<> Flags
final_flag)) [Note a]
ns
            else []
        | ScoreTime
t 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. ScoreTime -> ScoreTime -> Flags -> a -> Note a
Note ScoreTime
t ScoreTime
dur 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 forall a. [a] -> [a] -> [a]
++ [t] -> [(t, a)]
go [t]
ts
        Right [a]
_ -> [(t, a)]
pairs
        where ([(t, a)]
pairs, Either [t] [a]
rest) = forall a b. [a] -> [b] -> ([(a, b)], Either [a] [b])
Lists.zipRemainder (t
tforall 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 = forall {a} {b}. ([(a, b)], [b]) -> [(a, b)]
shift 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) = forall a b. [a] -> [b] -> [(a, b)]
zip [a]
ts (forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
rest_ns) [b]
ns forall a. [a] -> [a] -> [a]
++ [b]
rest_ns)
        where ([a]
ts, [b]
ns) = 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 -> 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) = forall a b. [a] -> [b] -> ([(a, b)], Either [a] [b])
Lists.zipRemainder (t
tforall 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 = forall a. [a] -> [a]
reverse (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
reverse [a]
xs) (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 = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap forall a b. (a -> b) -> a -> b
$ \(Note ScoreTime
start ScoreTime
dur Flags
flags a
note) ->
    forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
dur forall a b. (a -> b) -> a -> b
$ Flags -> NoteDeriver -> NoteDeriver
Call.add_flags Flags
flags 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
forall a. a -> a -> Bounded a
maxBound :: NorotStyle
$cmaxBound :: NorotStyle
minBound :: NorotStyle
$cminBound :: NorotStyle
Bounded, NorotStyle -> NorotStyle -> Bool
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]
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]
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
instance Typecheck.ToVal NorotStyle

data KotekanStyle = Telu | Pat deriving (KotekanStyle
forall a. a -> a -> Bounded a
maxBound :: KotekanStyle
$cmaxBound :: KotekanStyle
minBound :: KotekanStyle
$cminBound :: KotekanStyle
Bounded, KotekanStyle -> KotekanStyle -> Bool
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]
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]
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
instance Typecheck.ToVal KotekanStyle

-- * postproc

c_unison :: Derive.Transformer Derive.Note
c_unison :: Transformer Note
c_unison = 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`."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser (Pasang Instrument)
pasang_env 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 <- forall a. a -> a -> Pasang a
Pasang forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Deriver (Instrument, Instrument)
Derive.get_instrument (forall a. Pasang a -> a
polos Pasang Instrument
pasang)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Instrument -> Deriver (Instrument, Instrument)
Derive.get_instrument (forall a. Pasang a -> a
sangsih Pasang Instrument
pasang)
        forall a. (a -> [Note]) -> Stream a -> Stream Note
Post.emap_asc_ (Instrument -> Pasang (Instrument, Instrument) -> Note -> [Note]
unison Instrument
inst Pasang (Instrument, Instrument)
pasang) 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 forall a. Eq a => a -> a -> Bool
== Instrument
inst = [(Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set forall a. Pasang a -> a
polos, (Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set forall a. Pasang a -> a
sangsih]
        | Bool
otherwise = [Note
event]
        where
        msg :: Text
msg = Text
"unison from " forall a. Semigroup a => a -> a -> a
<> 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
Score.add_log Text
msg 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 = 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."
    ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe Pitch)
instrument_top_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Pasang Instrument)
pasang_env
    ) 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 <- forall a. a -> a -> Pasang a
Pasang forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Deriver (Instrument, Instrument)
Derive.get_instrument (forall a. Pasang a -> a
polos Pasang Instrument
pasang)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Instrument -> Deriver (Instrument, Instrument)
Derive.get_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
        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) 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 forall a. Eq a => a -> a -> Bool
== Instrument
pasang_inst =
            [ Text
-> (Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set (Text
"low kempyung from " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
pasang_inst) forall a. Pasang a -> a
polos
            , (Note -> Bool) -> Note -> Note
transpose Note -> Bool
too_high forall a b. (a -> b) -> a -> b
$
                Text
-> (Pasang (Instrument, Instrument) -> (Instrument, Instrument))
-> Note
set (Text
"high kempyung from " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
pasang_inst) 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
Score.add_log Text
msg 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 (forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose (Double -> Transpose
Pitch.Diatonic Double
3))
                    (Note -> Pitch
Score.event_pitch Note
event)
            }

c_nyogcag :: Library.Calls Derive.Note
c_nyogcag :: Calls Note
c_nyogcag = 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 forall a b. (a -> b) -> a -> b
$ \Pasang Instrument
pasang NoteDeriver
deriver -> do
        Instrument
inst <- Deriver Instrument
Call.get_instrument
        Pasang (Instrument, Instrument)
pasang <- forall a. a -> a -> Pasang a
Pasang forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Deriver (Instrument, Instrument)
Derive.get_instrument (forall a. Pasang a -> a
polos Pasang Instrument
pasang)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Instrument -> Deriver (Instrument, Instrument)
Derive.get_instrument (forall a. Pasang a -> a
sangsih Pasang Instrument
pasang)
        forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 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 forall a. Eq a => a -> a -> Bool
== Instrument
pasang_inst = Bool -> Bool
not Bool
is_polos
        | Instrument
event_inst forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (forall a. Pasang a -> a
polos Pasang (Instrument, Instrument)
pasang) = Bool
False
        | Instrument
event_inst forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (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 forall a. Pasang a -> a
polos Pasang (Instrument, Instrument)
pasang else 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 = forall a. HasCallStack => Text -> Either Text a -> a
StaticMacro.check Text
"c_realize_gangsa" forall a b. (a -> b) -> a -> b
$
    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
        [ forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
c_realize_noltol []
        , forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
c_cancel_pasang [Arg
StaticMacro.Var]
        , 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 = 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`."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ((,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"time" (Double
0.1 :: Double)
        Doc
"Play noltol if the time available exceeds this threshold."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"damp-dyn" (Double
0.65 :: Double)
        Doc
"Damped notes are multiplied by this dyn."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ScoreTime
dur_env
    ) forall a b. (a -> b) -> a -> b
$ \(RealTime -> Double
threshold, Double
damp_dyn, ScoreTime
max_dur) PassedArgs Note
args NoteDeriver
deriver -> do
        RealTime
max_dur <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) ScoreTime
max_dur
        Stream Note
events <- NoteDeriver
deriver
        let times :: [RealTime]
times = (RealTime -> Double) -> Stream Note -> [RealTime]
Post.real_time_control RealTime -> Double
threshold Stream Note
events
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Double -> RealTime -> (RealTime, Note) -> Note
put Double
damp_dyn RealTime
max_dur) forall a b. (a -> b) -> a -> b
$ forall a x. [a] -> Stream x -> Stream (a, x)
Stream.zip [RealTime]
times Stream Note
events
        where
        put :: Double -> RealTime -> (RealTime, Note) -> Note
put Double
damp_dyn RealTime
max_dur (RealTime
threshold, Note
event) =
            forall a. Typeable a => Text -> a -> Note -> Note
Score.put_arg Text
noltol_arg
                ((RealTime
threshold, RealTime
max_dur, Double
damp_dyn) :: NoltolArg) Note
event

c_realize_noltol :: Derive.Transformer Score.Event
c_realize_noltol :: Transformer Note
c_realize_noltol = 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`."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_args NoteDeriver
deriver -> Stream Note -> NoteDeriver
realize_noltol_call 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 =
    forall a.
(a -> Note) -> (a -> NoteDeriver) -> Stream a -> NoteDeriver
Post.emap_s_ forall a b. (a, b) -> a
fst (Note, Maybe Note) -> NoteDeriver
realize forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
            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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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, Double
damp_dyn) Note
event Maybe Note
next =
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Stream a
Stream.from_event Note
event) forall a. Semigroup a => a -> a -> a
<> NoteDeriver
muted
    where
    muted :: NoteDeriver
muted
        | Bool
should_noltol = do
            ScoreTime
start <- forall a. Time a => a -> Deriver ScoreTime
Derive.score (Note -> RealTime
Score.event_end Note
event)
            Pitch
pitch <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no 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.
            forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument (Note -> Instrument
Score.event_instrument Note
event) forall a b. (a -> b) -> a -> b
$
                forall a. Pitch -> Deriver a -> Deriver a
Call.with_pitch Pitch
pitch forall a b. (a -> b) -> a -> b
$
                forall a. Double -> Deriver a -> Deriver a
Call.multiply_dynamic Double
damp_dyn forall a b. (a -> b) -> a -> b
$
                forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
0 NoteDeriver
Call.note
        | Bool
otherwise = 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
&& forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((forall a. Ord a => a -> a -> Bool
>= RealTime
threshold) 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 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 = 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."
    forall a b. (a -> b) -> a -> b
$ forall key.
Ord key =>
Cancel -> Key key -> WithArgDoc (Transformer Note (Stream 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
strongs) = forall {a}. [Note] -> [Note] -> Either a [Note]
merge [Note]
strongs ([Note]
finals forall a. [a] -> [a] -> [a]
++ [Note]
rest)
    | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
finals) = forall {a}. [Note] -> [Note] -> Either a [Note]
merge [Note]
finals [Note]
rest
    | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
normals) = forall {a}. [Note] -> [Note] -> Either a [Note]
merge [Note]
normals [Note]
weaks
    | Bool
otherwise = forall a b. b -> Either a b
Right [Note]
weaks
    where
    ([Note]
strongs, [Note]
finals, [Note]
rest) = forall a. (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a], [a])
Lists.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) = 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 =
        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, forall {a}. Typecheck a => Text -> Maybe a
get Text
EnvKey.hand)
    where
    inst :: Either Instrument (Instrument, Instrument)
inst = case (forall {a}. Typecheck a => Text -> Maybe a
get Text
inst_polos, forall {a}. Typecheck a => Text -> Maybe a
get Text
inst_sangsih) of
        (Just Instrument
p, Just Instrument
s) -> forall a b. b -> Either a b
Right (Instrument
p, Instrument
s)
        (Maybe Instrument, Maybe Instrument)
_ -> forall a b. a -> Either a b
Left (Note -> Instrument
Score.event_instrument Note
e)
    get :: Text -> Maybe a
get Text
k = 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 = 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 = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> 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 = forall a.
Typecheck 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 (RealTime -> RealTime)
kotekan_env :: Parser (RealTime -> RealTime)
kotekan_env = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> RealTime
RealTime.seconds .) forall a b. (a -> b) -> a -> b
$
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"kotekan" EnvironDefault
Sig.Unprefixed (RealTime
0.15 :: RealTime)
        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 = (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"initial" EnvironDefault
Sig.Unprefixed (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        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."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> 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 =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Event -> Bool
Event.is_negative (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 = (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> 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."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> 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 = forall a deflt.
(Typecheck a, ToVal deflt) =>
Text -> deflt -> Doc -> Parser a
Sig.environ_key Text
EnvKey.instrument_top
    (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
    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 = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ do
    Pitch
top <- Maybe Pitch
maybe_top
    Note
note <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Transposed -> Either PitchError Note
PSignal.pitch_note Transposed
pitchv
    Pitch
pitch <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale forall a. Monoid a => a
mempty Note
note
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pitch
pitch 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 =
    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) 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 = forall a. a -> a -> Pasang a
Pasang
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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"