module Derive.Scale.TheoryFormat where
import qualified Data.Attoparsec.Text as A
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import Data.Vector ((!))
import qualified Data.Vector.Unboxed as Unboxed
import qualified Util.Num as Num
import qualified Util.ParseText as ParseText
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Scale.Theory as Theory
import qualified Perform.Pitch as Pitch
import Global
data Config = Config {
Config -> ShowOctave
config_show_octave :: ShowOctave
, Config -> ParseOctave
config_parse_octave :: ParseOctave
, Config -> AccidentalFormat
config_accidental :: AccidentalFormat
}
default_config :: Config
default_config :: Config
default_config = Config
{ config_show_octave :: ShowOctave
config_show_octave = ShowOctave
show_octave
, config_parse_octave :: ParseOctave
config_parse_octave = ParseOctave
parse_octave
, config_accidental :: AccidentalFormat
config_accidental = AccidentalFormat
ascii_accidentals
}
set_octave :: ShowOctave -> ParseOctave -> Config -> Config
set_octave :: ShowOctave -> ParseOctave -> Config -> Config
set_octave ShowOctave
show_octave ParseOctave
parse_octave Config
config = Config
config
{ config_show_octave :: ShowOctave
config_show_octave = ShowOctave
show_octave
, config_parse_octave :: ParseOctave
config_parse_octave = ParseOctave
parse_octave
}
type ShowOctave = Pitch.Octave -> Text -> Text
type ParseOctave = A.Parser (Pitch.PitchClass, Maybe Pitch.Accidentals)
-> A.Parser RelativePitch
data KeyConfig key = KeyConfig {
forall key. KeyConfig key -> ParseKey key
key_parse :: ParseKey key
, forall key. KeyConfig key -> key
key_default :: key
}
type ParseKey key = Maybe Pitch.Key -> Either DeriveT.PitchError key
data RelativePitch =
RelativePitch !Pitch.Octave !Pitch.PitchClass !(Maybe Pitch.Accidentals)
deriving (Accidentals -> RelativePitch -> ShowS
[RelativePitch] -> ShowS
RelativePitch -> String
(Accidentals -> RelativePitch -> ShowS)
-> (RelativePitch -> String)
-> ([RelativePitch] -> ShowS)
-> Show RelativePitch
forall a.
(Accidentals -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelativePitch] -> ShowS
$cshowList :: [RelativePitch] -> ShowS
show :: RelativePitch -> String
$cshow :: RelativePitch -> String
showsPrec :: Accidentals -> RelativePitch -> ShowS
$cshowsPrec :: Accidentals -> RelativePitch -> ShowS
Show)
instance Pretty RelativePitch where
pretty :: RelativePitch -> Text
pretty (RelativePitch Accidentals
oct Accidentals
pc Maybe Accidentals
accs) = Text
"relative:"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
oct Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
pc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Accidentals -> Text
forall a. Pretty a => a -> Text
pretty Maybe Accidentals
accs
relative_to_absolute :: RelativePitch -> Pitch.Pitch
relative_to_absolute :: RelativePitch -> Pitch
relative_to_absolute (RelativePitch Accidentals
oct Accidentals
pc Maybe Accidentals
acc) =
Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
oct (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc (Accidentals -> Maybe Accidentals -> Accidentals
forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 Maybe Accidentals
acc))
letters :: Pitch.PitchClass -> Format
letters :: Accidentals -> Format
letters Accidentals
pc_per_octave =
Text -> Degrees -> Format
make_absolute_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
where degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees ([Text] -> Degrees) -> [Text] -> Degrees
forall a b. (a -> b) -> a -> b
$ Accidentals -> [Text] -> [Text]
forall a. Accidentals -> [a] -> [a]
take Accidentals
pc_per_octave [Text]
letter_degrees
letter_degrees :: [Text]
letter_degrees :: [Text]
letter_degrees = (Char -> Text) -> String -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
Text.singleton [Char
'a'..Char
'z']
absolute_c :: Format
absolute_c :: Format
absolute_c = Text -> Degrees -> Format
make_absolute_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
where degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees [Text]
absolute_c_degrees
absolute_c_degrees :: [Text]
absolute_c_degrees :: [Text]
absolute_c_degrees = [Text
"c", Text
"d", Text
"e", Text
"f", Text
"g", Text
"a", Text
"b"]
data RelativeFormat key = RelativeFormat {
forall key. RelativeFormat key -> Config
rel_config :: Config
, forall key. RelativeFormat key -> KeyConfig key
rel_key_config :: KeyConfig key
, forall key. RelativeFormat key -> ShowDegree key
rel_show_degree :: ShowDegree key
, forall key. RelativeFormat key -> ToAbsolute key
rel_to_absolute :: ToAbsolute key
}
type ToAbsolute key = key -> Degrees -> RelativePitch -> Pitch.Pitch
type ShowDegree key = key -> ShowOctave -> Degrees -> AccidentalFormat
-> Either Pitch.Degree Pitch.Pitch -> Pitch.Note
sargam :: RelativeFormat key -> Format
sargam :: forall key. RelativeFormat key -> Format
sargam = Text -> Degrees -> RelativeFormat key -> Format
forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
where degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees [Text
"s", Text
"r", Text
"g", Text
"m", Text
"p", Text
"d", Text
"n"]
cipher :: Pitch.PitchClass -> RelativeFormat key -> Format
cipher :: forall key. Accidentals -> RelativeFormat key -> Format
cipher Accidentals
pc_per_octave = Text -> Degrees -> RelativeFormat key -> Format
forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format Text
pattern Degrees
degrees
where
degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees [Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
pc | Accidentals
pc <- [Accidentals
1..Accidentals
pc_per_octave]]
pattern :: Text
pattern = Text
"-[1-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
pc_per_octave Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
zh_cipher :: Pitch.PitchClass -> RelativeFormat key -> Format
zh_cipher :: forall key. Accidentals -> RelativeFormat key -> Format
zh_cipher Accidentals
pc_per_octave =
Text -> Degrees -> RelativeFormat key -> Format
forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
where
degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees ([Text] -> Degrees) -> [Text] -> Degrees
forall a b. (a -> b) -> a -> b
$ Accidentals -> [Text] -> [Text]
forall a. Accidentals -> [a] -> [a]
take Accidentals
pc_per_octave [Text]
ds
ds :: [Text]
ds = [Text
"一", Text
"二", Text
"三", Text
"四", Text
"五", Text
"六", Text
"七", Text
"八", Text
"九", Text
"十"]
gongche :: RelativeFormat key -> Format
gongche :: forall key. RelativeFormat key -> Format
gongche = Text -> Degrees -> RelativeFormat key -> Format
forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format (Degrees -> Text
make_pattern Degrees
degrees) Degrees
degrees
where degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees [Text
"士", Text
"下", Text
"ㄨ", Text
"工", Text
"六"]
make_pattern :: Degrees -> Text
make_pattern :: Degrees -> Text
make_pattern Degrees
degrees = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Degrees -> [Text]
forall a. Vector a -> [a]
Vector.toList Degrees
degrees) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
data Format = Format {
Format -> ShowPitch
fmt_show :: ShowPitch
, Format -> Parser RelativePitch
fmt_read :: A.Parser RelativePitch
, Format -> Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute :: Maybe Pitch.Key -> RelativePitch
-> Either DeriveT.PitchError Pitch.Pitch
, Format -> Text
fmt_pattern :: !Text
, Format -> Accidentals
fmt_pc_per_octave :: Pitch.PitchClass
, Format -> Bool
fmt_relative :: !Bool
}
type ShowPitch = Maybe Pitch.Key -> Either Pitch.Degree Pitch.Pitch
-> Pitch.Note
type Degrees = Vector.Vector Text
make_degrees :: [Text] -> Degrees
make_degrees :: [Text] -> Degrees
make_degrees = [Text] -> Degrees
forall a. [a] -> Vector a
Vector.fromList
show_key :: Format -> Theory.Key -> Pitch.Key
show_key :: Format -> Key -> Key
show_key Format
fmt Key
key =
Text -> Key
Pitch.Key (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ Text
tonic Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Text -> Bool
Text.null Text
name then Text
"" else Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
where
tonic :: Text
tonic = Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt Maybe Key
forall a. Maybe a
Nothing (Key -> Degree
Theory.key_tonic Key
key)
name :: Text
name = Key -> Text
Theory.key_name Key
key
show_key_signature :: Format -> Theory.Key -> Text
show_key_signature :: Format -> Key -> Text
show_key_signature Format
fmt Key
key =
Key -> Text
Pitch.key_text (Format -> Key -> Key
show_key Format
fmt Key
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
intervals
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
commas (Format -> Key -> [Text]
show_signature Format
fmt Key
key)
where
intervals :: Text
intervals = [Text] -> Text
commas ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Accidentals -> Text) -> [Accidentals] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Accidentals -> Text
forall a. Show a => a -> Text
showt ([Accidentals] -> [Text]) -> [Accidentals] -> [Text]
forall a b. (a -> b) -> a -> b
$ Vector Accidentals -> [Accidentals]
forall a. Unbox a => Vector a -> [a]
Unboxed.toList (Vector Accidentals -> [Accidentals])
-> Vector Accidentals -> [Accidentals]
forall a b. (a -> b) -> a -> b
$ Key -> Vector Accidentals
Theory.key_intervals Key
key
commas :: [Text] -> Text
commas = Text -> [Text] -> Text
Text.intercalate Text
", "
show_signature :: Format -> Theory.Key -> [Text]
show_signature :: Format -> Key -> [Text]
show_signature Format
fmt Key
key =
(Pitch -> Text) -> [Pitch] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt Maybe Key
forall a. Maybe a
Nothing (Degree -> Text) -> (Pitch -> Degree) -> Pitch -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Degree
Pitch.pitch_degree) [Pitch]
pitches
where
pc_per_octave :: Accidentals
pc_per_octave = Vector Accidentals -> Accidentals
forall a. Unbox a => Vector a -> Accidentals
Unboxed.length (Key -> Vector Accidentals
Theory.key_intervals Key
key)
pitches :: [Pitch]
pitches = (Accidentals -> Pitch) -> [Accidentals] -> [Pitch]
forall a b. (a -> b) -> [a] -> [b]
map Accidentals -> Pitch
transpose [Accidentals
0 .. Accidentals
pc_per_octave Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
- Accidentals
1]
transpose :: Accidentals -> Pitch
transpose Accidentals
pc = Key -> Accidentals -> Pitch -> Pitch
Theory.transpose_diatonic Key
key Accidentals
pc
(Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
0 (Key -> Degree
Theory.key_tonic Key
key))
key_degrees :: Theory.Key -> Format -> [Text]
key_degrees :: Key -> Format -> [Text]
key_degrees Key
key Format
fmt = (Pitch -> Text) -> [Pitch] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt Maybe Key
forall a. Maybe a
Nothing (Degree -> Text) -> (Pitch -> Degree) -> Pitch -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Degree
Pitch.pitch_degree) [Pitch]
pitches
where
per_octave :: Accidentals
per_octave = Layout -> Accidentals
Theory.layout_semis_per_octave (Key -> Layout
Theory.key_layout Key
key)
pitches :: [Pitch]
pitches = (Accidentals -> Pitch) -> [Accidentals] -> [Pitch]
forall a b. (a -> b) -> [a] -> [b]
map Accidentals -> Pitch
transpose [Accidentals
0 .. Accidentals
per_octave Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
- Accidentals
1]
transpose :: Accidentals -> Pitch
transpose Accidentals
steps = Key -> Accidentals -> Pitch -> Pitch
Theory.transpose_chromatic Key
key Accidentals
steps
(Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
0 (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
0 Accidentals
0))
show_pitch :: Format -> Maybe Pitch.Key -> Pitch.Pitch -> Pitch.Note
show_pitch :: Format -> Maybe Key -> Pitch -> Note
show_pitch Format
fmt Maybe Key
key = Format -> ShowPitch
fmt_show Format
fmt Maybe Key
key (Either Degree Pitch -> Note)
-> (Pitch -> Either Degree Pitch) -> Pitch -> Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Either Degree Pitch
forall a b. b -> Either a b
Right
scale_show_pitch :: Format -> Maybe Pitch.Key -> Pitch.Pitch
-> Either DeriveT.PitchError Pitch.Note
scale_show_pitch :: Format -> Maybe Key -> Pitch -> Either PitchError Note
scale_show_pitch Format
fmt Maybe Key
key = Note -> Either PitchError Note
forall a b. b -> Either a b
Right (Note -> Either PitchError Note)
-> (Pitch -> Note) -> Pitch -> Either PitchError Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> Maybe Key -> Pitch -> Note
show_pitch Format
fmt Maybe Key
key
show_degree :: Format -> Maybe Pitch.Key -> Pitch.Degree -> Text
show_degree :: Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt Maybe Key
key = Note -> Text
Pitch.note_text (Note -> Text) -> (Degree -> Note) -> Degree -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> ShowPitch
fmt_show Format
fmt Maybe Key
key (Either Degree Pitch -> Note)
-> (Degree -> Either Degree Pitch) -> Degree -> Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Degree -> Either Degree Pitch
forall a b. a -> Either a b
Left
read_pitch :: Format -> Maybe Pitch.Key -> Pitch.Note
-> Either DeriveT.PitchError Pitch.Pitch
read_pitch :: Format -> Maybe Key -> Note -> Either PitchError Pitch
read_pitch Format
fmt Maybe Key
key = Format -> Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute Format
fmt Maybe Key
key (RelativePitch -> Either PitchError Pitch)
-> (Note -> Either PitchError RelativePitch)
-> Note
-> Either PitchError Pitch
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Format -> Note -> Either PitchError RelativePitch
read_relative_pitch Format
fmt
read_relative_pitch :: Format -> Pitch.Note
-> Either DeriveT.PitchError RelativePitch
read_relative_pitch :: Format -> Note -> Either PitchError RelativePitch
read_relative_pitch Format
fmt Note
note = PitchError
-> Maybe RelativePitch -> Either PitchError RelativePitch
forall err a. err -> Maybe a -> Either err a
justErr (Note -> PitchError
DeriveT.UnparseableNote Note
note) (Maybe RelativePitch -> Either PitchError RelativePitch)
-> Maybe RelativePitch -> Either PitchError RelativePitch
forall a b. (a -> b) -> a -> b
$
Parser RelativePitch -> Text -> Maybe RelativePitch
forall a. Parser a -> Text -> Maybe a
ParseText.maybe_parse (Format -> Parser RelativePitch
fmt_read Format
fmt) (Text -> Maybe RelativePitch) -> Text -> Maybe RelativePitch
forall a b. (a -> b) -> a -> b
$
Note -> Text
Pitch.note_text Note
note
make_absolute_format :: Text -> Degrees -> Format
make_absolute_format :: Text -> Degrees -> Format
make_absolute_format = Config -> Text -> Degrees -> Format
make_absolute_format_config Config
default_config
make_absolute_format_keyed :: Config -> KeyConfig Theory.Key
-> Text -> Degrees -> Format
make_absolute_format_keyed :: Config -> KeyConfig Key -> Text -> Degrees -> Format
make_absolute_format_keyed Config
config KeyConfig Key
key_config Text
pattern Degrees
degrees =
(Config -> Text -> Degrees -> Format
make_absolute_format_config Config
config Text
pattern Degrees
degrees)
{ fmt_show :: ShowPitch
fmt_show = Config -> KeyConfig Key -> Degrees -> ShowPitch
show_pitch_keyed_absolute Config
config KeyConfig Key
key_config Degrees
degrees
, fmt_read :: Parser RelativePitch
fmt_read = Config -> Degrees -> Parser RelativePitch
p_pitch Config
config Degrees
degrees
, fmt_to_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute = \Maybe Key
maybe_key RelativePitch
pitch -> do
Key
key <- KeyConfig Key -> ParseKey Key
forall key. KeyConfig key -> ParseKey key
key_parse KeyConfig Key
key_config Maybe Key
maybe_key
Pitch -> Either PitchError Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch -> Either PitchError Pitch)
-> Pitch -> Either PitchError Pitch
forall a b. (a -> b) -> a -> b
$ Key -> RelativePitch -> Pitch
to_abs Key
key RelativePitch
pitch
}
where
to_abs :: Key -> RelativePitch -> Pitch
to_abs Key
key (RelativePitch Accidentals
octave Accidentals
pc Maybe Accidentals
maybe_acc) = case Maybe Accidentals
maybe_acc of
Maybe Accidentals
Nothing -> Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
octave
(Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc (Key -> Accidentals -> Accidentals
Theory.accidentals_at_pc Key
key Accidentals
pc))
Just Accidentals
acc -> Accidentals -> Degree -> Pitch
Pitch.Pitch Accidentals
octave (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc Accidentals
acc)
make_absolute_format_config :: Config -> Text -> Degrees -> Format
make_absolute_format_config :: Config -> Text -> Degrees -> Format
make_absolute_format_config Config
config Text
pattern Degrees
degrees = Format
{ fmt_show :: ShowPitch
fmt_show = Config -> Degrees -> ShowPitch
show_pitch_absolute Config
config Degrees
degrees
, fmt_read :: Parser RelativePitch
fmt_read = Config -> Degrees -> Parser RelativePitch
p_pitch Config
config Degrees
degrees
, fmt_to_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute = \Maybe Key
_ -> Pitch -> Either PitchError Pitch
forall a b. b -> Either a b
Right (Pitch -> Either PitchError Pitch)
-> (RelativePitch -> Pitch)
-> RelativePitch
-> Either PitchError Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativePitch -> Pitch
relative_to_absolute
, fmt_pattern :: Text
fmt_pattern = Text
octave_pattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_pattern
, fmt_pc_per_octave :: Accidentals
fmt_pc_per_octave = Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
, fmt_relative :: Bool
fmt_relative = Bool
False
}
make_relative_format :: Text -> Degrees -> RelativeFormat key -> Format
make_relative_format :: forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format Text
pattern Degrees
degrees RelativeFormat key
rel_fmt = Format
{ fmt_show :: ShowPitch
fmt_show = ShowPitch
p_show
, fmt_read :: Parser RelativePitch
fmt_read = Parser RelativePitch
p_read
, fmt_to_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute = Maybe Key -> RelativePitch -> Either PitchError Pitch
p_absolute
, fmt_pattern :: Text
fmt_pattern = Text
octave_pattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pattern Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_pattern
, fmt_pc_per_octave :: Accidentals
fmt_pc_per_octave = Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
, fmt_relative :: Bool
fmt_relative = Bool
True
}
where
RelativeFormat Config
config KeyConfig key
key_config ShowDegree key
show_degree ToAbsolute key
to_abs = RelativeFormat key
rel_fmt
p_show :: ShowPitch
p_show Maybe Key
key = ShowDegree key
show_degree
((PitchError -> key) -> (key -> key) -> Either PitchError key -> key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (key -> PitchError -> key
forall a b. a -> b -> a
const (KeyConfig key -> key
forall key. KeyConfig key -> key
key_default KeyConfig key
key_config)) key -> key
forall a. a -> a
id (KeyConfig key -> ParseKey key
forall key. KeyConfig key -> ParseKey key
key_parse KeyConfig key
key_config Maybe Key
key))
(Config -> ShowOctave
config_show_octave Config
config) Degrees
degrees (Config -> AccidentalFormat
config_accidental Config
config)
p_read :: Parser RelativePitch
p_read = Config -> Degrees -> Parser RelativePitch
p_pitch Config
config Degrees
degrees
p_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
p_absolute Maybe Key
maybe_key RelativePitch
pitch = do
key
key <- KeyConfig key -> ParseKey key
forall key. KeyConfig key -> ParseKey key
key_parse KeyConfig key
key_config Maybe Key
maybe_key
Pitch -> Either PitchError Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch -> Either PitchError Pitch)
-> Pitch -> Either PitchError Pitch
forall a b. (a -> b) -> a -> b
$ ToAbsolute key
to_abs key
key Degrees
degrees RelativePitch
pitch
acc_pattern :: Text
acc_pattern :: Text
acc_pattern = Text
"(bb|b|n|#|x)?"
octave_pattern :: Text
octave_pattern :: Text
octave_pattern = Text
"[-1-9]"
show_pitch_absolute :: Config -> Degrees -> ShowPitch
show_pitch_absolute :: Config -> Degrees -> ShowPitch
show_pitch_absolute Config
config Degrees
degrees Maybe Key
_key Either Degree Pitch
pitch =
Text -> Note
Pitch.Note (Text -> Note) -> Text -> Note
forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
pitch of
Left (Pitch.Degree Accidentals
pc Accidentals
acc) ->
Degrees
degrees Degrees -> Accidentals -> Text
forall a. Vector a -> Accidentals -> a
! (Accidentals
pc Accidentals -> Accidentals -> Accidentals
forall a. Integral a => a -> a -> a
`mod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AccidentalFormat -> Accidentals -> Text
show_accidentals (Config -> AccidentalFormat
config_accidental Config
config) Accidentals
acc
Right (Pitch.Pitch Accidentals
oct (Pitch.Degree Accidentals
pc_ Accidentals
acc)) ->
Config -> ShowOctave
config_show_octave Config
config (Accidentals
oct Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
Degrees
degrees Degrees -> Accidentals -> Text
forall a. Vector a -> Accidentals -> a
! Accidentals
pc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AccidentalFormat -> Accidentals -> Text
show_accidentals (Config -> AccidentalFormat
config_accidental Config
config) Accidentals
acc
where (Accidentals
pc_oct, Accidentals
pc) = Accidentals
pc_ Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
show_degree_chromatic :: ShowDegree Theory.Key
show_degree_chromatic :: ShowDegree Key
show_degree_chromatic Key
key ShowOctave
show_octave Degrees
degrees AccidentalFormat
acc_fmt Either Degree Pitch
degree_pitch =
Text -> Note
Pitch.Note (Text -> Note) -> Text -> Note
forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
degree_pitch of
Left Degree
_ -> Text
pc_text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text
Right (Pitch.Pitch Accidentals
oct Degree
_) ->
ShowOctave
show_octave (Accidentals
oct Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) (Text
pc_text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text)
where
Pitch.Degree Accidentals
pc Accidentals
acc = (Degree -> Degree)
-> (Pitch -> Degree) -> Either Degree Pitch -> Degree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Degree -> Degree
forall a. a -> a
id Pitch -> Degree
Pitch.pitch_degree Either Degree Pitch
degree_pitch
acc_text :: Text
acc_text = AccidentalFormat -> Accidentals -> Text
show_accidentals AccidentalFormat
acc_fmt (Accidentals -> Text) -> Accidentals -> Text
forall a b. (a -> b) -> a -> b
$ Accidentals
acc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
- Key -> Accidentals -> Accidentals
Theory.accidentals_at_pc Key
key Accidentals
pc
(Accidentals
pc_oct, Text
pc_text) =
Degrees -> Accidentals -> Accidentals -> (Accidentals, Text)
show_pc Degrees
degrees (Degree -> Accidentals
Pitch.degree_pc (Key -> Degree
Theory.key_tonic Key
key)) Accidentals
pc
chromatic_to_absolute :: ToAbsolute Theory.Key
chromatic_to_absolute :: ToAbsolute Key
chromatic_to_absolute Key
key Degrees
degrees (RelativePitch Accidentals
octave Accidentals
pc Maybe Accidentals
maybe_acc) =
Accidentals -> Degree -> Pitch
Pitch.Pitch (Accidentals
octave Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
oct) (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc2 Accidentals
acc2)
where
(Accidentals
oct, Accidentals
pc2) = (Accidentals
pc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Degree -> Accidentals
Pitch.degree_pc Degree
tonic) Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
acc2 :: Accidentals
acc2 = Accidentals -> Maybe Accidentals -> Accidentals
forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 Maybe Accidentals
maybe_acc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ case Key -> Maybe (Vector Accidentals)
Theory.key_signature Key
key of
Maybe (Vector Accidentals)
Nothing -> Degree -> Accidentals
Pitch.degree_accidentals Degree
tonic
Just Vector Accidentals
sig -> Accidentals -> Maybe Accidentals -> Accidentals
forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 (Vector Accidentals
sig Vector Accidentals -> Accidentals -> Maybe Accidentals
forall a. Unbox a => Vector a -> Accidentals -> Maybe a
Unboxed.!? Accidentals
pc)
tonic :: Degree
tonic = Key -> Degree
Theory.key_tonic Key
key
type Tonic = Pitch.PitchClass
show_degree_diatonic :: ShowDegree Tonic
show_degree_diatonic :: ShowDegree Accidentals
show_degree_diatonic Accidentals
tonic ShowOctave
show_octave Degrees
degrees AccidentalFormat
acc_fmt Either Degree Pitch
degree_pitch =
Text -> Note
Pitch.Note (Text -> Note) -> Text -> Note
forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
degree_pitch of
Left Degree
_ -> Text
pc_text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text
Right (Pitch.Pitch Accidentals
oct Degree
_) ->
ShowOctave
show_octave (Accidentals
oct Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) (Text
pc_text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text)
where
Pitch.Degree Accidentals
pc Accidentals
acc = (Degree -> Degree)
-> (Pitch -> Degree) -> Either Degree Pitch -> Degree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Degree -> Degree
forall a. a -> a
id Pitch -> Degree
Pitch.pitch_degree Either Degree Pitch
degree_pitch
acc_text :: Text
acc_text = AccidentalFormat -> Accidentals -> Text
show_accidentals AccidentalFormat
acc_fmt Accidentals
acc
(Accidentals
pc_oct, Text
pc_text) = Degrees -> Accidentals -> Accidentals -> (Accidentals, Text)
show_pc Degrees
degrees Accidentals
tonic Accidentals
pc
show_pc :: Degrees -> Tonic -> Pitch.PitchClass -> (Pitch.Octave, Text)
show_pc :: Degrees -> Accidentals -> Accidentals -> (Accidentals, Text)
show_pc Degrees
degrees Accidentals
tonic Accidentals
pc = (Accidentals
oct, Degrees
degrees Degrees -> Accidentals -> Text
forall a. Vector a -> Accidentals -> a
! Accidentals
degree)
where (Accidentals
oct, Accidentals
degree) = (Accidentals
pc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
- Accidentals
tonic) Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
diatonic_to_absolute :: ToAbsolute Tonic
diatonic_to_absolute :: ToAbsolute Accidentals
diatonic_to_absolute Accidentals
tonic Degrees
degrees (RelativePitch Accidentals
octave Accidentals
pc Maybe Accidentals
maybe_acc) =
Accidentals -> Degree -> Pitch
Pitch.Pitch (Accidentals
octave Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
oct) (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc2 (Accidentals -> Maybe Accidentals -> Accidentals
forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 Maybe Accidentals
maybe_acc))
where (Accidentals
oct, Accidentals
pc2) = (Accidentals
pc Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
tonic) Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
show_pitch_keyed_absolute :: Config -> KeyConfig Theory.Key -> Degrees
-> ShowPitch
show_pitch_keyed_absolute :: Config -> KeyConfig Key -> Degrees -> ShowPitch
show_pitch_keyed_absolute Config
config KeyConfig Key
key_config Degrees
degrees Maybe Key
maybe_key Either Degree Pitch
degree_pitch =
Text -> Note
Pitch.Note (Text -> Note) -> Text -> Note
forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
degree_pitch of
Left Degree
_ -> Text
pitch
Right (Pitch.Pitch Accidentals
oct Degree
_) -> ShowOctave
show_octave (Accidentals
oct Accidentals -> Accidentals -> Accidentals
forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) Text
pitch
where
Pitch.Degree Accidentals
pc_ Accidentals
acc = (Degree -> Degree)
-> (Pitch -> Degree) -> Either Degree Pitch -> Degree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Degree -> Degree
forall a. a -> a
id Pitch -> Degree
Pitch.pitch_degree Either Degree Pitch
degree_pitch
(Accidentals
pc_oct, Accidentals
pc) = Accidentals
pc_ Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Degrees -> Accidentals
forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
key :: Key
key = (PitchError -> Key) -> (Key -> Key) -> Either PitchError Key -> Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Key -> PitchError -> Key
forall a b. a -> b -> a
const (KeyConfig Key -> Key
forall key. KeyConfig key -> key
key_default KeyConfig Key
key_config)) Key -> Key
forall a. a -> a
id
(KeyConfig Key -> ParseKey Key
forall key. KeyConfig key -> ParseKey key
key_parse KeyConfig Key
key_config Maybe Key
maybe_key)
pitch :: Text
pitch = Degrees
degrees Degrees -> Accidentals -> Text
forall a. Vector a -> Accidentals -> a
! Accidentals
pc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc_text
acc_text :: Text
acc_text = AccidentalFormat -> Accidentals -> Accidentals -> Text
show_accidentals_keyed (Config -> AccidentalFormat
config_accidental Config
config)
(Key -> Accidentals -> Accidentals
Theory.accidentals_at_pc Key
key Accidentals
pc) Accidentals
acc
p_pitch :: Config -> Degrees -> A.Parser RelativePitch
p_pitch :: Config -> Degrees -> Parser RelativePitch
p_pitch Config
config Degrees
degrees =
Config -> ParseOctave
config_parse_octave Config
config
((,) (Accidentals
-> Maybe Accidentals -> (Accidentals, Maybe Accidentals))
-> Parser Text Accidentals
-> Parser
Text (Maybe Accidentals -> (Accidentals, Maybe Accidentals))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Accidentals
p_degree Parser Text (Maybe Accidentals -> (Accidentals, Maybe Accidentals))
-> Parser Text (Maybe Accidentals)
-> Parser Text (Accidentals, Maybe Accidentals)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AccidentalFormat -> Parser Text (Maybe Accidentals)
p_accidentals (Config -> AccidentalFormat
config_accidental Config
config))
where
p_degree :: Parser Text Accidentals
p_degree = [Parser Text Accidentals] -> Parser Text Accidentals
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
[ Text -> Parser Text
A.string Text
text Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return Accidentals
i
| (Accidentals
i, Text
text) <- [Accidentals] -> [Text] -> [(Accidentals, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Accidentals
0..] (Degrees -> [Text]
forall a. Vector a -> [a]
Vector.toList Degrees
degrees)
]
show_octave :: ShowOctave
show_octave :: ShowOctave
show_octave Accidentals
oct = (Accidentals -> Text
forall a. Show a => a -> Text
showt Accidentals
oct <>)
parse_octave :: ParseOctave
parse_octave :: ParseOctave
parse_octave Parser Text (Accidentals, Maybe Accidentals)
parse = do
Accidentals
oct <- Parser Text Accidentals
ParseText.p_int
(Accidentals
pc, Maybe Accidentals
acc) <- Parser Text (Accidentals, Maybe Accidentals)
parse
RelativePitch -> Parser RelativePitch
forall (m :: * -> *) a. Monad m => a -> m a
return (RelativePitch -> Parser RelativePitch)
-> RelativePitch -> Parser RelativePitch
forall a b. (a -> b) -> a -> b
$ Accidentals -> Accidentals -> Maybe Accidentals -> RelativePitch
RelativePitch Accidentals
oct Accidentals
pc Maybe Accidentals
acc
data AccidentalFormat = AccidentalFormat !Text !Text !Text !Text !Text
deriving (Accidentals -> AccidentalFormat -> ShowS
[AccidentalFormat] -> ShowS
AccidentalFormat -> String
(Accidentals -> AccidentalFormat -> ShowS)
-> (AccidentalFormat -> String)
-> ([AccidentalFormat] -> ShowS)
-> Show AccidentalFormat
forall a.
(Accidentals -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AccidentalFormat] -> ShowS
$cshowList :: [AccidentalFormat] -> ShowS
show :: AccidentalFormat -> String
$cshow :: AccidentalFormat -> String
showsPrec :: Accidentals -> AccidentalFormat -> ShowS
$cshowsPrec :: Accidentals -> AccidentalFormat -> ShowS
Show)
ascii_accidentals :: AccidentalFormat
ascii_accidentals :: AccidentalFormat
ascii_accidentals = Text -> Text -> Text -> Text -> Text -> AccidentalFormat
AccidentalFormat Text
"n" Text
"#" Text
"x" Text
"b" Text
"bb"
symbol_accidentals :: AccidentalFormat
symbol_accidentals :: AccidentalFormat
symbol_accidentals = Text -> Text -> Text -> Text -> Text -> AccidentalFormat
AccidentalFormat Text
"`n`" Text
"`#`" Text
"`##`" Text
"`b`" Text
"`bb`"
p_accidentals :: AccidentalFormat -> A.Parser (Maybe Pitch.Accidentals)
p_accidentals :: AccidentalFormat -> Parser Text (Maybe Accidentals)
p_accidentals (AccidentalFormat Text
natural Text
sharp1 Text
sharp2 Text
flat1 Text
flat2) =
Parser Text (Maybe Accidentals)
p_natural Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Accidentals -> Maybe Accidentals
forall a. a -> Maybe a
Just (Accidentals -> Maybe Accidentals)
-> ([Accidentals] -> Accidentals)
-> [Accidentals]
-> Maybe Accidentals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Accidentals] -> Accidentals
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum ([Accidentals] -> Maybe Accidentals)
-> Parser Text [Accidentals] -> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Accidentals -> Parser Text [Accidentals]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser Text Accidentals
p_acc Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Accidentals -> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Accidentals
forall a. Maybe a
Nothing
where
p_natural :: Parser Text (Maybe Accidentals)
p_natural = Text -> Parser Text
A.string Text
natural Parser Text
-> Parser Text (Maybe Accidentals)
-> Parser Text (Maybe Accidentals)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe Accidentals -> Parser Text (Maybe Accidentals)
forall (m :: * -> *) a. Monad m => a -> m a
return (Accidentals -> Maybe Accidentals
forall a. a -> Maybe a
Just Accidentals
0)
p_acc :: Parser Text Accidentals
p_acc = [Parser Text Accidentals] -> Parser Text Accidentals
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
[ Text -> Parser Text
A.string Text
sharp1 Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return Accidentals
1
, Text -> Parser Text
A.string Text
sharp2 Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return Accidentals
2
, Text -> Parser Text
A.string Text
flat1 Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return (-Accidentals
1)
, Text -> Parser Text
A.string Text
flat2 Parser Text -> Parser Text Accidentals -> Parser Text Accidentals
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Accidentals -> Parser Text Accidentals
forall (m :: * -> *) a. Monad m => a -> m a
return (-Accidentals
2)
]
show_accidentals_keyed :: AccidentalFormat -> Pitch.Accidentals
-> Pitch.Accidentals -> Text
show_accidentals_keyed :: AccidentalFormat -> Accidentals -> Accidentals -> Text
show_accidentals_keyed fmt :: AccidentalFormat
fmt@(AccidentalFormat Text
natural Text
_ Text
_ Text
_ Text
_) Accidentals
key_accs Accidentals
accs
| Accidentals
accs Accidentals -> Accidentals -> Bool
forall a. Eq a => a -> a -> Bool
== Accidentals
key_accs = Text
""
| Accidentals
accs Accidentals -> Accidentals -> Bool
forall a. Eq a => a -> a -> Bool
== Accidentals
0 Bool -> Bool -> Bool
&& Accidentals
key_accs Accidentals -> Accidentals -> Bool
forall a. Eq a => a -> a -> Bool
/= Accidentals
0 = Text
natural
| Bool
otherwise = AccidentalFormat -> Accidentals -> Text
show_accidentals AccidentalFormat
fmt Accidentals
accs
show_accidentals :: AccidentalFormat -> Pitch.Accidentals -> Text
show_accidentals :: AccidentalFormat -> Accidentals -> Text
show_accidentals (AccidentalFormat Text
_ Text
sharp1 Text
sharp2 Text
flat1 Text
flat2) Accidentals
acc
| Accidentals
acc Accidentals -> Accidentals -> Bool
forall a. Eq a => a -> a -> Bool
== Accidentals
0 = Text
""
| Accidentals
acc Accidentals -> Accidentals -> Bool
forall a. Ord a => a -> a -> Bool
< Accidentals
0 = ShowOctave
Text.replicate Accidentals
x Text
flat2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate Accidentals
s Text
flat1
| Bool
otherwise = ShowOctave
Text.replicate Accidentals
x Text
sharp2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate Accidentals
s Text
sharp1
where (Accidentals
x, Accidentals
s) = Accidentals -> Accidentals
forall a. Num a => a -> a
abs Accidentals
acc Accidentals -> Accidentals -> (Accidentals, Accidentals)
forall a. Integral a => a -> a -> (a, a)
`divMod` Accidentals
2