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

{- | This is the part of "Derive.Scale.Theory" that's concerned with converting
    'Pitch.Pitch'es to and from 'Pitch.Note's.

    It's split off to avoid cluttering Theory, but also because the
    "Derive.Scale" import would make it a circular dependency.

    This is basically just a bunch of functions that take a million arguments
    to configure octave format, accidental format, key parsing, etc.  To
    avoid annoyingly long argument lists, they are mostly packaged up into
    records, such as 'Config', 'KeyConfig', and 'RelativeFormat'.

    It's basically all just an attempt to parameterize scale creation, so I
    can reuse the shared parts but still be able to configure them.  It winds
    up being complicated, probably due to how it's evolved in reaction to
    increasingly varied scales, rather than according to an overarching design.
-}
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 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


-- * types

-- | General purpose config.
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
-- | This can't just be A.Parser Pitch.Octave because I don't know where the
-- octave is in the pitch text.
type ParseOctave = A.Parser (Pitch.PitchClass, Maybe Pitch.Accidentals)
    -> A.Parser RelativePitch

-- | Key config is only necessary for formatting that depends on the key, e.g.
-- 'RelativeFormat'.
data KeyConfig key = KeyConfig {
    forall key. KeyConfig key -> Maybe Key -> Either PitchError key
key_parse :: Maybe Pitch.Key -> Either DeriveT.PitchError key
    -- | Default key if there is none, or it's not parseable.  Otherwise, a bad
    -- or missing key would mean you couldn't even display notes.
    , forall key. KeyConfig key -> key
key_default :: key
    }

-- | This is a just-parsed pitch.  It hasn't yet been adjusted according to the
-- key, so it's not yet an absolute 'Pitch.Pitch'.  It also represents
-- a natural explicitly, via Just 0.
--
-- 'fmt_to_absolute' is responsible for converting this to a 'Pitch.Pitch',
-- likely via 'rel_to_absolute'.
data RelativePitch =
    RelativePitch !Pitch.Octave !Pitch.PitchClass !(Maybe Pitch.Accidentals)
    deriving (Accidentals -> RelativePitch -> ShowS
[RelativePitch] -> ShowS
RelativePitch -> String
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:"
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Accidentals
oct forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Accidentals
pc forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> 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 (forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 Maybe Accidentals
acc))

-- * absolute

-- | Make an absolute scale starting at @a@.
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 forall a b. (a -> b) -> a -> b
$ forall a. Accidentals -> [a] -> [a]
take Accidentals
pc_per_octave [Text]
letter_degrees

letter_degrees :: [Text]
letter_degrees :: [Text]
letter_degrees = forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
Text.singleton [Char
'a'..Char
'z']

-- | The usual 7 note scale, which wraps around at @c@ instead of @a@.
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"]

-- * relative

-- | Args for a relative scale format.
--
-- The 'Pitch.Pitch'es handled by a relative scale are still absolute, the same
-- as the Pitches of an absolute scale.  The difference is that the
-- 'read_pitch' and 'show_pitch' functions adjust based on the key to display
-- the absolute Pitch relative to the tonic of the key.
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
    }

-- | Given a RelativePitch relative to the default key, adjust it to
-- be absolute.  This is so I can figure out if a relative pitch is valid
-- without knowing the key, as described in 'fmt_to_absolute'.
type ToAbsolute key = key -> Degrees -> RelativePitch -> Pitch.Pitch

-- | This is a specialization of 'ShowPitch' for show functions that need
-- a key.
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 = 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 = forall key. Text -> Degrees -> RelativeFormat key -> Format
make_relative_format Text
pattern Degrees
degrees
    where
    degrees :: Degrees
degrees = [Text] -> Degrees
make_degrees [Text
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Accidentals
pc | Accidentals
pc <- [Accidentals
1..Accidentals
pc_per_octave]]
    pattern :: Text
pattern = Text
"-[1-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Accidentals
pc_per_octave 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 =
    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 forall a b. (a -> b) -> a -> b
$ 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 = 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
"[" 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
<> Text
"]"

-- * Format

-- | This is the central data structure for this module.  It has the set of
-- functions needed to parse and generate symbolic pitches.  Making one of
-- these gives you access to the set of functions in here, such as 'show_pitch'
-- and 'read_pitch', which in turn can be used to implement
-- a 'Derive.Scale.Scale'.
data Format = Format {
    Format -> ShowPitch
fmt_show :: ShowPitch
    -- | This doesn't need the key because that work is split off to
    -- 'fmt_to_absolute'.
    , Format -> Parser RelativePitch
fmt_read :: A.Parser RelativePitch
    -- | I need the key to parse the pitch, but that can't happen unless I want
    -- to give all pattern_lookup calls access to the env in scope.  But
    -- I don't need the env to recognize if it's a valid call or not.
    , Format -> Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute :: Maybe Pitch.Key -> RelativePitch
        -> Either DeriveT.PitchError Pitch.Pitch
    -- | Goes in 'Scale.scale_pattern'.
    , Format -> Text
fmt_pattern :: !Text
    -- TODO why do I need this?  can I have keys with different octaves?
    -- It's used only by JustScales
    , Format -> Accidentals
fmt_pc_per_octave :: Pitch.PitchClass
    -- | True if this scale is relative to the key.  Only used by
    -- ChromaticScales.  TODO split it out?
    , Format -> Bool
fmt_relative :: !Bool
    }

-- | This is used to show both a Pitch with an octave, and a Degree without
-- one (used for key names).  This is because the code is presumably mostly the
-- same.
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 = forall a. [a] -> Vector a
Vector.fromList

-- ** show keys

show_key :: Format -> Theory.Key -> Pitch.Key
show_key :: Format -> Key -> Key
show_key Format
fmt Key
key =
    Text -> Key
Pitch.Key forall a b. (a -> b) -> a -> b
$ Text
tonic forall a. Semigroup a => a -> a -> a
<> (if Text -> Bool
Text.null Text
name then Text
"" else Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
name)
    where
    tonic :: Text
tonic = Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt forall a. Maybe a
Nothing (Key -> Degree
Theory.key_tonic Key
key)
    name :: Text
name = Key -> Text
Theory.key_name Key
key

-- | Show a key along with its key signature.
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) forall a. Semigroup a => a -> a -> a
<> Text
" -- " forall a. Semigroup a => a -> a -> a
<> Text
intervals
        forall a. Semigroup a => a -> a -> a
<> Text
"\n    " 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
showt forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
Vector.toList forall a b. (a -> b) -> a -> b
$ Key -> Intervals
Theory.key_intervals Key
key
    commas :: [Text] -> Text
commas = Text -> [Text] -> Text
Text.intercalate Text
", "

-- | Show the signature of the given key by showing each scale degree with the
-- the accidentals implied by the key signature.
show_signature :: Format -> Theory.Key -> [Text]
show_signature :: Format -> Key -> [Text]
show_signature Format
fmt Key
key =
    forall a b. (a -> b) -> [a] -> [b]
map (Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt forall a. Maybe a
Nothing 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 = forall a. Vector a -> Accidentals
Vector.length (Key -> Intervals
Theory.key_intervals Key
key)
    pitches :: [Pitch]
pitches = forall a b. (a -> b) -> [a] -> [b]
map Accidentals -> Pitch
transpose [Accidentals
0 .. Accidentals
pc_per_octave 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))

-- | Get the degree names of a chromatic scale in this key.
key_degrees :: Theory.Key -> Format -> [Text]
key_degrees :: Key -> Format -> [Text]
key_degrees Key
key Format
fmt = forall a b. (a -> b) -> [a] -> [b]
map (Format -> Maybe Key -> Degree -> Text
show_degree Format
fmt forall a. Maybe a
Nothing 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 = forall a b. (a -> b) -> [a] -> [b]
map Accidentals -> Pitch
transpose [Accidentals
0 .. Accidentals
per_octave 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 pitches

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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right

-- | 'show_pitch' adapted to 'Scale.scale_show'.
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 = forall a b. b -> Either a b
Right 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> ShowPitch
fmt_show Format
fmt Maybe Key
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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

-- | Parse a Note, but don't adjust it for the key.  This means that relative
-- pitches will likely be incorrect.  'ToAbsolute' documents why this needs
-- to be separate.
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 = forall err a. err -> Maybe a -> Either err a
justErr (Note -> PitchError
DeriveT.UnparseableNote Note
note) forall a b. (a -> b) -> a -> b
$
    -- Debug.trace_ret "read_rel" note $
    forall a. Parser a -> Text -> Maybe a
ParseText.maybe_parse (Format -> Parser RelativePitch
fmt_read Format
fmt) forall a b. (a -> b) -> a -> b
$
    Note -> Text
Pitch.note_text Note
note

-- ** make

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 <- forall key. KeyConfig key -> Maybe Key -> Either PitchError key
key_parse KeyConfig Key
key_config Maybe Key
maybe_key
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Key -> RelativePitch -> Pitch
to_abs Key
key RelativePitch
pitch
    }
    where
    -- A note with no explicit accidentals gets the accidentals of the key
    -- signature.
    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)

-- | A configurable version of 'make_absolute_format'.
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
_ -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativePitch -> Pitch
relative_to_absolute
    , fmt_pattern :: Text
fmt_pattern = Text
octave_pattern forall a. Semigroup a => a -> a -> a
<> Text
pattern forall a. Semigroup a => a -> a -> a
<> Text
acc_pattern
    , fmt_pc_per_octave :: Accidentals
fmt_pc_per_octave = forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
    , fmt_relative :: Bool
fmt_relative = Bool
False
    }

-- | Make a Format from a 'RelativeFormat'.
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
    { ShowPitch
fmt_show :: ShowPitch
fmt_show :: ShowPitch
fmt_show
    , fmt_read :: Parser RelativePitch
fmt_read = Config -> Degrees -> Parser RelativePitch
p_pitch Config
rel_config Degrees
degrees
    , Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute
    , fmt_pattern :: Text
fmt_pattern = Text
octave_pattern forall a. Semigroup a => a -> a -> a
<> Text
pattern forall a. Semigroup a => a -> a -> a
<> Text
acc_pattern
    , fmt_pc_per_octave :: Accidentals
fmt_pc_per_octave = forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
    , fmt_relative :: Bool
fmt_relative = Bool
True
    }
    where
    RelativeFormat
        { Config
rel_config :: Config
rel_config :: forall key. RelativeFormat key -> Config
rel_config, KeyConfig key
rel_key_config :: KeyConfig key
rel_key_config :: forall key. RelativeFormat key -> KeyConfig key
rel_key_config, ShowDegree key
rel_show_degree :: ShowDegree key
rel_show_degree :: forall key. RelativeFormat key -> ShowDegree key
rel_show_degree, ToAbsolute key
rel_to_absolute :: ToAbsolute key
rel_to_absolute :: forall key. RelativeFormat key -> ToAbsolute key
rel_to_absolute
        } = RelativeFormat key
rel_fmt
    fmt_show :: ShowPitch
fmt_show Maybe Key
key = ShowDegree key
rel_show_degree
        (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (forall key. KeyConfig key -> key
key_default KeyConfig key
rel_key_config)) forall a. a -> a
id
            (forall key. KeyConfig key -> Maybe Key -> Either PitchError key
key_parse KeyConfig key
rel_key_config Maybe Key
key))
        (Config -> ShowOctave
config_show_octave Config
rel_config) Degrees
degrees (Config -> AccidentalFormat
config_accidental Config
rel_config)
    fmt_to_absolute :: Maybe Key -> RelativePitch -> Either PitchError Pitch
fmt_to_absolute Maybe Key
maybe_key RelativePitch
pitch = do
        key
key <- forall key. KeyConfig key -> Maybe Key -> Either PitchError key
key_parse KeyConfig key
rel_key_config Maybe Key
maybe_key
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ToAbsolute key
rel_to_absolute 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]"

-- *** absolute

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 forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
pitch of
        Left (Pitch.Degree Accidentals
pc Accidentals
acc) ->
            Text
degree forall a. Semigroup a => a -> a -> a
<> AccidentalFormat -> Accidentals -> Text
show_accidentals (Config -> AccidentalFormat
config_accidental Config
config) Accidentals
acc
            where (Accidentals
_, Text
degree) = Degrees -> Accidentals -> (Accidentals, Text)
degree_at Degrees
degrees Accidentals
pc
        Right (Pitch.Pitch Accidentals
oct (Pitch.Degree Accidentals
pc Accidentals
acc)) ->
            Config -> ShowOctave
config_show_octave Config
config (Accidentals
oct forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) forall a b. (a -> b) -> a -> b
$
                Text
degree forall a. Semigroup a => a -> a -> a
<> AccidentalFormat -> Accidentals -> Text
show_accidentals (Config -> AccidentalFormat
config_accidental Config
config) Accidentals
acc
            where (Accidentals
pc_oct, Text
degree) = Degrees -> Accidentals -> (Accidentals, Text)
degree_at Degrees
degrees Accidentals
pc

-- *** relative

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 forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
degree_pitch of
        Left Degree
_ -> Text
pc_text forall a. Semigroup a => a -> a -> a
<> Text
acc_text
        Right (Pitch.Pitch Accidentals
oct Degree
_) -> -- Debug.trace "show_degree_chromatic" $
            ShowOctave
show_octave (Accidentals
oct forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) (Text
pc_text forall a. Semigroup a => a -> a -> a
<> Text
acc_text)
    where
    Pitch.Degree Accidentals
pc Accidentals
acc = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either 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 forall a b. (a -> b) -> a -> b
$ Accidentals
acc 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) =
    -- Debug.trace_ret "ch to abs" (tonic, (pc, maybe_acc)) $
        Accidentals -> Degree -> Pitch
Pitch.Pitch (Accidentals
octave forall a. Num a => a -> a -> a
+ Accidentals
oct) (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc2 Accidentals
acc2)
    where
    -- sa in D is D, so add 1 PC for the tonic.
    -- If it's ri in c#-maj then it's considered d# or Relative 1 0 -> Pitch 1 1
    -- So, add the key signature.
    --
    -- But for pelog, Relative 3 -> Pitch 2 1.  So I take Relative as
    -- white notes and subtract layout to make Pitch into something relative to
    -- pathet (2+1) but which winds up being absolute "4" if acc + pc.
    -- Isn't it overcomplicated?  Why not Relative 3 -> Pitch 3, then show
    -- Pitch 3 in pelog is "4".  The place to care about pathet is diatonic
    -- transposition and kbd to call.
    (Accidentals
oct, Accidentals
pc2) = (Accidentals
pc forall a. Num a => a -> a -> a
+ Degree -> Accidentals
Pitch.degree_pc Degree
tonic) forall a. Integral a => a -> a -> (a, a)
`divMod` forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
    acc2 :: Accidentals
acc2 = forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 Maybe Accidentals
maybe_acc forall a. Num a => a -> a -> a
+ case Key -> Maybe Intervals
Theory.key_signature Key
key of
        -- If it's chromatic then I can't adjust for the mode, but I still
        -- want to map degree 1 to C# if I'm in C#.
        Maybe Intervals
Nothing -> Degree -> Accidentals
Pitch.degree_accidentals Degree
tonic
        Just Intervals
sig -> forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 (Intervals
sig forall a. Vector a -> Accidentals -> Maybe a
Vector.!? Accidentals
pc) -- Should never get Nothing.
    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 forall a b. (a -> b) -> a -> b
$ case Either Degree Pitch
degree_pitch of
        Left Degree
_ -> Text
pc_text forall a. Semigroup a => a -> a -> a
<> Text
acc_text
        Right (Pitch.Pitch Accidentals
oct Degree
_) ->
            ShowOctave
show_octave (Accidentals
oct forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) (Text
pc_text forall a. Semigroup a => a -> a -> a
<> Text
acc_text)
    where
    Pitch.Degree Accidentals
pc Accidentals
acc = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either 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 forall a. Vector a -> Accidentals -> a
! Accidentals
i)
    where (Accidentals
oct, Accidentals
i) = (Accidentals
pc forall a. Num a => a -> a -> a
- Accidentals
tonic) forall a. Integral a => a -> a -> (a, a)
`divMod` forall a. Vector a -> Accidentals
Vector.length Degrees
degrees

degree_at :: Degrees -> Pitch.PitchClass -> (Pitch.Octave, Text)
degree_at :: Degrees -> Accidentals -> (Accidentals, Text)
degree_at Degrees
degrees Accidentals
pc = Degrees -> Accidentals -> Accidentals -> (Accidentals, Text)
show_pc Degrees
degrees Accidentals
0 Accidentals
pc

-- | Convert a relative pitch using a simple diatonic key system, where the
-- key is just a note in the scale.
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 forall a. Num a => a -> a -> a
+ Accidentals
oct) (Accidentals -> Accidentals -> Degree
Pitch.Degree Accidentals
pc2 (forall a. a -> Maybe a -> a
fromMaybe Accidentals
0 Maybe Accidentals
maybe_acc))
    where (Accidentals
oct, Accidentals
pc2) = (Accidentals
pc forall a. Num a => a -> a -> a
+ Accidentals
tonic) forall a. Integral a => a -> a -> (a, a)
`divMod` forall a. Vector a -> Accidentals
Vector.length Degrees
degrees

-- *** keyed relative

-- | Like 'show_degree_chromatic', but format the accidentals as staff notation
-- does, in that accidentals implicit in the key signature are omitted, and
-- a natural that differs from the key signature is emitted.
-- TODO tons of args, can I package some up?
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 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 forall a. Num a => a -> a -> a
+ Accidentals
pc_oct) Text
pitch
    where
    Pitch.Degree Accidentals
pc_ Accidentals
acc = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id Pitch -> Degree
Pitch.pitch_degree Either Degree Pitch
degree_pitch
    (Accidentals
pc_oct, Accidentals
pc) = Accidentals
pc_ forall a. Integral a => a -> a -> (a, a)
`divMod` forall a. Vector a -> Accidentals
Vector.length Degrees
degrees
    key :: Key
key = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (forall key. KeyConfig key -> key
key_default KeyConfig Key
key_config)) forall a. a -> a
id
        (forall key. KeyConfig key -> Maybe Key -> Either PitchError key
key_parse KeyConfig Key
key_config Maybe Key
maybe_key)
    pitch :: Text
pitch = Degrees
degrees forall a. Vector a -> Accidentals -> a
! Accidentals
pc 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

-- * parse

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
        ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Accidentals
p_degree forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AccidentalFormat -> Parser (Maybe Accidentals)
p_accidentals (Config -> AccidentalFormat
config_accidental Config
config))
    where
    p_degree :: Parser Text Accidentals
p_degree = forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
        [ Text -> Parser Text
A.string Text
text forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Accidentals
i
        | (Accidentals
i, Text
text) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Accidentals
0..] (forall a. Vector a -> [a]
Vector.toList Degrees
degrees)
        ]

-- ** octave

-- | Most scales display the octave as a leading number.
show_octave :: ShowOctave
show_octave :: ShowOctave
show_octave Accidentals
oct = (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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Accidentals -> Accidentals -> Maybe Accidentals -> RelativePitch
RelativePitch Accidentals
oct Accidentals
pc Maybe Accidentals
acc

-- | Require a single digit octave.
parse_octave1 :: ParseOctave
parse_octave1 :: ParseOctave
parse_octave1 Parser Text (Accidentals, Maybe Accidentals)
parse = do
    Accidentals
oct <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Maybe Accidentals
Num.readDigit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Char -> Bool) -> Parser Char
A.satisfy Char -> Bool
ParseText.is_digit
    (Accidentals
pc, Maybe Accidentals
acc) <- Parser Text (Accidentals, Maybe Accidentals)
parse
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Accidentals -> Accidentals -> Maybe Accidentals -> RelativePitch
RelativePitch Accidentals
oct Accidentals
pc Maybe Accidentals
acc

-- ** accidentals

-- | natural, sharp1, sharp2, flat1, flat2
data AccidentalFormat = AccidentalFormat !Text !Text !Text !Text !Text
    deriving (Accidentals -> AccidentalFormat -> ShowS
[AccidentalFormat] -> ShowS
AccidentalFormat -> String
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 (Maybe Accidentals)
p_accidentals (AccidentalFormat Text
natural Text
sharp1 Text
sharp2 Text
flat1 Text
flat2) =
    Parser (Maybe Accidentals)
p_natural forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser Text Accidentals
p_acc forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    where
    p_natural :: Parser (Maybe Accidentals)
p_natural = Text -> Parser Text
A.string Text
natural forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Accidentals
0)
    p_acc :: Parser Text Accidentals
p_acc = forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
        [ Text -> Parser Text
A.string Text
sharp1 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return Accidentals
1
        , Text -> Parser Text
A.string Text
sharp2 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return Accidentals
2
        , Text -> Parser Text
A.string Text
flat1 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return (-Accidentals
1)
        , Text -> Parser Text
A.string Text
flat2 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return (-Accidentals
2)
        ]

-- | Show accidentals relative to the key signature.
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 forall a. Eq a => a -> a -> Bool
== Accidentals
key_accs = Text
""
    | Accidentals
accs forall a. Eq a => a -> a -> Bool
== Accidentals
0 Bool -> Bool -> Bool
&& Accidentals
key_accs 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 forall a. Eq a => a -> a -> Bool
== Accidentals
0 = Text
""
    | Accidentals
acc forall a. Ord a => a -> a -> Bool
< Accidentals
0 = ShowOctave
Text.replicate Accidentals
x Text
flat2 forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate Accidentals
s Text
flat1
    | Bool
otherwise = ShowOctave
Text.replicate Accidentals
x Text
sharp2 forall a. Semigroup a => a -> a -> a
<> ShowOctave
Text.replicate Accidentals
s Text
sharp1
    where (Accidentals
x, Accidentals
s) = forall a. Num a => a -> a
abs Accidentals
acc forall a. Integral a => a -> a -> (a, a)
`divMod` Accidentals
2