{-# Language TypeFamilies #-}
{-# Language LambdaCase #-}
module Csound.Air.Seg (
Seg, toSeg, runSeg,
constLim, constDel, constRest, limSnd
) where
import Data.Maybe
import Data.Boolean
import Temporal.Class
import Csound.Typed
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 xs -> xs
_ -> [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 xs -> xs
_ -> [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
Loop (Unlim _) -> undefined
Loop (Par _) -> undefined
Loop (Loop _) -> undefined
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 = \case
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)