{-# 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 = forall a. Ord a => a -> a -> Ordering
compare i
i forall v. AdditiveGroup v => v
zeroV
  iabs :: i -> i
  iabs i
i | forall i. Interval i => i -> Ordering
direction i
i forall a. Eq a => a -> a -> Bool
== Ordering
LT = 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 = forall i. IntervalClass i => i -> IOf i
emb i
ic forall v. AdditiveGroup v => v -> v -> v
^+^ (forall i. Interval i => i
octave forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* s
octs)

unison :: Interval i => i
unison :: forall i. Interval i => i
unison = 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 = 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 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 forall v. AdditiveGroup v => v
zeroV

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

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

class Notation i where
  showNotation  :: i -> String
  showNotationT :: i -> T.Text
  showNotationT = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Notation i => i -> String
showNotation
  parseNotation :: R.ReadP i
  readNotation  :: String -> Maybe i
  readNotation String
str = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
listToMaybe (forall a. ReadP a -> ReadS a
R.readP_to_S ReadP i
parseFull String
str)
    where parseFull :: ReadP i
parseFull = do
            i
result <- forall i. Notation i => ReadP i
parseNotation
            ReadP ()
R.eof
            forall (f :: * -> *) a. Applicative f => a -> f a
pure i
result
  readNotationT :: T.Text -> Maybe i
  readNotationT = forall i. Notation i => String -> Maybe i
readNotation 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
forall a. Eq a => Pitch a -> Pitch a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pitch a -> Pitch a -> Bool
$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
Eq, 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
min :: Pitch a -> Pitch a -> Pitch a
$cmin :: forall a. Ord a => Pitch a -> Pitch a -> Pitch a
max :: Pitch a -> Pitch a -> Pitch a
$cmax :: forall a. Ord a => Pitch a -> Pitch a -> Pitch a
>= :: 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
$c< :: forall a. Ord a => Pitch a -> Pitch a -> Bool
compare :: Pitch a -> Pitch a -> Ordering
$ccompare :: forall a. Ord a => Pitch a -> Pitch a -> Ordering
Ord, 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
$cto :: forall a x. Rep (Pitch a) x -> Pitch a
$cfrom :: forall a x. Pitch a -> Rep (Pitch a) x
Generic, [Pitch a] -> Encoding
[Pitch a] -> Value
Pitch a -> Encoding
Pitch a -> Value
forall a. ToJSON a => [Pitch a] -> Encoding
forall a. ToJSON a => [Pitch a] -> Value
forall a. ToJSON a => Pitch a -> Encoding
forall a. ToJSON a => Pitch a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Pitch a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [Pitch a] -> Encoding
toJSONList :: [Pitch a] -> Value
$ctoJSONList :: forall a. ToJSON a => [Pitch a] -> Value
toEncoding :: Pitch a -> Encoding
$ctoEncoding :: forall a. ToJSON a => Pitch a -> Encoding
toJSON :: Pitch a -> Value
$ctoJSON :: forall a. ToJSON a => Pitch a -> Value
ToJSON, Value -> Parser [Pitch a]
Value -> Parser (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]) -> FromJSON a
parseJSONList :: Value -> Parser [Pitch a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [Pitch a]
parseJSON :: Value -> Parser (Pitch a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (Pitch a)
FromJSON, Pitch a -> ()
forall a. NFData a => Pitch a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Pitch a -> ()
$crnf :: forall a. NFData a => Pitch a -> ()
NFData, 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
hash :: Pitch a -> Int
$chash :: forall a. Hashable a => Pitch a -> Int
hashWithSalt :: Int -> Pitch a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> 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) = forall a. a -> Pitch a
Pitch (a -> b
f a
p)

toPitch :: a -> Pitch a
toPitch = 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 forall v. AdditiveGroup v => v -> v -> v
^-^ v
a
(Pitch v
a) pfrom :: Pitch v -> Pitch v -> v
`pfrom` (Pitch v
b) = v
a forall v. AdditiveGroup v => v -> v -> v
^-^ v
b
(Pitch a
p) +^ :: Pitch a -> a -> Pitch a
+^ a
i = forall a. a -> Pitch a
Pitch (a
p forall v. AdditiveGroup v => v -> v -> v
^+^ a
i)
a
i ^+ :: a -> Pitch a -> Pitch a
^+ (Pitch a
p) = forall a. a -> Pitch a
Pitch (a
p forall v. AdditiveGroup v => v -> v -> v
^+^ a
i)
(Pitch a
p) -^ :: Pitch a -> a -> Pitch a
-^ a
i = forall a. a -> Pitch a
Pitch (a
p 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall v. AdditiveGroup v => v -> v -> v
^+^ i
by)

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

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

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

class ToMidi i where
  toMidi :: i -> Int

class ToFreq i where
  toFreq :: i -> Double