{-# Language TypeFamilies #-}
module Csound.Air.Seg (
        Seg, toSeg, runSeg,
        constLim, constDel, constRest, limSnd
) where

import Data.Maybe
import Data.Monoid
import Data.Boolean

import Temporal.Class

import Csound.Typed
import Csound.SigSpace
import Csound.Control

import Csound.Air.Wav hiding (Loop)

-- | A segment of the signal.
-- The signal segment is a limited span of signal in time.
-- The time can be measured in seconds or in events!
-- The time span which is measured in events is the first
-- occurence of the event in the event stream.
--
-- There are handy functions for scheduling the signal segments.
-- we can delay the segment or loop over it or limit it with tme interval
-- or play a sequence of segments. The main feature of the segments is the
-- ability to schedule the signals with event streams (like button clicks or midi-events).
data Seg a
        = Unlim a
        | Lim Tick (Seg a)
        | ConstLim Sig (Seg a)
        | Seq [Seg a]
        | Par [Seg a]
        | Loop (Seg a)

instance Functor Seg where
        fmap f x = case x of
                Unlim a -> Unlim $ f a
                Lim dt a -> Lim dt $ fmap f a
                ConstLim dt a -> ConstLim dt $ fmap f a
                Seq as  -> Seq $ fmap (fmap f) as
                Par as  -> Par $ fmap (fmap f) as
                Loop a  -> Loop $ fmap f a

instance SigSpace a => SigSpace (Seg a) where
        mapSig f x = fmap (mapSig f) x

type instance DurOf (Seg a) = Tick

instance Sigs a => Melody (Seg a) where
        mel = sflow

instance Sigs a => Harmony (Seg a) where
        har = spar

instance Sigs a => Compose (Seg a) where

instance Sigs a => Delay (Seg a) where
        del = sdel

instance Sigs a => Loop (Seg a) where
        loop = sloop

instance (Sigs a, Num a) => Rest (Seg a) where
        rest = srest

instance Sigs a => Limit (Seg a) where
        lim = slim

seq1 :: Tick -> a -> Seg a
seq1 dt a = Lim dt (Unlim a)

-- | Converts signals to segments.
-- The segment is not limited in length.
toSeg :: a -> Seg a
toSeg a = Unlim a

-- | Limits the length of the segment with event stream.
slim :: Tick -> Seg a -> Seg a
slim da x = case x of
        Par as   -> Par (fmap (slim da) as)
        _        -> Lim da x

-- | Limits the length of the segment with constant length in seconds.
constLim :: Sig -> Seg a -> Seg a
constLim da x = case x of
        Par as   -> Par (fmap (constLim da) as)
        _        -> ConstLim da x

-- | Plays the sequence of segments one ofter another.
sflow :: [Seg a] -> Seg a
sflow as = Seq $ flatten =<< as
        where
                flatten x = case x of
                        Seq as -> as
                        _      -> [x]

-- | Plays a list of segments at the same time.
-- the total length equals to the biggest length of all segments.
spar :: [Seg a] -> Seg a
spar as = Par $ flatten =<< as
        where
                flatten x = case x of
                        Par as -> as
                        _      -> [x]

-- | Loops over a segment. The segment should be limited for loop to take effect.
sloop :: Seg a -> Seg a
sloop x = case x of
        Unlim a -> Unlim a
        Loop a  -> Loop a
        Par as  -> Par (fmap sloop as)
        _       -> Loop x


-- | Limits a signal with an event stream and retriggers it after stop.
limSnd :: Sigs a => Tick -> a -> a
limSnd dt = runSeg . sloop . slim dt . toSeg

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

-- | Converts segments to signals.
runSeg :: (Sigs a) => Seg a -> a
runSeg x = case x of
        Unlim a -> a

        Lim dt (Unlim a) -> elim dt a
        Lim dt (Seq as)  -> uncurry (evtLoopOnce (Just dt)) (getEvtAndSig $ rmTailAfterUnlim as)
        Lim dt (Loop (Seq as)) -> uncurry (evtLoop (Just dt)) (getEvtAndSig $ rmTailAfterUnlim as)
        Lim dt (Loop a) -> elim dt (runSeg (Loop a))
        Lim dt a -> elim dt (runSeg a)


        ConstLim dt (Unlim a) -> takeSnd dt a
        ConstLim dt (Seq as)  -> uncurry (evtLoopOnce (Just $ impulseE $ ir dt)) (getEvtAndSig $ rmTailAfterUnlim as)
        ConstLim dt (Loop (Seq as)) -> uncurry (evtLoop (Just $ impulseE $ ir dt)) (getEvtAndSig $ rmTailAfterUnlim as)
        ConstLim dt (Loop a) -> takeSnd dt (runSeg (Loop a))
        ConstLim dt a -> takeSnd dt (runSeg a)

        Seq as -> uncurry (evtLoopOnce Nothing) (getEvtAndSig $ rmTailAfterUnlim as)

        Loop (ConstLim dt a) -> repeatSnd dt $ runSeg a
        Loop (Lim dt a)      -> evtLoop Nothing [return $ runSeg a] [dt]
        Loop (Seq as)            -> uncurry (evtLoop Nothing) (getEvtAndSig as)

        Par as -> maybeElim (getDur x) $ sum $ fmap (\a -> maybeElim (getDur a) $ runSeg a) as

getDur :: Seg a -> Maybe (Either Sig Tick)
getDur x = case x of
        Unlim _ -> Nothing
        Loop  _ -> Nothing
        Lim dt _ -> Just $ Right dt
        ConstLim dt _ -> Just $ Left dt
        Seq as -> fromListT sum aftT' as
        Par as -> fromListT (foldl1 maxB) simT' as
        where
                fromListT g f as
                        | all isJust ds = Just $ phi g f $ fmap fromJust ds
                        | otherwise     = Nothing
                        where ds = fmap getDur as

                phi g f xs
                        | all isJust as = Left  $ g $ fmap fromJust as
                        | otherwise     = Right $ f $ fmap toEvt xs
                        where as = fmap getConstT xs

                getConstT x = case x of
                        Left d -> Just d
                        _      -> Nothing

                toEvt = either (impulseE . ir) id

getEvtAndSig :: (Num a, Sigs a) => [Seg a] -> ([SE a], [Tick])
getEvtAndSig as = unzip $ fmap (\x -> (return (runSeg x), getTick $ getDur x)) as
        where getTick = maybe mempty (either (impulseE . ir) id)


rmTailAfterUnlim :: [Seg a] -> [Seg a]
rmTailAfterUnlim = takeByIncludeLast isUnlim
        where
                isUnlim x = case x of
                        Unlim _ -> True
                        Loop  _ -> True
                        Par  as -> any isUnlim as
                        _       -> False

takeByIncludeLast :: (a -> Bool) -> [a] -> [a]
takeByIncludeLast f xs = case xs of
        [] -> []
        a:as -> if f a then [a] else a : takeByIncludeLast f as

-------------------------------------------------
-- aux

-- | A pause. Plays nothing until something happens on the event stream.
srest :: (Num a) => Tick -> Seg a
srest dt = seq1 dt 0

-- | Delays a segment until something happens on the event stream.
sdel :: (Sigs a, Num a) => Tick -> Seg a -> Seg a
sdel dt a = sflow [srest dt, a]

-- | A pause. Plays nothing for the given time interval in seconds.
constRest :: Num a => Sig -> Seg a
constRest dt = constLim dt $ toSeg 0

-- | Delays a segment by a given time interval in seconds.
constDel :: Num a => Sig -> Seg a -> Seg a
constDel dt a = sflow [constRest dt, a]

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

elim :: Sigs a => Tick -> a -> a
elim dt asig = schedUntil (const $ return $ asig) (impulseE 0) dt

maybeElim :: (Num a, Sigs a) => Maybe (Either Sig Tick) -> a -> a
maybeElim mdt a = case mdt of
        Nothing -> a
        Just x  -> case x of
                Left d  -> takeSnd d a
                Right t -> elim t a

-- | Takes the first event from the event stream and ignores the rest of the stream.
take1 :: Evt a -> Evt a
take1 = fmap fst . filterE ((==* 0) . snd) . accumE (0 :: D) (\a s -> ((a, s), s + 1) )

-----------------------------------------------------------
-- tick funs with less instrs

aftT' :: [Tick] -> Tick
aftT' evts = take1 $ sigToEvt $ evtLoop Nothing asigs evts
        where
                asigs :: [SE Sig]
                asigs = fmap (return . sig) $ (replicate (length evts - 1) 0) ++ [1]

simT' :: [Tick] -> Tick
simT' as = Evt $ \bam -> do
        isAwaitingRef <- newRef (1 :: D)
        countDownRef  <- newRef (int (length as) :: D)

        mapM_ (mkEvt countDownRef) as

        countDown <- readRef countDownRef
        isAwaiting <- readRef isAwaitingRef
        when1 (sig isAwaiting ==* 1 &&* sig countDown ==* 0) $ do
                bam unit
                writeRef isAwaitingRef 0
        where
                mkEvt ref e = do
                        notFiredRef <- newRef (1 :: D)
                        notFired <- readRef notFiredRef
                        runEvt e $ \_ -> do
                                when1 (sig notFired ==* 1) $ do
                                        writeRef notFiredRef 0
                                        modifyRef ref (\x -> x - 1)