{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language
TypeFamilies,
FlexibleContexts,
FlexibleInstances #-}
module Csound.Typed.Types.Tuple(
-- ** Tuple
Tuple(..), TupleMethods, makeTupleMethods,
fromTuple, toTuple, tupleArity, tupleRates, defTuple, mapTuple,
Sig2, Sig3, Sig4, Sig5, Sig6, Sig8,
-- ** Outs
Sigs, outArity,
-- *** Multiple outs
multiOuts,
ar1, ar2, ar4, ar6, ar8,
-- ** Arguments
Arg, arg, toNote, argArity, toArg,
-- ** Logic functions
ifTuple, guardedTuple, caseTuple,
ifArg, guardedArg, caseArg,
-- ** Constructors
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
-- | A tuple of Csound values.
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)
-- | Defines instance of type class 'Tuple' for a new type in terms of an already defined one.
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
-- Tuple instances
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 TabList where tupleMethods = primTupleMethods Kr
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
-------------------------------------------------------------------------------
-- multiple outs
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
---------------------------------------------------------------------------------
-- out instances
-- | The tuples of signals.
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
---------------------------------------------------------------------------
-- Arguments
class (Tuple a) => Arg a where
instance Arg Unit
instance Arg D
instance Arg Str
instance Arg Tab
instance Arg TabList
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"
-------------------------------------------------------------------------
-- logic functions
-- tuples
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
-- | @ifB@ for tuples of csound values.
ifTuple :: (Tuple a) => BoolSig -> a -> a -> a
ifTuple p a b = fromBoolTuple $ ifB p (toBoolTuple a) (toBoolTuple b)
-- | @guardedB@ for tuples of csound values.
guardedTuple :: (Tuple b) => [(BoolSig, b)] -> b -> b
guardedTuple bs b = fromBoolTuple $ guardedB undefined (fmap (second toBoolTuple) bs) (toBoolTuple b)
-- | @caseB@ for tuples of csound values.
caseTuple :: (Tuple b) => a -> [(a -> BoolSig, b)] -> b -> b
caseTuple a bs other = fromBoolTuple $ caseB a (fmap (second toBoolTuple) bs) (toBoolTuple other)
-- arguments
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
-- | @ifB@ for constants.
ifArg :: (Arg a, Tuple a) => BoolD -> a -> a -> a
ifArg p a b = fromBoolArg $ ifB p (toBoolArg a) (toBoolArg b)
-- | @guardedB@ for constants.
guardedArg :: (Tuple b, Arg b) => [(BoolD, b)] -> b -> b
guardedArg bs b = fromBoolArg $ guardedB undefined (fmap (second toBoolArg) bs) (toBoolArg b)
-- | @caseB@ for constants.
caseArg :: (Tuple b, Arg b) => a -> [(a -> BoolD, b)] -> b -> b
caseArg a bs other = fromBoolArg $ caseB a (fmap (second toBoolArg) bs) (toBoolArg other)
-----------------------------------------------------------
-- tuple constructors
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
-------------------------------------------------
-- numeric instances
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)