{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-|
Module: Musicology.Pitch.Class
Description: Generic pitch and interval interface.
Copyright: Christoph Finkensiep, 2021
License: BSD
Maintainer: chfin@chfin.de
Stability: experimental

This module defines a generic interface for pitch and interval types.

It provides three basic blocks of functionality:

- a set of type classes for generically [working with intervals](#g:1)
- a generic type and associated operations for [working with pitches](#g:2)
- functionality for reading and printing pitches and intervals in a [common notation](#g:3)
-}
module Musicology.Pitch.Class
  (
  -- * Intervals
  --
  -- | Every interval implements the 'Interval' class.
  -- Since intervals form vector spaces (or rather [modules]()),
  -- 'Interval' inherits from 'VectorSpace' and the associated arithmetic operations '^+^', '^-^', '*^', and '^*'.
  -- Each 'Interval' type is associated with an 'IntervalClass' type that implements octave equivalence.
  -- In addition, the classes 'Diatonic' and 'Chromatic' provide extra functionality
  -- for intervals that have diatonic and chromatic interpretations.
  module Data.VectorSpace
  , Interval(..)
  , IntervalClass(..)
  , oct
  , unison
  -- , ClassyInterval(..)
  , Diatonic(..)
  , Chromatic(..)
  , aug
  , dim
  , down
  , ImperfectInterval(..)
  , minor
  , major
  -- * Pitches
  --
  -- | Pitches are derived from intervals by interpreting an interval relative to a conventional reference point,
  -- which is specific to the interval type at hand.
  -- A pitch is represented as a 'Pitch' value, which is a newtype wrapper around an interval type.
  -- Calculating with pitches and intervals is done with
  --
  -- - 'pto', 'pfrom' between pitches,
  -- - '+^', '^+', '-^' between pitches and intervals (the @^@ is on the interval side)
  -- - 'pc' for turning a pitch into a pitch class.
  , Pitch(..)
  , toPitch
  , toInterval
  , pto
  , pfrom
  , (+^)
  , (^+)
  , (-^)
  , pc
  -- * Notation
  --
  -- | The 'Notation' class implements showing and reading a standard notation
  -- that is compatible with other implementations of this library (for standard interval and pitch types).
  , Notation(..)
  -- * Other Functions
  , transpose
  , embedI
  , embedP
  , embed
  , embed'
  -- * Conversion Classes
  , ToMidi(..)
  , ToFreq(..)
  )
where

import           Data.VectorSpace

import           GHC.Generics                   ( Generic )
import qualified Data.Text                     as T
import qualified Text.ParserCombinators.ReadP  as R
import           Control.DeepSeq                ( NFData )
import           Data.Aeson                     ( FromJSON
                                                , ToJSON
                                                )
import           Data.Maybe                     ( listToMaybe )
import           Data.Hashable                  ( Hashable )

---------------
-- Intervals --
---------------


class (Interval i, Interval (IOf i), VectorSpace i, ICOf (IOf i) ~ i) => IntervalClass i where
  type IOf i
--  ic :: IOf i -> i
  emb :: i -> IOf i

class VectorSpace i => Interval i where
  type ICOf i
  ic :: i -> ICOf i
  octave :: i
  direction :: i -> Ordering
  default direction :: Ord i => i -> Ordering
  direction i
i = i -> i -> Ordering
forall a. Ord a => a -> a -> Ordering
compare i
i i
forall v. AdditiveGroup v => v
zeroV
  iabs :: i -> i
  iabs i
i | i -> Ordering
forall i. Interval i => i -> Ordering
direction i
i Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT = i -> i
forall v. AdditiveGroup v => v -> v
negateV i
i
         | Bool
otherwise         = i
i

oct :: (IntervalClass i, s ~ Scalar (IOf i)) => s -> i -> IOf i
oct :: forall i s.
(IntervalClass i, s ~ Scalar (IOf i)) =>
s -> i -> IOf i
oct s
octs i
ic = i -> IOf i
forall i. IntervalClass i => i -> IOf i
emb i
ic IOf i -> IOf i -> IOf i
forall v. AdditiveGroup v => v -> v -> v
^+^ (IOf i
forall i. Interval i => i
octave IOf i -> s -> IOf i
forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* s
octs)

unison :: Interval i => i
unison :: forall i. Interval i => i
unison = i
forall v. AdditiveGroup v => v
zeroV

-- class (Interval i, IntervalClass (PCOf i), IOf (ICOf i) ~ i) => ClassyInterval i where  

class Interval i => Diatonic i where
  isStep :: i -> Bool

class Interval i => Chromatic i where
  chromaticSemitone :: i

down :: Interval i => i -> i
down :: forall i. Interval i => i -> i
down = i -> i
forall v. AdditiveGroup v => v -> v
negateV

newtype ImperfectInterval i = Impf (i -> i)

minor :: Chromatic i => ImperfectInterval i -> i
minor :: forall i. Chromatic i => ImperfectInterval i -> i
minor (Impf i -> i
int) = i -> i
int i
forall i. Chromatic i => i
chromaticSemitone

major :: Interval i => ImperfectInterval i -> i
major :: forall i. Interval i => ImperfectInterval i -> i
major (Impf i -> i
int) = i -> i
int i
forall v. AdditiveGroup v => v
zeroV

dim :: Chromatic i => i -> i
dim :: forall i. Chromatic i => i -> i
dim = (i -> i -> i
forall v. AdditiveGroup v => v -> v -> v
^-^ i
forall i. Chromatic i => i
chromaticSemitone)

aug :: Chromatic i => i -> i
aug :: forall i. Chromatic i => i -> i
aug = (i -> i -> i
forall v. AdditiveGroup v => v -> v -> v
^+^ i
forall i. Chromatic i => i
chromaticSemitone)

class Notation i where
  showNotation  :: i -> String
  showNotationT :: i -> T.Text
  showNotationT = String -> Text
T.pack (String -> Text) -> (i -> String) -> i -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> String
forall i. Notation i => i -> String
showNotation
  parseNotation :: R.ReadP i
  readNotation  :: String -> Maybe i
  readNotation String
str = (i, String) -> i
forall a b. (a, b) -> a
fst ((i, String) -> i) -> Maybe (i, String) -> Maybe i
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(i, String)] -> Maybe (i, String)
forall a. [a] -> Maybe a
listToMaybe (ReadP i -> ReadS i
forall a. ReadP a -> ReadS a
R.readP_to_S ReadP i
parseFull String
str)
    where parseFull :: ReadP i
parseFull = do
            result <- ReadP i
forall i. Notation i => ReadP i
parseNotation
            R.eof
            pure result
  readNotationT :: T.Text -> Maybe i
  readNotationT = String -> Maybe i
forall i. Notation i => String -> Maybe i
readNotation (String -> Maybe i) -> (Text -> String) -> Text -> Maybe i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-------------
-- Pitches --
-------------

-- wrapper type: turn intervals into pitches
newtype Pitch a = Pitch a
  deriving (Pitch a -> Pitch a -> Bool
(Pitch a -> Pitch a -> Bool)
-> (Pitch a -> Pitch a -> Bool) -> Eq (Pitch a)
forall a. Eq a => Pitch a -> Pitch a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Pitch a -> Pitch a -> Bool
== :: Pitch a -> Pitch a -> Bool
$c/= :: forall a. Eq a => Pitch a -> Pitch a -> Bool
/= :: Pitch a -> Pitch a -> Bool
Eq, Eq (Pitch a)
Eq (Pitch a) =>
(Pitch a -> Pitch a -> Ordering)
-> (Pitch a -> Pitch a -> Bool)
-> (Pitch a -> Pitch a -> Bool)
-> (Pitch a -> Pitch a -> Bool)
-> (Pitch a -> Pitch a -> Bool)
-> (Pitch a -> Pitch a -> Pitch a)
-> (Pitch a -> Pitch a -> Pitch a)
-> Ord (Pitch a)
Pitch a -> Pitch a -> Bool
Pitch a -> Pitch a -> Ordering
Pitch a -> Pitch a -> Pitch a
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
forall a. Ord a => Eq (Pitch a)
forall a. Ord a => Pitch a -> Pitch a -> Bool
forall a. Ord a => Pitch a -> Pitch a -> Ordering
forall a. Ord a => Pitch a -> Pitch a -> Pitch a
$ccompare :: forall a. Ord a => Pitch a -> Pitch a -> Ordering
compare :: Pitch a -> Pitch a -> Ordering
$c< :: forall a. Ord a => Pitch a -> Pitch a -> Bool
< :: Pitch a -> Pitch a -> Bool
$c<= :: forall a. Ord a => Pitch a -> Pitch a -> Bool
<= :: Pitch a -> Pitch a -> Bool
$c> :: forall a. Ord a => Pitch a -> Pitch a -> Bool
> :: Pitch a -> Pitch a -> Bool
$c>= :: forall a. Ord a => Pitch a -> Pitch a -> Bool
>= :: Pitch a -> Pitch a -> Bool
$cmax :: forall a. Ord a => Pitch a -> Pitch a -> Pitch a
max :: Pitch a -> Pitch a -> Pitch a
$cmin :: forall a. Ord a => Pitch a -> Pitch a -> Pitch a
min :: Pitch a -> Pitch a -> Pitch a
Ord, (forall x. Pitch a -> Rep (Pitch a) x)
-> (forall x. Rep (Pitch a) x -> Pitch a) -> Generic (Pitch a)
forall x. Rep (Pitch a) x -> Pitch a
forall x. Pitch a -> Rep (Pitch a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Pitch a) x -> Pitch a
forall a x. Pitch a -> Rep (Pitch a) x
$cfrom :: forall a x. Pitch a -> Rep (Pitch a) x
from :: forall x. Pitch a -> Rep (Pitch a) x
$cto :: forall a x. Rep (Pitch a) x -> Pitch a
to :: forall x. Rep (Pitch a) x -> Pitch a
Generic, [Pitch a] -> Value
[Pitch a] -> Encoding
Pitch a -> Bool
Pitch a -> Value
Pitch a -> Encoding
(Pitch a -> Value)
-> (Pitch a -> Encoding)
-> ([Pitch a] -> Value)
-> ([Pitch a] -> Encoding)
-> (Pitch a -> Bool)
-> ToJSON (Pitch a)
forall a. ToJSON a => [Pitch a] -> Value
forall a. ToJSON a => [Pitch a] -> Encoding
forall a. ToJSON a => Pitch a -> Bool
forall a. ToJSON a => Pitch a -> Value
forall a. ToJSON a => Pitch a -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall a. ToJSON a => Pitch a -> Value
toJSON :: Pitch a -> Value
$ctoEncoding :: forall a. ToJSON a => Pitch a -> Encoding
toEncoding :: Pitch a -> Encoding
$ctoJSONList :: forall a. ToJSON a => [Pitch a] -> Value
toJSONList :: [Pitch a] -> Value
$ctoEncodingList :: forall a. ToJSON a => [Pitch a] -> Encoding
toEncodingList :: [Pitch a] -> Encoding
$comitField :: forall a. ToJSON a => Pitch a -> Bool
omitField :: Pitch a -> Bool
ToJSON, Maybe (Pitch a)
Value -> Parser [Pitch a]
Value -> Parser (Pitch a)
(Value -> Parser (Pitch a))
-> (Value -> Parser [Pitch a])
-> Maybe (Pitch a)
-> FromJSON (Pitch a)
forall a. FromJSON a => Maybe (Pitch a)
forall a. FromJSON a => Value -> Parser [Pitch a]
forall a. FromJSON a => Value -> Parser (Pitch a)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall a. FromJSON a => Value -> Parser (Pitch a)
parseJSON :: Value -> Parser (Pitch a)
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [Pitch a]
parseJSONList :: Value -> Parser [Pitch a]
$comittedField :: forall a. FromJSON a => Maybe (Pitch a)
omittedField :: Maybe (Pitch a)
FromJSON, Pitch a -> ()
(Pitch a -> ()) -> NFData (Pitch a)
forall a. NFData a => Pitch a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => Pitch a -> ()
rnf :: Pitch a -> ()
NFData, Eq (Pitch a)
Eq (Pitch a) =>
(Int -> Pitch a -> Int) -> (Pitch a -> Int) -> Hashable (Pitch a)
Int -> Pitch a -> Int
Pitch a -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall a. Hashable a => Eq (Pitch a)
forall a. Hashable a => Int -> Pitch a -> Int
forall a. Hashable a => Pitch a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> Pitch a -> Int
hashWithSalt :: Int -> Pitch a -> Int
$chash :: forall a. Hashable a => Pitch a -> Int
hash :: Pitch a -> Int
Hashable)

instance Functor Pitch where
  fmap :: forall a b. (a -> b) -> Pitch a -> Pitch b
fmap a -> b
f (Pitch a
p) = b -> Pitch b
forall a. a -> Pitch a
Pitch (a -> b
f a
p)

toPitch :: a -> Pitch a
toPitch = a -> Pitch a
forall a. a -> Pitch a
Pitch
toInterval :: Pitch a -> a
toInterval (Pitch a
i) = a
i

(Pitch v
a) pto :: Pitch v -> Pitch v -> v
`pto` (Pitch v
b) = v
b v -> v -> v
forall v. AdditiveGroup v => v -> v -> v
^-^ v
a
(Pitch v
a) pfrom :: Pitch v -> Pitch v -> v
`pfrom` (Pitch v
b) = v
a v -> v -> v
forall v. AdditiveGroup v => v -> v -> v
^-^ v
b
(Pitch a
p) +^ :: Pitch a -> a -> Pitch a
+^ a
i = a -> Pitch a
forall a. a -> Pitch a
Pitch (a
p a -> a -> a
forall v. AdditiveGroup v => v -> v -> v
^+^ a
i)
a
i ^+ :: a -> Pitch a -> Pitch a
^+ (Pitch a
p) = a -> Pitch a
forall a. a -> Pitch a
Pitch (a
p a -> a -> a
forall v. AdditiveGroup v => v -> v -> v
^+^ a
i)
(Pitch a
p) -^ :: Pitch a -> a -> Pitch a
-^ a
i = a -> Pitch a
forall a. a -> Pitch a
Pitch (a
p a -> a -> a
forall v. AdditiveGroup v => v -> v -> v
^-^ a
i)
pc :: (Interval p) => Pitch p -> Pitch (ICOf p)
pc :: forall p. Interval p => Pitch p -> Pitch (ICOf p)
pc = (p -> ICOf p) -> Pitch p -> Pitch (ICOf p)
forall a b. (a -> b) -> Pitch a -> Pitch b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap p -> ICOf p
forall i. Interval i => i -> ICOf i
ic

-------------
-- Helpers --
-------------

transpose :: (Functor f, Interval i) => i -> f i -> f i
transpose :: forall (f :: * -> *) i. (Functor f, Interval i) => i -> f i -> f i
transpose i
by = (i -> i) -> f i -> f i
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (i -> i -> i
forall v. AdditiveGroup v => v -> v -> v
^+^ i
by)

embedI :: b -> IOf b -> b -> IOf b
embedI b
rot IOf b
trans = (IOf b -> IOf b -> IOf b
forall v. AdditiveGroup v => v -> v -> v
^+^ IOf b
trans) (IOf b -> IOf b) -> (b -> IOf b) -> b -> IOf b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> IOf b
forall i. IntervalClass i => i -> IOf i
emb (b -> IOf b) -> (b -> b) -> b -> IOf b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b -> b
forall v. AdditiveGroup v => v -> v -> v
^+^ b
rot)

embedP :: a -> IOf a -> Pitch a -> Pitch (IOf a)
embedP a
rot IOf a
trans = (Pitch (IOf a) -> IOf a -> Pitch (IOf a)
forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ IOf a
trans) (Pitch (IOf a) -> Pitch (IOf a))
-> (Pitch a -> Pitch (IOf a)) -> Pitch a -> Pitch (IOf a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> IOf a) -> Pitch a -> Pitch (IOf a)
forall a b. (a -> b) -> Pitch a -> Pitch b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> IOf a
forall i. IntervalClass i => i -> IOf i
emb (Pitch a -> Pitch (IOf a))
-> (Pitch a -> Pitch a) -> Pitch a -> Pitch (IOf a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pitch a -> a -> Pitch a
forall {a}. AdditiveGroup a => Pitch a -> a -> Pitch a
+^ a
rot)

embed :: a -> IOf a -> f a -> f (IOf a)
embed a
rot IOf a
trans = IOf a -> f (IOf a) -> f (IOf a)
forall (f :: * -> *) i. (Functor f, Interval i) => i -> f i -> f i
transpose IOf a
trans (f (IOf a) -> f (IOf a)) -> (f a -> f (IOf a)) -> f a -> f (IOf a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> IOf a) -> f a -> f (IOf a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> IOf a
forall i. IntervalClass i => i -> IOf i
emb (f a -> f (IOf a)) -> (f a -> f a) -> f a -> f (IOf a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a -> f a
forall (f :: * -> *) i. (Functor f, Interval i) => i -> f i -> f i
transpose a
rot
embed' :: v -> Pitch v -> f (ICOf v) -> f (IOf (ICOf v))
embed' v
slide Pitch v
c0 = ICOf v -> IOf (ICOf v) -> f (ICOf v) -> f (IOf (ICOf v))
forall {a} {f :: * -> *}.
(Functor f, IntervalClass a) =>
a -> IOf a -> f a -> f (IOf a)
embed (ICOf v -> ICOf v
forall v. AdditiveGroup v => v -> v
negateV (v -> ICOf v
forall i. Interval i => i -> ICOf i
ic v
slide)) (Pitch v -> v
forall {a}. Pitch a -> a
toInterval Pitch v
c0 v -> v -> v
forall v. AdditiveGroup v => v -> v -> v
^+^ v
slide)

----------------
-- conversion --
----------------

class ToMidi i where
  toMidi :: i -> Int

class ToFreq i where
  toFreq :: i -> Double