module Csound.Exp.Tuple(
CsdTuple(..),
fromCsdTuple, toCsdTuple, arityCsdTuple, ratesCsdTuple, defCsdTuple,
Out(..), multiOuts, outArity
) where
import Data.Default
import Control.Applicative(liftA2)
import Control.Monad(join)
import Csound.Exp
import Csound.Exp.Wrapper(Val(..), Sig, D, Str, Spec, onExp, toExp,
withRate, getRates)
import Csound.Exp.SE(SE)
class CsdTuple a where
csdTupleMethods :: CsdTupleMethods a
data CsdTupleMethods a = CsdTupleMethods
{ fromCsdTuple_ :: a -> [E]
, toCsdTuple_ :: [E] -> a
, arityCsdTuple_ :: a -> Int
, ratesCsdTuple_ :: a -> [Rate]
, defCsdTuple_ :: a }
fromCsdTuple :: CsdTuple a => a -> [E]
fromCsdTuple = fromCsdTuple_ csdTupleMethods
toCsdTuple :: CsdTuple a => [E] -> a
toCsdTuple = toCsdTuple_ csdTupleMethods
arityCsdTuple :: CsdTuple a => a -> Int
arityCsdTuple = arityCsdTuple_ csdTupleMethods
ratesCsdTuple :: CsdTuple a => a -> [Rate]
ratesCsdTuple = ratesCsdTuple_ csdTupleMethods
defCsdTuple :: CsdTuple a => a
defCsdTuple = defCsdTuple_ csdTupleMethods
makeCsdTupleMethods :: (CsdTuple a) => (a -> b) -> (b -> a) -> CsdTupleMethods b
makeCsdTupleMethods to from = CsdTupleMethods
{ fromCsdTuple_ = fromCsdTuple . from
, toCsdTuple_ = to . toCsdTuple
, arityCsdTuple_ = const $ arityCsdTuple $ proxy to
, ratesCsdTuple_ = ratesCsdTuple . from
, defCsdTuple_ = to defCsdTuple }
where proxy :: (a -> b) -> a
proxy = undefined
class CsdTuple (NoSE a) => Out a where
type NoSE a :: *
toOut :: a -> SE [Sig]
fromOut :: [Sig] -> a
outArity :: Out a => a -> Int
outArity a = arityCsdTuple (proxy a)
where proxy :: Out a => a -> NoSE a
proxy = undefined
instance CsdTuple () where
csdTupleMethods = CsdTupleMethods
{ fromCsdTuple_ = return []
, toCsdTuple_ = const ()
, arityCsdTuple_ = const 0
, ratesCsdTuple_ = const []
, defCsdTuple_ = () }
instance CsdTuple Sig where
csdTupleMethods = CsdTupleMethods
{ fromCsdTuple_ = return . toE
, toCsdTuple_ = fromE . head
, arityCsdTuple_ = const 1
, ratesCsdTuple_ = const [Ar]
, defCsdTuple_ = def }
instance CsdTuple D where
csdTupleMethods = CsdTupleMethods
{ fromCsdTuple_ = return . toE
, toCsdTuple_ = fromE . head
, arityCsdTuple_ = const 1
, ratesCsdTuple_ = const [Ir]
, defCsdTuple_ = def }
instance CsdTuple Tab where
csdTupleMethods = CsdTupleMethods
{ fromCsdTuple_ = return . toE
, toCsdTuple_ = fromE . head
, arityCsdTuple_ = const 1
, ratesCsdTuple_ = const [Ir]
, defCsdTuple_ = def }
instance CsdTuple Str where
csdTupleMethods = CsdTupleMethods
{ fromCsdTuple_ = return . toE
, toCsdTuple_ = fromE . head
, arityCsdTuple_ = const 1
, ratesCsdTuple_ = const [Sr]
, defCsdTuple_ = def }
instance CsdTuple Spec where
csdTupleMethods = CsdTupleMethods
{ fromCsdTuple_ = return . toE
, toCsdTuple_ = fromE . head
, arityCsdTuple_ = const 1
, ratesCsdTuple_ = const [Fr]
, defCsdTuple_ = def }
instance (CsdTuple a, CsdTuple b) => CsdTuple (a, b) where
csdTupleMethods = CsdTupleMethods fromCsdTuple' toCsdTuple' arityCsdTuple' ratesCsdTuple' defCsdTuple'
where
fromCsdTuple' (a, b) = fromCsdTuple a ++ fromCsdTuple b
arityCsdTuple' x = let (a, b) = proxy x in arityCsdTuple a + arityCsdTuple b
where proxy :: (a, b) -> (a, b)
proxy = const (undefined, undefined)
toCsdTuple' xs = (a, b)
where a = toCsdTuple $ take (arityCsdTuple a) xs
xsb = drop (arityCsdTuple a) xs
b = toCsdTuple (take (arityCsdTuple b) xsb)
ratesCsdTuple' (a, b) = ratesCsdTuple a ++ ratesCsdTuple b
defCsdTuple' = (defCsdTuple, defCsdTuple)
instance (CsdTuple a, CsdTuple b, CsdTuple c) => CsdTuple (a, b, c) where
csdTupleMethods = makeCsdTupleMethods to from
where to (a, (b, c)) = (a, b, c)
from (a, b, c) = (a, (b, c))
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d) => CsdTuple (a, b, c, d) where
csdTupleMethods = makeCsdTupleMethods to from
where to (a, (b, c, d)) = (a, b, c, d)
from (a, b, c, d) = (a, (b, c, d))
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e) => CsdTuple (a, b, c, d, e) where
csdTupleMethods = makeCsdTupleMethods to from
where to (a, (b, c, d, e)) = (a, b, c, d, e)
from (a, b, c, d, e) = (a, (b, c, d, e))
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f) => CsdTuple (a, b, c, d, e, f) where
csdTupleMethods = makeCsdTupleMethods to from
where to (a, (b, c, d, e, f)) = (a, b, c, d, e, f)
from (a, b, c, d, e, f) = (a, (b, c, d, e, f))
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g) => CsdTuple (a, b, c, d, e, f, g) where
csdTupleMethods = makeCsdTupleMethods to from
where to (a, (b, c, d, e, f, g)) = (a, b, c, d, e, f, g)
from (a, b, c, d, e, f, g) = (a, (b, c, d, e, f, g))
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g, CsdTuple h) => CsdTuple (a, b, c, d, e, f, g, h) where
csdTupleMethods = makeCsdTupleMethods to from
where to (a, (b, c, d, e, f, g, h)) = (a, b, c, d, e, f, g, h)
from (a, b, c, d, e, f, g, h) = (a, (b, c, d, e, f, g, h))
multiOuts :: CsdTuple a => E -> a
multiOuts expr = res
where res = toCsdTuple $ multiOutsSection (arityCsdTuple res) expr
multiOutsSection :: Int -> E -> [E]
multiOutsSection n e = zipWith (\cellId r -> select cellId r e') [0 ..] outRates
where outRates = take n $ getRates $ toExp e
e' = onExp (setMultiRate outRates) e
setMultiRate rates (Tfm info xs) = Tfm (info{ infoSignature = MultiRate rates ins }) xs
where ins = case infoSignature info of
MultiRate _ a -> a
_ -> error "Tuple.hs: multiOutsSection -- should be multiOut expression"
setMultiRate _ _ = error "Tuple.hs: multiOutsSection -- argument should be Tfm-expression"
select cellId rate expr = withRate rate $ Select rate cellId (PrimOr $ Right expr)
instance Out () where
type NoSE () = ()
toOut = const (return [])
fromOut = const ()
instance Out Sig where
type NoSE Sig = Sig
toOut = return . return
fromOut = head
instance (Out a, CsdTuple a) => Out (SE a) where
type NoSE (SE a) = a
toOut = join . fmap toOut
fromOut = return . fromOut
instance (CsdTuple a, CsdTuple b, Out a, Out b) => Out (a, b) where
type NoSE (a, b) = (NoSE a, NoSE b)
toOut (a, b) = liftA2 (++) (toOut a) (toOut b)
fromOut = toCsdTuple . fmap toE
instance (CsdTuple a, CsdTuple b, CsdTuple c, Out a, Out b, Out c) => Out (a, b, c) where
type NoSE (a, b, c) = (NoSE a, NoSE b, NoSE c)
toOut (a, b, c) = toOut (a, (b, c))
fromOut = toCsdTuple . fmap toE
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, Out a, Out b, Out c, Out d) => Out (a, b, c, d) where
type NoSE (a, b, c, d) = (NoSE a, NoSE b, NoSE c, NoSE d)
toOut (a, b, c, d) = toOut (a, (b, c, d))
fromOut = toCsdTuple . fmap toE
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, Out a, Out b, Out c, Out d, Out e) => Out (a, b, c, d, e) where
type NoSE (a, b, c, d, e) = (NoSE a, NoSE b, NoSE c, NoSE d, NoSE e)
toOut (a, b, c, d, e) = toOut (a, (b, c, d, e))
fromOut = toCsdTuple . fmap toE
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, Out a, Out b, Out c, Out d, Out e, Out f) => Out (a, b, c, d, e, f) where
type NoSE (a, b, c, d, e, f) = (NoSE a, NoSE b, NoSE c, NoSE d, NoSE e, NoSE f)
toOut (a, b, c, d, e, f) = toOut (a, (b, c, d, e, f))
fromOut = toCsdTuple . fmap toE
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g, Out a, Out b, Out c, Out d, Out e, Out f, Out g) => Out (a, b, c, d, e, f, g) where
type NoSE (a, b, c, d, e, f, g) = (NoSE a, NoSE b, NoSE c, NoSE d, NoSE e, NoSE f, NoSE g)
toOut (a, b, c, d, e, f, g) = toOut (a, (b, c, d, e, f, g))
fromOut = toCsdTuple . fmap toE
instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g, CsdTuple h, Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h) => Out (a, b, c, d, e, f, g, h) where
type NoSE (a, b, c, d, e, f, g, h) = (NoSE a, NoSE b, NoSE c, NoSE d, NoSE e, NoSE f, NoSE g, NoSE h)
toOut (a, b, c, d, e, f, g, h) = toOut (a, (b, c, d, e, f, g, h))
fromOut = toCsdTuple . fmap toE