{-# 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,
    Vol(volume),
    Volume(..), Level(..),
    volumeNum, levelNum,
    level, mediumLevel,
	-- * Transformers
	VolumeFunctor(..), LevelFunctor(..),
	setDiapason, setLevel, setAccent,
    accent, al', aq',
    loud, quiet, louder, quieter,
    dynamics, dynamicsRel, dynamicsSeg,
    -- * Rendering
    amplitude, unsafeAmplitude, 
    absVolume, unsafeAbsVolume
)
where

import Data.Function(on)

import Temporal.Music.Notation.Seg(Seg, segSize)
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


class Seg a => Vol a where
    volume :: Level a -> Volume a

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

class VolumeFunctor a where
	mapVolume :: (forall n . Seg n => Volume n -> Volume n) -> (a -> a)

instance Seg n => VolumeFunctor (Volume n) where
	mapVolume f = f

instance VolumeFunctor a => VolumeFunctor (Score a) where
	mapVolume f = fmap (mapVolume f)

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

-- | setDiapason
setDiapason :: VolumeFunctor a => (Amplitude, Amplitude) -> a -> a
setDiapason x = mapVolume $ \(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 Seg n => Level n = Level
        { levelAccent  :: Accent
        , levelStep    :: n
        } deriving (Show, Eq)

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

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

phantomNum :: Seg n => f n -> Int
phantomNum = segSize . num
    where num :: f n -> n
          num = const undefined

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

-- | 'level' constructs 'Level' from type of class 'Seg'. 'Accent' is set to zero.
level :: Seg n => n -> Level n
level = Level 0 

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

instance Seg n => Enum (Level n) where
    toEnum   = level . toEnum
    fromEnum = fromEnum . levelStep
  
instance Seg n => Bounded (Level n) where
    maxBound = level maxBound
    minBound = level minBound

instance Seg n => Seg (Level n)

instance (Eq n, Seg n) => Ord (Level n) where
    compare = compare `on` (\(Level a s) -> (fromIntegral $ fromEnum s) + a)

instance (Show n, Eq n, Seg n) => Num (Level n) where
    (+) = liftBi (+) (+)
    (-) = liftBi (-) (-)
    (*) = liftBi (*) (*)
    abs = id
    signum x
        | x == minBound = 0
        | otherwise     = 1
    fromInteger x = res
        where n   = levelNum res
              res = level $ toEnum $ sat 0 n $ fromInteger x

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

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

instance Seg 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

-- | shorcut for 'accent louder' 
al' :: LevelFunctor a => Accent -> a -> a
al' = accent

-- | shorcut for 'accent quieter' 
aq' :: LevelFunctor a => Accent -> a -> a
aq' = accent . negate

-- | '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 :: (Seg n, LevelFunctor a) => n -> a -> a
setLevel n = mapLevel 
    (\l@(Level a _) -> Level a $ toEnum $ sat 0 (levelNum l) $ fromEnum 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 $ liftUn id (+n)
    | n < 0 = mapLevel $ liftUn id (\x -> x - n)

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

-- | Linear relative 'dyn' 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.
dynamicsRel :: LevelFunctor a => [Accent] -> Score a -> Score a
dynamicsRel xs = dynamics $ linseg $ init $ f =<< xs
    where dt  = recip $ fromIntegral $ length xs
          f x = [x, dt]

-- | 'dynSeg' lifts 'linseg' function to dynamics level
dynamicsSeg :: LevelFunctor a => [Double] -> Score a -> Score a
dynamicsSeg xs = dynamics $ linseg xs

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

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

-- | converts volume to amplitude with 'unsafeAmplitude' function
unsafeAbsVolume :: Seg 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 :: Seg 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 :: Seg n => Diapason -> Level n -> Amplitude
unsafeAmplitude = amplitudeGen id

amplitudeGen :: Seg 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 $ fromEnum s) + a


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

liftUn :: Seg n
    => (Accent  -> Accent)
    -> (Int     -> Int)
    -> (Level n -> Level n)
liftUn f g l@(Level a s) = Level (f a) 
    (toEnum $ sat 0 (levelNum l) $ g $ fromEnum s)

liftBi :: Seg 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') (toEnum $ sat 0 (levelNum l) $ fromEnum s `g` fromEnum s')

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