-- 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.Num as Num
import qualified Util.Seq as Seq
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 "
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Key -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc Key
EnvKey.tuning Doc -> Doc -> Doc
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 "
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Control -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc Control
c_ombak
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" control is present, they will be tuned that many hz apart.\
        \\nThe " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Key -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc Key
laras_key Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" env var chooses between\
        \ different tunings.  It defaults to "
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Key -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc (Laras -> Key
laras_name (ScaleMap -> Laras
smap_default_laras ScaleMap
smap))
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
". Laras:\n"
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
forall a. (Textlike a, Monoid a, IsString a) => [a] -> a
Texts.enumeration
            [ Key -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc Key
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" - " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Laras -> Doc
laras_doc Laras
laras
            | (Key
name, Laras
laras) <- Map Key Laras -> [(Key, Laras)]
forall k a. Map k a -> [(k, a)]
Map.toList (ScaleMap -> Map Key Laras
smap_laras ScaleMap
smap)
            ]

data ScaleMap = ScaleMap {
    ScaleMap -> ScaleMap
smap_chromatic :: !ChromaticScales.ScaleMap
    , ScaleMap -> Map Key Laras
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 Map Key Laras
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 -> Map Key Laras -> Laras -> SemisToNoteNumber
semis_to_nn Layout
layout Map Key Laras
laras Laras
default_laras
            -- Convert range to absolute.
            , smap_range :: (Int, Int)
ChromaticScales.smap_range = (Int -> Int) -> (Int -> Int) -> (Int, Int) -> (Int, Int)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
offset) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
offset) (Int, Int)
range
            }
        , smap_laras :: Map Key Laras
smap_laras = Map Key Laras
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 = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
0, Int
top) Maybe (Int, Int)
maybe_range
    top :: Int
top = Int -> (Laras -> Int) -> Maybe Laras -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> (Laras -> Int) -> Laras -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector NoteNumber -> Int
forall a. Vector a -> Int
Vector.length (Vector NoteNumber -> Int)
-> (Laras -> Vector NoteNumber) -> Laras -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Laras -> Vector NoteNumber
laras_umbang) (Maybe Laras -> Int) -> Maybe Laras -> Int
forall a b. (a -> b) -> a -> b
$
        [Laras] -> Maybe Laras
forall a. [a] -> Maybe a
Seq.head (Map Key Laras -> [Laras]
forall k a. Map k a -> [a]
Map.elems Map Key Laras
laras)

data Config = Config {
    Config -> Layout
config_layout :: !Theory.Layout
    , Config -> Keys
config_keys :: !ChromaticScales.Keys
    , Config -> Key
config_default_key :: !Theory.Key
    , Config -> Map Key Laras
config_laras :: !LarasMap
    , Config -> Laras
config_default_laras :: !Laras
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
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 ((Int, Int) -> Maybe (Int, Int)
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
(Instrument -> Instrument -> Bool)
-> (Instrument -> Instrument -> Bool) -> Eq Instrument
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
(Int -> Instrument -> ShowS)
-> (Instrument -> String)
-> ([Instrument] -> ShowS)
-> Show Instrument
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
(Laras -> Laras -> Bool) -> (Laras -> Laras -> Bool) -> Eq Laras
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
(Int -> Laras -> ShowS)
-> (Laras -> String) -> ([Laras] -> ShowS) -> Show Laras
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] -> Map Key Laras
laras_map = [(Key, Laras)] -> Map Key Laras
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Key, Laras)] -> Map Key Laras)
-> ([Laras] -> [(Key, Laras)]) -> [Laras] -> Map Key Laras
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Laras -> Key) -> [Laras] -> [(Key, Laras)]
forall a k. (a -> k) -> [a] -> [(k, a)]
Seq.key_on 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 = [NoteNumber] -> Vector NoteNumber
forall a. [a] -> Vector a
Vector.fromList ([NoteNumber] -> [NoteNumber]
extend [NoteNumber]
umbang)
    , laras_isep :: Vector NoteNumber
laras_isep = [NoteNumber] -> Vector NoteNumber
forall a. [a] -> Vector a
Vector.fromList ([NoteNumber] -> [NoteNumber]
extend [NoteNumber]
isep)
    }
    where ([NoteNumber]
umbang, [NoteNumber]
isep) = [(NoteNumber, NoteNumber)] -> ([NoteNumber], [NoteNumber])
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Pitch -> Int
Pitch.pitch_octave Pitch
base_pitch
        Int -> Int -> Int
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 =
    [NoteNumber] -> [NoteNumber] -> [(NoteNumber, NoteNumber)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Vector NoteNumber -> [NoteNumber]
forall a. Vector a -> [a]
Vector.toList (Laras -> Vector NoteNumber
laras_umbang Laras
laras)) (Vector NoteNumber -> [NoteNumber]
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 =
    Key -> Degrees -> RelativeFormat Key -> Format
forall key. Key -> Degrees -> RelativeFormat key -> Format
TheoryFormat.make_relative_format
        (Key
"[1-9]" Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Degrees -> Key
degrees_doc Degrees
degrees Key -> Key -> Key
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
'^', Char -> Maybe 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
    , Maybe Char
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
"[" Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> [Key] -> Key
forall a. Monoid a => [a] -> a
mconcat (Degrees -> [Key]
forall a. Vector a -> [a]
Vector.toList Degrees
degrees) Key -> Key -> Key
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 =
    Key -> Degrees -> RelativeFormat Key -> Format
forall key. Key -> Degrees -> RelativeFormat key -> Format
TheoryFormat.make_relative_format
        (Degrees -> Key
degrees_doc Degrees
degrees Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> (if Bool
chromatic then Key
"#?" else Key
"") Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"[_^-]")
        Degrees
degrees RelativeFormat Key
fmt
    where
    fmt :: RelativeFormat Key
fmt = (Config -> Config) -> RelativeFormat Key -> RelativeFormat Key
forall key.
(Config -> Config) -> RelativeFormat key -> RelativeFormat key
with_config (RelativeOctaves -> Int -> Config -> Config
set_relative_octaves RelativeOctaves
relative_octaves Int
center) (RelativeFormat Key -> RelativeFormat Key)
-> RelativeFormat Key -> RelativeFormat Key
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

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

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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
center = (Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate (Int
octInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
center) (Char -> Key
t Char
high))
        | Int
oct Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
center = (Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate (Int
centerInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
oct) (Char -> Key
t Char
low))
        | Bool
otherwise = (Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key -> (Char -> Key) -> Maybe Char -> Key
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 <- Parser Key Char -> Parser Key String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many' (Parser Key Char -> Parser Key String)
-> Parser Key Char -> Parser Key String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Key Char
A.satisfy ((Char -> Bool) -> Parser Key Char)
-> (Char -> Bool) -> Parser Key Char
forall a b. (a -> b) -> a -> b
$ \Char
c ->
            Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
high Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
low Bool -> Bool -> Bool
|| Bool -> (Char -> Bool) -> Maybe Char -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) Maybe Char
middle
        let oct_value :: Char -> a
oct_value Char
c
                | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
high = a
1
                | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
low = -a
1
                | Bool
otherwise = a
0
        let oct :: Int
oct = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
forall {a}. Num a => Char -> a
oct_value String
oct_str
        RelativePitch -> Parser Key RelativePitch
forall (m :: * -> *) a. Monad m => a -> m a
return (RelativePitch -> Parser Key RelativePitch)
-> RelativePitch -> Parser Key RelativePitch
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Maybe Int -> RelativePitch
TheoryFormat.RelativePitch (Int
center Int -> Int -> Int
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 =
    Key -> Degrees -> RelativeFormat Key -> Format
forall key. Key -> Degrees -> RelativeFormat key -> Format
TheoryFormat.make_relative_format Key
"[12356]|`[12356][.^]*`" Degrees
cipher5 RelativeFormat Key
fmt
    where
    fmt :: RelativeFormat Key
fmt = (Config -> Config) -> RelativeFormat Key -> RelativeFormat Key
forall key.
(Config -> Config) -> RelativeFormat key -> RelativeFormat key
with_config (Int -> Config -> Config
dotted_octaves Int
center) (RelativeFormat Key -> RelativeFormat Key)
-> RelativeFormat Key -> RelativeFormat Key
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
center = Key
d
        | Bool
otherwise = Key
"`" Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
d
            Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> (if Int
oct Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
center then ShowOctave
Text.replicate (Int
octInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
center) Key
"^"
                else ShowOctave
Text.replicate (Int
centerInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
oct) Key
".")
            Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"`"
    parse_octave :: ParseOctave
parse_octave Parser Key (Int, Maybe Int)
p_degree =
        (Int -> Maybe Int -> RelativePitch)
-> (Int, Maybe Int) -> RelativePitch
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> Int -> Maybe Int -> RelativePitch
TheoryFormat.RelativePitch Int
center) ((Int, Maybe Int) -> RelativePitch) -> ParseOctave
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Key (Int, Maybe Int)
p_degree
            Parser Key RelativePitch
-> Parser Key RelativePitch -> Parser Key RelativePitch
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 Key Char
A.char Char
'`'
        (Int
pc, Maybe Int
acc) <- Parser Key (Int, Maybe Int)
p_degree
        String
octs <- Parser Key Char -> Parser Key String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
A.many' (Parser Key Char -> Parser Key String)
-> Parser Key Char -> Parser Key String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Key Char
A.satisfy ((Char -> Bool) -> Parser Key Char)
-> (Char -> Bool) -> Parser Key Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'^'
        Char -> Parser Key Char
A.char Char
'`'
        let oct :: Int
oct = (Char -> Bool) -> String -> Int
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Int
Seq.count (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'^') String
octs Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Char -> Bool) -> String -> Int
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Int
Seq.count (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') String
octs
        RelativePitch -> Parser Key RelativePitch
forall (m :: * -> *) a. Monad m => a -> m a
return (RelativePitch -> Parser Key RelativePitch)
-> RelativePitch -> Parser Key RelativePitch
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Maybe Int -> RelativePitch
TheoryFormat.RelativePitch (Int
center Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
oct) Int
pc Maybe Int
acc

-- * tuning

data Tuning = Umbang | Isep deriving (Tuning -> Tuning -> Bool
(Tuning -> Tuning -> Bool)
-> (Tuning -> Tuning -> Bool) -> Eq Tuning
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
Eq Tuning
-> (Tuning -> Tuning -> Ordering)
-> (Tuning -> Tuning -> Bool)
-> (Tuning -> Tuning -> Bool)
-> (Tuning -> Tuning -> Bool)
-> (Tuning -> Tuning -> Bool)
-> (Tuning -> Tuning -> Tuning)
-> (Tuning -> Tuning -> Tuning)
-> Ord 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]
(Tuning -> Tuning)
-> (Tuning -> Tuning)
-> (Int -> Tuning)
-> (Tuning -> Int)
-> (Tuning -> [Tuning])
-> (Tuning -> Tuning -> [Tuning])
-> (Tuning -> Tuning -> [Tuning])
-> (Tuning -> Tuning -> Tuning -> [Tuning])
-> Enum 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
Tuning -> Tuning -> Bounded Tuning
forall a. a -> a -> Bounded a
maxBound :: Tuning
$cmaxBound :: Tuning
minBound :: Tuning
$cminBound :: Tuning
Bounded, Int -> Tuning -> ShowS
[Tuning] -> ShowS
Tuning -> String
(Int -> Tuning -> ShowS)
-> (Tuning -> String) -> ([Tuning] -> ShowS) -> Show Tuning
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 = Tuning -> Key
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 -> Map Key Laras -> Laras -> SemisToNoteNumber
semis_to_nn Layout
layout Map Key Laras
laras Laras
default_laras =
    \(PSignal.PitchConfig Environ
env ControlValMap
controls) FSemi
fsemis_ -> do
        Laras
laras <- (Key -> Maybe Laras)
-> Maybe Laras -> Key -> Environ -> Either PitchError Laras
forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Key -> Environ -> Either PitchError val
Scales.read_environ (\Key
v -> Key -> Map Key Laras -> Maybe Laras
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
v Map Key Laras
laras)
            (Laras -> Maybe Laras
forall a. a -> Maybe a
Just Laras
default_laras) Key
laras_key Environ
env
        let fsemis :: FSemi
fsemis = FSemi
fsemis_ FSemi -> FSemi -> FSemi
forall a. Num a => a -> a -> a
- Int -> FSemi
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 <- (Tuning -> Maybe Tuning)
-> Maybe Tuning -> Key -> Environ -> Either PitchError Tuning
forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Key -> Environ -> Either PitchError val
Scales.read_environ Tuning -> Maybe Tuning
forall a. a -> Maybe a
Just (Tuning -> Maybe Tuning
forall a. a -> Maybe a
Just Tuning
Umbang) Key
EnvKey.tuning Environ
env
        let err :: PitchError
err = FSemi -> (Int, Int) -> PitchError
forall a. Real a => a -> (Int, Int) -> PitchError
DeriveT.out_of_range_error FSemi
fsemis
                (Int
0, Vector NoteNumber -> Int
forall a. Vector a -> Int
Vector.length (Laras -> Vector NoteNumber
laras_umbang Laras
laras))
        PitchError -> Maybe NoteNumber -> Either PitchError NoteNumber
forall err a. err -> Maybe a -> Either err a
justErr PitchError
err (Maybe NoteNumber -> Either PitchError NoteNumber)
-> Maybe NoteNumber -> Either PitchError NoteNumber
forall a b. (a -> b) -> a -> b
$ case Control -> ControlValMap -> Maybe FSemi
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 FSemi -> FSemi -> FSemi
forall a. Num a => a -> a -> a
+ NoteNumber -> FSemi
Pitch.nn_to_hz NoteNumber
isep) FSemi -> FSemi -> FSemi
forall a. Fractional a => a -> a -> a
/ FSemi
2
                NoteNumber -> Maybe NoteNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Maybe NoteNumber) -> NoteNumber -> Maybe NoteNumber
forall a b. (a -> b) -> a -> b
$ FSemi -> NoteNumber
Pitch.hz_to_nn (FSemi -> NoteNumber) -> FSemi -> NoteNumber
forall a b. (a -> b) -> a -> b
$ case Tuning
tuning of
                    Tuning
Umbang -> FSemi
avg FSemi -> FSemi -> FSemi
forall a. Num a => a -> a -> a
- FSemi
ombak FSemi -> FSemi -> FSemi
forall a. Fractional a => a -> a -> a
/ FSemi
2
                    Tuning
Isep -> FSemi
avg FSemi -> FSemi -> FSemi
forall a. Num a => a -> a -> a
+ FSemi
ombak FSemi -> FSemi -> FSemi
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 FSemi -> FSemi -> Bool
forall a. Eq a => a -> a -> Bool
== FSemi
0 = Vector NoteNumber
nns Vector NoteNumber -> Int -> Maybe NoteNumber
forall a. Vector a -> Int -> Maybe a
!? Int
semis
    | Bool
otherwise = do
        NoteNumber
low <- Vector NoteNumber
nns Vector NoteNumber -> Int -> Maybe NoteNumber
forall a. Vector a -> Int -> Maybe a
!? Int
semis
        NoteNumber
high <- Vector NoteNumber
nns Vector NoteNumber -> Int -> Maybe NoteNumber
forall a. Vector a -> Int -> Maybe a
!? (Int
semis Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        NoteNumber -> Maybe NoteNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Maybe NoteNumber) -> NoteNumber -> Maybe NoteNumber
forall a b. (a -> b) -> a -> b
$ NoteNumber -> NoteNumber -> NoteNumber -> NoteNumber
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
low NoteNumber
high (FSemi -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn FSemi
frac)
    where (Int
semis, FSemi
frac) = FSemi -> (Int, FSemi)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction FSemi
fsemis