{-# LANGUAGE 
        FlexibleInstances, 
        TypeSynonymInstances, 
        Rank2Types #-}

-- | representing volume
module Temporal.Music.Notation.Volume(
	-- * Types
    -- | Main datatypes are 'Amplitude', 'Diapason' and 'Level'.
    -- 'Volume' consists of 'Diapason' and 'Level'. Every
    -- 'Volume' can be converted to 'Amplitude' (see 'absVolume').
    -- 'Amplitude' is linear units and 'Level' is logarithmic units,
    -- or decibels. 'Diapason' defines lower and upper bound for volume level
    -- in amplitude linear units. 
	Amplitude,
    Diapason, Accent,
    Volume(..), Level(..),
    volumeNum, levelNum,
    level, mediumLevel,
	-- * Transformers
	VolFunctor(..), LevelFunctor(..),
	setDiapason, setLevel, setAccent,
    accent,
    loud, quiet, louder, quieter,
    dynamic, dynamicRel,
    -- * Rendering
    amplitude, unsafeAmplitude, 
    absVolume, unsafeAbsVolume
)
where

import Data.Function(on)
import TypeLevel.NaturalNumber
import Temporal.Music.Notation.Score(Score, Time, tmapRel, linseg)

-- | Linear volume units
type Amplitude = Double

-- | Volume lower and upper bounds. Lower bound must be positive
-- and upper bound must exceed lower bound.
type Diapason = (Amplitude, Amplitude)

-- | 'Accent' defines values between 'Level' values on logarithmic 
-- scale. 1 'Accent' == 1 'Level' 's step.
type Accent   = Double

-- | 'Volume' consists of 'Diapason' and 'Level'.
data NaturalNumber n => Volume n = Volume 
        { volumeDiapason :: Diapason
        , volumeLevel    :: Level n
        } deriving (Show, Eq)

class VolFunctor a where
	mapVol :: (forall n . NaturalNumber n => Volume n -> Volume n) -> (a -> a)

instance NaturalNumber n => VolFunctor (Volume n) where
	mapVol f = f

instance VolFunctor a => VolFunctor (Score a) where
	mapVol f = fmap (mapVol f)

instance NaturalNumber n => LevelFunctor (Volume n) where
    mapLevel f = \(Volume d l) -> Volume d $ f l

-- | setDiapason
setDiapason :: VolFunctor a => (Amplitude, Amplitude) -> a -> a
setDiapason x = mapVol $ \(Volume _ l) -> Volume x l
--------------------------------------------------
--------------------------------------------------
-- Level

-- | 'Level' defines number of equally spaced stamps on
-- logarithmic scale (steps), and degree of diversion 
-- from the stamps (accents).
data NaturalNumber n => Level n = Level
        { levelAccent  :: Accent
        , levelStep    :: Int
        } deriving (Show, Eq)

-- | number of levels in 'Volume' scale
volumeNum :: NaturalNumber n => Volume n -> Int
volumeNum = phantomNum

-- | number of levels in 'Level' scale
levelNum :: NaturalNumber n => Level n -> Int
levelNum = phantomNum

phantomNum :: NaturalNumber n => f n -> Int
phantomNum = naturalNumberAsInt . num
    where num :: f n -> n
          num = const undefined

-------------------------------------------
-- constructors

-- | 'level' constructs 'Level' from 'Int'. 'Accent' is set to zero.
-- If input exceeds 'levelNum' then result is set to 'levelNum',
-- if input is negative then result set is to zero.
level :: NaturalNumber n => Int -> Level n
level x = res
    where n   = levelNum res
          res = Level 0 $ sat 0 n x

-------------------------------------------
-- instances

instance NaturalNumber n => Enum (Level n) where
    toEnum   = level
    fromEnum = levelStep
   
instance NaturalNumber n => Ord (Level n) where
    compare = compare `on` (\(Level a s) -> fromIntegral s + a)

instance NaturalNumber n => Num (Level n) where
    (+) = liftBi (+) (+)
    (-) = liftBi (-) (-)
    (*) = liftBi (*) (*)
    abs = id
    signum x
        | x == level 0 = 0
        | otherwise    = 1
    fromInteger = level . fromInteger

--------------------------------------
-- transformers

class LevelFunctor a where
    mapLevel :: (forall n . NaturalNumber n => Level n -> Level n) -> (a -> a)

instance NaturalNumber n => LevelFunctor (Level n) where
    mapLevel f = f

instance LevelFunctor a => LevelFunctor (Score a) where
	mapLevel f = fmap (mapLevel f)

-- | 'accent' increases 'Accent' value by some degree
accent :: LevelFunctor a => Accent -> a -> a
accent d = mapLevel $ \(Level a s) -> Level (a+d) s

-- | 'setAccent' sets 'Accent' value to given input
setAccent :: LevelFunctor a => Accent -> a -> a
setAccent d = mapLevel $ \(Level _ s) -> Level d s

-- | 'setLevel' sets 'levelStep' to given input 
setLevel :: LevelFunctor a => Int -> a -> a
setLevel n = mapLevel 
    (\l@(Level a _) -> Level a $ sat 0 (levelNum l) n)

-- | Input becomes one step louder
loud :: LevelFunctor a => a -> a
loud = louder 1

-- | Input becomes one step quieter
quiet :: LevelFunctor a => a -> a
quiet = quieter 1

-- | Input becomes given number of steps quieter
quieter :: LevelFunctor a => Int -> a -> a
quieter n = louder (-n)

-- | Input becomes given number of steps louder
louder :: LevelFunctor a => Int -> a -> a
louder n 
    | n > 0 = mapLevel ( + level n)
    | n < 0 = mapLevel (\x -> x - level n)


-- | Medium level
mediumLevel :: NaturalNumber n => Level n
mediumLevel = res
    where res = level $ round $ fromIntegral n / 2
          n   = levelNum res
          
-- | Accent that depends on time of note
dynamic :: LevelFunctor a => (Time -> Accent) -> Score a -> Score a
dynamic f = tmapRel $ \t -> accent (f t)

-- | Linear relative 'dynamic' function. Function is defined by list of
-- its values equaly spaced along time axis. For example
-- list [0, 1, 0] defines rise then decay lineary along full 'Score' 's
-- input duration. Time intervals of 
-- rise and decay segments are equal to 'dur' /2. And list [0, 1, 0.5, 0] 
-- defines
-- rise and decay again but here decay segment is twice longer then
-- rise segment.
dynamicRel :: LevelFunctor a => [Accent] -> Score a -> Score a
dynamicRel xs = dynamic $ linseg $ init $ f =<< xs
    where dt  = recip $ fromIntegral $ length xs
          f x = [x, dt]

--------------------------------------------------
-- rendering

-- | converts volume to amplitude with 'amplitude' function
absVolume :: NaturalNumber n => Volume n -> Amplitude
absVolume (Volume d l) = amplitude d l

-- | converts volume to amplitude with 'unsafeAmplitude' function
unsafeAbsVolume :: NaturalNumber n => Volume n -> Amplitude
unsafeAbsVolume (Volume d l) = unsafeAmplitude d l

-- | converts equally spaced between lower and upper diapason bounds
-- 'Level' values to amplitudes. 
-- Here resulting amplitude value lies within 'Diapason' interval.
-- All outsiders are placed inside interval with saturation.
amplitude :: NaturalNumber n => Diapason -> Level n -> Amplitude
amplitude d l = amplitudeGen (sat 0 $ fromIntegral $ levelNum l) d l

-- | unsafe analog of 'amplitude' function. Here result can go
-- beyond limits of 'Diapason' interval.
unsafeAmplitude :: NaturalNumber n => Diapason -> Level n -> Amplitude
unsafeAmplitude = amplitudeGen id

amplitudeGen :: NaturalNumber n 
    => (Double -> Double)
    -> Diapason -> Level n -> Amplitude
amplitudeGen bound (low, high) l@(Level a s) = (low * ) $ (high / low) ** x
    where n = fromIntegral $ levelNum l
          x = ( / n) $ bound $ fromIntegral s + a


--------------------------------------
-- level manipulation

liftBi :: NaturalNumber n
    => (Accent  -> Accent  -> Accent)
    -> (Int     -> Int    ->  Int )
    -> (Level n -> Level n -> Level n)
liftBi f g l@(Level a s) (Level a' s') =      
    Level (a `f` a') (sat 0 (levelNum l) $ s `g` s')

sat :: Ord a => a -> a -> a -> a
sat low high x
    | x < low   = low
    | x > high  = high
    | otherwise = x