{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-|
Module: Musicology.Pitch.Spelled
Description: Spelled pitch and interval types (Western notation).
Copyright: Christoph Finkensiep, 2021
License: BSD
Maintainer: chfin@chfin.de
Stability: experimental

This module defines pitch and interval types for spelled pitch, i.e. Western notation.
-}
module Musicology.Pitch.Spelled
  ( -- * Interval Types
    SInterval(..)
  , spelled
  , spelledDiaChrom
  , SIC(..)
  , sic
  -- * Pitch Types
  , SPitch
  , SPC
  , spelledp
  , spc
  -- * Common Accessors
  , Spelled(..)
  , letter
  -- * Concrete Intervals
  --
  -- | Concrete intervals come in two variants,
  -- one for intervals (e.g. 'fifth') and one for interval classes ('fifth'').
  -- Imperfect intervals have a 'ImperfectInterval' type
  -- and must be used with 'major' or 'minor' (e.g. @'minor' 'third'@).
  -- All (fully applied) intervals can be used with 'aug', 'dim' and 'down'
  , second
  , third
  , fourth
  , tritone
  , fifth
  , sixth
  , seventh
  , second'
  , third'
  , fourth'
  , tritone'
  , fifth'
  , sixth'
  , seventh'
  -- * Concrete pitches
  --
  -- | Concrete pitches are constructed from an accidental ('flt', 'nat', or 'shp')
  -- and (for non-class pitches) and octave number.
  , Accidental(..)
  , flt
  , nat
  , shp
  , c
  , d
  , e
  , f
  , g
  , a
  , b
  , c'
  , d'
  , e'
  , f'
  , g'
  , a'
  , b'
  )
where

import           Musicology.Pitch.Class
import           Musicology.Pitch.Internal

import           GHC.Generics                   ( Generic )
import           Data.Aeson                     ( FromJSON
                                                , ToJSON
                                                )
import           Control.DeepSeq                ( NFData )
import qualified Text.ParserCombinators.ReadP  as R
import           Control.Applicative            ( (<|>) )
import           Data.Char                      ( ord
                                                , chr
                                                )
import Data.Hashable (Hashable)

-- Spelled Interval
-------------------

-- helpers

isPerfect :: Int -> Bool
isPerfect :: Int -> Bool
isPerfect Int
0 = Bool
True
isPerfect Int
3 = Bool
True
isPerfect Int
4 = Bool
True
isPerfect Int
_ = Bool
False

accstr :: Int -> Char -> Char -> String
accstr Int
0 Char
_ Char
_ = String
""
accstr Int
n Char
u Char
d | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0     = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
u
             | Bool
otherwise = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int
forall a. Num a => a -> a
abs Int
n) Char
d
qualpf :: Int -> a -> a -> a -> [a]
qualpf Int
n a
a a
p a
d | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0     = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
n a
a
               | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = [a
p]
               | Bool
otherwise = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate (-Int
n) a
d
qualimpf :: Int -> a -> a -> a -> a -> [a]
qualimpf Int
n a
a a
mj a
mn a
d | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0     = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
n a
a
                     | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = [a
mj]
                     | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (-Int
1) = [a
mn]
                     | Bool
otherwise = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate ((-Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) a
d

fifths2degree :: Int -> Int
fifths2degree :: Int -> Int
fifths2degree Int
fifths = Int
fifths Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7

-- accessor class (for SInterval and SIC)

class Spelled i where
  fifths :: i -> Int
  octaves :: i -> Int
  internalOctaves :: i -> Int
  degree :: i -> Int
  generic :: i -> Int
  diasteps :: i -> Int
  alteration :: i -> Int

data SInterval = SInterval
                 { SInterval -> Int
siFifths :: Int
                 , SInterval -> Int
siOctaves :: Int
                 }
  deriving (SInterval -> SInterval -> Bool
(SInterval -> SInterval -> Bool)
-> (SInterval -> SInterval -> Bool) -> Eq SInterval
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SInterval -> SInterval -> Bool
== :: SInterval -> SInterval -> Bool
$c/= :: SInterval -> SInterval -> Bool
/= :: SInterval -> SInterval -> Bool
Eq, (forall x. SInterval -> Rep SInterval x)
-> (forall x. Rep SInterval x -> SInterval) -> Generic SInterval
forall x. Rep SInterval x -> SInterval
forall x. SInterval -> Rep SInterval x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SInterval -> Rep SInterval x
from :: forall x. SInterval -> Rep SInterval x
$cto :: forall x. Rep SInterval x -> SInterval
to :: forall x. Rep SInterval x -> SInterval
Generic, Int -> SInterval -> ShowS
[SInterval] -> ShowS
SInterval -> String
(Int -> SInterval -> ShowS)
-> (SInterval -> String)
-> ([SInterval] -> ShowS)
-> Show SInterval
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SInterval -> ShowS
showsPrec :: Int -> SInterval -> ShowS
$cshow :: SInterval -> String
show :: SInterval -> String
$cshowList :: [SInterval] -> ShowS
showList :: [SInterval] -> ShowS
Show, SInterval -> ()
(SInterval -> ()) -> NFData SInterval
forall a. (a -> ()) -> NFData a
$crnf :: SInterval -> ()
rnf :: SInterval -> ()
NFData, Eq SInterval
Eq SInterval =>
(Int -> SInterval -> Int)
-> (SInterval -> Int) -> Hashable SInterval
Int -> SInterval -> Int
SInterval -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> SInterval -> Int
hashWithSalt :: Int -> SInterval -> Int
$chash :: SInterval -> Int
hash :: SInterval -> Int
Hashable)

-- smart constructors

spelled :: Int -> Int -> SInterval
spelled :: Int -> Int -> SInterval
spelled = Int -> Int -> SInterval
SInterval

wholetone :: SInterval
wholetone = Int -> Int -> SInterval
spelled Int
2 (-Int
1)

onlyDia :: Int -> SInterval
onlyDia Int
x = SInterval
wholetone SInterval -> Int -> SInterval
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Int
x SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^-^ SInterval
forall i. Chromatic i => i
chromaticSemitone SInterval -> Int -> SInterval
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
x)

spelledDiaChrom :: Int -> Int -> SInterval
spelledDiaChrom :: Int -> Int -> SInterval
spelledDiaChrom Int
dia Int
chrom = SInterval
diaPart SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^+^ SInterval
chromPart
 where
  diaPart :: SInterval
diaPart   = SInterval
wholetone SInterval -> Int -> SInterval
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Int
dia
  chromPart :: SInterval
chromPart = SInterval
forall i. Chromatic i => i
chromaticSemitone SInterval -> Int -> SInterval
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* (Int
chrom Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dia)

second :: ImperfectInterval SInterval
second = (SInterval -> SInterval) -> ImperfectInterval SInterval
forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> Int -> SInterval
spelled Int
2 (-Int
1) SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^-^)
third :: ImperfectInterval SInterval
third = (SInterval -> SInterval) -> ImperfectInterval SInterval
forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> Int -> SInterval
spelled Int
4 (-Int
2) SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^-^)
fourth :: SInterval
fourth = Int -> Int -> SInterval
spelled (-Int
1) Int
1
tritone :: SInterval
tritone = SInterval -> SInterval
forall i. Chromatic i => i -> i
aug SInterval
fourth -- SInterval 3 6
fifth :: SInterval
fifth = Int -> Int -> SInterval
spelled Int
1 Int
0
sixth :: ImperfectInterval SInterval
sixth = (SInterval -> SInterval) -> ImperfectInterval SInterval
forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> Int -> SInterval
spelled Int
3 (-Int
1) SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^-^)
seventh :: ImperfectInterval SInterval
seventh = (SInterval -> SInterval) -> ImperfectInterval SInterval
forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> Int -> SInterval
spelled Int
5 (-Int
2) SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^-^)

instance ToJSON SInterval -- TODO make more specific
instance FromJSON SInterval

instance Spelled SInterval where
  fifths :: SInterval -> Int
fifths (SInterval Int
f Int
_) = Int
f
  octaves :: SInterval -> Int
octaves (SInterval Int
f Int
o) = Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
7)
  internalOctaves :: SInterval -> Int
internalOctaves (SInterval Int
_ Int
o) = Int
o
  degree :: SInterval -> Int
degree (SInterval Int
f Int
_) = Int -> Int
fifths2degree Int
f
  generic :: SInterval -> Int
generic SInterval
i =
    if SInterval -> Ordering
forall i. Interval i => i -> Ordering
direction SInterval
i Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT then Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ SInterval -> Int
forall i. Spelled i => i -> Int
degree (SInterval -> Int) -> SInterval -> Int
forall a b. (a -> b) -> a -> b
$ SInterval -> SInterval
forall v. AdditiveGroup v => v -> v
negateV SInterval
i else SInterval -> Int
forall i. Spelled i => i -> Int
degree SInterval
i
  diasteps :: SInterval -> Int
diasteps (SInterval Int
f Int
o) = Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
7
  alteration :: SInterval -> Int
alteration SInterval
i = (SInterval -> Int
forall i. Spelled i => i -> Int
fifths (SInterval -> SInterval
forall i. Interval i => i -> i
iabs SInterval
i) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
7

instance Ord SInterval where
  SInterval
i1 <= :: SInterval -> SInterval -> Bool
<= SInterval
i2 = SInterval -> Ordering
forall i. Interval i => i -> Ordering
direction (SInterval
i1 SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^-^ SInterval
i2) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT --(diasteps i1, alteration i1) <= (diasteps i2, alteration i2)
  compare :: SInterval -> SInterval -> Ordering
compare SInterval
i1 SInterval
i2 = SInterval -> Ordering
forall i. Interval i => i -> Ordering
direction (SInterval
i1 SInterval -> SInterval -> SInterval
forall v. AdditiveGroup v => v -> v -> v
^-^ SInterval
i2)
    -- compare (diasteps i1, alteration i1) (diasteps i2, alteration i2)

-- instance Show SInterval where
--   -- show (SInterval d c) = diaget diaints d <> accstr augs '+' '-' <> show (div d 7)
--   --   where augs = c - dia2chrom d
--   show (SInterval d c) = "SInterval " <> show d <> " " <> show c

instance AdditiveGroup SInterval where
  zeroV :: SInterval
zeroV = Int -> Int -> SInterval
SInterval Int
0 Int
0
  negateV :: SInterval -> SInterval
negateV (SInterval Int
f Int
o) = Int -> Int -> SInterval
SInterval (-Int
f) (-Int
o)
  (SInterval Int
f1 Int
o1) ^+^ :: SInterval -> SInterval -> SInterval
^+^ (SInterval Int
f2 Int
o2) = Int -> Int -> SInterval
SInterval (Int
f1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
f2) (Int
o1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
o2)
  (SInterval Int
f1 Int
o1) ^-^ :: SInterval -> SInterval -> SInterval
^-^ (SInterval Int
f2 Int
o2) = Int -> Int -> SInterval
SInterval (Int
f1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
f2) (Int
o1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
o2)

instance VectorSpace SInterval where
  type Scalar SInterval = Int
  Scalar SInterval
s *^ :: Scalar SInterval -> SInterval -> SInterval
*^ (SInterval Int
f Int
o) = Int -> Int -> SInterval
SInterval (Int
Scalar SInterval
s Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
f) (Int
Scalar SInterval
s Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
o)

instance Interval SInterval where
  type ICOf SInterval = SIC
  ic :: SInterval -> ICOf SInterval
ic (SInterval Int
f Int
_) = Int -> SIC
sic Int
f
  octave :: SInterval
octave = Int -> Int -> SInterval
SInterval Int
0 Int
1
  direction :: SInterval -> Ordering
direction SInterval
i = (Int, Int) -> (Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SInterval -> Int
forall i. Spelled i => i -> Int
diasteps SInterval
i, (SInterval -> Int
forall i. Spelled i => i -> Int
fifths SInterval
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
7) (Int
0, Int
0)

instance Diatonic SInterval where
  isStep :: SInterval -> Bool
isStep SInterval
i = Int -> Int
forall a. Num a => a -> a
abs (SInterval -> Int
forall i. Spelled i => i -> Int
diasteps SInterval
i) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2

instance Chromatic SInterval where
  chromaticSemitone :: SInterval
chromaticSemitone = Int -> Int -> SInterval
SInterval Int
7 (-Int
4)

instance ToMidi SInterval where
  toMidi :: SInterval -> Int
toMidi (SInterval Int
f Int
o) = Int
f 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
12

-- parsing helpers:

anyChar :: [Char] -> R.ReadP Char
anyChar :: String -> ReadP Char
anyChar String
chars = (Char -> Bool) -> ReadP Char
R.satisfy (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
chars)

altAug :: R.ReadP (Bool -> R.ReadP Int)
altAug :: ReadP (Bool -> ReadP Int)
altAug = do
  as <- (Char -> Bool) -> ReadP String
R.munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'a')
  pure $ \Bool
_ -> Int -> ReadP Int
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ReadP Int) -> Int -> ReadP Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
as

altDim :: R.ReadP (Bool -> R.ReadP Int)
altDim :: ReadP (Bool -> ReadP Int)
altDim = do
  ds <- (Char -> Bool) -> ReadP String
R.munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'd')
  pure $ \Bool
pf -> Int -> ReadP Int
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ReadP Int) -> Int -> ReadP Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
negate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ds) Int -> Int -> Int
forall a. Num a => a -> a -> a
- if Bool
pf then Int
0 else Int
1

altQual :: R.ReadP (Bool -> R.ReadP Int)
altQual :: ReadP (Bool -> ReadP Int)
altQual = do
  qual <- String -> ReadP Char
anyChar String
"MPm"
  case qual of
    Char
'P' -> (Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int)
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int))
-> (Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int)
forall a b. (a -> b) -> a -> b
$ \Bool
pf -> if Bool
pf then Int -> ReadP Int
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0 else ReadP Int
forall a. ReadP a
R.pfail
    Char
'M' -> (Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int)
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int))
-> (Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int)
forall a b. (a -> b) -> a -> b
$ \Bool
pf -> if Bool
pf then ReadP Int
forall a. ReadP a
R.pfail else Int -> ReadP Int
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
    Char
'm' -> (Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int)
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int))
-> (Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int)
forall a b. (a -> b) -> a -> b
$ \Bool
pf -> if Bool
pf then ReadP Int
forall a. ReadP a
R.pfail else Int -> ReadP Int
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (-Int
1)
    Char
_ -> ReadP (Bool -> ReadP Int)
forall a. ReadP a
R.pfail

parseDia :: ReadP Int
parseDia = do
  falt <- ReadP (Bool -> ReadP Int)
altQual ReadP (Bool -> ReadP Int)
-> ReadP (Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int)
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP (Bool -> ReadP Int)
altAug ReadP (Bool -> ReadP Int)
-> ReadP (Bool -> ReadP Int) -> ReadP (Bool -> ReadP Int)
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP (Bool -> ReadP Int)
altDim
  dia  <- (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) <$> parseInt'
  alt  <- falt $ isPerfect dia
  return $ ((dia * 2 + 1) `mod` 7) - 1 + (7 * alt)

instance Notation SInterval where
  showNotation :: SInterval -> String
showNotation SInterval
i | SInterval -> Ordering
forall i. Interval i => i -> Ordering
direction SInterval
i Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT = String
"-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SInterval -> String
forall i. Notation i => i -> String
showNotation (SInterval -> SInterval
forall v. AdditiveGroup v => v -> v
negateV SInterval
i)
                 | Bool
otherwise         = String
qual String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
dia String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: String
octs)
   where
    deg :: Int
deg  = SInterval -> Int
forall i. Spelled i => i -> Int
degree SInterval
i
    dia :: String
dia  = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int
deg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    alt :: Int
alt  = SInterval -> Int
forall i. Spelled i => i -> Int
alteration SInterval
i
    qual :: String
qual = if Int -> Bool
isPerfect Int
deg
      then Int -> Char -> Char -> Char -> String
forall {a}. Int -> a -> a -> a -> [a]
qualpf Int
alt Char
'a' Char
'P' Char
'd'
      else Int -> Char -> Char -> Char -> Char -> String
forall {a}. Int -> a -> a -> a -> a -> [a]
qualimpf Int
alt Char
'a' Char
'M' Char
'm' Char
'd'
    octs :: String
octs = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ SInterval -> Int
forall i. Spelled i => i -> Int
octaves SInterval
i
  parseNotation :: ReadP SInterval
parseNotation = do
    sign <- Char -> ReadP Char -> ReadP Char
forall a. a -> ReadP a -> ReadP a
R.option Char
'+' (Char -> ReadP Char
R.char Char
'-')
    f    <- parseDia
    R.char ':'
    o <- parseInt
    let i = Int -> Int -> SInterval
SInterval Int
f (Int -> SInterval) -> Int -> SInterval
forall a b. (a -> b) -> a -> b
$ Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
7)
    pure $ if sign == '-' then negateV i else i

-- spelled pitch class (aka tonal pc) type and instances
-- spc are based on the line of fifth

newtype SIC = SIC { SIC -> Int
sFifth :: Int }
  deriving (SIC -> SIC -> Bool
(SIC -> SIC -> Bool) -> (SIC -> SIC -> Bool) -> Eq SIC
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SIC -> SIC -> Bool
== :: SIC -> SIC -> Bool
$c/= :: SIC -> SIC -> Bool
/= :: SIC -> SIC -> Bool
Eq, Eq SIC
Eq SIC =>
(SIC -> SIC -> Ordering)
-> (SIC -> SIC -> Bool)
-> (SIC -> SIC -> Bool)
-> (SIC -> SIC -> Bool)
-> (SIC -> SIC -> Bool)
-> (SIC -> SIC -> SIC)
-> (SIC -> SIC -> SIC)
-> Ord SIC
SIC -> SIC -> Bool
SIC -> SIC -> Ordering
SIC -> SIC -> SIC
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
$ccompare :: SIC -> SIC -> Ordering
compare :: SIC -> SIC -> Ordering
$c< :: SIC -> SIC -> Bool
< :: SIC -> SIC -> Bool
$c<= :: SIC -> SIC -> Bool
<= :: SIC -> SIC -> Bool
$c> :: SIC -> SIC -> Bool
> :: SIC -> SIC -> Bool
$c>= :: SIC -> SIC -> Bool
>= :: SIC -> SIC -> Bool
$cmax :: SIC -> SIC -> SIC
max :: SIC -> SIC -> SIC
$cmin :: SIC -> SIC -> SIC
min :: SIC -> SIC -> SIC
Ord, Int -> SIC -> ShowS
[SIC] -> ShowS
SIC -> String
(Int -> SIC -> ShowS)
-> (SIC -> String) -> ([SIC] -> ShowS) -> Show SIC
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SIC -> ShowS
showsPrec :: Int -> SIC -> ShowS
$cshow :: SIC -> String
show :: SIC -> String
$cshowList :: [SIC] -> ShowS
showList :: [SIC] -> ShowS
Show, (forall x. SIC -> Rep SIC x)
-> (forall x. Rep SIC x -> SIC) -> Generic SIC
forall x. Rep SIC x -> SIC
forall x. SIC -> Rep SIC x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SIC -> Rep SIC x
from :: forall x. SIC -> Rep SIC x
$cto :: forall x. Rep SIC x -> SIC
to :: forall x. Rep SIC x -> SIC
Generic, SIC -> ()
(SIC -> ()) -> NFData SIC
forall a. (a -> ()) -> NFData a
$crnf :: SIC -> ()
rnf :: SIC -> ()
NFData, Eq SIC
Eq SIC => (Int -> SIC -> Int) -> (SIC -> Int) -> Hashable SIC
Int -> SIC -> Int
SIC -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> SIC -> Int
hashWithSalt :: Int -> SIC -> Int
$chash :: SIC -> Int
hash :: SIC -> Int
Hashable)

instance ToJSON SIC -- TODO: better keys in object
instance FromJSON SIC

sic :: Int -> SIC
sic :: Int -> SIC
sic = Int -> SIC
SIC

second' :: ImperfectInterval SIC
second' = (SIC -> SIC) -> ImperfectInterval SIC
forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> SIC
sic Int
2 SIC -> SIC -> SIC
forall v. AdditiveGroup v => v -> v -> v
^-^)
third' :: ImperfectInterval SIC
third' = (SIC -> SIC) -> ImperfectInterval SIC
forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> SIC
sic Int
4 SIC -> SIC -> SIC
forall v. AdditiveGroup v => v -> v -> v
^-^)
fourth' :: SIC
fourth' = Int -> SIC
sic (-Int
1)
tritone' :: SIC
tritone' = Int -> SIC
sic Int
6
fifth' :: SIC
fifth' = Int -> SIC
sic Int
1
sixth' :: ImperfectInterval SIC
sixth' = (SIC -> SIC) -> ImperfectInterval SIC
forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> SIC
sic Int
3 SIC -> SIC -> SIC
forall v. AdditiveGroup v => v -> v -> v
^-^)
seventh' :: ImperfectInterval SIC
seventh' = (SIC -> SIC) -> ImperfectInterval SIC
forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> SIC
sic Int
5 SIC -> SIC -> SIC
forall v. AdditiveGroup v => v -> v -> v
^-^)

instance Spelled SIC where
  fifths :: SIC -> Int
fifths (SIC Int
f) = Int
f
  octaves :: SIC -> Int
octaves SIC
_ = Int
0
  internalOctaves :: SIC -> Int
internalOctaves SIC
_ = Int
0
  degree :: SIC -> Int
degree (SIC Int
f) = Int -> Int
fifths2degree Int
f
  generic :: SIC -> Int
generic (SIC Int
f) = Int -> Int
fifths2degree Int
f
  diasteps :: SIC -> Int
diasteps (SIC Int
f) = Int -> Int
fifths2degree Int
f
  alteration :: SIC -> Int
alteration (SIC Int
f) = (Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
7

instance AdditiveGroup SIC where
  zeroV :: SIC
zeroV = Int -> SIC
SIC Int
0
  negateV :: SIC -> SIC
negateV (SIC Int
f) = Int -> SIC
SIC (-Int
f)
  (SIC Int
f1) ^+^ :: SIC -> SIC -> SIC
^+^ (SIC Int
f2) = Int -> SIC
SIC (Int -> SIC) -> Int -> SIC
forall a b. (a -> b) -> a -> b
$ Int
f1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
f2
  (SIC Int
f1) ^-^ :: SIC -> SIC -> SIC
^-^ (SIC Int
f2) = Int -> SIC
SIC (Int -> SIC) -> Int -> SIC
forall a b. (a -> b) -> a -> b
$ Int
f1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
f2

instance VectorSpace SIC where
  type Scalar SIC = Int
  Scalar SIC
s *^ :: Scalar SIC -> SIC -> SIC
*^ (SIC Int
f) = Int -> SIC
SIC (Int -> SIC) -> Int -> SIC
forall a b. (a -> b) -> a -> b
$ Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
Scalar SIC
s

instance Interval SIC where
  type ICOf SIC = SIC
  ic :: SIC -> ICOf SIC
ic     = SIC -> ICOf SIC
SIC -> SIC
forall a. a -> a
id
  octave :: SIC
octave = SIC
forall v. AdditiveGroup v => v
zeroV
  direction :: SIC -> Ordering
direction (SIC Int
0) = Ordering
EQ
  direction SIC
i | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SIC -> Int
forall i. Spelled i => i -> Int
alteration SIC
i) Int
0
              | Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4     = Ordering
GT
              | Bool
otherwise = Ordering
LT
    where d :: Int
d = SIC -> Int
forall i. Spelled i => i -> Int
diasteps SIC
i

instance Diatonic SIC where
  isStep :: SIC -> Bool
isStep SIC
ic = Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
|| Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 where d :: Int
d = SIC -> Int
forall i. Spelled i => i -> Int
degree SIC
ic

instance Chromatic SIC where
  chromaticSemitone :: SIC
chromaticSemitone = Int -> SIC
sic Int
7

instance IntervalClass SIC where
  type IOf SIC = SInterval
  -- ic (SInterval d c) = sic d c
  emb :: SIC -> IOf SIC
emb (SIC Int
f) = Int -> Int -> SInterval
SInterval Int
f (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
7)

instance ToMidi SIC where
  toMidi :: SIC -> Int
toMidi (SIC Int
f) = Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
7 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12

instance Notation SIC where
  showNotation :: SIC -> String
showNotation SIC
i = String
qual String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
dia Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
   where
    dia :: Int
dia  = SIC -> Int
forall i. Spelled i => i -> Int
diasteps SIC
i
    alt :: Int
alt  = SIC -> Int
forall i. Spelled i => i -> Int
alteration SIC
i
    qual :: String
qual = if Int -> Bool
isPerfect Int
dia
      then Int -> Char -> Char -> Char -> String
forall {a}. Int -> a -> a -> a -> [a]
qualpf Int
alt Char
'a' Char
'P' Char
'd'
      else Int -> Char -> Char -> Char -> Char -> String
forall {a}. Int -> a -> a -> a -> a -> [a]
qualimpf Int
alt Char
'a' Char
'M' Char
'm' Char
'd'
  parseNotation :: ReadP SIC
parseNotation = do
    sign <- Char -> ReadP Char -> ReadP Char
forall a. a -> ReadP a -> ReadP a
R.option Char
'+' (Char -> ReadP Char
R.char Char
'-')
    i    <- sic <$> parseDia
    pure $ if sign == '-' then negateV i else i

-- spelled pitch / pitch class
------------------------------

instance (Spelled i, Interval i, Spelled (ICOf i)) => Spelled (Pitch i) where
  fifths :: Pitch i -> Int
fifths (Pitch i
i) = i -> Int
forall i. Spelled i => i -> Int
fifths i
i
  octaves :: Pitch i -> Int
octaves (Pitch i
i) = i -> Int
forall i. Spelled i => i -> Int
octaves i
i
  internalOctaves :: Pitch i -> Int
internalOctaves (Pitch i
i) = i -> Int
forall i. Spelled i => i -> Int
internalOctaves i
i
  degree :: Pitch i -> Int
degree (Pitch i
i) = i -> Int
forall i. Spelled i => i -> Int
degree i
i
  generic :: Pitch i -> Int
generic (Pitch i
i) = i -> Int
forall i. Spelled i => i -> Int
degree i
i -- not well-defined for pitches
  diasteps :: Pitch i -> Int
diasteps (Pitch i
i) = i -> Int
forall i. Spelled i => i -> Int
degree i
i -- not well-defined for pitches
  alteration :: Pitch i -> Int
alteration (Pitch i
i) = ICOf i -> Int
forall i. Spelled i => i -> Int
alteration (ICOf i -> Int) -> ICOf i -> Int
forall a b. (a -> b) -> a -> b
$ i -> ICOf i
forall i. Interval i => i -> ICOf i
ic i
i

letter :: Spelled i => i -> Char
letter :: forall i. Spelled i => i -> Char
letter i
i = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ((i -> Int
forall i. Spelled i => i -> Int
degree i
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7)

type SPitch = Pitch SInterval
type SPC = Pitch SIC

spelledp :: Int -> Int -> SPitch
spelledp :: Int -> Int -> SPitch
spelledp Int
f Int
o = SInterval -> SPitch
forall a. a -> Pitch a
Pitch (SInterval -> SPitch) -> SInterval -> SPitch
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SInterval
SInterval Int
f Int
o

-- helper
parseAccs :: R.ReadP Int
parseAccs :: ReadP Int
parseAccs = Int -> ReadP Int -> ReadP Int
forall a. a -> ReadP a -> ReadP a
R.option Int
0 (ReadP Int -> ReadP Int) -> ReadP Int -> ReadP Int
forall a b. (a -> b) -> a -> b
$ ReadP Int
sharps ReadP Int -> ReadP Int -> ReadP Int
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Int
flats
 where
  sharps :: ReadP Int
sharps = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> ReadP String -> ReadP Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ReadP String
munchChar1 Char
'♯' ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ReadP String
munchChar1 Char
'#')
  flats :: ReadP Int
flats  = Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> (String -> Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> ReadP String -> ReadP Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ReadP String
munchChar1 Char
'♭' ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ReadP String
munchChar1 Char
'b')

parseName :: R.ReadP Int
parseName :: ReadP Int
parseName = do
  name <- String -> ReadP Char
anyChar String
"ABCDEFG"
  let dia = (Char -> Int
ord Char
name Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7
  alt <- parseAccs
  return $ ((dia * 2 + 1) `mod` 7) - 1 + 7 * alt

newtype Accidental = Acc Int

flt :: Accidental
flt = Int -> Accidental
Acc (-Int
1)
shp :: Accidental
shp = Int -> Accidental
Acc Int
1
nat :: Accidental
nat = Int -> Accidental
Acc Int
0

toSpelled :: Int -> Int -> Accidental -> Int -> SPitch
toSpelled :: Int -> Int -> Accidental -> Int -> SPitch
toSpelled Int
f Int
o (Acc Int
acc) Int
oct =
  Int -> Int -> SPitch
spelledp Int
f (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
oct) SPitch -> SInterval -> SPitch
forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ (SInterval
forall i. Chromatic i => i
chromaticSemitone SInterval -> Int -> SInterval
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Int
acc)

c :: Accidental -> Int -> SPitch
c = Int -> Int -> Accidental -> Int -> SPitch
toSpelled Int
0 Int
0
d :: Accidental -> Int -> SPitch
d = Int -> Int -> Accidental -> Int -> SPitch
toSpelled Int
2 (-Int
1)
e :: Accidental -> Int -> SPitch
e = Int -> Int -> Accidental -> Int -> SPitch
toSpelled Int
4 (-Int
2)
f :: Accidental -> Int -> SPitch
f = Int -> Int -> Accidental -> Int -> SPitch
toSpelled (-Int
1) Int
1
g :: Accidental -> Int -> SPitch
g = Int -> Int -> Accidental -> Int -> SPitch
toSpelled Int
1 Int
0
a :: Accidental -> Int -> SPitch
a = Int -> Int -> Accidental -> Int -> SPitch
toSpelled Int
3 (-Int
1)
b :: Accidental -> Int -> SPitch
b = Int -> Int -> Accidental -> Int -> SPitch
toSpelled Int
5 (-Int
2)

instance Show SPitch where
  show :: SPitch -> String
show = SPitch -> String
forall i. Notation i => i -> String
showNotation

instance Notation SPitch where
  showNotation :: SPitch -> String
showNotation SPitch
p = SPitch -> Char
forall i. Spelled i => i -> Char
letter SPitch
p Char -> ShowS
forall a. a -> [a] -> [a]
: String
accs String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (SPitch -> Int
forall i. Spelled i => i -> Int
octaves SPitch
p)
    where accs :: String
accs = Int -> Char -> Char -> String
accstr (SPitch -> Int
forall i. Spelled i => i -> Int
alteration SPitch
p) Char
'♯' Char
'♭'
  parseNotation :: ReadP SPitch
parseNotation = do
    f <- ReadP Int
parseName
    o <- parseInt
    pure $ spelledp f (o - (f * 4 `div` 7))

instance ToMidi SPitch where
  toMidi :: SPitch -> Int
toMidi (Pitch SInterval
i) = SInterval -> Int
forall i. ToMidi i => i -> Int
toMidi SInterval
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
12

spc :: Int -> SPC
spc :: Int -> SPC
spc Int
f = SIC -> SPC
forall a. a -> Pitch a
Pitch (SIC -> SPC) -> SIC -> SPC
forall a b. (a -> b) -> a -> b
$ Int -> SIC
sic Int
f

toSPC :: Int -> Accidental -> SPC
toSPC :: Int -> Accidental -> SPC
toSPC Int
f (Acc Int
acc) = Int -> SPC
spc Int
f SPC -> SIC -> SPC
forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ (SIC
forall i. Chromatic i => i
chromaticSemitone SIC -> Int -> SIC
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Int
acc)

c' :: Accidental -> SPC
c' = Int -> Accidental -> SPC
toSPC Int
0
d' :: Accidental -> SPC
d' = Int -> Accidental -> SPC
toSPC Int
2
e' :: Accidental -> SPC
e' = Int -> Accidental -> SPC
toSPC Int
4
f' :: Accidental -> SPC
f' = Int -> Accidental -> SPC
toSPC (-Int
1)
g' :: Accidental -> SPC
g' = Int -> Accidental -> SPC
toSPC Int
1
a' :: Accidental -> SPC
a' = Int -> Accidental -> SPC
toSPC Int
3
b' :: Accidental -> SPC
b' = Int -> Accidental -> SPC
toSPC Int
5

instance Show SPC where
  show :: SPC -> String
show = SPC -> String
forall i. Notation i => i -> String
showNotation

instance Notation SPC where
  showNotation :: SPC -> String
showNotation SPC
p = SPC -> Char
forall i. Spelled i => i -> Char
letter SPC
p Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Char -> Char -> String
accstr (SPC -> Int
forall i. Spelled i => i -> Int
alteration SPC
p) Char
'♯' Char
'♭'
  parseNotation :: ReadP SPC
parseNotation = Int -> SPC
spc (Int -> SPC) -> ReadP Int -> ReadP SPC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Int
parseName

instance ToMidi SPC where
  toMidi :: SPC -> Int
toMidi (Pitch SIC
ic) = SIC -> Int
forall i. ToMidi i => i -> Int
toMidi SIC
ic Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
60