module Temporal.Music.Pitch (
Hz, Interval, c1, a1, transpose,
Pitch(..), fromStep, Bend, Octave, Step,
Scale(..), fromIntervals,
scaleStep, scaleLength,
PitchLike(..), mapPitch,
absPitch, pitchAsDouble, scaleAt
)
where
import Data.Default
import qualified Data.Vector as V
type Hz = Double
type Interval = Double
c1 :: Hz
c1 = 261.626
a1 :: Hz
a1 = 440
data Pitch = Pitch {
pitchScale :: Scale,
pitchBend :: Bend,
pitchOctave :: Octave,
pitchStep :: Step
} deriving (Show, Eq)
type Bend = Double
type Octave = Int
type Step = Int
pitchAsDouble :: Pitch -> Double
pitchAsDouble p = pitchBend p + fromIntegral (pitchAsInt p)
pitchAsInt :: Pitch -> Int
pitchAsInt p = pitchOctave p * (scaleLength $ pitchScale p) + pitchStep p
instance Default Pitch where
def = Pitch def def def def
data Scale = Scale {
scaleBase :: Hz,
scaleOctave :: Interval,
scaleSteps :: V.Vector Interval
} deriving (Show, Eq)
instance Default Scale where
def = eqt c1
where eqt = fromIntervals 2 (map ((2 **) . (/12)) [0 .. 11])
fromIntervals :: Interval -> [Interval] -> (Hz -> Scale)
fromIntervals octave steps = \f0 -> Scale f0 octave $ V.fromList steps
scaleAt :: Scale -> Double -> Hz
scaleAt s x = scaleAtInt s d * bendCoeff s n r
where (d, r) = properFraction x
n = mod d $ scaleLength s
class PitchLike a where
setPitch :: Pitch -> a -> a
getPitch :: a -> Pitch
mapPitch :: PitchLike a => (Pitch -> Pitch) -> a -> a
mapPitch f x = setPitch (f $ getPitch x) x
instance PitchLike Pitch where
setPitch = const id
getPitch = id
fromStep :: Int -> Pitch
fromStep a = def{ pitchStep = a }
scaleStep :: Scale -> Int -> Interval
scaleStep s x = (scaleOctave s ^^ o) * scaleSteps s V.! n
where (o, n) = divMod x $ scaleLength s
scaleLength :: Scale -> Int
scaleLength = V.length . scaleSteps
transpose :: Interval -> Hz -> Hz
transpose k a = k * a
renderPitch :: Pitch -> Hz
renderPitch p = pitchScale p `scaleAt` pitchAsDouble p
absPitch :: PitchLike a => a -> Hz
absPitch = renderPitch . getPitch
scaleAtInt :: Scale -> Int -> Hz
scaleAtInt s x = scaleBase s * scaleStep s x
bendCoeff :: Scale -> Int -> Double -> Hz
bendCoeff s n x
| abs x < 1e-6 = 1
| x > 0 = flip loginterpCoeff x $ getTones s n $ n + 1
| otherwise = flip loginterpCoeff (abs x) $ getTones s n $ n 1
where getTones s n1 n2 = (getTone s n1, getTone s n2)
getTone s x
| x >= 0 && x < n = scaleSteps s V.! x
| x == n = o
| x == 1 = scaleSteps s V.! (n1) / o
| otherwise = error $ "scaleStep: out of bounds"
where n = scaleLength s
o = scaleOctave s
loginterpCoeff :: (Double, Double) -> Double -> Double
loginterpCoeff (l, r) x = (r / l) ** x