{-# LANGUAGE
    DataKinds
  , DeriveGeneric
  , DerivingVia
  , MultiParamTypeClasses
  , PatternSynonyms
  , TupleSections
  , TypeApplications
  , ViewPatterns
#-}

{-# OPTIONS_HADDOCK ignore-exports #-}

{-|
Module: Acts.MusicalIntervals

Illustrative usage of 'Group', 'Act' and 'Torsor': manipulation of musical intervals.


The musical distance between two musical notes is a musical interval.

Intervals can be compounded and inverted, so they form a 'Group'.

Notes can be translated by a given interval, which is an 'Act' of intervals on notes.

There's a unique musical interval taking any note to any other given one, so notes are a torsor under intervals.


This functionality is useful in providing enharmonically correct voicings of chords.
-}

module Acts.Examples.MusicalIntervals where

-- base

import Data.Monoid
  ( Sum(..) )

-- acts

import Data.Act
import Data.Group
import Data.Group.Cyclic

-----------------------------------------------------------------

-- * Musical notes

--

-- $notenames

-- We begin by defining note names, which are acted upon by the cyclic group of order 7.


-- | Musical note names.

--

-- The enumeration starts with @C@ to conform with scientific pitch notation.

data NoteName = C | D | E | F | G | A | B
  deriving stock ( NoteName -> NoteName -> Bool
(NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> Bool) -> Eq NoteName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteName -> NoteName -> Bool
$c/= :: NoteName -> NoteName -> Bool
== :: NoteName -> NoteName -> Bool
$c== :: NoteName -> NoteName -> Bool
Eq, Eq NoteName
Eq NoteName
-> (NoteName -> NoteName -> Ordering)
-> (NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> Bool)
-> (NoteName -> NoteName -> NoteName)
-> (NoteName -> NoteName -> NoteName)
-> Ord NoteName
NoteName -> NoteName -> Bool
NoteName -> NoteName -> Ordering
NoteName -> NoteName -> NoteName
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 :: NoteName -> NoteName -> NoteName
$cmin :: NoteName -> NoteName -> NoteName
max :: NoteName -> NoteName -> NoteName
$cmax :: NoteName -> NoteName -> NoteName
>= :: NoteName -> NoteName -> Bool
$c>= :: NoteName -> NoteName -> Bool
> :: NoteName -> NoteName -> Bool
$c> :: NoteName -> NoteName -> Bool
<= :: NoteName -> NoteName -> Bool
$c<= :: NoteName -> NoteName -> Bool
< :: NoteName -> NoteName -> Bool
$c< :: NoteName -> NoteName -> Bool
compare :: NoteName -> NoteName -> Ordering
$ccompare :: NoteName -> NoteName -> Ordering
$cp1Ord :: Eq NoteName
Ord, Int -> NoteName -> ShowS
[NoteName] -> ShowS
NoteName -> String
(Int -> NoteName -> ShowS)
-> (NoteName -> String) -> ([NoteName] -> ShowS) -> Show NoteName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteName] -> ShowS
$cshowList :: [NoteName] -> ShowS
show :: NoteName -> String
$cshow :: NoteName -> String
showsPrec :: Int -> NoteName -> ShowS
$cshowsPrec :: Int -> NoteName -> ShowS
Show, Int -> NoteName
NoteName -> Int
NoteName -> [NoteName]
NoteName -> NoteName
NoteName -> NoteName -> [NoteName]
NoteName -> NoteName -> NoteName -> [NoteName]
(NoteName -> NoteName)
-> (NoteName -> NoteName)
-> (Int -> NoteName)
-> (NoteName -> Int)
-> (NoteName -> [NoteName])
-> (NoteName -> NoteName -> [NoteName])
-> (NoteName -> NoteName -> [NoteName])
-> (NoteName -> NoteName -> NoteName -> [NoteName])
-> Enum NoteName
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 :: NoteName -> NoteName -> NoteName -> [NoteName]
$cenumFromThenTo :: NoteName -> NoteName -> NoteName -> [NoteName]
enumFromTo :: NoteName -> NoteName -> [NoteName]
$cenumFromTo :: NoteName -> NoteName -> [NoteName]
enumFromThen :: NoteName -> NoteName -> [NoteName]
$cenumFromThen :: NoteName -> NoteName -> [NoteName]
enumFrom :: NoteName -> [NoteName]
$cenumFrom :: NoteName -> [NoteName]
fromEnum :: NoteName -> Int
$cfromEnum :: NoteName -> Int
toEnum :: Int -> NoteName
$ctoEnum :: Int -> NoteName
pred :: NoteName -> NoteName
$cpred :: NoteName -> NoteName
succ :: NoteName -> NoteName
$csucc :: NoteName -> NoteName
Enum, NoteName
NoteName -> NoteName -> Bounded NoteName
forall a. a -> a -> Bounded a
maxBound :: NoteName
$cmaxBound :: NoteName
minBound :: NoteName
$cminBound :: NoteName
Bounded )
  deriving ( Act ( C 7 ), Torsor ( C 7 ) )
    via CyclicEnum NoteName

-- $deriving1

-- In this case we used @DerivingVia@ to derive the action of @C 7@,

-- using the 'CyclicEnum' newtype created for this exact purpose.


-- | Alterations, i.e. sharps and flats.

--

-- Pattern synonyms such as 'Sharp' and 'Flat' are also bundled.

newtype Alteration = Alteration { Alteration -> Int
getAlteration :: Int }
  deriving ( b -> Alteration -> Alteration
NonEmpty Alteration -> Alteration
Alteration -> Alteration -> Alteration
(Alteration -> Alteration -> Alteration)
-> (NonEmpty Alteration -> Alteration)
-> (forall b. Integral b => b -> Alteration -> Alteration)
-> Semigroup Alteration
forall b. Integral b => b -> Alteration -> Alteration
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Alteration -> Alteration
$cstimes :: forall b. Integral b => b -> Alteration -> Alteration
sconcat :: NonEmpty Alteration -> Alteration
$csconcat :: NonEmpty Alteration -> Alteration
<> :: Alteration -> Alteration -> Alteration
$c<> :: Alteration -> Alteration -> Alteration
Semigroup, Semigroup Alteration
Alteration
Semigroup Alteration
-> Alteration
-> (Alteration -> Alteration -> Alteration)
-> ([Alteration] -> Alteration)
-> Monoid Alteration
[Alteration] -> Alteration
Alteration -> Alteration -> Alteration
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Alteration] -> Alteration
$cmconcat :: [Alteration] -> Alteration
mappend :: Alteration -> Alteration -> Alteration
$cmappend :: Alteration -> Alteration -> Alteration
mempty :: Alteration
$cmempty :: Alteration
$cp1Monoid :: Semigroup Alteration
Monoid, Monoid Alteration
n -> Alteration -> Alteration
Monoid Alteration
-> (Alteration -> Alteration)
-> (forall b. Integral b => b -> Alteration -> Alteration)
-> Group Alteration
Alteration -> Alteration
forall b. Integral b => b -> Alteration -> Alteration
forall g.
Monoid g
-> (g -> g) -> (forall n. Integral n => n -> g -> g) -> Group g
gtimes :: n -> Alteration -> Alteration
$cgtimes :: forall b. Integral b => b -> Alteration -> Alteration
inverse :: Alteration -> Alteration
$cinverse :: Alteration -> Alteration
$cp1Group :: Monoid Alteration
Group )
    via Sum Int

-- $deriving2

-- Note the use of @DerivingVia@ to transfer algebraic operations from @Sum Int@.

-- 

-- For non-newtypes, one can use generics, for example:

--

-- > data Klein4 = Klein4 ( C 2 ) ( C 2 )

-- >   deriving stock Generic

-- >   deriving ( Semigroup, Monoid, Group )

-- >     via Generically Klein4

--

-- This uses the 'Generically' newtype from the @generic-data@ library.


-- | Note names such as @A4@ or @C#6@: note name, alteration, and octave (scientific pitch notation).

data Note = Note { Note -> NoteName
name :: NoteName, Note -> Alteration
alteration :: Alteration, Note -> Int
octave :: Int }

-----------------------------------------------------------------

-- * Musical intervals

--

-- $intervals

-- An interval is represented as a number of scale steps to take (relative to the major scale),

-- together with an additional alteration to apply.

--

-- For instance, a major third is two steps up (diatonic steps relative to the root in a major scale):

--

-- > > Steps ( Sum 2 ) Natural

-- > major 3rd up

--

-- A minor sixth is 5 steps up, and then a flat:

--

-- > > Steps ( Sum 5 ) Flat

-- > minor 6th up

--

-- The smart constructor 'Interval' is also provided that is more intuitive to use:

--

-- > > Interval 3 Natural

-- > major 3rd up

--

-- > > Interval 7 Flat

-- > minor 7th up

--

-- Note that the @Semigroup@/@Group@ operations on intervals are __not__ the obvious ones, e.g.:

--

-- > > Steps ( Sum 2 ) Natural

-- > major 3rd up

--

-- > > Steps ( Sum (-2) ) Natural

-- > minor 3rd down

--

-- > > inverse ( Steps ( Sum 2 ) Natural )

-- > Steps ( Sum (-2) ) Flat

-- > major 3rd down


-- | Musical interval: steps (relative to the root in a major scale) and additional alteration.

data Interval = Steps { Interval -> Sum Int
intervalSteps :: Sum Int, Interval -> Alteration
intervalAlteration :: Alteration }

-- | Compute the number of semitones in an interval, using the reference of the C major scale.

semitones :: Interval -> Int
semitones :: Interval -> Int
semitones Interval
ival = case Interval -> Note -> Note
forall s x. Act s x => s -> x -> x
act Interval
ival ( NoteName -> Alteration -> Int -> Note
Note NoteName
C Alteration
Natural Int
0 ) of
  Note NoteName
n Alteration
a Int
o -> Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Alteration -> Int
getAlteration Alteration
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
majorValue
    where
      majorValue :: Int
majorValue = let i :: Int
i = NoteName -> Int
forall a. Enum a => a -> Int
fromEnum NoteName
n in Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Bool -> Int
forall a. Enum a => a -> Int
fromEnum ( Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 )

-- $interval_operations

-- To define algebraic operations on intervals,

-- we use an equivariant bijection to the product group @( Sum Int, Sum Int )@.

--

-- Note that @( Sum Int, Sum Int )@ is automatically a 'Semigroup', 'Monoid' and 'Group'

-- using the product structure.


-- | Forward part of the bijection.

straighten :: Interval -> ( Sum Int, Sum Int )
straighten :: Interval -> (Sum Int, Sum Int)
straighten ival :: Interval
ival@( Steps Sum Int
steps Alteration
_ ) = ( Sum Int
steps, Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> Int -> Sum Int
forall a b. (a -> b) -> a -> b
$ Interval -> Int
semitones Interval
ival )
-- | Back part of the bijection.

twist :: ( Sum Int, Sum Int ) -> Interval
twist :: (Sum Int, Sum Int) -> Interval
twist ( Sum Int
i, Sum Int
a ) = Sum Int -> Alteration -> Interval
Steps Sum Int
i ( Int -> Alteration
Alteration ( Interval -> Int
semitones ( Sum Int -> Alteration -> Interval
Steps Sum Int
i Alteration
forall a. Monoid a => a
mempty ) ) Alteration -> Alteration -> Alteration
forall g x. Torsor g x => x -> x -> g
--> Int -> Alteration
Alteration Int
a )

instance Semigroup Interval where
  Interval
iv1 <> :: Interval -> Interval -> Interval
<> Interval
iv2 = (Sum Int, Sum Int) -> Interval
twist ( Interval -> (Sum Int, Sum Int)
straighten Interval
iv1 (Sum Int, Sum Int) -> (Sum Int, Sum Int) -> (Sum Int, Sum Int)
forall a. Semigroup a => a -> a -> a
<> Interval -> (Sum Int, Sum Int)
straighten Interval
iv2 )
instance Monoid Interval where
  mempty :: Interval
mempty = Sum Int -> Alteration -> Interval
Steps Sum Int
forall a. Monoid a => a
mempty Alteration
forall a. Monoid a => a
mempty
instance Group Interval where
  inverse :: Interval -> Interval
inverse = (Sum Int, Sum Int) -> Interval
twist ((Sum Int, Sum Int) -> Interval)
-> (Interval -> (Sum Int, Sum Int)) -> Interval -> Interval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sum Int, Sum Int) -> (Sum Int, Sum Int)
forall g. Group g => g -> g
inverse ((Sum Int, Sum Int) -> (Sum Int, Sum Int))
-> (Interval -> (Sum Int, Sum Int))
-> Interval
-> (Sum Int, Sum Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interval -> (Sum Int, Sum Int)
straighten

-- | Intervallically correct action of intervals on notes.

--

--  * minor third up from @C@: @Eb@

--  * minor third up from @A@: @C@.

instance Act Interval Note where
  act :: Interval -> Note -> Note
act ( Steps ( Sum Int
steps ) Alteration
a ) ( Note NoteName
C Alteration
a' Int
o ) = NoteName -> Alteration -> Int -> Note
Note ( C 7 -> NoteName -> NoteName
forall s x. Act s x => s -> x -> x
act ( Int -> C 7
forall (n :: Nat). KnownNat n => Int -> Cyclic n
Cyclic @7 Int
r ) NoteName
C ) ( Alteration
a Alteration -> Alteration -> Alteration
forall a. Semigroup a => a -> a -> a
<> Alteration
a' ) ( Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
o )
    where
      ( Int
q, Int
r ) = Int
steps Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
7
  act Interval
ival Note
note = Interval -> Note -> Note
forall s x. Act s x => s -> x -> x
act ( Interval
ival Interval -> Interval -> Interval
forall a. Semigroup a => a -> a -> a
<> ( NoteName -> Alteration -> Int -> Note
Note NoteName
C Alteration
Natural Int
0 Note -> Note -> Interval
forall g x. Torsor g x => x -> x -> g
--> Note
note ) ) ( NoteName -> Alteration -> Int -> Note
Note NoteName
C Alteration
Natural Int
0 )

-- | Computes the interval between two notes.

--

-- > > Note C Natural 5 --> Note A Natural 4

-- > minor 3rd down

--

-- > > Note E Flat 4 --> Note A Natural 5

-- > augmented 11th up

instance Torsor Interval Note where
  Note NoteName
C Alteration
a Int
o --> :: Note -> Note -> Interval
--> Note NoteName
n Alteration
a' Int
o' = Sum Int -> Alteration -> Interval
Steps ( Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> Int -> Sum Int
forall a b. (a -> b) -> a -> b
$ NoteName -> Int
forall a. Enum a => a -> Int
fromEnum NoteName
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
o' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
o) ) ( Alteration
a Alteration -> Alteration -> Alteration
forall g x. Torsor g x => x -> x -> g
--> Alteration
a' )
  Note
note1 --> Note
note2 = ( NoteName -> Alteration -> Int -> Note
Note NoteName
C Alteration
Natural Int
0 Note -> Note -> Interval
forall g x. Torsor g x => x -> x -> g
--> Note
note1 :: Interval ) Interval -> Interval -> Interval
forall g x. Torsor g x => x -> x -> g
--> ( NoteName -> Alteration -> Int -> Note
Note NoteName
C Alteration
Natural Int
0 Note -> Note -> Interval
forall g x. Torsor g x => x -> x -> g
--> Note
note2 :: Interval )

-----------------------------------------------------------------

-- * Illustration of the functionality


-- ** Chords


-- | Major triad: major third, perfect fifth.

majorTriad :: [ Interval ]
majorTriad :: [Interval]
majorTriad = [ Interval
forall a. Monoid a => a
mempty, Int -> Alteration -> Interval
Interval Int
3 Alteration
Natural, Int -> Alteration -> Interval
Interval Int
5 Alteration
Natural ]

-- | Diminished seventh chord: minor third, diminished fifth, diminished seventh.

diminished7th :: [ Interval ]
diminished7th :: [Interval]
diminished7th = [ Interval
forall a. Monoid a => a
mempty, Int -> Alteration -> Interval
Interval Int
3 Alteration
Flat, Int -> Alteration -> Interval
Interval Int
5 Alteration
Flat, Int -> Alteration -> Interval
Interval Int
7 Alteration
DoubleFlat ]

-- | Minor 11th chord (Kenny Barron voicing).

minor11th :: [ Interval ]
minor11th :: [Interval]
minor11th = [ Interval
forall a. Monoid a => a
mempty, Int -> Alteration -> Interval
Interval Int
5 Alteration
Natural, Int -> Alteration -> Interval
Interval Int
9 Alteration
Natural
            , Int -> Alteration -> Interval
Interval Int
10 Alteration
Flat, Int -> Alteration -> Interval
Interval Int
14 Alteration
Flat, Int -> Alteration -> Interval
Interval Int
18 Alteration
Natural
            ]

-- $chords

-- Example chords:

--

-- > > majorTriad <&> ( • Note C Natural 4 )

-- > [C4,E4,G4]

-- 

-- > > diminished7th <&> ( • Note G Sharp 3 )

-- > [G#3,B3,D4,F4]

--

-- > > minor11th <&> ( • Note D Natural 3 )

-- > [D3,A3,E4,F4,C5,G5]


-- ** Scales


-- | Modes of C major.

mode :: NoteName -> [ Interval ]
mode :: NoteName -> [Interval]
mode NoteName
root =
  ((NoteName, Int) -> Interval) -> [(NoteName, Int)] -> [Interval]
forall a b. (a -> b) -> [a] -> [b]
map
    ( \ ( NoteName
n, Int
i ) -> NoteName -> Alteration -> Int -> Note
Note NoteName
root Alteration
Natural Int
0 Note -> Note -> Interval
forall g x. Torsor g x => x -> x -> g
--> NoteName -> Alteration -> Int -> Note
Note NoteName
n Alteration
Natural Int
i )
    ( (NoteName -> (NoteName, Int)) -> [NoteName] -> [(NoteName, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ( , Int
0 ) [ NoteName
root .. NoteName
forall a. Bounded a => a
maxBound ] [(NoteName, Int)] -> [(NoteName, Int)] -> [(NoteName, Int)]
forall a. [a] -> [a] -> [a]
++ (NoteName -> (NoteName, Int)) -> [NoteName] -> [(NoteName, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ( , Int
1 ) [ NoteName
forall a. Bounded a => a
minBound .. NoteName
root ] )

-- | Phrygian scale.

phrygian :: [ Interval ]
phrygian :: [Interval]
phrygian = NoteName -> [Interval]
mode NoteName
E

-- | Lydian scale.

lydian :: [ Interval ]
lydian :: [Interval]
lydian = NoteName -> [Interval]
mode NoteName
F

-- | Whole tone scale.

wholeTone :: [ Interval ]
wholeTone :: [Interval]
wholeTone = (Interval -> Interval -> Interval)
-> Interval -> [Interval] -> [Interval]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Interval -> Interval -> Interval
forall a. Semigroup a => a -> a -> a
(<>) Interval
forall a. Monoid a => a
mempty
  [ Int -> Alteration -> Interval
Interval Int
2 Alteration
Natural, Int -> Alteration -> Interval
Interval Int
2 Alteration
Natural, Int -> Alteration -> Interval
Interval Int
2 Alteration
Natural, Int -> Alteration -> Interval
Interval Int
3 Alteration
DoubleFlat, Int -> Alteration -> Interval
Interval Int
2 Alteration
Natural ]

-- $scales

-- Example scales:

--

-- > > phrygian <&> ( • Note E Natural 3 )

-- > [E3,F3,G3,A3,B3,C4,D4,E4]

--

-- > > phrygian <&> ( • Note C Sharp 3 )

-- > [C#3,D3,E3,F#3,G#3,A3,B3,C#4]

--

-- > > lydian <&> ( • Note C Natural 4 )

-- > [C4,D4,E4,F#4,G4,A4,B4,C5]

--

-- > > wholeTone <&> ( • Note G Natural 5 )

-- > [G5,A5,B5,C#6,Eb6,F6]


---------------------------------------------------

-- * Helper code

-- $end

-- End of main example code.

--

-- Follows: helper code for reading/showing musical notes and intervals.


pattern Natural :: Alteration
pattern $bNatural :: Alteration
$mNatural :: forall r. Alteration -> (Void# -> r) -> (Void# -> r) -> r
Natural = Alteration 0
pattern Flat :: Alteration
pattern $bFlat :: Alteration
$mFlat :: forall r. Alteration -> (Void# -> r) -> (Void# -> r) -> r
Flat = Alteration (-1)
pattern DoubleFlat :: Alteration
pattern $bDoubleFlat :: Alteration
$mDoubleFlat :: forall r. Alteration -> (Void# -> r) -> (Void# -> r) -> r
DoubleFlat = Alteration (-2)
pattern Sharp :: Alteration
pattern $bSharp :: Alteration
$mSharp :: forall r. Alteration -> (Void# -> r) -> (Void# -> r) -> r
Sharp = Alteration 1
pattern DoubleSharp :: Alteration
pattern $bDoubleSharp :: Alteration
$mDoubleSharp :: forall r. Alteration -> (Void# -> r) -> (Void# -> r) -> r
DoubleSharp = Alteration 2

instance Show Alteration where
  show :: Alteration -> String
show ( Alteration Int
i ) = Int -> Char -> String
forall a. Int -> a -> [a]
replicate ( Int -> Int
forall a. Num a => a -> a
abs Int
i ) Char
accidental
    where
      accidental :: Char
      accidental :: Char
accidental
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = Char
'#'
        | Bool
otherwise = Char
'b'

instance Show Note where
  show :: Note -> String
show ( Note NoteName
n Alteration
alt Int
oct ) = NoteName -> String
forall a. Show a => a -> String
show NoteName
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Alteration -> String
forall a. Show a => a -> String
show Alteration
alt String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
oct

pattern Interval :: Int -> Alteration -> Interval
pattern $bInterval :: Int -> Alteration -> Interval
$mInterval :: forall r. Interval -> (Int -> Alteration -> r) -> (Void# -> r) -> r
Interval i a <-
  ( ( \ ( Steps ( Sum steps ) alt ) -> ( if steps >= 0 then steps + 1 else steps - 1, alt ) )
  -> (i, a)
  )
  where
    Interval Int
i Alteration
a = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Sum Int -> Alteration -> Interval
Steps ( Int -> Sum Int
forall a. a -> Sum a
Sum (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ) Alteration
a else Sum Int -> Alteration -> Interval
Steps ( Int -> Sum Int
forall a. a -> Sum a
Sum (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ) Alteration
a

instance Show Interval where
  show :: Interval -> String
show ival :: Interval
ival@( Steps ( Sum Int
i ) Alteration
_ )
    | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
7
    , let
        ivalName :: String
ivalName = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
i Int
0 of
          Ordering
LT -> String
"octave down"
          Ordering
GT -> String
"octave up"
          Ordering
EQ -> String
"unison"
    = if Interval -> String
quality Interval
ival String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"perfect"
      then String
ivalName
      else Interval -> String
quality Interval
ival String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ivalName
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
    = Interval -> String
quality ( Interval -> Interval
forall g. Group g => g -> g
inverse Interval
ival ) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
showOrdinal (-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" down"
    | Bool
otherwise
    = Interval -> String
quality Interval
ival String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
showOrdinal (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" up"

quality :: Interval -> String
quality :: Interval -> String
quality ( Steps ( Sum Int
i ) ( Alteration Int
a ) )
  | ( Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7 ) Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Int
0, Int
3, Int
4 ]
  = case Int
a of
      Int
0 -> String
"perfect"
      Int
_ -> 
        if Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then Int -> String
multiplicity   Int
a  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"augmented"
        else Int -> String
multiplicity (-Int
a) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"diminished"
  | Bool
otherwise
  = case Int
a of
      Int
0    -> String
"major"
      (-1) -> String
"minor"
      Int
_    -> 
        if Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then Int -> String
multiplicity   Int
a    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"augmented"
        else Int -> String
multiplicity (-Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"diminished"

showOrdinal :: Int -> String
showOrdinal :: Int -> String
showOrdinal Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
  = String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
showOrdinal ( Int -> Int
forall a. Num a => a -> a
abs Int
i )
  | Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
11
  = Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"st"
  | Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
12
  = Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"nd"
  | Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
13
  = Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"rd"
  | Bool
otherwise
  = Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"th"

multiplicity :: Int -> String
multiplicity :: Int -> String
multiplicity Int
1 = String
""
multiplicity Int
2 = String
"doubly "
multiplicity Int
3 = String
"triply "
multiplicity Int
4 = String
"quadruply "
multiplicity Int
5 = String
"quintuply "
multiplicity Int
6 = String
"sextuply "
multiplicity Int
7 = String
"heptuply "
multiplicity Int
n = Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-tuply "