{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}
{- |
Copyright   :  (c) Henning Thielemann 2008
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
-}
module Synthesizer.Plain.Filter.Recursive.Allpass where

import qualified Synthesizer.Plain.Signal   as Sig
import qualified Synthesizer.Plain.Modifier as Modifier

import qualified Algebra.Module                as Module
import qualified Algebra.RealTranscendental    as RealTrans
import qualified Algebra.Transcendental        as Trans
import qualified Algebra.Field                 as Field
import qualified Algebra.Ring                  as Ring
import qualified Algebra.Additive              as Additive

import Algebra.Module((*>))

import Number.Complex ((+:))
import qualified Number.Complex as Complex
import Synthesizer.Utility (nest, mapSnd, )

import Control.Monad.State (State(..), evalState, )

import qualified Prelude as P
import PreludeBase
import NumericPrelude



newtype Parameter a = Parameter a  {- ^ Feedback factor. -}
   deriving Show


{-# INLINE parameter #-}
parameter :: Trans.C a =>
     Int  {- ^ The number of equally designed 1st order allpasses. -}
  -> a    {- ^ The phase shift to be achieved for the given frequency. -}
  -> a    {- ^ The frequency we specified the phase shift for. -}
  -> Parameter a
parameter order phase frequency =
    let orderFloat = fromIntegral order
        omega = frequency * 2 * pi
        phi = phase / orderFloat
        k = (cos phi - cos omega) / (1 - cos (phi - omega))
    in  Parameter k

{-# INLINE flangerParameter #-}
flangerParameter :: Trans.C a => Int -> a -> Parameter a
flangerParameter order frequency =
    parameter order (-2*pi) frequency

{-# INLINE firstOrderStep #-}
firstOrderStep :: (Ring.C a, Module.C a v) =>
   Parameter a -> v -> State (v,v) v
firstOrderStep (Parameter k) u0 =
   State (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0)))

{-# INLINE firstOrderModifier #-}
firstOrderModifier :: (Ring.C a, Module.C a v) =>
   Modifier.Simple (v,v) (Parameter a) v v
firstOrderModifier =
   Modifier.Simple (zero,zero) firstOrderStep

{-# INLINE firstOrder #-}
firstOrder :: (Ring.C a, Module.C a v) =>
   Sig.T (Parameter a) -> Sig.T v -> Sig.T v
firstOrder = Sig.modifyModulated firstOrderModifier


{-# INLINE makePhase #-}
makePhase :: RealTrans.C a => Parameter a -> a -> a
makePhase (Parameter k) frequency =
    let omega = 2*pi * frequency
    in  2 * Complex.phase ((k+cos omega)+:(- sin omega)) + omega

{-
internal storage is not very efficient
because the second value of one pair is equal
to the first value of the subsequent value
-}
{-# INLINE cascadeStepStackPairs #-}
cascadeStepStackPairs :: (Ring.C a, Module.C a v) =>
   Parameter a -> v -> State [(v,v)] v
cascadeStepStackPairs k =
   -- stackStatesR would work as well, but with reversed list of states
   Modifier.stackStatesL (firstOrderStep k)

{-# INLINE cascadeStepStack #-}
cascadeStepStack :: (Ring.C a, Module.C a v) =>
   Parameter a -> v -> State [v] v
cascadeStepStack k x =
   State $
      mapSnd fromPairs .
      runState (cascadeStepStackPairs k x) .
      toPairs

{-# INLINE fromPairs #-}
fromPairs :: [(a,a)] -> [a]
fromPairs xs@(x:_) = fst x : map snd xs
fromPairs [] = error "Allpass.fromPairs: empty list"

{-# INLINE toPairs #-}
toPairs :: [a] -> [(a,a)]
toPairs xs = zip xs (tail xs)

{-# INLINE cascadeStep #-}
{-# INLINE cascadeStepRec #-}
{-# INLINE cascadeStepRecAlt #-}
cascadeStep, cascadeStepRec, cascadeStepRecAlt ::
   (Ring.C a, Module.C a v) =>
   Parameter a -> v -> State [v] v

cascadeStep = cascadeStepRec

cascadeStepRec (Parameter k) x = State $ \s ->
    let crawl _ [] = error "Allpass.crawl needs at least one element in the list"
        crawl u0 (_:[]) = u0:[]
        crawl u0 (u1:y1:us) =
            let y0 = u1 + k *> (u0-y1)
            in  u0 : crawl y0 (y1:us)
        news = crawl x s
    in  (last news, news)

cascadeStepRecAlt k x = State $ \s ->
    let crawl _ [] = error "Allpass.crawl needs at least one element in the list"
        crawl u0 (u1:u1s) = mapSnd (u0:) $
           case u1s of
              [] -> (u0,[])
              (y1:_) ->
                 crawl (evalState (firstOrderStep k u0) (u1,y1)) u1s
    in  crawl x s

{-# INLINE cascadeModifier #-}
cascadeModifier :: (Ring.C a, Module.C a v) =>
   Int -> Modifier.Simple [v] (Parameter a) v v
cascadeModifier order =
   Modifier.Simple (replicate (succ order) zero) cascadeStep


{-# INLINE cascade #-}
{-# INLINE cascadeState #-}
{-# INLINE cascadeIterative #-}
cascade, cascadeState, cascadeIterative ::
   (Ring.C a, Module.C a v) =>
   Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v

{-| Choose one of the implementations below -}
cascade = cascadeState

{-| Simulate the Allpass cascade by a list of states of the partial allpasses -}
cascadeState order =
   Sig.modifyModulated (cascadeModifier order)

{-| Directly implement the allpass cascade as multiple application of allpasses of 1st order -}
cascadeIterative order c =
   nest order (firstOrder c)