-- | Common music notation intervals.
module Music.Theory.Interval where

import Data.List {- base -}
import Data.Maybe {- base -}

import qualified Music.Theory.Ord as T {- hmt -}
import qualified Music.Theory.Pitch as T {- hmt -}
import qualified Music.Theory.Pitch.Note as T {- hmt -}

-- | Interval type or degree.
data Interval_Type = Unison | Second | Third | Fourth
                | Fifth | Sixth | Seventh
                  deriving (Interval_Type -> Interval_Type -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Interval_Type -> Interval_Type -> Bool
$c/= :: Interval_Type -> Interval_Type -> Bool
== :: Interval_Type -> Interval_Type -> Bool
$c== :: Interval_Type -> Interval_Type -> Bool
Eq,Int -> Interval_Type
Interval_Type -> Int
Interval_Type -> [Interval_Type]
Interval_Type -> Interval_Type
Interval_Type -> Interval_Type -> [Interval_Type]
Interval_Type -> Interval_Type -> Interval_Type -> [Interval_Type]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Interval_Type -> Interval_Type -> Interval_Type -> [Interval_Type]
$cenumFromThenTo :: Interval_Type -> Interval_Type -> Interval_Type -> [Interval_Type]
enumFromTo :: Interval_Type -> Interval_Type -> [Interval_Type]
$cenumFromTo :: Interval_Type -> Interval_Type -> [Interval_Type]
enumFromThen :: Interval_Type -> Interval_Type -> [Interval_Type]
$cenumFromThen :: Interval_Type -> Interval_Type -> [Interval_Type]
enumFrom :: Interval_Type -> [Interval_Type]
$cenumFrom :: Interval_Type -> [Interval_Type]
fromEnum :: Interval_Type -> Int
$cfromEnum :: Interval_Type -> Int
toEnum :: Int -> Interval_Type
$ctoEnum :: Int -> Interval_Type
pred :: Interval_Type -> Interval_Type
$cpred :: Interval_Type -> Interval_Type
succ :: Interval_Type -> Interval_Type
$csucc :: Interval_Type -> Interval_Type
Enum,Interval_Type
forall a. a -> a -> Bounded a
maxBound :: Interval_Type
$cmaxBound :: Interval_Type
minBound :: Interval_Type
$cminBound :: Interval_Type
Bounded,Eq Interval_Type
Interval_Type -> Interval_Type -> Bool
Interval_Type -> Interval_Type -> Ordering
Interval_Type -> Interval_Type -> Interval_Type
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 :: Interval_Type -> Interval_Type -> Interval_Type
$cmin :: Interval_Type -> Interval_Type -> Interval_Type
max :: Interval_Type -> Interval_Type -> Interval_Type
$cmax :: Interval_Type -> Interval_Type -> Interval_Type
>= :: Interval_Type -> Interval_Type -> Bool
$c>= :: Interval_Type -> Interval_Type -> Bool
> :: Interval_Type -> Interval_Type -> Bool
$c> :: Interval_Type -> Interval_Type -> Bool
<= :: Interval_Type -> Interval_Type -> Bool
$c<= :: Interval_Type -> Interval_Type -> Bool
< :: Interval_Type -> Interval_Type -> Bool
$c< :: Interval_Type -> Interval_Type -> Bool
compare :: Interval_Type -> Interval_Type -> Ordering
$ccompare :: Interval_Type -> Interval_Type -> Ordering
Ord,Int -> Interval_Type -> ShowS
[Interval_Type] -> ShowS
Interval_Type -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Interval_Type] -> ShowS
$cshowList :: [Interval_Type] -> ShowS
show :: Interval_Type -> String
$cshow :: Interval_Type -> String
showsPrec :: Int -> Interval_Type -> ShowS
$cshowsPrec :: Int -> Interval_Type -> ShowS
Show)

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

-- | Common music notation interval.  An 'Ordering' of 'LT' indicates
-- an ascending interval, 'GT' a descending interval, and 'EQ' a
-- unison.
data Interval = Interval {Interval -> Interval_Type
interval_type :: Interval_Type
                         ,Interval -> Interval_Quality
interval_quality :: Interval_Quality
                         ,Interval -> Ordering
interval_direction :: Ordering
                         ,Interval -> Int
interval_octave :: T.Octave}
                deriving (Interval -> Interval -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Interval -> Interval -> Bool
$c/= :: Interval -> Interval -> Bool
== :: Interval -> Interval -> Bool
$c== :: Interval -> Interval -> Bool
Eq,Int -> Interval -> ShowS
[Interval] -> ShowS
Interval -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Interval] -> ShowS
$cshowList :: [Interval] -> ShowS
show :: Interval -> String
$cshow :: Interval -> String
showsPrec :: Int -> Interval -> ShowS
$cshowsPrec :: Int -> Interval -> ShowS
Show)

-- | Interval type between 'Note' values.
--
-- > map (interval_ty C) [E,B] == [Third,Seventh]
interval_ty :: T.Note -> T.Note -> Interval_Type
interval_ty :: Note -> Note -> Interval_Type
interval_ty Note
n1 Note
n2 = forall a. Enum a => Int -> a
toEnum ((forall a. Enum a => a -> Int
fromEnum Note
n2 forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Note
n1) forall a. Integral a => a -> a -> a
`mod` Int
7)

-- | Table of interval qualities.  For each 'Interval_Type' gives
-- directed semitone interval counts for each allowable 'Interval_Quality'.
-- For lookup function see 'interval_q', for reverse lookup see
-- 'interval_q_reverse'.
interval_q_tbl :: Integral n => [(Interval_Type, [(n,Interval_Quality)])]
interval_q_tbl :: forall n. Integral n => [(Interval_Type, [(n, Interval_Quality)])]
interval_q_tbl =
    [(Interval_Type
Unison,[(n
11,Interval_Quality
Diminished)
             ,(n
0,Interval_Quality
Perfect)
             ,(n
1,Interval_Quality
Augmented)])
    ,(Interval_Type
Second,[(n
0,Interval_Quality
Diminished)
             ,(n
1,Interval_Quality
Minor)
             ,(n
2,Interval_Quality
Major)
             ,(n
3,Interval_Quality
Augmented)])
    ,(Interval_Type
Third,[(n
2,Interval_Quality
Diminished)
            ,(n
3,Interval_Quality
Minor)
            ,(n
4,Interval_Quality
Major)
            ,(n
5,Interval_Quality
Augmented)])
    ,(Interval_Type
Fourth,[(n
4,Interval_Quality
Diminished)
             ,(n
5,Interval_Quality
Perfect)
             ,(n
6,Interval_Quality
Augmented)])
    ,(Interval_Type
Fifth,[(n
6,Interval_Quality
Diminished)
            ,(n
7,Interval_Quality
Perfect)
            ,(n
8,Interval_Quality
Augmented)])
    ,(Interval_Type
Sixth,[(n
7,Interval_Quality
Diminished)
            ,(n
8,Interval_Quality
Minor)
            ,(n
9,Interval_Quality
Major)
            ,(n
10,Interval_Quality
Augmented)])
    ,(Interval_Type
Seventh,[(n
9,Interval_Quality
Diminished)
              ,(n
10,Interval_Quality
Minor)
              ,(n
11,Interval_Quality
Major)
              ,(n
12,Interval_Quality
Augmented)])]

-- | Lookup 'Interval_Quality' for given 'Interval_Type' and semitone count.
--
-- > interval_q Unison 11 == Just Diminished
-- > interval_q Third 5 == Just Augmented
-- > interval_q Fourth 5 == Just Perfect
-- > interval_q Unison 3 == Nothing
interval_q :: Interval_Type -> Int -> Maybe Interval_Quality
interval_q :: Interval_Type -> Int -> Maybe Interval_Quality
interval_q Interval_Type
i Int
n = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Interval_Type
i forall n. Integral n => [(Interval_Type, [(n, Interval_Quality)])]
interval_q_tbl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
n

-- | Lookup semitone difference of 'Interval_Type' with 'Interval_Quality'.
--
-- > interval_q_reverse Third Minor == Just 3
-- > interval_q_reverse Unison Diminished == Just 11
interval_q_reverse :: Interval_Type -> Interval_Quality -> Maybe Int
interval_q_reverse :: Interval_Type -> Interval_Quality -> Maybe Int
interval_q_reverse Interval_Type
ty Interval_Quality
qu =
    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Interval_Type
ty forall n. Integral n => [(Interval_Type, [(n, Interval_Quality)])]
interval_q_tbl of
      Maybe [(Int, Interval_Quality)]
Nothing -> forall a. Maybe a
Nothing
      Just [(Int, Interval_Quality)]
tbl -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Interval_Quality
qu) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Int, Interval_Quality)]
tbl)

-- | Semitone difference of 'Interval'.
--
-- > interval_semitones (interval (Pitch C Sharp 4) (Pitch E Sharp 5)) == 16
-- > interval_semitones (interval (Pitch C Natural 4) (Pitch D Sharp 3)) == -9
interval_semitones :: Interval -> Int
interval_semitones :: Interval -> Int
interval_semitones (Interval Interval_Type
ty Interval_Quality
qu Ordering
dir Int
oct) =
    case Interval_Type -> Interval_Quality -> Maybe Int
interval_q_reverse Interval_Type
ty Interval_Quality
qu of
      Just Int
n -> let o :: Int
o = Int
12 forall a. Num a => a -> a -> a
* Int
oct
                in if Ordering
dir forall a. Eq a => a -> a -> Bool
== Ordering
GT then forall a. Num a => a -> a
negate Int
n forall a. Num a => a -> a -> a
- Int
o else Int
n forall a. Num a => a -> a -> a
+ Int
o
      Maybe Int
Nothing -> forall a. HasCallStack => String -> a
error String
"interval_semitones"

-- | Determine 'Interval' between two 'Pitch'es.
--
-- > interval (T.Pitch T.C T.Sharp 4) (T.Pitch T.D T.Flat 4) == Interval Second Diminished EQ 0
-- > interval (T.Pitch T.C T.Sharp 4) (T.Pitch T.E T.Sharp 5) == Interval Third Major LT 1
interval :: T.Pitch -> T.Pitch -> Interval
interval :: Pitch -> Pitch -> Interval
interval Pitch
p1 Pitch
p2 =
    let c :: Ordering
c = forall a. Ord a => a -> a -> Ordering
compare Pitch
p1 Pitch
p2
        (T.Pitch Note
n1 Alteration
_ Int
o1) = Pitch
p1
        (T.Pitch Note
n2 Alteration
_ Int
o2) = Pitch
p2
        p1' :: Int
p1' = Pitch -> Int
T.pitch_to_pc Pitch
p1
        p2' :: Int
p2' = Pitch -> Int
T.pitch_to_pc Pitch
p2
        st :: Int
st = (Int
p2' forall a. Num a => a -> a -> a
- Int
p1') forall a. Integral a => a -> a -> a
`mod` Int
12
        ty :: Interval_Type
ty = Note -> Note -> Interval_Type
interval_ty Note
n1 Note
n2
        qu :: Interval_Quality
qu = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"interval?") (Interval_Type -> Int -> Maybe Interval_Quality
interval_q Interval_Type
ty (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
st))
        o_a :: Int
o_a = if Note
n1 forall a. Ord a => a -> a -> Bool
> Note
n2 then -Int
1 else Int
0
    in case Ordering
c of
         Ordering
GT -> (Pitch -> Pitch -> Interval
interval Pitch
p2 Pitch
p1) { interval_direction :: Ordering
interval_direction = Ordering
GT }
         Ordering
_ -> Interval_Type -> Interval_Quality -> Ordering -> Int -> Interval
Interval Interval_Type
ty Interval_Quality
qu Ordering
c (Int
o2 forall a. Num a => a -> a -> a
- Int
o1 forall a. Num a => a -> a -> a
+ Int
o_a)

-- | Apply 'T.ord_invert' to 'interval_direction' of 'Interval'.
--
-- > invert_interval (Interval Third Major LT 1) == Interval Third Major GT 1
invert_interval :: Interval -> Interval
invert_interval :: Interval -> Interval
invert_interval (Interval Interval_Type
t Interval_Quality
qu Ordering
d Int
o) = Interval_Type -> Interval_Quality -> Ordering -> Int -> Interval
Interval Interval_Type
t Interval_Quality
qu (Ordering -> Ordering
T.ord_invert Ordering
d) Int
o

-- | The signed difference in semitones between two 'Interval_Quality'
-- values when applied to the same 'Interval_Type'.  Can this be written
-- correctly without knowing the Interval_Type?
--
-- > quality_difference_m Minor Augmented == Just 2
-- > quality_difference_m Augmented Diminished == Just (-3)
-- > quality_difference_m Major Perfect == Nothing
quality_difference_m :: Interval_Quality -> Interval_Quality -> Maybe Int
quality_difference_m :: Interval_Quality -> Interval_Quality -> Maybe Int
quality_difference_m Interval_Quality
a Interval_Quality
b =
    let rule :: (Interval_Quality, Interval_Quality) -> Maybe a
rule (Interval_Quality
x,Interval_Quality
y) =
            if Interval_Quality
x forall a. Eq a => a -> a -> Bool
== Interval_Quality
y
            then forall a. a -> Maybe a
Just a
0
            else case (Interval_Quality
x,Interval_Quality
y) of
                   (Interval_Quality
Diminished,Interval_Quality
Minor) -> forall a. a -> Maybe a
Just a
1
                   (Interval_Quality
Diminished,Interval_Quality
Major) -> forall a. a -> Maybe a
Just a
2
                   (Interval_Quality
Diminished,Interval_Quality
Augmented) -> forall a. a -> Maybe a
Just a
3
                   (Interval_Quality
Minor,Interval_Quality
Major) -> forall a. a -> Maybe a
Just a
1
                   (Interval_Quality
Minor,Interval_Quality
Augmented) -> forall a. a -> Maybe a
Just a
2
                   (Interval_Quality
Major,Interval_Quality
Augmented) -> forall a. a -> Maybe a
Just a
1
                   (Interval_Quality
Diminished,Interval_Quality
Perfect) -> forall a. a -> Maybe a
Just a
1
                   (Interval_Quality
Perfect,Interval_Quality
Augmented) -> forall a. a -> Maybe a
Just a
1
                   (Interval_Quality, Interval_Quality)
_ -> forall a. Maybe a
Nothing
        fwd :: Maybe Int
fwd = forall {a}.
Num a =>
(Interval_Quality, Interval_Quality) -> Maybe a
rule (Interval_Quality
a,Interval_Quality
b)
        rvs :: Maybe Int
rvs = forall {a}.
Num a =>
(Interval_Quality, Interval_Quality) -> Maybe a
rule (Interval_Quality
b,Interval_Quality
a)
    in case Maybe Int
fwd of
         Just Int
n -> forall a. a -> Maybe a
Just Int
n
         Maybe Int
Nothing -> case Maybe Int
rvs of
                      Just Int
n -> forall a. a -> Maybe a
Just (forall a. Num a => a -> a
negate Int
n)
                      Maybe Int
Nothing -> forall a. Maybe a
Nothing

-- | Erroring variant of 'quality_difference_m'.
quality_difference :: Interval_Quality -> Interval_Quality -> Int
quality_difference :: Interval_Quality -> Interval_Quality -> Int
quality_difference Interval_Quality
a Interval_Quality
b =
    let err :: a
err = forall a. HasCallStack => String -> a
error (String
"quality_difference: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Interval_Quality
a,Interval_Quality
b))
    in forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err (Interval_Quality -> Interval_Quality -> Maybe Int
quality_difference_m Interval_Quality
a Interval_Quality
b)

-- | Transpose a 'Pitch' by an 'Interval'.
--
-- > transpose (Interval Third Diminished LT 0) (Pitch C Sharp 4) == Pitch E Flat 4
pitch_transpose :: Interval -> T.Pitch -> T.Pitch
pitch_transpose :: Interval -> Pitch -> Pitch
pitch_transpose Interval
i Pitch
ip =
    let (T.Pitch Note
p_n Alteration
p_a Int
p_o) = Pitch
ip
        (Interval Interval_Type
i_t Interval_Quality
i_q Ordering
i_d Int
i_o) = Interval
i
        i_d' :: Int
i_d' = if Ordering
i_d forall a. Eq a => a -> a -> Bool
== Ordering
GT
               then -Int
1
               else Int
1
        p_n' :: Note
p_n' = forall a. Enum a => Int -> a
toEnum ((forall a. Enum a => a -> Int
fromEnum Note
p_n forall a. Num a => a -> a -> a
+ (forall a. Enum a => a -> Int
fromEnum Interval_Type
i_t forall a. Num a => a -> a -> a
* Int
i_d')) forall a. Integral a => a -> a -> a
`mod` Int
7)
        -- oa = octave alteration
        oa :: Int
oa = if Note
p_n' forall a. Ord a => a -> a -> Bool
> Note
p_n Bool -> Bool -> Bool
&& Ordering
i_d forall a. Eq a => a -> a -> Bool
== Ordering
GT
             then -Int
1
             else if Note
p_n' forall a. Ord a => a -> a -> Bool
< Note
p_n Bool -> Bool -> Bool
&& Ordering
i_d forall a. Eq a => a -> a -> Bool
== Ordering
LT
                  then Int
1
                  else Int
0
        ip' :: Pitch
ip' = Note -> Alteration -> Int -> Pitch
T.Pitch Note
p_n' Alteration
p_a (Int
p_o forall a. Num a => a -> a -> a
+ Int
i_o forall a. Num a => a -> a -> a
+ Int
oa)
        st :: Int
st = if Ordering
i_d forall a. Eq a => a -> a -> Bool
== Ordering
GT
             then (Pitch -> Int
T.pitch_to_pc Pitch
ip forall a. Num a => a -> a -> a
- Pitch -> Int
T.pitch_to_pc Pitch
ip') forall a. Integral a => a -> a -> a
`mod` Int
12
             else (Pitch -> Int
T.pitch_to_pc Pitch
ip' forall a. Num a => a -> a -> a
- Pitch -> Int
T.pitch_to_pc Pitch
ip) forall a. Integral a => a -> a -> a
`mod` Int
12
        ty :: Interval_Type
ty = if Ordering
i_d forall a. Eq a => a -> a -> Bool
== Ordering
GT
             then Note -> Note -> Interval_Type
interval_ty Note
p_n' Note
p_n
             else Note -> Note -> Interval_Type
interval_ty Note
p_n Note
p_n'
        qu :: Interval_Quality
qu = let err :: a
err = forall a. HasCallStack => String -> a
error (String
"qu: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Interval_Type
ty,Int
st))
             in forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err (Interval_Type -> Int -> Maybe Interval_Quality
interval_q Interval_Type
ty (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
st))
        qd :: Int
qd = Interval_Quality -> Interval_Quality -> Int
quality_difference Interval_Quality
qu Interval_Quality
i_q forall a. Num a => a -> a -> a
* Int
i_d'
        p_a' :: Alteration
p_a' = forall a. Enum a => Int -> a
toEnum (forall a. Enum a => a -> Int
fromEnum Alteration
p_a forall a. Num a => a -> a -> a
+ (Int
qd forall a. Num a => a -> a -> a
* Int
2))
    in Pitch
ip' {alteration :: Alteration
T.alteration = Alteration
p_a'}

-- | Make leftwards (perfect fourth) and and rightwards (perfect
-- fifth) circles from 'Pitch'.
--
-- > let c = circle_of_fifths (Pitch F Sharp 4)
-- > in map pitch_to_pc (snd c) == [6,1,8,3,10,5,12,7,2,9,4,11]
circle_of_fifths :: T.Pitch -> ([T.Pitch], [T.Pitch])
circle_of_fifths :: Pitch -> ([Pitch], [Pitch])
circle_of_fifths Pitch
x =
    let p4 :: Interval
p4 = Interval_Type -> Interval_Quality -> Ordering -> Int -> Interval
Interval Interval_Type
Fourth Interval_Quality
Perfect Ordering
LT Int
0
        p5 :: Interval
p5 = Interval_Type -> Interval_Quality -> Ordering -> Int -> Interval
Interval Interval_Type
Fifth Interval_Quality
Perfect Ordering
LT Int
0
        mk :: Interval -> [Pitch]
mk Interval
y = forall a. Int -> [a] -> [a]
take Int
12 (forall a. (a -> a) -> a -> [a]
iterate (Interval -> Pitch -> Pitch
pitch_transpose Interval
y) Pitch
x)
    in (Interval -> [Pitch]
mk Interval
p4,Interval -> [Pitch]
mk Interval
p5)

-- | Parse a positive integer into interval type and octave
-- displacement.
--
-- > mapMaybe parse_interval_type (map show [1 .. 15])
parse_interval_type :: String -> Maybe (Interval_Type,T.Octave)
parse_interval_type :: String -> Maybe (Interval_Type, Int)
parse_interval_type String
n =
    case forall a. Read a => ReadS a
reads String
n of
      [(Int
n',[])] -> if Int
n' forall a. Eq a => a -> a -> Bool
== Int
0
                   then forall a. Maybe a
Nothing
                   else let (Int
o,Int
t) = (Int
n' forall a. Num a => a -> a -> a
- Int
1) forall a. Integral a => a -> a -> (a, a)
`divMod` Int
7
                        in forall a. a -> Maybe a
Just (forall a. Enum a => Int -> a
toEnum Int
t,forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
o)
      [(Int, String)]
_ -> forall a. Maybe a
Nothing

-- | Parse interval quality notation.
--
-- > mapMaybe parse_interval_quality "dmPMA" == [minBound .. maxBound]
parse_interval_quality :: Char -> Maybe Interval_Quality
parse_interval_quality :: Char -> Maybe Interval_Quality
parse_interval_quality Char
q =
    let c :: [(Char, Int)]
c = forall a b. [a] -> [b] -> [(a, b)]
zip String
"dmPMA" [Int
0..]
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Enum a => Int -> a
toEnum (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
q [(Char, Int)]
c)

-- | Degree of interval type and octave displacement.  Inverse of
-- 'parse_interval_type'.
--
-- > map interval_type_degree [(Third,0),(Second,1),(Unison,2)] == [3,9,15]
interval_type_degree :: (Interval_Type,T.Octave) -> Int
interval_type_degree :: (Interval_Type, Int) -> Int
interval_type_degree (Interval_Type
t,Int
o) = forall a. Enum a => a -> Int
fromEnum Interval_Type
t forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
o forall a. Num a => a -> a -> a
* Int
7)

-- | Inverse of 'parse_interval_quality.
interval_quality_pp :: Interval_Quality -> Char
interval_quality_pp :: Interval_Quality -> Char
interval_quality_pp Interval_Quality
q = String
"dmPMA" forall a. [a] -> Int -> a
!! forall a. Enum a => a -> Int
fromEnum Interval_Quality
q

-- | Parse standard common music interval notation.
--
-- > let i = mapMaybe parse_interval (words "P1 d2 m2 M2 A3 P8 +M9 -M2")
-- > in unwords (map interval_pp i) == "P1 d2 m2 M2 A3 P8 M9 -M2"
--
-- > mapMaybe (fmap interval_octave . parse_interval) (words "d1 d8 d15") == [-1,0,1]
parse_interval :: String -> Maybe Interval
parse_interval :: String -> Maybe Interval
parse_interval String
i =
    let unisons :: [(Interval_Quality, Interval_Type)]
unisons = [(Interval_Quality
Perfect,Interval_Type
Unison)
                  ,(Interval_Quality
Diminished,Interval_Type
Second)
                  ,(Interval_Quality
Augmented,Interval_Type
Seventh)]
        f :: Char -> String -> Maybe Interval
f Char
q String
n = case (Char -> Maybe Interval_Quality
parse_interval_quality Char
q,String -> Maybe (Interval_Type, Int)
parse_interval_type String
n) of
                    (Just Interval_Quality
q',Just (Interval_Type
n',Int
o)) ->
                       let o' :: Int
o' = if (Interval_Quality
q',Interval_Type
n') forall a. Eq a => a -> a -> Bool
== (Interval_Quality
Diminished,Interval_Type
Unison)
                                then Int
o forall a. Num a => a -> a -> a
- Int
1
                                else Int
o
                           d :: Ordering
d = if Int
o' forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& (Interval_Quality
q',Interval_Type
n') forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Interval_Quality, Interval_Type)]
unisons
                               then Ordering
EQ
                               else Ordering
LT
                       in forall a. a -> Maybe a
Just (Interval_Type -> Interval_Quality -> Ordering -> Int -> Interval
Interval Interval_Type
n' Interval_Quality
q' Ordering
d Int
o')
                    (Maybe Interval_Quality, Maybe (Interval_Type, Int))
_ -> forall a. Maybe a
Nothing
    in case String
i of
         Char
'-':Char
q:String
n -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Interval -> Interval
invert_interval (Char -> String -> Maybe Interval
f Char
q String
n)
         Char
'+':Char
q:String
n -> Char -> String -> Maybe Interval
f Char
q String
n
         Char
q:String
n -> Char -> String -> Maybe Interval
f Char
q String
n
         String
_ -> forall a. Maybe a
Nothing

-- | 'error' variant.
parse_interval_err :: String -> Interval
parse_interval_err :: String -> Interval
parse_interval_err = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"parse_interval") forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Interval
parse_interval

-- | Pretty printer for intervals, inverse of 'parse_interval'.
interval_pp :: Interval -> String
interval_pp :: Interval -> String
interval_pp (Interval Interval_Type
n Interval_Quality
q Ordering
d Int
o) =
    let d' :: ShowS
d' = if Ordering
d forall a. Eq a => a -> a -> Bool
== Ordering
GT then (Char
'-' forall a. a -> [a] -> [a]
:) else forall a. a -> a
id
    in ShowS
d' (Interval_Quality -> Char
interval_quality_pp Interval_Quality
q forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show ((Interval_Type, Int) -> Int
interval_type_degree (Interval_Type
n,Int
o)))

-- | Standard names for the intervals within the octave, divided into
-- perfect, major and minor at the left, and diminished and augmented
-- at the right.
--
-- > let {bimap f (p,q) = (f p,f q)
-- >     ;f = mapMaybe (fmap interval_semitones . parse_interval)}
-- > in bimap f std_interval_names
std_interval_names :: ([String],[String])
std_interval_names :: ([String], [String])
std_interval_names =
    let pmM :: String
pmM = String
"P1 m2 M2 m3 M3 P4 P5 m6 M6 m7 M7 P8"
        dA :: String
dA = String
"d2 A1 d3 A2 d4 A3 d5 A4 d6 A5 d7 A6 d8 A7"
    in (String -> [String]
words String
pmM,String -> [String]
words String
dA)