{-# 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)