{-# LANGUAGE
    DataKinds
  , DeriveAnyClass
  , 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(..) )
import GHC.Generics
  ( Generic )

-- finitary

import Data.Finitary
  ( Finitary )

-- finite-typelits

import Data.Finite
  ( Finite )

-- groups

import Data.Group
  ( Group(..) )

-- acts

import Data.Act
  ( Act(..), Torsor(..), Finitely(..) )

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

-- * Musical notes

--

-- $notenames

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


-- | Cyclic group of order 7.

type C7 = Sum ( Finite 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, (forall x. NoteName -> Rep NoteName x)
-> (forall x. Rep NoteName x -> NoteName) -> Generic NoteName
forall x. Rep NoteName x -> NoteName
forall x. NoteName -> Rep NoteName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NoteName x -> NoteName
$cfrom :: forall x. NoteName -> Rep NoteName x
Generic )
  deriving anyclass Eq NoteName
KnownNat (Cardinality NoteName)
(Eq NoteName, KnownNat (Cardinality NoteName)) =>
(Finite (Cardinality NoteName) -> NoteName)
-> (NoteName -> Finite (Cardinality NoteName))
-> ((1 <= Cardinality NoteName) => NoteName)
-> ((1 <= Cardinality NoteName) => NoteName)
-> (forall (f :: * -> *). Alternative f => NoteName -> f NoteName)
-> (forall (f :: * -> *). Alternative f => NoteName -> f NoteName)
-> Finitary NoteName
(1 <= Cardinality NoteName) => NoteName
Finite (Cardinality NoteName) -> NoteName
NoteName -> Finite (Cardinality NoteName)
forall a.
(Eq a, KnownNat (Cardinality a)) =>
(Finite (Cardinality a) -> a)
-> (a -> Finite (Cardinality a))
-> ((1 <= Cardinality a) => a)
-> ((1 <= Cardinality a) => a)
-> (forall (f :: * -> *). Alternative f => a -> f a)
-> (forall (f :: * -> *). Alternative f => a -> f a)
-> Finitary a
forall (f :: * -> *). Alternative f => NoteName -> f NoteName
next :: NoteName -> f NoteName
$cnext :: forall (f :: * -> *). Alternative f => NoteName -> f NoteName
previous :: NoteName -> f NoteName
$cprevious :: forall (f :: * -> *). Alternative f => NoteName -> f NoteName
end :: NoteName
$cend :: (1 <= Cardinality NoteName) => NoteName
start :: NoteName
$cstart :: (1 <= Cardinality NoteName) => NoteName
toFinite :: NoteName -> Finite (Cardinality NoteName)
$ctoFinite :: NoteName -> Finite (Cardinality NoteName)
fromFinite :: Finite (Cardinality NoteName) -> NoteName
$cfromFinite :: Finite (Cardinality NoteName) -> NoteName
$cp2Finitary :: KnownNat (Cardinality NoteName)
$cp1Finitary :: Eq NoteName
Finitary
  deriving ( Act C7, Torsor C7 )
    via Finitely NoteName

-- $deriving1

-- In this case we used @DerivingVia@ to derive the action of @C7@

-- through the 'Finitary' instance of 'NoteName' by using the 'Finitely' newtype.


-- | 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
Monoid Alteration =>
(Alteration -> Alteration)
-> (forall x. Integral x => Alteration -> x -> Alteration)
-> Group Alteration
Alteration -> Alteration
Alteration -> x -> Alteration
forall x. Integral x => Alteration -> x -> Alteration
forall m.
Monoid m =>
(m -> m) -> (forall x. Integral x => m -> x -> m) -> Group m
pow :: Alteration -> x -> Alteration
$cpow :: forall x. Integral x => Alteration -> x -> Alteration
invert :: Alteration -> Alteration
$cinvert :: 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

--

-- > > invert ( 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 ival :: 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 0 ) of
  Note n :: NoteName
n a :: Alteration
a o :: Int
o -> 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 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
>= 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 steps :: Sum Int
steps _ ) = ( 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 ( i :: Sum Int
i, Sum a :: 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
  iv1 :: Interval
iv1 <> :: Interval -> Interval -> Interval
<> iv2 :: 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
  invert :: Interval -> Interval
invert = (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 m. Group m => m -> m
invert ((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 steps :: Int
steps ) a :: Alteration
a ) ( Note C a' :: Alteration
a' o :: Int
o ) = NoteName -> Alteration -> Int -> Note
Note ( C7 -> NoteName -> NoteName
forall s x. Act s x => s -> x -> x
act ( Int -> C7
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r :: C7 ) 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
      q, r :: Int
      ( q :: Int
q, r :: Int
r ) = Int
steps Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 7
  act ival :: Interval
ival note :: 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 0 Note -> Note -> Interval
forall g x. Torsor g x => x -> x -> g
--> Note
note ) ) ( NoteName -> Alteration -> Int -> Note
Note NoteName
C Alteration
Natural 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 C a :: Alteration
a o :: Int
o --> :: Note -> Note -> Interval
--> Note n :: NoteName
n a' :: Alteration
a' o' :: 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
+ 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' )
  note1 :: Note
note1 --> note2 :: Note
note2 = ( NoteName -> Alteration -> Int -> Note
Note NoteName
C Alteration
Natural 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 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 3 Alteration
Natural, Int -> Alteration -> Interval
Interval 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 3 Alteration
Flat, Int -> Alteration -> Interval
Interval 5 Alteration
Flat, Int -> Alteration -> Interval
Interval 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 5 Alteration
Natural, Int -> Alteration -> Interval
Interval 9 Alteration
Natural
            , Int -> Alteration -> Interval
Interval 10 Alteration
Flat, Int -> Alteration -> Interval
Interval 14 Alteration
Flat, Int -> Alteration -> Interval
Interval 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 root :: NoteName
root =
  ((NoteName, Int) -> Interval) -> [(NoteName, Int)] -> [Interval]
forall a b. (a -> b) -> [a] -> [b]
map
    ( \ ( n :: NoteName
n, i :: Int
i ) -> NoteName -> Alteration -> Int -> Note
Note NoteName
root Alteration
Natural 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 ( , 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 ( , 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 2 Alteration
Natural, Int -> Alteration -> Interval
Interval 2 Alteration
Natural, Int -> Alteration -> Interval
Interval 2 Alteration
Natural, Int -> Alteration -> Interval
Interval 3 Alteration
DoubleFlat, Int -> Alteration -> Interval
Interval 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 i :: 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
>= 0 = '#'
        | Bool
otherwise = 'b'

instance Show Note where
  show :: Note -> String
show ( Note n :: NoteName
n alt :: Alteration
alt oct :: 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 i :: Int
i a :: Alteration
a = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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
+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
-1) ) Alteration
a

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

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

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

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