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

-- | Utilities for Balinese scales.  Mostly that means dealing with umbang and
-- isep.
--
-- They're implemented as a modification of "ChromaticScales" because a saih
-- pitu or pelog scale requires a key or pathet, which winds up being similar
-- to a simplified chromatic scale.
module Derive.Scale.BaliScales where
import qualified Data.Attoparsec.Text as A
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import           Data.Vector ((!?))

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Util.Texts as Texts

import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
import qualified Derive.PSignal as PSignal
import qualified Derive.REnv as REnv
import qualified Derive.Scale as Scale
import qualified Derive.Scale.ChromaticScales as ChromaticScales
import qualified Derive.Scale.Scales as Scales
import qualified Derive.Scale.Theory as Theory
import qualified Derive.Scale.TheoryFormat as TheoryFormat
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch

import           Global


-- | Top level scale constructor.
make_scale :: Pitch.ScaleId -> ScaleMap -> Scale.Scale
make_scale :: ScaleId -> ScaleMap -> Scale
make_scale ScaleId
scale_id ScaleMap
smap =
    (ScaleId -> ScaleMap -> Doc -> Scale
ChromaticScales.make_scale ScaleId
scale_id (ScaleMap -> ScaleMap
smap_chromatic ScaleMap
smap) Doc
doc)
    { scale_enharmonics :: Enharmonics
Scale.scale_enharmonics = Enharmonics
Scales.no_enharmonics }
    where
    doc :: Doc
doc = Doc
"Balinese scales come in detuned pairs. They use the "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Key
EnvKey.tuning forall a. Semigroup a => a -> a -> a
<> Doc
" env var to select between pengumbang\
        \ and pengisep. The env var should be set to either `umbang` or `isep`,\
        \ defaulting to `umbang`. Normally the umbang and isep\
        \ frequencies are hardcoded according to the scale, but if the "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
c_ombak
        forall a. Semigroup a => a -> a -> a
<> Doc
" control is present, they will be tuned that many hz apart.\
        \\nThe " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Key
laras_key forall a. Semigroup a => a -> a -> a
<> Doc
" env var chooses between\
        \ different tunings.  It defaults to "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc (Laras -> Key
laras_name (ScaleMap -> Laras
smap_default_laras ScaleMap
smap))
        forall a. Semigroup a => a -> a -> a
<> Doc
". Laras:\n"
        forall a. Semigroup a => a -> a -> a
<> forall a. (Textlike a, Monoid a, IsString a) => [a] -> a
Texts.enumeration
            [ forall a. ShowVal a => a -> Doc
ShowVal.doc Key
name forall a. Semigroup a => a -> a -> a
<> Doc
" - " forall a. Semigroup a => a -> a -> a
<> Laras -> Doc
laras_doc Laras
laras
            | (Key
name, Laras
laras) <- forall k a. Map k a -> [(k, a)]
Map.toList (ScaleMap -> LarasMap
smap_laras ScaleMap
smap)
            ]

data ScaleMap = ScaleMap {
    ScaleMap -> ScaleMap
smap_chromatic :: !ChromaticScales.ScaleMap
    , ScaleMap -> LarasMap
smap_laras :: !LarasMap
    , ScaleMap -> Laras
smap_default_laras :: !Laras
    }

type LarasMap = Map Text Laras

scale_map :: Config -> TheoryFormat.Format -> Maybe (Pitch.Semi, Pitch.Semi)
    -- ^ If not given, use the complete range of the saih.
    -> ScaleMap
scale_map :: Config -> Format -> Maybe (Int, Int) -> ScaleMap
scale_map (Config Layout
layout Keys
all_keys Key
default_key LarasMap
laras Laras
default_laras)
        Format
fmt Maybe (Int, Int)
maybe_range =
    ScaleMap
        { smap_chromatic :: ScaleMap
smap_chromatic =
            (Layout -> Format -> Keys -> Key -> ScaleMap
ChromaticScales.scale_map Layout
layout Format
fmt Keys
all_keys Key
default_key)
            { smap_semis_to_nn :: SemisToNoteNumber
ChromaticScales.smap_semis_to_nn =
                Layout -> LarasMap -> Laras -> SemisToNoteNumber
semis_to_nn Layout
layout LarasMap
laras Laras
default_laras
            -- Convert range to absolute.
            , smap_range :: (Int, Int)
ChromaticScales.smap_range = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. Num a => a -> a -> a
+Int
offset) (forall a. Num a => a -> a -> a
+Int
offset) (Int, Int)
range
            }
        , smap_laras :: LarasMap
smap_laras = LarasMap
laras
        , smap_default_laras :: Laras
smap_default_laras = Laras
default_laras
        }
    where
    -- Each laras can start on a different note, but I use the default one
    -- for the range as a whole.
    offset :: Int
offset = Layout -> Laras -> Int
laras_offset Layout
layout Laras
default_laras
    range :: (Int, Int)
range = forall a. a -> Maybe a -> a
fromMaybe (Int
0, Int
top) Maybe (Int, Int)
maybe_range
    top :: Int
top = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall a. Num a => a -> a -> a
subtract Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> Int
Vector.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Laras -> Vector NoteNumber
laras_umbang) forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> Maybe a
Lists.head (forall k a. Map k a -> [a]
Map.elems LarasMap
laras)

data Config = Config {
    Config -> Layout
config_layout :: !Theory.Layout
    , Config -> Keys
config_keys :: !ChromaticScales.Keys
    , Config -> Key
config_default_key :: !Theory.Key
    , Config -> LarasMap
config_laras :: !LarasMap
    , Config -> Laras
config_default_laras :: !Laras
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

-- | This is a specialized version of 'scale_map' that uses base octave and
-- low and high pitches to compute the range.
instrument_scale_map :: Config -> Instrument -> ScaleMap
instrument_scale_map :: Config -> Instrument -> ScaleMap
instrument_scale_map Config
config
        (Instrument Degrees
degrees RelativeOctaves
relative_octaves Int
center_oct Pitch
low Pitch
high) =
    Config -> Format -> Maybe (Int, Int) -> ScaleMap
scale_map Config
config Format
fmt (forall a. a -> Maybe a
Just (Pitch -> Int
to_pc Pitch
low, Pitch -> Int
to_pc Pitch
high))
    where
    to_pc :: Pitch -> Int
to_pc Pitch
p = Int -> Pitch -> Pitch -> Int
Pitch.diff_pc Int
per_oct Pitch
p Pitch
base_pitch
    base_pitch :: Pitch
base_pitch = Laras -> Pitch
laras_base (Config -> Laras
config_default_laras Config
config)
    fmt :: Format
fmt = Degrees -> RelativeOctaves -> Int -> Bool -> Key -> Keys -> Format
relative_arrow Degrees
degrees RelativeOctaves
relative_octaves Int
center_oct Bool
True
        (Config -> Key
config_default_key Config
config) (Config -> Keys
config_keys Config
config)
    per_oct :: Int
per_oct = Layout -> Int
Theory.layout_semis_per_octave (Config -> Layout
config_layout Config
config)

-- | Describe an instrument-relative scale.
data Instrument = Instrument {
    Instrument -> Degrees
inst_degrees :: !TheoryFormat.Degrees
    , Instrument -> RelativeOctaves
inst_relative_octaves :: !RelativeOctaves
    , Instrument -> Int
inst_center :: !Pitch.Octave
    , Instrument -> Pitch
inst_low :: !Pitch.Pitch
    , Instrument -> Pitch
inst_high :: !Pitch.Pitch
    } deriving (Instrument -> Instrument -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Instrument -> Instrument -> Bool
$c/= :: Instrument -> Instrument -> Bool
== :: Instrument -> Instrument -> Bool
$c== :: Instrument -> Instrument -> Bool
Eq, Int -> Instrument -> ShowS
[Instrument] -> ShowS
Instrument -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instrument] -> ShowS
$cshowList :: [Instrument] -> ShowS
show :: Instrument -> String
$cshow :: Instrument -> String
showsPrec :: Int -> Instrument -> ShowS
$cshowsPrec :: Int -> Instrument -> ShowS
Show)

instrument_range :: Instrument -> Scale.Range
instrument_range :: Instrument -> Range
instrument_range Instrument
inst = Pitch -> Pitch -> Range
Scale.Range (Instrument -> Pitch
inst_low Instrument
inst) (Instrument -> Pitch
inst_high Instrument
inst)

-- * Laras

-- | Describe the frequencies in a saih.  This doesn't say what the range is,
-- since that's in the 'ScaleMap', and all saihs in one scale should have the
-- same range.
data Laras = Laras {
    Laras -> Key
laras_name :: Text
    , Laras -> Doc
laras_doc :: Doc.Doc
    -- | The pitch where the laras starts.  It should be such that octave 4 is
    -- close to middle C.
    , Laras -> Pitch
laras_base :: Pitch.Pitch
    , Laras -> Vector NoteNumber
laras_umbang :: Vector.Vector Pitch.NoteNumber
    , Laras -> Vector NoteNumber
laras_isep :: Vector.Vector Pitch.NoteNumber
    } deriving (Laras -> Laras -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Laras -> Laras -> Bool
$c/= :: Laras -> Laras -> Bool
== :: Laras -> Laras -> Bool
$c== :: Laras -> Laras -> Bool
Eq, Int -> Laras -> ShowS
[Laras] -> ShowS
Laras -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Laras] -> ShowS
$cshowList :: [Laras] -> ShowS
show :: Laras -> String
$cshow :: Laras -> String
showsPrec :: Int -> Laras -> ShowS
$cshowsPrec :: Int -> Laras -> ShowS
Show)

laras_map :: [Laras] -> Map Text Laras
laras_map :: [Laras] -> LarasMap
laras_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn Laras -> Key
laras_name

laras :: Text -> Pitch.Pitch -> ([Pitch.NoteNumber] -> [Pitch.NoteNumber])
    -> Doc.Doc -> [(Pitch.NoteNumber, Pitch.NoteNumber)] -> Laras
laras :: Key
-> Pitch
-> ([NoteNumber] -> [NoteNumber])
-> Doc
-> [(NoteNumber, NoteNumber)]
-> Laras
laras Key
name Pitch
base_pitch [NoteNumber] -> [NoteNumber]
extend Doc
doc [(NoteNumber, NoteNumber)]
nns = Laras
    { laras_name :: Key
laras_name = Key
name
    , laras_doc :: Doc
laras_doc = Doc
doc
    , laras_base :: Pitch
laras_base = Pitch
base_pitch
    , laras_umbang :: Vector NoteNumber
laras_umbang = forall a. [a] -> Vector a
Vector.fromList ([NoteNumber] -> [NoteNumber]
extend [NoteNumber]
umbang)
    , laras_isep :: Vector NoteNumber
laras_isep = forall a. [a] -> Vector a
Vector.fromList ([NoteNumber] -> [NoteNumber]
extend [NoteNumber]
isep)
    }
    where ([NoteNumber]
umbang, [NoteNumber]
isep) = forall a b. [(a, b)] -> ([a], [b])
unzip [(NoteNumber, NoteNumber)]
nns

laras_offset :: Theory.Layout -> Laras -> Pitch.Semi
laras_offset :: Layout -> Laras -> Int
laras_offset Layout
layout Laras
laras =
    Layout -> Int
Theory.layout_semis_per_octave Layout
layout forall a. Num a => a -> a -> a
* Pitch -> Int
Pitch.pitch_octave Pitch
base_pitch
        forall a. Num a => a -> a -> a
+ Pitch -> Int
Pitch.pitch_pc Pitch
base_pitch
    where
    base_pitch :: Pitch
base_pitch = Laras -> Pitch
laras_base Laras
laras

laras_nns :: Laras -> [(Pitch.NoteNumber, Pitch.NoteNumber)]
laras_nns :: Laras -> [(NoteNumber, NoteNumber)]
laras_nns Laras
laras =
    forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Vector a -> [a]
Vector.toList (Laras -> Vector NoteNumber
laras_umbang Laras
laras)) (forall a. Vector a -> [a]
Vector.toList (Laras -> Vector NoteNumber
laras_isep Laras
laras))

-- * Format

-- | This can't use backtick symbols because then the combining octave
-- characters don't combine.
balinese :: TheoryFormat.Degrees
balinese :: Degrees
balinese = [Key] -> Degrees
TheoryFormat.make_degrees [Key
"᭦", Key
"᭡", Key
"᭢", Key
"᭣", Key
"᭤"]

ioeua :: TheoryFormat.Degrees
ioeua :: Degrees
ioeua = [Key] -> Degrees
TheoryFormat.make_degrees [Key
"i", Key
"o", Key
"e", Key
"u", Key
"a"]

digit_octave_relative :: TheoryFormat.Degrees -> Bool -> Theory.Key
    -> ChromaticScales.Keys -> TheoryFormat.Format
digit_octave_relative :: Degrees -> Bool -> Key -> Keys -> Format
digit_octave_relative Degrees
degrees Bool
chromatic Key
default_key Keys
keys =
    forall key. Key -> Degrees -> RelativeFormat key -> Format
TheoryFormat.make_relative_format
        (Key
"[1-9]" forall a. Semigroup a => a -> a -> a
<> Degrees -> Key
degrees_doc Degrees
degrees forall a. Semigroup a => a -> a -> a
<> if Bool
chromatic then Key
"#?" else Key
"")
        Degrees
degrees RelativeFormat Key
fmt
    where fmt :: RelativeFormat Key
fmt = Key -> Keys -> RelativeFormat Key
ChromaticScales.relative_fmt Key
default_key Keys
keys

ioeua_relative :: Bool -> Theory.Key -> ChromaticScales.Keys
    -> TheoryFormat.Format
ioeua_relative :: Bool -> Key -> Keys -> Format
ioeua_relative = Degrees -> Bool -> Key -> Keys -> Format
digit_octave_relative Degrees
ioeua

-- | (high, middle, low)
type RelativeOctaves = (Char, Maybe Char, Char)

-- | Use ascii-art arrows for octaves.
arrow_octaves :: RelativeOctaves
arrow_octaves :: RelativeOctaves
arrow_octaves = (Char
'^', forall a. a -> Maybe a
Just Char
'-', Char
'_')

-- | Use combining marks for octaves.
balinese_octaves :: RelativeOctaves
balinese_octaves :: RelativeOctaves
balinese_octaves =
    ( Char
'\x1b6b' -- balinese musical symbol combining tegeh
    , forall a. Maybe a
Nothing
    , Char
'\x1b6c' -- balinese musical symbol combining endep
    )

degrees_doc :: TheoryFormat.Degrees -> Text
degrees_doc :: Degrees -> Key
degrees_doc Degrees
degrees = Key
"[" forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. Vector a -> [a]
Vector.toList Degrees
degrees) forall a. Semigroup a => a -> a -> a
<> Key
"]"

relative_arrow :: TheoryFormat.Degrees -> RelativeOctaves
    -> Pitch.Octave -> Bool -> Theory.Key
    -> ChromaticScales.Keys -> TheoryFormat.Format
relative_arrow :: Degrees -> RelativeOctaves -> Int -> Bool -> Key -> Keys -> Format
relative_arrow Degrees
degrees RelativeOctaves
relative_octaves Int
center Bool
chromatic Key
default_key Keys
keys =
    forall key. Key -> Degrees -> RelativeFormat key -> Format
TheoryFormat.make_relative_format
        (Degrees -> Key
degrees_doc Degrees
degrees forall a. Semigroup a => a -> a -> a
<> (if Bool
chromatic then Key
"#?" else Key
"") forall a. Semigroup a => a -> a -> a
<> Key
"[_^-]")
        Degrees
degrees RelativeFormat Key
fmt
    where
    fmt :: RelativeFormat Key
fmt = forall key.
(Config -> Config) -> RelativeFormat key -> RelativeFormat key
modify_config (RelativeOctaves -> Int -> Config -> Config
set_relative_octaves RelativeOctaves
relative_octaves Int
center) forall a b. (a -> b) -> a -> b
$
        Key -> Keys -> RelativeFormat Key
ChromaticScales.relative_fmt Key
default_key Keys
keys

ioeua_relative_arrow :: Pitch.Octave -> Bool -> Theory.Key
    -> ChromaticScales.Keys -> TheoryFormat.Format
ioeua_relative_arrow :: Int -> Bool -> Key -> Keys -> Format
ioeua_relative_arrow = Degrees -> RelativeOctaves -> Int -> Bool -> Key -> Keys -> Format
relative_arrow Degrees
ioeua RelativeOctaves
arrow_octaves

ioeua_absolute :: TheoryFormat.Format
ioeua_absolute :: Format
ioeua_absolute = Key -> Degrees -> Format
TheoryFormat.make_absolute_format Key
"[1-9][ioeua]" Degrees
ioeua

modify_config :: (TheoryFormat.Config -> TheoryFormat.Config)
    -> TheoryFormat.RelativeFormat key -> TheoryFormat.RelativeFormat key
modify_config :: forall key.
(Config -> Config) -> RelativeFormat key -> RelativeFormat key
modify_config Config -> Config
f RelativeFormat key
fmt = RelativeFormat key
fmt
    { rel_config :: Config
TheoryFormat.rel_config = Config -> Config
f (forall key. RelativeFormat key -> Config
TheoryFormat.rel_config RelativeFormat key
fmt) }

set_relative_octaves :: RelativeOctaves -> Pitch.Octave
    -> TheoryFormat.Config -> TheoryFormat.Config
set_relative_octaves :: RelativeOctaves -> Int -> Config -> Config
set_relative_octaves (Char
high, Maybe Char
middle, Char
low) Int
center =
    ShowOctave -> ParseOctave -> Config -> Config
TheoryFormat.set_octave ShowOctave
show_octave ParseOctave
parse_octave
    where
    show_octave :: ShowOctave
show_octave Int
oct
        | Int
oct forall a. Ord a => a -> a -> Bool
> Int
center = (forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate (Int
octforall a. Num a => a -> a -> a
-Int
center) (Char -> Key
t Char
high))
        | Int
oct forall a. Ord a => a -> a -> Bool
< Int
center = (forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate (Int
centerforall a. Num a => a -> a -> a
-Int
oct) (Char -> Key
t Char
low))
        | Bool
otherwise = (forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Key
"" Char -> Key
t Maybe Char
middle)
    parse_octave :: ParseOctave
parse_octave Parser Key (Int, Maybe Int)
p_degree = do
        (Int
pc, Maybe Int
acc) <- Parser Key (Int, Maybe Int)
p_degree
        String
oct_str <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many' forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Char
A.satisfy forall a b. (a -> b) -> a -> b
$ \Char
c ->
            Char
c forall a. Eq a => a -> a -> Bool
== Char
high Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
low Bool -> Bool -> Bool
|| forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
==Char
c) Maybe Char
middle
        let oct_value :: Char -> a
oct_value Char
c
                | Char
c forall a. Eq a => a -> a -> Bool
== Char
high = a
1
                | Char
c forall a. Eq a => a -> a -> Bool
== Char
low = -a
1
                | Bool
otherwise = a
0
        let oct :: Int
oct = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Num a => Char -> a
oct_value String
oct_str
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> Maybe Int -> RelativePitch
TheoryFormat.RelativePitch (Int
center forall a. Num a => a -> a -> a
+ Int
oct) Int
pc Maybe Int
acc
    t :: Char -> Key
t = Char -> Key
Text.singleton

cipher_relative_dotted :: Pitch.Octave -> Theory.Key -> ChromaticScales.Keys
    -> TheoryFormat.Format
cipher_relative_dotted :: Int -> Key -> Keys -> Format
cipher_relative_dotted Int
center Key
default_key Keys
keys =
    forall key. Key -> Degrees -> RelativeFormat key -> Format
TheoryFormat.make_relative_format Key
"[12356]|`[12356][.^]*`" Degrees
cipher5 RelativeFormat Key
fmt
    where
    fmt :: RelativeFormat Key
fmt = forall key.
(Config -> Config) -> RelativeFormat key -> RelativeFormat key
modify_config (Int -> Config -> Config
dotted_octaves Int
center) forall a b. (a -> b) -> a -> b
$
        Key -> Keys -> RelativeFormat Key
ChromaticScales.relative_fmt Key
default_key Keys
keys

cipher5 :: TheoryFormat.Degrees
cipher5 :: Degrees
cipher5 = [Key] -> Degrees
TheoryFormat.make_degrees [Key
"1", Key
"2", Key
"3", Key
"5", Key
"6"]

dotted_octaves :: Pitch.Octave -> TheoryFormat.Config -> TheoryFormat.Config
dotted_octaves :: Int -> Config -> Config
dotted_octaves Int
center = ShowOctave -> ParseOctave -> Config -> Config
TheoryFormat.set_octave ShowOctave
show_octave ParseOctave
parse_octave
    where
    show_octave :: ShowOctave
show_octave Int
oct Key
d
        | Int
oct forall a. Eq a => a -> a -> Bool
== Int
center = Key
d
        | Bool
otherwise = Key
"`" forall a. Semigroup a => a -> a -> a
<> Key
d
            forall a. Semigroup a => a -> a -> a
<> (if Int
oct forall a. Ord a => a -> a -> Bool
>= Int
center then ShowOctave
Text.replicate (Int
octforall a. Num a => a -> a -> a
-Int
center) Key
"^"
                else ShowOctave
Text.replicate (Int
centerforall a. Num a => a -> a -> a
-Int
oct) Key
".")
            forall a. Semigroup a => a -> a -> a
<> Key
"`"
    parse_octave :: ParseOctave
parse_octave Parser Key (Int, Maybe Int)
p_degree =
        forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> Int -> Maybe Int -> RelativePitch
TheoryFormat.RelativePitch Int
center) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Key (Int, Maybe Int)
p_degree
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParseOctave
with_octave Parser Key (Int, Maybe Int)
p_degree
    with_octave :: ParseOctave
with_octave Parser Key (Int, Maybe Int)
p_degree = do
        Char -> Parser Char
A.char Char
'`'
        (Int
pc, Maybe Int
acc) <- Parser Key (Int, Maybe Int)
p_degree
        String
octs <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many' forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Char
A.satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'^'
        Char -> Parser Char
A.char Char
'`'
        let oct :: Int
oct = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Int
Lists.count (forall a. Eq a => a -> a -> Bool
==Char
'^') String
octs forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Int
Lists.count (forall a. Eq a => a -> a -> Bool
==Char
'.') String
octs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> Maybe Int -> RelativePitch
TheoryFormat.RelativePitch (Int
center forall a. Num a => a -> a -> a
+ Int
oct) Int
pc Maybe Int
acc

-- * tuning

data Tuning = Umbang | Isep deriving (Tuning -> Tuning -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tuning -> Tuning -> Bool
$c/= :: Tuning -> Tuning -> Bool
== :: Tuning -> Tuning -> Bool
$c== :: Tuning -> Tuning -> Bool
Eq, Eq Tuning
Tuning -> Tuning -> Bool
Tuning -> Tuning -> Ordering
Tuning -> Tuning -> Tuning
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 :: Tuning -> Tuning -> Tuning
$cmin :: Tuning -> Tuning -> Tuning
max :: Tuning -> Tuning -> Tuning
$cmax :: Tuning -> Tuning -> Tuning
>= :: Tuning -> Tuning -> Bool
$c>= :: Tuning -> Tuning -> Bool
> :: Tuning -> Tuning -> Bool
$c> :: Tuning -> Tuning -> Bool
<= :: Tuning -> Tuning -> Bool
$c<= :: Tuning -> Tuning -> Bool
< :: Tuning -> Tuning -> Bool
$c< :: Tuning -> Tuning -> Bool
compare :: Tuning -> Tuning -> Ordering
$ccompare :: Tuning -> Tuning -> Ordering
Ord, Int -> Tuning
Tuning -> Int
Tuning -> [Tuning]
Tuning -> Tuning
Tuning -> Tuning -> [Tuning]
Tuning -> Tuning -> Tuning -> [Tuning]
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 :: Tuning -> Tuning -> Tuning -> [Tuning]
$cenumFromThenTo :: Tuning -> Tuning -> Tuning -> [Tuning]
enumFromTo :: Tuning -> Tuning -> [Tuning]
$cenumFromTo :: Tuning -> Tuning -> [Tuning]
enumFromThen :: Tuning -> Tuning -> [Tuning]
$cenumFromThen :: Tuning -> Tuning -> [Tuning]
enumFrom :: Tuning -> [Tuning]
$cenumFrom :: Tuning -> [Tuning]
fromEnum :: Tuning -> Int
$cfromEnum :: Tuning -> Int
toEnum :: Int -> Tuning
$ctoEnum :: Int -> Tuning
pred :: Tuning -> Tuning
$cpred :: Tuning -> Tuning
succ :: Tuning -> Tuning
$csucc :: Tuning -> Tuning
Enum, Tuning
forall a. a -> a -> Bounded a
maxBound :: Tuning
$cmaxBound :: Tuning
minBound :: Tuning
$cminBound :: Tuning
Bounded, Int -> Tuning -> ShowS
[Tuning] -> ShowS
Tuning -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tuning] -> ShowS
$cshowList :: [Tuning] -> ShowS
show :: Tuning -> String
$cshow :: Tuning -> String
showsPrec :: Int -> Tuning -> ShowS
$cshowsPrec :: Int -> Tuning -> ShowS
Show)

instance Pretty Tuning where pretty :: Tuning -> Key
pretty = forall a. Show a => a -> Key
showt
instance Typecheck.Typecheck Tuning
instance REnv.ToVal Tuning
instance ShowVal.ShowVal Tuning

-- | If ombak is unset, use the hardcoded tunings.  Otherwise, create new
-- umbang and isep tunings based on the given number.
c_ombak :: ScoreT.Control
c_ombak :: Control
c_ombak = Control
"ombak"

-- | Convert 'Pitch.FSemi' to 'Pitch.NoteNumber'.
semis_to_nn :: Theory.Layout -> LarasMap -> Laras
    -> ChromaticScales.SemisToNoteNumber
semis_to_nn :: Layout -> LarasMap -> Laras -> SemisToNoteNumber
semis_to_nn Layout
layout LarasMap
laras_map Laras
default_laras =
    \(PSignal.PitchConfig Environ
env ControlValMap
controls) FSemi
fsemis_ -> do
        Laras
laras <- forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Key -> Environ -> Either PitchError val
Scales.read_environ (\Key
v -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
v LarasMap
laras_map)
            (forall a. a -> Maybe a
Just Laras
default_laras) Key
laras_key Environ
env
        let fsemis :: FSemi
fsemis = FSemi
fsemis_ forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset
            offset :: Int
offset = Layout -> Laras -> Int
laras_offset Layout
layout Laras
laras
        Tuning
tuning <- forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Key -> Environ -> Either PitchError val
Scales.read_environ forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just Tuning
Umbang) Key
EnvKey.tuning Environ
env
        let err :: PitchError
err = forall a. Real a => a -> (Int, Int) -> PitchError
DeriveT.out_of_range_error FSemi
fsemis
                (Int
0, forall a. Vector a -> Int
Vector.length (Laras -> Vector NoteNumber
laras_umbang Laras
laras))
        forall err a. err -> Maybe a -> Either err a
justErr PitchError
err forall a b. (a -> b) -> a -> b
$ case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c_ombak ControlValMap
controls of
            Maybe FSemi
Nothing -> case Tuning
tuning of
                Tuning
Umbang -> Vector NoteNumber -> FSemi -> Maybe NoteNumber
get_nn (Laras -> Vector NoteNumber
laras_umbang Laras
laras) FSemi
fsemis
                Tuning
Isep -> Vector NoteNumber -> FSemi -> Maybe NoteNumber
get_nn (Laras -> Vector NoteNumber
laras_isep Laras
laras) FSemi
fsemis
            Just FSemi
ombak -> do
                NoteNumber
umbang <- Vector NoteNumber -> FSemi -> Maybe NoteNumber
get_nn (Laras -> Vector NoteNumber
laras_umbang Laras
laras) FSemi
fsemis
                NoteNumber
isep <- Vector NoteNumber -> FSemi -> Maybe NoteNumber
get_nn (Laras -> Vector NoteNumber
laras_isep Laras
laras) FSemi
fsemis
                let avg :: FSemi
avg = (NoteNumber -> FSemi
Pitch.nn_to_hz NoteNumber
umbang forall a. Num a => a -> a -> a
+ NoteNumber -> FSemi
Pitch.nn_to_hz NoteNumber
isep) forall a. Fractional a => a -> a -> a
/ FSemi
2
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FSemi -> NoteNumber
Pitch.hz_to_nn forall a b. (a -> b) -> a -> b
$ case Tuning
tuning of
                    Tuning
Umbang -> FSemi
avg forall a. Num a => a -> a -> a
- FSemi
ombak forall a. Fractional a => a -> a -> a
/ FSemi
2
                    Tuning
Isep -> FSemi
avg forall a. Num a => a -> a -> a
+ FSemi
ombak forall a. Fractional a => a -> a -> a
/ FSemi
2

-- | VStr: Select saih tuning.
laras_key :: EnvKey.Key
laras_key :: Key
laras_key = Key
"laras"

get_nn :: Vector.Vector Pitch.NoteNumber -> Pitch.FSemi
    -> Maybe Pitch.NoteNumber
get_nn :: Vector NoteNumber -> FSemi -> Maybe NoteNumber
get_nn Vector NoteNumber
nns FSemi
fsemis
    | FSemi
frac forall a. Eq a => a -> a -> Bool
== FSemi
0 = Vector NoteNumber
nns forall a. Vector a -> Int -> Maybe a
!? Int
semis
    | Bool
otherwise = do
        NoteNumber
low <- Vector NoteNumber
nns forall a. Vector a -> Int -> Maybe a
!? Int
semis
        NoteNumber
high <- Vector NoteNumber
nns forall a. Vector a -> Int -> Maybe a
!? (Int
semis forall a. Num a => a -> a -> a
+ Int
1)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
low NoteNumber
high (forall a. Real a => a -> NoteNumber
Pitch.nn FSemi
frac)
    where (Int
semis, FSemi
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction FSemi
fsemis