{-# 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 forall a. Ord a => a -> a -> Bool
> Int
0     = forall a. Int -> a -> [a]
replicate Int
n Char
u
             | Bool
otherwise = forall a. Int -> a -> [a]
replicate (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 forall a. Ord a => a -> a -> Bool
> Int
0     = forall a. Int -> a -> [a]
replicate Int
n a
a
               | Int
n forall a. Eq a => a -> a -> Bool
== Int
0    = [a
p]
               | Bool
otherwise = 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 forall a. Ord a => a -> a -> Bool
> Int
0     = forall a. Int -> a -> [a]
replicate Int
n a
a
                     | Int
n forall a. Eq a => a -> a -> Bool
== Int
0    = [a
mj]
                     | Int
n forall a. Eq a => a -> a -> Bool
== (-Int
1) = [a
mn]
                     | Bool
otherwise = forall a. Int -> a -> [a]
replicate ((-Int
n) forall a. Num a => a -> a -> a
- Int
1) a
d

fifths2degree :: Int -> Int
fifths2degree :: Int -> Int
fifths2degree Int
fifths = Int
fifths forall a. Num a => a -> a -> a
* Int
4 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SInterval -> SInterval -> Bool
$c/= :: SInterval -> SInterval -> Bool
== :: SInterval -> SInterval -> Bool
$c== :: SInterval -> SInterval -> Bool
Eq, 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
$cto :: forall x. Rep SInterval x -> SInterval
$cfrom :: forall x. SInterval -> Rep SInterval x
Generic, Int -> SInterval -> ShowS
[SInterval] -> ShowS
SInterval -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SInterval] -> ShowS
$cshowList :: [SInterval] -> ShowS
show :: SInterval -> String
$cshow :: SInterval -> String
showsPrec :: Int -> SInterval -> ShowS
$cshowsPrec :: Int -> SInterval -> ShowS
Show, SInterval -> ()
forall a. (a -> ()) -> NFData a
rnf :: SInterval -> ()
$crnf :: SInterval -> ()
NFData, Eq SInterval
Int -> SInterval -> Int
SInterval -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: SInterval -> Int
$chash :: SInterval -> Int
hashWithSalt :: Int -> SInterval -> Int
$chashWithSalt :: Int -> 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 forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* Int
x forall v. AdditiveGroup v => v -> v -> v
^-^ forall i. Chromatic i => i
chromaticSemitone forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* (Int
2 forall a. Num a => a -> a -> a
* Int
x)

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

second :: ImperfectInterval SInterval
second = forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> Int -> SInterval
spelled Int
2 (-Int
1) forall v. AdditiveGroup v => v -> v -> v
^-^)
third :: ImperfectInterval SInterval
third = forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> Int -> SInterval
spelled Int
4 (-Int
2) forall v. AdditiveGroup v => v -> v -> v
^-^)
fourth :: SInterval
fourth = Int -> Int -> SInterval
spelled (-Int
1) Int
1
tritone :: SInterval
tritone = 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 = forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> Int -> SInterval
spelled Int
3 (-Int
1) forall v. AdditiveGroup v => v -> v -> v
^-^)
seventh :: ImperfectInterval SInterval
seventh = forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> Int -> SInterval
spelled Int
5 (-Int
2) 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 forall a. Num a => a -> a -> a
+ (Int
f forall a. Num a => a -> a -> a
* Int
4 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 forall i. Interval i => i -> Ordering
direction SInterval
i forall a. Eq a => a -> a -> Bool
== Ordering
LT then forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ forall i. Spelled i => i -> Int
degree forall a b. (a -> b) -> a -> b
$ forall v. AdditiveGroup v => v -> v
negateV SInterval
i else forall i. Spelled i => i -> Int
degree SInterval
i
  diasteps :: SInterval -> Int
diasteps (SInterval Int
f Int
o) = Int
f forall a. Num a => a -> a -> a
* Int
4 forall a. Num a => a -> a -> a
+ Int
o forall a. Num a => a -> a -> a
* Int
7
  alteration :: SInterval -> Int
alteration SInterval
i = (forall i. Spelled i => i -> Int
fifths (forall i. Interval i => i -> i
iabs SInterval
i) forall a. Num a => a -> a -> a
+ Int
1) forall a. Integral a => a -> a -> a
`div` Int
7

instance Ord SInterval where
  SInterval
i1 <= :: SInterval -> SInterval -> Bool
<= SInterval
i2 = forall i. Interval i => i -> Ordering
direction (SInterval
i1 forall v. AdditiveGroup v => v -> v -> v
^-^ SInterval
i2) 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 = forall i. Interval i => i -> Ordering
direction (SInterval
i1 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 forall a. Num a => a -> a -> a
+ Int
f2) (Int
o1 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 forall a. Num a => a -> a -> a
- Int
f2) (Int
o1 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 (Scalar SInterval
s forall a. Num a => a -> a -> a
* Int
f) (Scalar SInterval
s 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 = forall a. Ord a => a -> a -> Ordering
compare (forall i. Spelled i => i -> Int
diasteps SInterval
i, (forall i. Spelled i => i -> Int
fifths SInterval
i forall a. Num a => a -> a -> a
+ Int
1) forall a. Integral a => a -> a -> a
`div` Int
7) (Int
0, Int
0)

instance Diatonic SInterval where
  isStep :: SInterval -> Bool
isStep SInterval
i = forall a. Num a => a -> a
abs (forall i. Spelled i => i -> Int
diasteps SInterval
i) 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 forall a. Num a => a -> a -> a
* Int
7 forall a. Num a => a -> a -> a
+ Int
o 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 (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
  String
as <- (Char -> Bool) -> ReadP String
R.munch1 (forall a. Eq a => a -> a -> Bool
== Char
'a')
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Bool
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
  String
ds <- (Char -> Bool) -> ReadP String
R.munch1 (forall a. Eq a => a -> a -> Bool
== Char
'd')
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Bool
pf -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ds) 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
  Char
qual <- String -> ReadP Char
anyChar String
"MPm"
  case Char
qual of
    Char
'P' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Bool
pf -> if Bool
pf then forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0 else forall a. ReadP a
R.pfail
    Char
'M' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Bool
pf -> if Bool
pf then forall a. ReadP a
R.pfail else forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
    Char
'm' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Bool
pf -> if Bool
pf then forall a. ReadP a
R.pfail else forall (f :: * -> *) a. Applicative f => a -> f a
pure (-Int
1)
    Char
_ -> forall a. ReadP a
R.pfail

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

instance Notation SInterval where
  showNotation :: SInterval -> String
showNotation SInterval
i | forall i. Interval i => i -> Ordering
direction SInterval
i forall a. Eq a => a -> a -> Bool
== Ordering
LT = String
"-" forall a. Semigroup a => a -> a -> a
<> forall i. Notation i => i -> String
showNotation (forall v. AdditiveGroup v => v -> v
negateV SInterval
i)
                 | Bool
otherwise         = String
qual forall a. Semigroup a => a -> a -> a
<> String
dia forall a. Semigroup a => a -> a -> a
<> (Char
':' forall a. a -> [a] -> [a]
: String
octs)
   where
    deg :: Int
deg  = forall i. Spelled i => i -> Int
degree SInterval
i
    dia :: String
dia  = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int
deg forall a. Num a => a -> a -> a
+ Int
1
    alt :: Int
alt  = forall i. Spelled i => i -> Int
alteration SInterval
i
    qual :: String
qual = if Int -> Bool
isPerfect Int
deg
      then forall {a}. Int -> a -> a -> a -> [a]
qualpf Int
alt Char
'a' Char
'P' Char
'd'
      else forall {a}. Int -> a -> a -> a -> a -> [a]
qualimpf Int
alt Char
'a' Char
'M' Char
'm' Char
'd'
    octs :: String
octs = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall i. Spelled i => i -> Int
octaves SInterval
i
  parseNotation :: ReadP SInterval
parseNotation = do
    Char
sign <- forall a. a -> ReadP a -> ReadP a
R.option Char
'+' (Char -> ReadP Char
R.char Char
'-')
    Int
f    <- ReadP Int
parseDia
    Char -> ReadP Char
R.char Char
':'
    Int
o <- ReadP Int
parseInt
    let i :: SInterval
i = Int -> Int -> SInterval
SInterval Int
f forall a b. (a -> b) -> a -> b
$ Int
o forall a. Num a => a -> a -> a
- ((Int
f forall a. Num a => a -> a -> a
* Int
4) forall a. Integral a => a -> a -> a
`div` Int
7)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Char
sign forall a. Eq a => a -> a -> Bool
== Char
'-' then forall v. AdditiveGroup v => v -> v
negateV SInterval
i else SInterval
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SIC -> SIC -> Bool
$c/= :: SIC -> SIC -> Bool
== :: SIC -> SIC -> Bool
$c== :: SIC -> SIC -> Bool
Eq, Eq 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
min :: SIC -> SIC -> SIC
$cmin :: SIC -> SIC -> SIC
max :: SIC -> SIC -> SIC
$cmax :: SIC -> SIC -> SIC
>= :: SIC -> SIC -> Bool
$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
compare :: SIC -> SIC -> Ordering
$ccompare :: SIC -> SIC -> Ordering
Ord, Int -> SIC -> ShowS
[SIC] -> ShowS
SIC -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SIC] -> ShowS
$cshowList :: [SIC] -> ShowS
show :: SIC -> String
$cshow :: SIC -> String
showsPrec :: Int -> SIC -> ShowS
$cshowsPrec :: Int -> SIC -> ShowS
Show, 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
$cto :: forall x. Rep SIC x -> SIC
$cfrom :: forall x. SIC -> Rep SIC x
Generic, SIC -> ()
forall a. (a -> ()) -> NFData a
rnf :: SIC -> ()
$crnf :: SIC -> ()
NFData, Eq SIC
Int -> SIC -> Int
SIC -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: SIC -> Int
$chash :: SIC -> Int
hashWithSalt :: Int -> SIC -> Int
$chashWithSalt :: Int -> 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' = forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> SIC
sic Int
2 forall v. AdditiveGroup v => v -> v -> v
^-^)
third' :: ImperfectInterval SIC
third' = forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> SIC
sic Int
4 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' = forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> SIC
sic Int
3 forall v. AdditiveGroup v => v -> v -> v
^-^)
seventh' :: ImperfectInterval SIC
seventh' = forall i. (i -> i) -> ImperfectInterval i
Impf (Int -> SIC
sic Int
5 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 forall a. Num a => a -> a -> a
+ Int
1) 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 forall a b. (a -> b) -> a -> b
$ Int
f1 forall a. Num a => a -> a -> a
+ Int
f2
  (SIC Int
f1) ^-^ :: SIC -> SIC -> SIC
^-^ (SIC Int
f2) = Int -> SIC
SIC forall a b. (a -> b) -> a -> b
$ Int
f1 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 forall a b. (a -> b) -> a -> b
$ Int
f forall a. Num a => a -> a -> a
* Scalar SIC
s

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

instance Diatonic SIC where
  isStep :: SIC -> Bool
isStep SIC
ic = Int
d forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
d forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
|| Int
d forall a. Eq a => a -> a -> Bool
== Int
6 where d :: Int
d = 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 (forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ Int
f forall a. Num a => a -> a -> a
* Int
4 forall a. Integral a => a -> a -> a
`div` Int
7)

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

instance Notation SIC where
  showNotation :: SIC -> String
showNotation SIC
i = String
qual forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Int
dia forall a. Num a => a -> a -> a
+ Int
1)
   where
    dia :: Int
dia  = forall i. Spelled i => i -> Int
diasteps SIC
i
    alt :: Int
alt  = forall i. Spelled i => i -> Int
alteration SIC
i
    qual :: String
qual = if Int -> Bool
isPerfect Int
dia
      then forall {a}. Int -> a -> a -> a -> [a]
qualpf Int
alt Char
'a' Char
'P' Char
'd'
      else forall {a}. Int -> a -> a -> a -> a -> [a]
qualimpf Int
alt Char
'a' Char
'M' Char
'm' Char
'd'
  parseNotation :: ReadP SIC
parseNotation = do
    Char
sign <- forall a. a -> ReadP a -> ReadP a
R.option Char
'+' (Char -> ReadP Char
R.char Char
'-')
    SIC
i    <- Int -> SIC
sic forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Int
parseDia
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Char
sign forall a. Eq a => a -> a -> Bool
== Char
'-' then forall v. AdditiveGroup v => v -> v
negateV SIC
i else SIC
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) = forall i. Spelled i => i -> Int
fifths i
i
  octaves :: Pitch i -> Int
octaves (Pitch i
i) = forall i. Spelled i => i -> Int
octaves i
i
  internalOctaves :: Pitch i -> Int
internalOctaves (Pitch i
i) = forall i. Spelled i => i -> Int
internalOctaves i
i
  degree :: Pitch i -> Int
degree (Pitch i
i) = forall i. Spelled i => i -> Int
degree i
i
  generic :: Pitch i -> Int
generic (Pitch i
i) = forall i. Spelled i => i -> Int
degree i
i -- not well-defined for pitches
  diasteps :: Pitch i -> Int
diasteps (Pitch i
i) = forall i. Spelled i => i -> Int
degree i
i -- not well-defined for pitches
  alteration :: Pitch i -> Int
alteration (Pitch i
i) = forall i. Spelled i => i -> Int
alteration forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'A' forall a. Num a => a -> a -> a
+ ((forall i. Spelled i => i -> Int
degree i
i forall a. Num a => a -> a -> a
+ Int
2) 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 = forall a. a -> Pitch a
Pitch forall a b. (a -> b) -> a -> b
$ Int -> Int -> SInterval
SInterval Int
f Int
o

-- helper
parseAccs :: R.ReadP Int
parseAccs :: ReadP Int
parseAccs = forall a. a -> ReadP a -> ReadP a
R.option Int
0 forall a b. (a -> b) -> a -> b
$ ReadP Int
sharps forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Int
flats
 where
  sharps :: ReadP Int
sharps = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ReadP String
munchChar1 Char
'♯' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ReadP String
munchChar1 Char
'#')
  flats :: ReadP Int
flats  = forall a. Num a => a -> a
negate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> ReadP String
munchChar1 Char
'♭' 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
  Char
name <- String -> ReadP Char
anyChar String
"ABCDEFG"
  let dia :: Int
dia = (Char -> Int
ord Char
name forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A' forall a. Num a => a -> a -> a
- Int
2) forall a. Integral a => a -> a -> a
`mod` Int
7
  Int
alt <- ReadP Int
parseAccs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((Int
dia forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
1) forall a. Integral a => a -> a -> a
`mod` Int
7) forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
+ Int
7 forall a. Num a => a -> a -> a
* Int
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 forall a. Num a => a -> a -> a
+ Int
oct) forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ (forall i. Chromatic i => i
chromaticSemitone 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 = forall i. Notation i => i -> String
showNotation

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

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

spc :: Int -> SPC
spc :: Int -> SPC
spc Int
f = forall a. a -> Pitch a
Pitch 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 forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ (forall i. Chromatic i => i
chromaticSemitone 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 = forall i. Notation i => i -> String
showNotation

instance Notation SPC where
  showNotation :: SPC -> String
showNotation SPC
p = forall i. Spelled i => i -> Char
letter SPC
p forall a. a -> [a] -> [a]
: Int -> Char -> Char -> String
accstr (forall i. Spelled i => i -> Int
alteration SPC
p) Char
'♯' Char
'♭'
  parseNotation :: ReadP SPC
parseNotation = Int -> SPC
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) = forall i. ToMidi i => i -> Int
toMidi SIC
ic forall a. Num a => a -> a -> a
+ Int
60