-- | An envelope made up from linear or cubic bezier segments.
-- (The word \"envelope\" is understood as in ADSR.)
 
module Data.Envelope 
{-
  ( SegmentType(..)
  , EnvSegment(..)
  , Envelope(..)
  , Envelope'
  , calcEnvelopeSegment
  , calcEnvelope
  ) 
-}
  where

import Control.Monad

-------------------------------------------------------

{-
clamp :: Ord a => (a,a) -> a -> a
clamp (minv,maxv) x = max (min x maxv) minv
-}

first :: (a -> b) -> (a,c) -> (b,c)
first f (x,y) = (f x, y)

second :: (b -> c) -> (a,b) -> (a,c)
second f (x,y) = (x, f y)

-------------------------------------------------------

data SegmentType = LinearS | CubicS deriving (Eq,Read,Show)

-- the editor wants to remember to the control points even if we are
-- in a linear mode... thus, ugliness wins against elegance
data EnvSegment a = EnvSegment
  { es_type  :: SegmentType
  , es_left  :: a 
  , es_ctrl1 :: a
  , es_ctrl2 :: a
  , es_right :: a
  }   
  deriving (Read,Show)

{-    
-- for debugging
instance Show a => Show (EnvSegment a) where
  show (EnvSegment LinearS x _ _ y) = show [x,y]
  show (EnvSegment CubicS  x y z w) = show (x,y,z,w)
instance (Show a, Show t) => Show (Envelope t a) where
  show (Envelope n env') = show (take n env')
-}
 
isCubic :: EnvSegment a -> Bool
isCubic es = es_type es == CubicS

isLinear :: EnvSegment a -> Bool
isLinear es = es_type es == LinearS
   
flipType :: EnvSegment a -> EnvSegment a   
flipType es = es { es_type = typ' } where
  typ' = flip (es_type es)
  flip CubicS  = LinearS
  flip LinearS = CubicS
   
-- | An envelope on the interval [0,1], made up from (scaled) segments.
type Envelope' t a = [ ( EnvSegment a , t ) ]

-- again, the editor wants to remember "offscreen" segments...
data Envelope t a = Envelope Int (Envelope' t a) deriving (Read,Show)

{-
instance Functor EnvSegment where
  fmap f (EnvSegment typ x y z w) = EnvSegment typ (f x) (f y) (f z) (f w)
instance Functor (Envelope' t) where
  fmap f = map (first f) 
-}

tmap :: (t -> t) -> Envelope' t a -> Envelope' t a
tmap f = map (second f)

nthTimePoint :: Num t => Int -> Envelope' t a -> t 
nthTimePoint 0 _ = 0
nthTimePoint k xs = snd (xs!!(k-1))

nthEndpoint :: Floating t => Int -> Envelope' t a -> (t,a) 
nthEndpoint 0 ((seg,_):_) = (0,es_left seg)
nthEndpoint k xs = let (seg,t) = xs!!(k-1) in (t, es_right seg)

nthControl :: Floating t => Int -> Int -> Envelope' t a -> (t,a)
nthControl i j xs = 
  case j of
    1 -> ( s+  (t-s)/3 , es_ctrl1 seg )
    2 -> ( s+2*(t-s)/3 , es_ctrl2 seg )
  where
    (seg,t) = xs!!i 
    s = nthTimePoint i xs
    
liftEnv :: (Envelope' t a -> Envelope' t a) -> Envelope t a -> Envelope t a    
liftEnv f (Envelope n x) = Envelope n (f x)
    
updateNthEndpoint :: Int -> (t,a) -> Envelope' t a -> Envelope' t a     
updateNthEndpoint 0 (_,y) ((seg,t):rest) = (seg { es_left  = y } , t) : rest  
updateNthEndpoint 1 xy@(x,y) ((seg,_):rest) = (seg { es_right = y } , x) : updateNthEndpoint 0 (x,y) rest  
updateNthEndpoint k xy@(x,y) (this   :rest) = this : updateNthEndpoint (k-1) xy rest

updateNthControl :: (Int,Int) -> a -> Envelope' t a -> Envelope' t a     
updateNthControl (0,1) y ((seg,t):rest) = (seg { es_ctrl1 = y } , t) : rest  
updateNthControl (0,2) y ((seg,t):rest) = (seg { es_ctrl2 = y } , t) : rest  
updateNthControl (k,j) y (this   :rest) = this : updateNthControl (k-1,j) y rest
  
updateNumberOfSegments :: Floating t => Int -> Envelope t a -> Envelope t a  
updateNumberOfSegments n (Envelope k env) = Envelope n new where
  new = tmap (*x) env
  x = nthTimePoint k env / nthTimePoint n env    -- nthTimePoint k == 1.0
  
changeNumberOfSegments f env@(Envelope n _) = updateNumberOfSegments (f n) env 
  
-- | Computes the value of an envelope segment at a 0<=t<=1. 
calcEnvelopeSegment :: Floating a => a -> EnvSegment a -> a
calcEnvelopeSegment t (EnvSegment LinearS l _ _ r) = l + (r-l)*t 
calcEnvelopeSegment t (EnvSegment CubicS  l c d r) = ss*(s*l+3*t*c) + tt*(3*s*d+r*t) 
  where
    s  = 1 - t
    ss = s*s
    tt = t*t

-- | Computes the value of an envelope at a 0<=t<=1. 
calcEnvelope' :: RealFloat a => a -> Envelope' a a -> a
calcEnvelope' t env = worker t 0 env where
  worker t l ((seg,_):[] ) = calcEnvelopeSegment ((t-l)/(1-l)) seg
  worker t l ((seg,r):env) = if t<=r 
    then calcEnvelopeSegment ((t-l)/(r-l)) seg
    else worker t r env
      
calcEnvelope :: RealFloat a => a -> Envelope a a -> a
calcEnvelope t (Envelope n env') = calcEnvelope' t (take n env')
      
defaultSegment' :: a -> EnvSegment a
defaultSegment' x = EnvSegment LinearS x x x x      

-------------------------------------------------------

{-
-- | Envelope segment: either a line segment or 
-- a cubic bezier curve, on the interval [0,1].
data EnvSegment a
  = EnvLinear 
      { es_left  :: a 
      , es_right :: a
      }
  | EnvCubic 
      { es_left  :: a 
      , es_ctrl1 :: a
      , es_ctrl2 :: a
      , es_right :: a
      }

instance Show a => Show (EnvSegment a) where
  show (EnvLinear x y) = show [x,y]
  show (EnvCubic  x y z w) = show (x,y,z,w)
instance (Show a, Show t) => Show (Envelope t a) where
  show (ESeg seg) = show seg
  show (ECons seg t env) = show seg ++ " :" ++ show t ++ ": " ++ show env
      
-- | An envelope on the interval [0,1], made up from (scaled) segments.
data Envelope t a  
  = ESeg  (EnvSegment a) 
  | ECons { _leftSeg :: (EnvSegment a) , _rightT :: t , _rightEnv :: (Envelope t a) }

instance Functor EnvSegment where
  fmap f (EnvLinear x y    ) = EnvLinear (f x) (f y)
  fmap f (EnvCubic  x y z w) = EnvCubic  (f x) (f y) (f z) (f w)

instance Functor (Envelope t) where
  fmap f (ESeg seg) = ESeg (fmap f seg)      
  fmap f (ECons seg t env) = ECons (fmap f seg) t (fmap f env)

tmap :: (t -> t) -> Envelope t a -> Envelope t a
tmap f eseg@(ESeg _) = eseg
tmap f (ECons seg t env) = ECons seg (f t) env
  
-- | Computes the value of an envelope segment at a 0<=t<=1. 
calcEnvelopeSegment :: Floating a => a -> EnvSegment a -> a
calcEnvelopeSegment t (EnvLinear l r    ) = l + (r-l)*t 
calcEnvelopeSegment t (EnvCubic  l c d r) = ss*(s*l+t*c) + tt*(s*d+r*t) 
  where
    s  = 1 - t
    ss = s*s
    tt = t*t

-- | Computes the value of an envelope at a 0<=t<=1. 
calcEnvelope :: RealFloat a => a -> Envelope a a -> a
calcEnvelope t env = worker t 0 env where
  worker t l (ESeg seg) = calcEnvelopeSegment ((t-l)/(1-l)) seg
  worker t l (ECons seg r env) = if t<=r 
    then calcEnvelopeSegment ((t-l)/(r-l)) seg
    else worker t r env
      
defaultSegment' :: a -> EnvSegment a
defaultSegment' x = EnvLinear x x      

envTake :: Int -> Envelope t a -> Envelope t a
envTake 1 eseg@(ESeg _) = eseg
envTake 1 (ECons seg _ _) = ESeg seg
envTake n (ECons seg t env) = ECons seg t (envTake (n-1) env)
-}

-------------------------------------------------------