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

{-# LANGUAGE DeriveDataTypeable #-}
{- | Representation for scales, pitches, and frequencies (note numbers).

    There are many representations for a pitch, at many different levels of
    abstraction.
-}
module Perform.Pitch (
    -- * Note
    Note(..), note_text

    -- * Pitch
    , Pitch(..), pitch, Degree(..)
    , Octave, PitchClass, Accidentals, Semi, FSemi, Step
    , pitch_accidentals, pitch_pc
    , add_octave, add_pc, diff_pc
    , middle_octave, middle_c

    -- * Input
    , Input(..), KbdType(..), Frac

    -- * NoteNumber
    , NoteNumber(..), nn, nn_to_double
    , Cent, nn_to_cents
    , nns_equal, nns_close

    -- * Hz
    , Hz, add_hz, modify_hz, nn_to_hz, hz_to_nn, middle_c_hz

    -- * Scale
    , ScaleId(..), empty_scale, twelve
    , Transpose(..), zero_transpose, modify_transpose
    , Key(Key), key_text
) where
import qualified Data.String as String
import qualified Data.Text as Text
import qualified Data.Typeable as Typeable

import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.Read as Read

import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Serialize as Serialize
import qualified Util.Test.ApproxEq as ApproxEq

import qualified Derive.ShowVal as ShowVal

import           Global


-- * Note

-- | A Note is the most abstract representation of pitch, in that it's simply
-- an unparsed bit of text representing that pitch.  Given a Scale, it's
-- expected to name a val call exported by that scale.
newtype Note = Note Text
    deriving (Note -> Note -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note -> Note -> Bool
$c/= :: Note -> Note -> Bool
== :: Note -> Note -> Bool
$c== :: Note -> Note -> Bool
Eq, Eq Note
Note -> Note -> Bool
Note -> Note -> Ordering
Note -> Note -> Note
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 :: Note -> Note -> Note
$cmin :: Note -> Note -> Note
max :: Note -> Note -> Note
$cmax :: Note -> Note -> Note
>= :: Note -> Note -> Bool
$c>= :: Note -> Note -> Bool
> :: Note -> Note -> Bool
$c> :: Note -> Note -> Bool
<= :: Note -> Note -> Bool
$c<= :: Note -> Note -> Bool
< :: Note -> Note -> Bool
$c< :: Note -> Note -> Bool
compare :: Note -> Note -> Ordering
$ccompare :: Note -> Note -> Ordering
Ord, Cent -> Note -> ShowS
[Note] -> ShowS
Note -> String
forall a.
(Cent -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note] -> ShowS
$cshowList :: [Note] -> ShowS
show :: Note -> String
$cshow :: Note -> String
showsPrec :: Cent -> Note -> ShowS
$cshowsPrec :: Cent -> Note -> ShowS
Show, String -> Note
forall a. (String -> a) -> IsString a
fromString :: String -> Note
$cfromString :: String -> Note
String.IsString, Get Note
Putter Note
forall a. Putter a -> Get a -> Serialize a
get :: Get Note
$cget :: Get Note
put :: Putter Note
$cput :: Putter Note
Serialize.Serialize)

note_text :: Note -> Text
note_text :: Note -> Text
note_text (Note Text
s) = Text
s

instance Pretty Note where pretty :: Note -> Text
pretty (Note Text
n) = Text
n


-- * pitch

-- | A Pitch is a parsed 'Note'.  Functions that want to manipulate notes
-- in a scale-independent way can ask the scale to convert to and from a Note.
-- Not all scales use all the fields.
data Pitch = Pitch {
    Pitch -> Cent
pitch_octave :: !Octave
    , Pitch -> Degree
pitch_degree :: !Degree
    } deriving (Pitch -> Pitch -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pitch -> Pitch -> Bool
$c/= :: Pitch -> Pitch -> Bool
== :: Pitch -> Pitch -> Bool
$c== :: Pitch -> Pitch -> Bool
Eq, Eq Pitch
Pitch -> Pitch -> Bool
Pitch -> Pitch -> Ordering
Pitch -> Pitch -> Pitch
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 :: Pitch -> Pitch -> Pitch
$cmin :: Pitch -> Pitch -> Pitch
max :: Pitch -> Pitch -> Pitch
$cmax :: Pitch -> Pitch -> Pitch
>= :: Pitch -> Pitch -> Bool
$c>= :: Pitch -> Pitch -> Bool
> :: Pitch -> Pitch -> Bool
$c> :: Pitch -> Pitch -> Bool
<= :: Pitch -> Pitch -> Bool
$c<= :: Pitch -> Pitch -> Bool
< :: Pitch -> Pitch -> Bool
$c< :: Pitch -> Pitch -> Bool
compare :: Pitch -> Pitch -> Ordering
$ccompare :: Pitch -> Pitch -> Ordering
Ord, ReadPrec [Pitch]
ReadPrec Pitch
Cent -> ReadS Pitch
ReadS [Pitch]
forall a.
(Cent -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Pitch]
$creadListPrec :: ReadPrec [Pitch]
readPrec :: ReadPrec Pitch
$creadPrec :: ReadPrec Pitch
readList :: ReadS [Pitch]
$creadList :: ReadS [Pitch]
readsPrec :: Cent -> ReadS Pitch
$creadsPrec :: Cent -> ReadS Pitch
Read, Cent -> Pitch -> ShowS
[Pitch] -> ShowS
Pitch -> String
forall a.
(Cent -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pitch] -> ShowS
$cshowList :: [Pitch] -> ShowS
show :: Pitch -> String
$cshow :: Pitch -> String
showsPrec :: Cent -> Pitch -> ShowS
$cshowsPrec :: Cent -> Pitch -> ShowS
Show)

pitch :: Enum pc => Octave -> pc -> Pitch
pitch :: forall pc. Enum pc => Cent -> pc -> Pitch
pitch Cent
oct pc
pc = Cent -> Degree -> Pitch
Pitch Cent
oct (Cent -> Cent -> Degree
Degree (forall a. Enum a => a -> Cent
fromEnum pc
pc) Cent
0)

instance Pretty Pitch where
    pretty :: Pitch -> Text
pretty (Pitch Cent
oct Degree
degree) = forall a. Show a => a -> Text
showt Cent
oct forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Degree
degree

-- | This relies on the presence of a @pitch@ val call.
instance ShowVal.ShowVal Pitch where
    show_val :: Pitch -> Text
show_val (Pitch Cent
oct (Degree Cent
pc Cent
accs)) =
        Text
"(pitch " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords [Text]
args forall a. Semigroup a => a -> a -> a
<> Text
")"
        where args :: [Text]
args = forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
showt forall a b. (a -> b) -> a -> b
$ Cent
oct forall a. a -> [a] -> [a]
: Cent
pc forall a. a -> [a] -> [a]
: if Cent
accs forall a. Eq a => a -> a -> Bool
== Cent
0 then [] else [Cent
accs]

instance Serialize.Serialize Pitch where
    put :: Putter Pitch
put (Pitch Cent
a Degree
b) = forall a. Serialize a => Putter a
Serialize.put Cent
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put Degree
b
    get :: Get Pitch
get = Cent -> Degree -> Pitch
Pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get

-- | A scale degree, without reference to an octave.
data Degree = Degree {
    Degree -> Cent
degree_pc :: !PitchClass
    -- | Ignored for diatonic scales.
    , Degree -> Cent
degree_accidentals :: !Accidentals
    } deriving (Degree -> Degree -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Degree -> Degree -> Bool
$c/= :: Degree -> Degree -> Bool
== :: Degree -> Degree -> Bool
$c== :: Degree -> Degree -> Bool
Eq, Eq Degree
Degree -> Degree -> Bool
Degree -> Degree -> Ordering
Degree -> Degree -> Degree
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 :: Degree -> Degree -> Degree
$cmin :: Degree -> Degree -> Degree
max :: Degree -> Degree -> Degree
$cmax :: Degree -> Degree -> Degree
>= :: Degree -> Degree -> Bool
$c>= :: Degree -> Degree -> Bool
> :: Degree -> Degree -> Bool
$c> :: Degree -> Degree -> Bool
<= :: Degree -> Degree -> Bool
$c<= :: Degree -> Degree -> Bool
< :: Degree -> Degree -> Bool
$c< :: Degree -> Degree -> Bool
compare :: Degree -> Degree -> Ordering
$ccompare :: Degree -> Degree -> Ordering
Ord, ReadPrec [Degree]
ReadPrec Degree
Cent -> ReadS Degree
ReadS [Degree]
forall a.
(Cent -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Degree]
$creadListPrec :: ReadPrec [Degree]
readPrec :: ReadPrec Degree
$creadPrec :: ReadPrec Degree
readList :: ReadS [Degree]
$creadList :: ReadS [Degree]
readsPrec :: Cent -> ReadS Degree
$creadsPrec :: Cent -> ReadS Degree
Read, Cent -> Degree -> ShowS
[Degree] -> ShowS
Degree -> String
forall a.
(Cent -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Degree] -> ShowS
$cshowList :: [Degree] -> ShowS
show :: Degree -> String
$cshow :: Degree -> String
showsPrec :: Cent -> Degree -> ShowS
$cshowsPrec :: Cent -> Degree -> ShowS
Show)

instance Pretty Degree where
    pretty :: Degree -> Text
pretty (Degree Cent
pc Cent
acc) = forall a. Show a => a -> Text
showt Cent
pc
        forall a. Semigroup a => a -> a -> a
<> if Cent
acc forall a. Ord a => a -> a -> Bool
< Cent
0 then Cent -> Text -> Text
Text.replicate (forall a. Num a => a -> a
abs Cent
acc) Text
"b"
            else Cent -> Text -> Text
Text.replicate Cent
acc Text
"#"

instance Serialize.Serialize Degree where
    put :: Putter Degree
put (Degree Cent
a Cent
b) = forall a. Serialize a => Putter a
Serialize.put Cent
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put Cent
b
    get :: Get Degree
get = Cent -> Cent -> Degree
Degree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get

-- | Just a way to label an octave, either relative or absolute.
type Octave = Int

-- | A PitchClass maps directly to a scale degree, which is a letter in
-- traditional Western notation, though this PitchClass may have fewer or
-- greater than 7 notes.  The PitchClass is absolute in that it doesn't depend
-- on the tonic of a key.
--
-- These numbers are expected to wrap around at the octave, so they usually use
-- modular arithmetic, but if an octave is not handy (i.e. they're not in
-- a 'Pitch'), then steps exceeding an octave will be wrapped into an octave
-- when one is available.
type PitchClass = Int

-- | Positive for sharps, negative for flats.
type Accidentals = Int

-- | Number of semitones.  This is an absolute measure from octave 0,
-- regardless of whether the scale has notes at octave 0.  This is so you can
-- convert between Semis and the similarly absolute 'Pitch' in the same way for
-- all scales.
type Semi = Int

-- | This is like 'Semi', but floating point.
type FSemi = Double

-- | This is a relative amount of transposition.  It could be either chromatic
-- or diatonic.
type Step = Int

pitch_accidentals :: Pitch -> Accidentals
pitch_accidentals :: Pitch -> Cent
pitch_accidentals = Degree -> Cent
degree_accidentals forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Degree
pitch_degree

pitch_pc :: Pitch -> PitchClass
pitch_pc :: Pitch -> Cent
pitch_pc = Degree -> Cent
degree_pc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Degree
pitch_degree

add_octave :: Octave  -> Pitch -> Pitch
add_octave :: Cent -> Pitch -> Pitch
add_octave Cent
oct (Pitch Cent
octave Degree
degree) = Cent -> Degree -> Pitch
Pitch (Cent
oct forall a. Num a => a -> a -> a
+ Cent
octave) Degree
degree

-- | Add diatonic steps.  This doesn't deal with key signatures or non-diatonic
-- scales.
add_pc :: PitchClass -> PitchClass -> Pitch -> Pitch
add_pc :: Cent -> Cent -> Pitch -> Pitch
add_pc Cent
per_octave Cent
steps (Pitch Cent
octave (Degree Cent
pc Cent
accs)) =
    Cent -> Degree -> Pitch
Pitch (Cent
oct forall a. Num a => a -> a -> a
+ Cent
octave) (Cent -> Cent -> Degree
Degree Cent
pc2 Cent
accs)
    where (Cent
oct, Cent
pc2) = (Cent
pc forall a. Num a => a -> a -> a
+ Cent
steps) forall a. Integral a => a -> a -> (a, a)
`divMod` Cent
per_octave

diff_pc :: PitchClass -> Pitch -> Pitch -> PitchClass
diff_pc :: Cent -> Pitch -> Pitch -> Cent
diff_pc Cent
per_octave (Pitch Cent
oct1 (Degree Cent
pc1 Cent
_)) (Pitch Cent
oct2 (Degree Cent
pc2 Cent
_)) =
    Cent
oct_diff forall a. Num a => a -> a -> a
+ Cent
pc1 forall a. Num a => a -> a -> a
- Cent
pc2
    where oct_diff :: Cent
oct_diff = Cent
per_octave forall a. Num a => a -> a -> a
* (Cent
oct1 forall a. Num a => a -> a -> a
- Cent
oct2)

-- | The middle octave.  The \"center\" of a scale should be oriented around
-- this.
middle_octave :: Octave
middle_octave :: Cent
middle_octave = Cent
4

middle_c :: Pitch
middle_c :: Pitch
middle_c = Cent -> Degree -> Pitch
Pitch Cent
middle_octave (Cent -> Cent -> Degree
Degree Cent
0 Cent
0)

-- * Input

-- | A physically played note on some input device.  This hasn't been mapped to
-- a scale yet, so the Pitch is in the context of the device's layout.
--
-- I have 3 kinds of kbds:
--
-- ASCII has 10 white keys, and black keys between each one.  It should be
-- relative, so that C or sa is always on Q and Z, and if the octave is <10
-- then it will wrap on the same row.
--
-- MIDI has the usual piano layout.  It's absolute, so that a relative scale
-- can start at keys other than C, if that would be convenient for the layout.
-- The octave is rounded up to the nearest multiple of 7, and the extra keys
-- are unused, so the octave always starts at C.
--
-- Continuum has no keys, just NNs.  So it gets the scale degree that's
-- closest to the given NN.  That's different from the MIDI kbd because the
-- MIDI kbd never wants a key to emit something between notes.  TODO not
-- supported yet
data Input = Input !KbdType !Pitch !Frac
    deriving (Input -> Input -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Input -> Input -> Bool
$c/= :: Input -> Input -> Bool
== :: Input -> Input -> Bool
$c== :: Input -> Input -> Bool
Eq, Cent -> Input -> ShowS
[Input] -> ShowS
Input -> String
forall a.
(Cent -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Input] -> ShowS
$cshowList :: [Input] -> ShowS
show :: Input -> String
$cshow :: Input -> String
showsPrec :: Cent -> Input -> ShowS
$cshowsPrec :: Cent -> Input -> ShowS
Show)

data KbdType =
    -- | An absolute kbd maps the same key to the same absolute pitch,
    -- regardless of the key.  This is the case for a piano style kbd.
    -- This is consistent with convention, but also the piano kbd has a fixed
    -- layout of white and black keys.  So if you e.g. transpose A-major to
    -- start on C, then you have a mysterious black key in between B and C, and
    -- no way to play C#.
    PianoKbd
    -- | A relative kbd always maps the same key to the same relative pitch.
    -- This is appropriate for the ASCII kbd, because it has \"black keys\"
    -- between every white key, so scales can be transposed freely.
    | AsciiKbd
    deriving (KbdType -> KbdType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KbdType -> KbdType -> Bool
$c/= :: KbdType -> KbdType -> Bool
== :: KbdType -> KbdType -> Bool
$c== :: KbdType -> KbdType -> Bool
Eq, Cent -> KbdType -> ShowS
[KbdType] -> ShowS
KbdType -> String
forall a.
(Cent -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KbdType] -> ShowS
$cshowList :: [KbdType] -> ShowS
show :: KbdType -> String
$cshow :: KbdType -> String
showsPrec :: Cent -> KbdType -> ShowS
$cshowsPrec :: Cent -> KbdType -> ShowS
Show)

-- | A number between -1 and 1 exclusive, representing the portion of the way
-- between two scale degrees.  I could have used \"Cents\" for this, but that
-- implies equal temperedness.
type Frac = Double

instance Pretty Input where
    pretty :: Input -> Text
pretty (Input KbdType
kbd Pitch
pitch Double
frac) = forall a. Show a => a -> Text
showt KbdType
kbd forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pitch
pitch
        forall a. Semigroup a => a -> a -> a
<> if Double
frac forall a. Eq a => a -> a -> Bool
== Double
0 then Text
"" else Text
"+" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Double
frac

-- * NoteNumber

-- | This is equal tempered scale notes with the same definition as MIDI, so
-- MIDI note 0 is NoteNumber 0, at 8.176 Hz, and is -1c.  Middle C (4c) is
-- NoteNumber 60.
--
-- 'Derive.PSignal.PSignal's are converted into this before performance
-- since performance doesn't understand scales.
newtype NoteNumber = NoteNumber Double
    deriving (Double -> NoteNumber -> NoteNumber -> Bool
forall a. (Double -> a -> a -> Bool) -> ApproxEq a
eq :: Double -> NoteNumber -> NoteNumber -> Bool
$ceq :: Double -> NoteNumber -> NoteNumber -> Bool
ApproxEq.ApproxEq, NoteNumber -> NoteNumber -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteNumber -> NoteNumber -> Bool
$c/= :: NoteNumber -> NoteNumber -> Bool
== :: NoteNumber -> NoteNumber -> Bool
$c== :: NoteNumber -> NoteNumber -> Bool
Eq, Eq NoteNumber
NoteNumber -> NoteNumber -> Bool
NoteNumber -> NoteNumber -> Ordering
NoteNumber -> NoteNumber -> NoteNumber
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 :: NoteNumber -> NoteNumber -> NoteNumber
$cmin :: NoteNumber -> NoteNumber -> NoteNumber
max :: NoteNumber -> NoteNumber -> NoteNumber
$cmax :: NoteNumber -> NoteNumber -> NoteNumber
>= :: NoteNumber -> NoteNumber -> Bool
$c>= :: NoteNumber -> NoteNumber -> Bool
> :: NoteNumber -> NoteNumber -> Bool
$c> :: NoteNumber -> NoteNumber -> Bool
<= :: NoteNumber -> NoteNumber -> Bool
$c<= :: NoteNumber -> NoteNumber -> Bool
< :: NoteNumber -> NoteNumber -> Bool
$c< :: NoteNumber -> NoteNumber -> Bool
compare :: NoteNumber -> NoteNumber -> Ordering
$ccompare :: NoteNumber -> NoteNumber -> Ordering
Ord, Num NoteNumber
Rational -> NoteNumber
NoteNumber -> NoteNumber
NoteNumber -> NoteNumber -> NoteNumber
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> NoteNumber
$cfromRational :: Rational -> NoteNumber
recip :: NoteNumber -> NoteNumber
$crecip :: NoteNumber -> NoteNumber
/ :: NoteNumber -> NoteNumber -> NoteNumber
$c/ :: NoteNumber -> NoteNumber -> NoteNumber
Fractional, Num NoteNumber
Ord NoteNumber
NoteNumber -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: NoteNumber -> Rational
$ctoRational :: NoteNumber -> Rational
Real, Fractional NoteNumber
Real NoteNumber
forall b. Integral b => NoteNumber -> b
forall b. Integral b => NoteNumber -> (b, NoteNumber)
forall a.
Real a
-> Fractional a
-> (forall b. Integral b => a -> (b, a))
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> (forall b. Integral b => a -> b)
-> RealFrac a
floor :: forall b. Integral b => NoteNumber -> b
$cfloor :: forall b. Integral b => NoteNumber -> b
ceiling :: forall b. Integral b => NoteNumber -> b
$cceiling :: forall b. Integral b => NoteNumber -> b
round :: forall b. Integral b => NoteNumber -> b
$cround :: forall b. Integral b => NoteNumber -> b
truncate :: forall b. Integral b => NoteNumber -> b
$ctruncate :: forall b. Integral b => NoteNumber -> b
properFraction :: forall b. Integral b => NoteNumber -> (b, NoteNumber)
$cproperFraction :: forall b. Integral b => NoteNumber -> (b, NoteNumber)
RealFrac, Integer -> NoteNumber
NoteNumber -> NoteNumber
NoteNumber -> NoteNumber -> NoteNumber
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> NoteNumber
$cfromInteger :: Integer -> NoteNumber
signum :: NoteNumber -> NoteNumber
$csignum :: NoteNumber -> NoteNumber
abs :: NoteNumber -> NoteNumber
$cabs :: NoteNumber -> NoteNumber
negate :: NoteNumber -> NoteNumber
$cnegate :: NoteNumber -> NoteNumber
* :: NoteNumber -> NoteNumber -> NoteNumber
$c* :: NoteNumber -> NoteNumber -> NoteNumber
- :: NoteNumber -> NoteNumber -> NoteNumber
$c- :: NoteNumber -> NoteNumber -> NoteNumber
+ :: NoteNumber -> NoteNumber -> NoteNumber
$c+ :: NoteNumber -> NoteNumber -> NoteNumber
Num,
        Get NoteNumber
Putter NoteNumber
forall a. Putter a -> Get a -> Serialize a
get :: Get NoteNumber
$cget :: Get NoteNumber
put :: Putter NoteNumber
$cput :: Putter NoteNumber
Serialize.Serialize, Typeable.Typeable)

instance Show NoteNumber where
    show :: NoteNumber -> String
show (NoteNumber Double
nn) = forall a. Show a => a -> String
show Double
nn forall a. Semigroup a => a -> a -> a
<> String
"nn"
instance Read NoteNumber where
    readPrec :: ReadPrec NoteNumber
readPrec = do
        Double
n <- forall a. Read a => ReadPrec a
Read.readPrec
        forall a. ReadP a -> ReadPrec a
Read.lift forall a b. (a -> b) -> a -> b
$ ReadP ()
ReadP.skipSpaces forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ReadP String
ReadP.string String
"nn"
        forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> NoteNumber
NoteNumber Double
n)

instance ShowVal.ShowVal NoteNumber where
    show_val :: NoteNumber -> Text
show_val (NoteNumber Double
nn) = forall a. ShowVal a => a -> Text
ShowVal.show_val Double
nn forall a. Semigroup a => a -> a -> a
<> Text
"nn"
    -- The suffix should be the same as DeriveT.type_to_code Nn

instance Pretty NoteNumber where
    pretty :: NoteNumber -> Text
pretty (NoteNumber Double
nn) = forall a. RealFloat a => Maybe Cent -> a -> Text
Num.showFloat0 (forall a. a -> Maybe a
Just Cent
3) Double
nn forall a. Semigroup a => a -> a -> a
<> Text
"nn"

nn :: Real a => a -> NoteNumber
nn :: forall a. Real a => a -> NoteNumber
nn = Double -> NoteNumber
NoteNumber forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

nn_to_double :: NoteNumber -> Double
nn_to_double :: NoteNumber -> Double
nn_to_double (NoteNumber Double
nn) = Double
nn

type Cent = Int

nn_to_cents :: NoteNumber -> Cent
nn_to_cents :: NoteNumber -> Cent
nn_to_cents = forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*NoteNumber
100)

-- | True if the NoteNumbers are close enough that they sound the same.
nns_equal :: NoteNumber -> NoteNumber -> Bool
nns_equal :: NoteNumber -> NoteNumber -> Bool
nns_equal = Cent -> NoteNumber -> NoteNumber -> Bool
nns_close Cent
3 -- almost certainly less than JND

nns_close :: Cent -> NoteNumber -> NoteNumber -> Bool
nns_close :: Cent -> NoteNumber -> NoteNumber -> Bool
nns_close Cent
cents NoteNumber
nn1 NoteNumber
nn2 = forall a. Num a => a -> a
abs (NoteNumber -> Cent
nn_to_cents NoteNumber
nn1 forall a. Num a => a -> a -> a
- NoteNumber -> Cent
nn_to_cents NoteNumber
nn2) forall a. Ord a => a -> a -> Bool
<= Cent
cents

-- * Hz

-- | This is absolute non-logarithmic frequency.
type Hz = Double

add_hz :: Hz -> NoteNumber -> NoteNumber
add_hz :: Double -> NoteNumber -> NoteNumber
add_hz Double
0 NoteNumber
nn = NoteNumber
nn -- hz_to_nn . nn_to_hz adds a tiny bit of inaccuracy
add_hz Double
hz NoteNumber
nn = Double -> NoteNumber
hz_to_nn (Double
hz forall a. Num a => a -> a -> a
+ NoteNumber -> Double
nn_to_hz NoteNumber
nn)

modify_hz :: (Hz -> Hz) -> NoteNumber -> NoteNumber
modify_hz :: (Double -> Double) -> NoteNumber -> NoteNumber
modify_hz Double -> Double
f = Double -> NoteNumber
hz_to_nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteNumber -> Double
nn_to_hz

nn_to_hz :: NoteNumber -> Hz
nn_to_hz :: NoteNumber -> Double
nn_to_hz (NoteNumber Double
nn) = forall a. Floating a => a -> a
exp (Double
nn forall a. Num a => a -> a -> a
* Double
_hz_scale forall a. Num a => a -> a -> a
+ Double
_hz_offset)

-- | Negative hz will result in NaN.  TODO take an abs or throw an error, or
-- let the NaN propagate?
hz_to_nn :: Hz -> NoteNumber
hz_to_nn :: Double -> NoteNumber
hz_to_nn Double
hz = Double -> NoteNumber
NoteNumber forall a b. (a -> b) -> a -> b
$ (forall a. Floating a => a -> a
log Double
hz forall a. Num a => a -> a -> a
- Double
_hz_offset) forall a. Fractional a => a -> a -> a
/ Double
_hz_scale

-- | Constants to calculate equal tempered conversions.
_hz_scale, _hz_offset :: Hz
_hz_scale :: Double
_hz_scale = forall a. Floating a => a -> a
log Double
2 forall a. Fractional a => a -> a -> a
/ Double
12
_hz_offset :: Double
_hz_offset = forall a. Floating a => a -> a
log Double
a_hz forall a. Num a => a -> a -> a
- (Double
a_nn forall a. Num a => a -> a -> a
* Double
_hz_scale)
    where
    -- NoteNumber is defined with these values.  Ultimately it's because midi
    -- synthesizers are by default defined with these values.
    a_hz :: Double
a_hz = Double
440
    a_nn :: Double
a_nn = Double
69

middle_c_hz :: Hz
middle_c_hz :: Double
middle_c_hz = NoteNumber -> Double
nn_to_hz NoteNumber
60

-- Alternate implementation that also introduces a bit of imprecision.  Seems
-- to be about the same as the one above.
--
-- nn_to_hz :: NoteNumber -> Hz
-- nn_to_hz (NoteNumber nn) = a_hz * rt12 ** (nn - a_nn)
--     where rt12 = 2**(1/12)
--
-- hz_to_nn :: Hz -> NoteNumber
-- hz_to_nn hz = NoteNumber $ logBase rt12 (hz / a_hz * (rt12**a_nn))
--     where rt12 = 2**(1/12)
--
-- a_hz, a_nn :: Double
-- a_hz = 440
-- a_nn = 69


-- * scale

newtype ScaleId = ScaleId Text
    deriving (ScaleId -> ScaleId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScaleId -> ScaleId -> Bool
$c/= :: ScaleId -> ScaleId -> Bool
== :: ScaleId -> ScaleId -> Bool
$c== :: ScaleId -> ScaleId -> Bool
Eq, Eq ScaleId
ScaleId -> ScaleId -> Bool
ScaleId -> ScaleId -> Ordering
ScaleId -> ScaleId -> ScaleId
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 :: ScaleId -> ScaleId -> ScaleId
$cmin :: ScaleId -> ScaleId -> ScaleId
max :: ScaleId -> ScaleId -> ScaleId
$cmax :: ScaleId -> ScaleId -> ScaleId
>= :: ScaleId -> ScaleId -> Bool
$c>= :: ScaleId -> ScaleId -> Bool
> :: ScaleId -> ScaleId -> Bool
$c> :: ScaleId -> ScaleId -> Bool
<= :: ScaleId -> ScaleId -> Bool
$c<= :: ScaleId -> ScaleId -> Bool
< :: ScaleId -> ScaleId -> Bool
$c< :: ScaleId -> ScaleId -> Bool
compare :: ScaleId -> ScaleId -> Ordering
$ccompare :: ScaleId -> ScaleId -> Ordering
Ord, ReadPrec [ScaleId]
ReadPrec ScaleId
Cent -> ReadS ScaleId
ReadS [ScaleId]
forall a.
(Cent -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ScaleId]
$creadListPrec :: ReadPrec [ScaleId]
readPrec :: ReadPrec ScaleId
$creadPrec :: ReadPrec ScaleId
readList :: ReadS [ScaleId]
$creadList :: ReadS [ScaleId]
readsPrec :: Cent -> ReadS ScaleId
$creadsPrec :: Cent -> ReadS ScaleId
Read, Cent -> ScaleId -> ShowS
[ScaleId] -> ShowS
ScaleId -> String
forall a.
(Cent -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScaleId] -> ShowS
$cshowList :: [ScaleId] -> ShowS
show :: ScaleId -> String
$cshow :: ScaleId -> String
showsPrec :: Cent -> ScaleId -> ShowS
$cshowsPrec :: Cent -> ScaleId -> ShowS
Show, String -> ScaleId
forall a. (String -> a) -> IsString a
fromString :: String -> ScaleId
$cfromString :: String -> ScaleId
String.IsString, Get ScaleId
Putter ScaleId
forall a. Putter a -> Get a -> Serialize a
get :: Get ScaleId
$cget :: Get ScaleId
put :: Putter ScaleId
$cput :: Putter ScaleId
Serialize.Serialize)

instance Pretty ScaleId where pretty :: ScaleId -> Text
pretty (ScaleId Text
s) = Text
s

-- | Usually this means to use the scale currently in scope.
empty_scale :: ScaleId
empty_scale :: ScaleId
empty_scale = ScaleId
""

twelve :: ScaleId
twelve :: ScaleId
twelve = ScaleId
"twelve"

-- | A generic transposition, for operations that can transpose diatonically,
-- chromatically, or by absolute NoteNumber.
data Transpose = Chromatic Double | Diatonic Double
    -- | Nn is scale-independent, so it's not suitable for symbolic
    -- transposition, but it's still useful for pitch transposition.
    | Nn Double
    deriving (Transpose -> Transpose -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Transpose -> Transpose -> Bool
$c/= :: Transpose -> Transpose -> Bool
== :: Transpose -> Transpose -> Bool
$c== :: Transpose -> Transpose -> Bool
Eq, Eq Transpose
Transpose -> Transpose -> Bool
Transpose -> Transpose -> Ordering
Transpose -> Transpose -> Transpose
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 :: Transpose -> Transpose -> Transpose
$cmin :: Transpose -> Transpose -> Transpose
max :: Transpose -> Transpose -> Transpose
$cmax :: Transpose -> Transpose -> Transpose
>= :: Transpose -> Transpose -> Bool
$c>= :: Transpose -> Transpose -> Bool
> :: Transpose -> Transpose -> Bool
$c> :: Transpose -> Transpose -> Bool
<= :: Transpose -> Transpose -> Bool
$c<= :: Transpose -> Transpose -> Bool
< :: Transpose -> Transpose -> Bool
$c< :: Transpose -> Transpose -> Bool
compare :: Transpose -> Transpose -> Ordering
$ccompare :: Transpose -> Transpose -> Ordering
Ord, Cent -> Transpose -> ShowS
[Transpose] -> ShowS
Transpose -> String
forall a.
(Cent -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Transpose] -> ShowS
$cshowList :: [Transpose] -> ShowS
show :: Transpose -> String
$cshow :: Transpose -> String
showsPrec :: Cent -> Transpose -> ShowS
$cshowsPrec :: Cent -> Transpose -> ShowS
Show)

instance Pretty Transpose where pretty :: Transpose -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val
instance ShowVal.ShowVal Transpose where
    -- TODO convert to a ScoreT.Typed Signal.Y and use its ShowVal
    show_val :: Transpose -> Text
show_val (Chromatic Double
d) = forall a. ShowVal a => a -> Text
ShowVal.show_val Double
d forall a. Semigroup a => a -> a -> a
<> Text
"c"
    show_val (Diatonic Double
d) = forall a. ShowVal a => a -> Text
ShowVal.show_val Double
d forall a. Semigroup a => a -> a -> a
<> Text
"d"
    show_val (Nn Double
d) = forall a. ShowVal a => a -> Text
ShowVal.show_val Double
d forall a. Semigroup a => a -> a -> a
<> Text
"nn"

zero_transpose :: Transpose -> Bool
zero_transpose :: Transpose -> Bool
zero_transpose Transpose
t = case Transpose
t of
    Chromatic Double
d -> Double
d forall a. Eq a => a -> a -> Bool
== Double
0
    Diatonic Double
d -> Double
d forall a. Eq a => a -> a -> Bool
== Double
0
    Nn Double
d -> Double
d forall a. Eq a => a -> a -> Bool
== Double
0

modify_transpose :: (Double -> Double) -> Transpose -> Transpose
modify_transpose :: (Double -> Double) -> Transpose -> Transpose
modify_transpose Double -> Double
f Transpose
t = case Transpose
t of
    Chromatic Double
d -> Double -> Transpose
Chromatic (Double -> Double
f Double
d)
    Diatonic Double
d -> Double -> Transpose
Diatonic (Double -> Double
f Double
d)
    Nn Double
d -> Double -> Transpose
Nn (Double -> Double
f Double
d)

-- | Diatonic transposition often requires a Key for context.
--
-- This is not very strongly typed, because it's intended to be scale
-- independent, and not every scale will have the same values for key and
-- mode.
newtype Key = Key Text
    deriving (Key -> Key -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Eq Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
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 :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmax :: Key -> Key -> Key
>= :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c< :: Key -> Key -> Bool
compare :: Key -> Key -> Ordering
$ccompare :: Key -> Key -> Ordering
Ord, ReadPrec [Key]
ReadPrec Key
Cent -> ReadS Key
ReadS [Key]
forall a.
(Cent -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Key]
$creadListPrec :: ReadPrec [Key]
readPrec :: ReadPrec Key
$creadPrec :: ReadPrec Key
readList :: ReadS [Key]
$creadList :: ReadS [Key]
readsPrec :: Cent -> ReadS Key
$creadsPrec :: Cent -> ReadS Key
Read, Cent -> Key -> ShowS
[Key] -> ShowS
Key -> String
forall a.
(Cent -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Cent -> Key -> ShowS
$cshowsPrec :: Cent -> Key -> ShowS
Show, Key -> Text
forall a. (a -> Text) -> ShowVal a
show_val :: Key -> Text
$cshow_val :: Key -> Text
ShowVal.ShowVal, Get Key
Putter Key
forall a. Putter a -> Get a -> Serialize a
get :: Get Key
$cget :: Get Key
put :: Putter Key
$cput :: Putter Key
Serialize.Serialize)

key_text :: Key -> Text
key_text :: Key -> Text
key_text (Key Text
t) = Text
t

instance Pretty Key where format :: Key -> Doc
format (Key Text
s) = Text -> Doc
Pretty.text Text
s