module Temporal.Music.Notation.Pitch (
Frequency, c1, a1,
Pch(pitch),
Pitch(..),
Interval, Scale(..), scaleSize, fromIntervals,
Bend, Octave, Step,
Tone(..), tone, toneNum,
PitchFunctor(..),
setScale, mapBase, setBase, transposeScale,
ToneFunctor(..),
setBend, bend, step, transp,
low, l', ll', high, h', hh', lower, higher, invert,
frequency, absPitch
)
where
import Data.Function(on)
import qualified Data.Vector as V
import Temporal.Music.Notation.Score(Score)
import Control.Arrow(first, second)
import Temporal.Music.Notation.Seg
type Frequency = Double
c1 :: Frequency
c1 = 261.626
a1 :: Frequency
a1 = 440
class Seg a => Pch a where
pitch :: Tone a -> Pitch a
data Seg n => Pitch n = Pitch
{ pitchScale :: Scale
, pitchTone :: Tone n
} deriving (Show, Eq)
type Interval = Frequency
data Scale = Scale
{ scaleBase :: (Int, Frequency)
, scaleOctave :: Interval
, scaleSteps :: V.Vector Interval
} deriving (Show, Eq)
scaleSize :: Scale -> Int
scaleSize = V.length . scaleSteps
fromIntervals ::
Interval -> [Interval]
-> (Int -> Frequency -> Scale)
fromIntervals octave steps = \c0 f0 -> Scale (c0, f0) octave $ V.fromList steps
type Bend = Double
type Octave = Int
type Step = Int
data Seg n => Tone n = Tone
{ toneBend :: Bend
, toneOctave :: Octave
, toneStep :: n
} deriving (Eq, Show)
tone :: Seg n => n -> Tone n
tone = Tone 0 0
toneNum :: Seg n => Tone n -> Int
toneNum x = segSize $ num x
where num :: Seg n => Tone n -> n
num = const undefined
instance (Eq n, Seg n) => Ord (Tone n) where
compare = compare `on` (\(Tone b o s) -> (o, fromEnum s, b))
instance Seg n => Enum (Tone n) where
toEnum x = res
where res = Tone 0 o $ toEnum s
(o, s) = divMod x (toneNum res)
fromEnum x = toneOctave x * toneNum x + (fromEnum $ toneStep x)
instance (Eq n, Show n, Seg n) => Num (Tone n) where
(+) = liftBi (+) (+) (+)
() = liftBi () () (+)
(*) = liftBi (*) (*) (*)
abs = liftUn abs abs abs
signum t@(Tone b o s)
| abs b < 1e-6 && o == 0 && s == minBound = 0
| t > 0 = fromInteger 1
| otherwise = fromInteger $ 1
fromInteger x = step (fromInteger x) $ tone minBound
class PitchFunctor a where
mapPitch :: (forall n . Seg n => Pitch n -> Pitch n) -> (a -> a)
instance Seg n => PitchFunctor (Pitch n) where
mapPitch f = f
instance (PitchFunctor a) => PitchFunctor (Score a) where
mapPitch f = fmap (mapPitch f)
mapScale :: PitchFunctor a => (Scale -> Scale) -> a -> a
mapScale f = mapPitch $ \p -> p{ pitchScale = f $ pitchScale p }
setScale :: PitchFunctor a => Scale -> a -> a
setScale x = mapScale $ const x
mapBase :: PitchFunctor a => (Frequency -> Frequency) -> a -> a
mapBase f = mapScale $ \s -> s{ scaleBase = second f $ scaleBase s }
setBase :: PitchFunctor a => Frequency -> a -> a
setBase b = mapBase $ const b
transposeScale :: PitchFunctor a => Step -> a -> a
transposeScale n = mapScale $ \(Scale b o s) -> Scale b o $ rotateSteps n s
where rotateSteps x s = V.map ( (/d) . (s V.! ) . flip mod n) ids
where n = V.length s
d = s V.! (mod x n)
ids = V.fromList [x .. x + n]
class ToneFunctor a where
mapTone :: (forall n . Seg n => Tone n -> Tone n) -> (a -> a)
instance Seg n => ToneFunctor (Tone n) where
mapTone f = f
instance ToneFunctor a => ToneFunctor (Score a) where
mapTone f = fmap (mapTone f)
instance Seg n => ToneFunctor (Pitch n) where
mapTone f (Pitch s t) = Pitch s $ f t
setBend :: ToneFunctor a => Bend -> a -> a
setBend d = mapTone $ \x -> x{ toneBend = d }
bend :: ToneFunctor a => Bend -> a -> a
bend d = mapTone $ \x -> x{ toneBend = toneBend x + d }
step :: ToneFunctor a => Step -> a -> a
step n = mapTone $ liftUn id id ( + n)
transp :: ToneFunctor a => Step -> a -> a
transp = step
low :: ToneFunctor a => a -> a
low = lower 1
l' :: ToneFunctor a => a -> a
l' = low
ll' :: ToneFunctor a => a -> a
ll' = lower 2
high :: ToneFunctor a => a -> a
high = higher 1
h' :: ToneFunctor a => a -> a
h' = high
hh' :: ToneFunctor a => a -> a
hh' = higher 2
lower :: ToneFunctor a => Int -> a -> a
lower n = higher (n)
higher :: ToneFunctor a => Int -> a -> a
higher n = mapTone $ \(Tone b o s) -> Tone b (o + n) s
invert :: ToneFunctor a => Step -> a -> a
invert center = mapTone $
\t@(Tone b o s) ->
let n = toneNum t
c = mod center n
w = fromEnum s
q = if c <= w
then (2 * c + n w)
else (2 * c n w)
(o', s') = divMod q n
in Tone b (o + o') $ toEnum s'
absPitch :: Seg n => Pitch n -> Frequency
absPitch (Pitch s t) = frequency s t
frequency :: Seg n => Scale -> Tone n -> Frequency
frequency s t@(Tone b o n) = (bendCoeff r' d s * ) $
scaleFreq s d
where (b', r') = properFraction b
d = fromEnum t + fromIntegral b'
bendCoeff :: Bend -> Step -> Scale -> Double
bendCoeff r n s
| abs r < 1e-6 = 1
| r > 0 = flip loginterpCoeff r $ getTones s n $ n + 1
| otherwise = flip loginterpCoeff (abs r) $ getTones s n $ n 1
where getTones s n1 n2 = (scaleFreq s n1, scaleFreq s n2)
scaleFreq :: Scale -> Int -> Frequency
scaleFreq s x = f0 * (scaleOctave s ^^ o) * (scaleSteps s V.! n)
where (o, n) = divMod (x c0) $ scaleSize s
(c0, f0) = scaleBase s
loginterpCoeff :: (Double, Double) -> Double -> Double
loginterpCoeff (l, r) x = (r / l) ** x
liftUn :: Seg n
=> (Double -> Double)
-> (Int -> Int)
-> (Int -> Int)
-> Tone n -> Tone n
liftUn f g h t@(Tone b o s) =
(uncurry $ Tone (f b)) $
fit (toneNum t) (g o, h $ fromEnum s)
liftBi :: Seg n
=> (Double -> Double -> Double)
-> (Int -> Int -> Int)
-> (Int -> Int -> Int)
-> Tone n -> Tone n -> Tone n
liftBi f g h t@(Tone b o s) (Tone b' o' s') =
(uncurry $ Tone (b `f` b')) $
fit (toneNum t) (o `g` o', fromEnum s `h` fromEnum s')
fit :: Seg s => Int -> (Int, Int) -> (Int, s)
fit n (o, s) = (o + o', toEnum s')
where (o', s') = divMod s n