module Csound.Typed.Types.Tuple(
Tuple(..), TupleMethods, makeTupleMethods,
fromTuple, toTuple, tupleArity, tupleRates, defTuple, mapTuple,
Sig2, Sig3, Sig4, Sig5, Sig6, Sig8,
Sigs, outArity,
multiOuts,
ar1, ar2, ar4, ar6, ar8,
Arg, arg, toNote, argArity, toArg,
ifTuple, guardedTuple, caseTuple,
ifArg, guardedArg, caseArg,
pureTuple, dirtyTuple
) where
import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Data.Default
import Data.Boolean
import Csound.Dynamic
import Csound.Typed.Types.Prim
import Csound.Typed.GlobalState.GE
import Csound.Typed.GlobalState.SE
import Csound.Typed.Types.TupleHelpers
class Tuple a where
tupleMethods :: TupleMethods a
data TupleMethods a = TupleMethods
{ fromTuple_ :: a -> GE [E]
, toTuple_ :: GE [E] -> a
, tupleArity_ :: a -> Int
, tupleRates_ :: a -> [Rate]
, defTuple_ :: a }
fromTuple :: Tuple a => a -> GE [E]
fromTuple = fromTuple_ tupleMethods
toTuple :: Tuple a => GE [E] -> a
toTuple = toTuple_ tupleMethods
tupleArity :: Tuple a => a -> Int
tupleArity = tupleArity_ tupleMethods
tupleRates :: Tuple a => a -> [Rate]
tupleRates = tupleRates_ tupleMethods
defTuple :: Tuple a => a
defTuple = defTuple_ tupleMethods
mapTuple :: Tuple a => (E -> E) -> a -> a
mapTuple f a = toTuple (fmap (fmap f) $ fromTuple a)
makeTupleMethods :: (Tuple a) => (a -> b) -> (b -> a) -> TupleMethods b
makeTupleMethods to from = TupleMethods
{ fromTuple_ = fromTuple . from
, toTuple_ = to . toTuple
, tupleArity_ = const $ tupleArity $ proxy to
, tupleRates_ = tupleRates . from
, defTuple_ = to defTuple }
where proxy :: (a -> b) -> a
proxy = undefined
primTupleMethods :: (Val a, Default a) => Rate -> TupleMethods a
primTupleMethods rate = TupleMethods
{ fromTuple_ = fmap return . toGE
, toTuple_ = fromGE . fmap head
, tupleArity_ = const 1
, tupleRates_ = const [rate]
, defTuple_ = def }
instance Tuple Unit where
tupleMethods = TupleMethods
{ fromTuple_ = \x -> unUnit x >> (return [])
, toTuple_ = \es -> Unit $ es >> return ()
, tupleArity_ = const 0
, tupleRates_ = const []
, defTuple_ = Unit $ return () }
instance Tuple Sig where tupleMethods = primTupleMethods Ar
instance Tuple D where tupleMethods = primTupleMethods Kr
instance Tuple Tab where tupleMethods = primTupleMethods Kr
instance Tuple Str where tupleMethods = primTupleMethods Sr
instance Tuple Spec where tupleMethods = primTupleMethods Fr
instance (Tuple a, Tuple b) => Tuple (a, b) where
tupleMethods = TupleMethods fromTuple' toTuple' tupleArity' tupleRates' defTuple'
where
fromTuple' (a, b) = liftA2 (++) (fromTuple a) (fromTuple b)
tupleArity' x = let (a, b) = proxy x in tupleArity a + tupleArity b
where proxy :: (a, b) -> (a, b)
proxy = const (undefined, undefined)
toTuple' xs = (a, b)
where a = toTuple $ fmap (take (tupleArity a)) xs
xsb = fmap (drop (tupleArity a)) xs
b = toTuple $ fmap (take (tupleArity b)) xsb
tupleRates' (a, b) = tupleRates a ++ tupleRates b
defTuple' = (defTuple, defTuple)
instance (Tuple a, Tuple b, Tuple c) => Tuple (a, b, c) where tupleMethods = makeTupleMethods cons3 split3
instance (Tuple a, Tuple b, Tuple c, Tuple d) => Tuple (a, b, c, d) where tupleMethods = makeTupleMethods cons4 split4
instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e) => Tuple (a, b, c, d, e) where tupleMethods = makeTupleMethods cons5 split5
instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e, Tuple f) => Tuple (a, b, c, d, e, f) where tupleMethods = makeTupleMethods cons6 split6
instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e, Tuple f, Tuple g) => Tuple (a, b, c, d, e, f, g) where tupleMethods = makeTupleMethods cons7 split7
instance (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e, Tuple f, Tuple g, Tuple h) => Tuple (a, b, c, d, e, f, g, h) where tupleMethods = makeTupleMethods cons8 split8
multiOuts :: Tuple a => E -> a
multiOuts expr = res
where res = toTuple $ return $ mo (tupleArity res) expr
ar1 :: Sig -> Sig
ar2 :: (Sig, Sig) -> (Sig, Sig)
ar4 :: (Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig)
ar6 :: (Sig, Sig, Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig, Sig, Sig)
ar8 :: (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) -> (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)
ar1 = id; ar2 = id; ar4 = id; ar6 = id; ar8 = id
class (Tuple a, Num a) => Sigs a where
type Sig2 = (Sig, Sig)
type Sig3 = (Sig, Sig, Sig)
type Sig4 = (Sig, Sig, Sig, Sig)
type Sig5 = (Sig, Sig, Sig, Sig, Sig)
type Sig6 = (Sig, Sig, Sig, Sig, Sig, Sig)
type Sig8 = (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig)
instance Sigs Sig
instance Sigs Sig2
instance Sigs Sig4
instance Sigs Sig6
instance Sigs Sig8
instance Sigs (Sig8, Sig8)
instance Sigs (Sig8, Sig8, Sig8, Sig8)
outArity :: Tuple a => SE a -> Int
outArity = tupleArity . proxy
where
proxy :: SE a -> a
proxy = const undefined
class (Tuple a) => Arg a where
instance Arg Unit
instance Arg D
instance Arg Str
instance Arg Tab
instance (Arg a, Arg b) => Arg (a, b)
instance (Arg a, Arg b, Arg c) => Arg (a, b, c)
instance (Arg a, Arg b, Arg c, Arg d) => Arg (a, b, c, d)
instance (Arg a, Arg b, Arg c, Arg d, Arg e) => Arg (a, b, c, d, e)
instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f) => Arg (a, b, c, d, e, f)
instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg h) => Arg (a, b, c, d, e, f, h)
instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg h, Arg g) => Arg (a, b, c, d, e, f, h, g)
arg :: Arg a => Int -> a
arg n = toTuple $ return $ fmap pn [n ..]
toArg :: Arg a => a
toArg = arg 4
argArity :: Arg a => a -> Int
argArity = tupleArity
toNote :: Arg a => a -> GE [E]
toNote a = zipWithM phi (tupleRates a) =<< fromTuple a
where
phi rate x = case rate of
Sr -> saveStr $ getStringUnsafe x
_ -> return x
getStringUnsafe x = case getPrimUnsafe x of
PrimString y -> y
_ -> error "Arg(Str):getStringUnsafe value is not a string"
newtype BoolTuple = BoolTuple { unBoolTuple :: GE [E] }
toBoolTuple :: Tuple a => a -> BoolTuple
toBoolTuple = BoolTuple . fromTuple
fromBoolTuple :: Tuple a => BoolTuple -> a
fromBoolTuple = toTuple . unBoolTuple
type instance BooleanOf BoolTuple = BoolSig
instance IfB BoolTuple where
ifB mp (BoolTuple mas) (BoolTuple mbs) = BoolTuple $
liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs
ifTuple :: (Tuple a) => BoolSig -> a -> a -> a
ifTuple p a b = fromBoolTuple $ ifB p (toBoolTuple a) (toBoolTuple b)
guardedTuple :: (Tuple b) => [(BoolSig, b)] -> b -> b
guardedTuple bs b = fromBoolTuple $ guardedB undefined (fmap (second toBoolTuple) bs) (toBoolTuple b)
caseTuple :: (Tuple b) => a -> [(a -> BoolSig, b)] -> b -> b
caseTuple a bs other = fromBoolTuple $ caseB a (fmap (second toBoolTuple) bs) (toBoolTuple other)
newtype BoolArg = BoolArg { unBoolArg :: GE [E] }
toBoolArg :: (Arg a, Tuple a) => a -> BoolArg
toBoolArg = BoolArg . fromTuple
fromBoolArg :: (Arg a, Tuple a) => BoolArg -> a
fromBoolArg = toTuple . unBoolArg
type instance BooleanOf BoolArg = BoolD
instance IfB BoolArg where
ifB mp (BoolArg mas) (BoolArg mbs) = BoolArg $
liftA3 (\p as bs -> zipWith (ifB p) as bs) (toGE mp) mas mbs
ifArg :: (Arg a, Tuple a) => BoolD -> a -> a -> a
ifArg p a b = fromBoolArg $ ifB p (toBoolArg a) (toBoolArg b)
guardedArg :: (Tuple b, Arg b) => [(BoolD, b)] -> b -> b
guardedArg bs b = fromBoolArg $ guardedB undefined (fmap (second toBoolArg) bs) (toBoolArg b)
caseArg :: (Tuple b, Arg b) => a -> [(a -> BoolD, b)] -> b -> b
caseArg a bs other = fromBoolArg $ caseB a (fmap (second toBoolArg) bs) (toBoolArg other)
pureTuple :: Tuple a => GE (MultiOut [E]) -> a
pureTuple a = res
where res = toTuple $ fmap ($ tupleArity res) a
dirtyTuple :: Tuple a => GE (MultiOut [E]) -> SE a
dirtyTuple a = res
where
res = fmap (toTuple . return) $ SE
$ mapM depT =<< (lift $ fmap ($ (tupleArity $ proxy res)) a)
proxy :: SE a -> a
proxy = const undefined
instance Num Sig2 where
(a1, a2) + (b1, b2) = (a1 + b1, a2 + b2)
(a1, a2) * (b1, b2) = (a1 * b1, a2 * b2)
negate (a1, a2) = (negate a1, negate a2)
fromInteger n = (fromInteger n, fromInteger n)
signum (a1, a2) = (signum a1, signum a2)
abs (a1, a2) = (abs a1, abs a2)
instance Num Sig3 where
(a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3)
(a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3)
negate (a1, a2, a3) = (negate a1, negate a2, negate a3)
fromInteger n = (fromInteger n, fromInteger n, fromInteger n)
signum (a1, a2, a3) = (signum a1, signum a2, signum a3)
abs (a1, a2, a3) = (abs a1, abs a2, abs a3)
instance Num Sig4 where
(a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4)
(a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4)
negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4)
fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n)
signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4)
abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4)
instance Num Sig6 where
(a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6)
(a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6)
negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6)
fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n)
signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6)
abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6)
instance Num Sig8 where
(a1, a2, a3, a4, a5, a6, a7, a8) + (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6, a7 + b7, a8 + b8)
(a1, a2, a3, a4, a5, a6, a7, a8) * (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6, a7 + b7, a8 + b8)
negate (a1, a2, a3, a4, a5, a6, a7, a8) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6, negate a7, negate a8)
fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n)
signum (a1, a2, a3, a4, a5, a6, a7, a8) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6, signum a7, signum a8)
abs (a1, a2, a3, a4, a5, a6, a7, a8) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6, abs a7, abs a8)
instance Num (Sig8, Sig8) where
(a1, a2) + (b1, b2) = (a1 + b1, a2 + b2)
(a1, a2) * (b1, b2) = (a1 * b1, a2 * b2)
negate (a1, a2) = (negate a1, negate a2)
fromInteger n = (fromInteger n, fromInteger n)
signum (a1, a2) = (signum a1, signum a2)
abs (a1, a2) = (abs a1, abs a2)
instance Num (Sig8, Sig8, Sig8, Sig8) where
(a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4)
(a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4)
negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4)
fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n)
signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4)
abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4)