module Csound.Typed.Types.Prim(
Sig(..), D(..), Tab(..), unTab, Str(..), Spec(..), Wspec(..),
BoolSig(..), BoolD(..), Unit(..), unit, Val(..), hideGE, SigOrD,
preTab, TabSize(..), TabArgs(..), updateTabSize,
fromPreTab, getPreTabUnsafe, skipNorm, forceNorm,
nsamp, ftlen, ftchnls, ftsr, ftcps,
double, int, text,
idur, getSampleRate, getControlRate, getBlockSize, getZeroDbfs,
ar, kr, ir, sig,
on0, on1, on2, on3,
quot', rem', div', mod', ceil', floor', round', int', frac',
when1, whens, untilDo, whileDo, boolSig
) where
import Control.Applicative hiding ((<*))
import Control.Monad
import Control.Monad.Trans.Class
import Data.Monoid
import qualified Data.IntMap as IM
import Data.Default
import Data.Boolean
import Csound.Dynamic hiding (double, int, str, when1, whens, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd, untilDo)
import qualified Csound.Dynamic as D(double, int, str, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd)
import Csound.Typed.GlobalState
newtype Sig = Sig { unSig :: GE E }
newtype D = D { unD :: GE E }
newtype Str = Str { unStr :: GE E }
newtype Spec = Spec { unSpec :: GE E }
newtype Wspec = Wspec { unWspec :: GE E }
newtype BoolSig = BoolSig { unBoolSig :: GE E }
newtype BoolD = BoolD { unBoolD :: GE E }
type instance BooleanOf Sig = BoolSig
type instance BooleanOf D = BoolD
type instance BooleanOf Str = BoolD
type instance BooleanOf Tab = BoolD
type instance BooleanOf Spec = BoolD
newtype Unit = Unit { unUnit :: GE () }
unit :: Unit
unit = Unit $ return ()
instance Monoid Unit where
mempty = Unit (return ())
mappend a b = Unit $ (unUnit a) >> (unUnit b)
instance Default Unit where
def = unit
data Tab
= Tab (GE E)
| TabPre PreTab
preTab :: TabSize -> Int -> TabArgs -> Tab
preTab size gen args = TabPre $ PreTab size gen args
data PreTab = PreTab
{ preTabSize :: TabSize
, preTabGen :: Int
, preTabArgs :: TabArgs }
data TabSize
= SizePlain Int
| SizeDegree
{ hasGuardPoint :: Bool
, sizeDegree :: Int
}
instance Default TabSize where
def = SizeDegree
{ hasGuardPoint = False
, sizeDegree = 0 }
data TabArgs
= ArgsPlain [Double]
| ArgsRelative [Double]
| ArgsGen16 [Double]
| FileAccess String [Double]
renderTab :: PreTab -> GE E
renderTab a = saveGen =<< fromPreTab a
getPreTabUnsafe :: String -> Tab -> PreTab
getPreTabUnsafe msg x = case x of
TabPre a -> a
_ -> error msg
fromPreTab :: PreTab -> GE Gen
fromPreTab a = withOptions $ \opt -> go (defTabFi opt) a
where
go :: TabFi -> PreTab -> Gen
go tabFi tab = Gen size (preTabGen tab) args file
where size = defineTabSize (getTabSizeBase tabFi tab) (preTabSize tab)
(args, file) = defineTabArgs size (preTabArgs tab)
getTabSizeBase :: TabFi -> PreTab -> Int
getTabSizeBase tf tab = IM.findWithDefault (tabFiBase tf) (preTabGen tab) (tabFiGens tf)
defineTabSize :: Int -> TabSize -> Int
defineTabSize base x = case x of
SizePlain n -> n
SizeDegree guardPoint degree ->
byGuardPoint guardPoint $
byDegree base degree
where byGuardPoint guardPoint
| guardPoint = (+ 1)
| otherwise = id
byDegree zero n = 2 ^ max 0 (zero + n)
defineTabArgs :: Int -> TabArgs -> ([Double], Maybe String)
defineTabArgs size args = case args of
ArgsPlain as -> (as, Nothing)
ArgsRelative as -> (fromRelative size as, Nothing)
ArgsGen16 as -> (formRelativeGen16 size as, Nothing)
FileAccess filename as -> (as, Just filename)
where fromRelative n as = substEvens (mkRelative n $ getEvens as) as
getEvens xs = case xs of
[] -> []
_:[] -> []
_:b:as -> b : getEvens as
substEvens evens xs = case (evens, xs) of
([], as) -> as
(_, []) -> []
(e:es, a:_:as) -> a : e : substEvens es as
_ -> error "table argument list should contain even number of elements"
mkRelative n as = fmap ((fromIntegral :: (Int -> Double)) . round . (s * )) as
where s = fromIntegral n / sum as
formRelativeGen16 n as = substGen16 (mkRelative n $ getGen16 as) as
getGen16 xs = case xs of
_:durN:_:rest -> durN : getGen16 rest
_ -> []
substGen16 durs xs = case (durs, xs) of
([], as) -> as
(_, []) -> []
(d:ds, valN:_:typeN:rest) -> valN : d : typeN : substGen16 ds rest
(_, _) -> xs
skipNorm :: Tab -> Tab
skipNorm x = case x of
Tab _ -> error "you can skip normalization only for primitive tables (made with gen-routines)"
TabPre a -> TabPre $ a{ preTabGen = negate $ abs $ preTabGen a }
forceNorm :: Tab -> Tab
forceNorm x = case x of
Tab _ -> error "you can force normalization only for primitive tables (made with gen-routines)"
TabPre a -> TabPre $ a{ preTabGen = abs $ preTabGen a }
updateTabSize :: (TabSize -> TabSize) -> Tab -> Tab
updateTabSize phi x = case x of
Tab _ -> error "you can change size only for primitive tables (made with gen-routines)"
TabPre a -> TabPre $ a{ preTabSize = phi $ preTabSize a }
double :: Double -> D
double = fromE . D.double
int :: Int -> D
int = fromE . D.int
text :: String -> Str
text = fromE . D.str
idur :: D
idur = fromE $ pn 3
getSampleRate :: D
getSampleRate = fromE $ readOnlyVar (VarVerbatim Ir "sr")
getControlRate :: D
getControlRate = fromE $ readOnlyVar (VarVerbatim Ir "kr")
getBlockSize :: D
getBlockSize = fromE $ readOnlyVar (VarVerbatim Ir "ksmps")
getZeroDbfs :: D
getZeroDbfs = fromE $ readOnlyVar (VarVerbatim Ir "0dbfs")
ar :: Sig -> Sig
ar = on1 $ setRate Ar
kr :: Sig -> Sig
kr = on1 $ setRate Kr
ir :: Sig -> D
ir = on1 $ setRate Ir
sig :: D -> Sig
sig = on1 $ setRate Kr
class Val a where
fromGE :: GE E -> a
toGE :: a -> GE E
fromE :: E -> a
fromE = fromGE . return
hideGE :: Val a => GE a -> a
hideGE = fromGE . join . fmap toGE
instance Val Sig where { fromGE = Sig ; toGE = unSig }
instance Val D where { fromGE = D ; toGE = unD }
instance Val Str where { fromGE = Str ; toGE = unStr }
instance Val Spec where { fromGE = Spec ; toGE = unSpec }
instance Val Wspec where { fromGE = Wspec ; toGE = unWspec}
instance Val Tab where
fromGE = Tab
toGE = unTab
unTab :: Tab -> GE E
unTab x = case x of
Tab a -> a
TabPre a -> renderTab a
instance Val BoolSig where { fromGE = BoolSig ; toGE = unBoolSig }
instance Val BoolD where { fromGE = BoolD ; toGE = unBoolD }
class Val a => SigOrD a where
instance SigOrD Sig where
instance SigOrD D where
on0 :: Val a => E -> a
on0 = fromE
on1 :: (Val a, Val b) => (E -> E) -> (a -> b)
on1 f a = fromGE $ fmap f $ toGE a
on2 :: (Val a, Val b, Val c) => (E -> E -> E) -> (a -> b -> c)
on2 f a b = fromGE $ liftA2 f (toGE a) (toGE b)
on3 :: (Val a, Val b, Val c, Val d) => (E -> E -> E -> E) -> (a -> b -> c -> d)
on3 f a b c = fromGE $ liftA3 f (toGE a) (toGE b) (toGE c)
instance Default Sig where def = 0
instance Default D where def = 0
instance Default Tab where def = fromE 0
instance Default Str where def = text ""
instance Default Spec where def = fromE 0
instance Monoid Sig where { mempty = on0 mempty ; mappend = on2 mappend }
instance Monoid D where { mempty = on0 mempty ; mappend = on2 mappend }
instance Num Sig where
{ (+) = on2 (+); (*) = on2 (*); negate = on1 negate; () = on2 (\a b -> a b)
; fromInteger = on0 . fromInteger; abs = on1 abs; signum = on1 signum }
instance Num D where
{ (+) = on2 (+); (*) = on2 (*); negate = on1 negate; () = on2 (\a b -> a b)
; fromInteger = on0 . fromInteger; abs = on1 abs; signum = on1 signum }
instance Fractional Sig where { (/) = on2 (/); fromRational = on0 . fromRational }
instance Fractional D where { (/) = on2 (/); fromRational = on0 . fromRational }
instance Floating Sig where
{ pi = on0 pi; exp = on1 exp; sqrt = on1 sqrt; log = on1 log; logBase = on2 logBase; (**) = on2 (**)
; sin = on1 sin; tan = on1 tan; cos = on1 cos; sinh = on1 sinh; tanh = on1 tanh; cosh = on1 cosh
; asin = on1 asin; atan = on1 atan; acos = on1 acos ; asinh = on1 asinh; acosh = on1 acosh; atanh = on1 atanh }
instance Floating D where
{ pi = on0 pi; exp = on1 exp; sqrt = on1 sqrt; log = on1 log; logBase = on2 logBase; (**) = on2 (**)
; sin = on1 sin; tan = on1 tan; cos = on1 cos; sinh = on1 sinh; tanh = on1 tanh; cosh = on1 cosh
; asin = on1 asin; atan = on1 atan; acos = on1 acos ; asinh = on1 asinh; acosh = on1 acosh; atanh = on1 atanh }
ceil', floor', frac', int', round' :: SigOrD a => a -> a
quot', rem', div', mod' :: SigOrD a => a -> a -> a
ceil' = on1 ceilE; floor' = on1 floorE; frac' = on1 fracE; int' = on1 intE; round' = on1 roundE
quot' = on2 quot; rem' = on2 rem; div' = on2 div; mod' = on2 mod
instance Boolean BoolSig where { true = on0 true; false = on0 false; notB = on1 notB; (&&*) = on2 (&&*); (||*) = on2 (||*) }
instance Boolean BoolD where { true = on0 true; false = on0 false; notB = on1 notB; (&&*) = on2 (&&*); (||*) = on2 (||*) }
instance IfB Sig where ifB = on3 ifB
instance IfB D where ifB = on3 ifB
instance IfB Tab where ifB = on3 ifB
instance IfB Str where ifB = on3 ifB
instance IfB Spec where ifB = on3 ifB
instance EqB Sig where { (==*) = on2 (==*); (/=*) = on2 (/=*) }
instance EqB D where { (==*) = on2 (==*); (/=*) = on2 (/=*) }
instance OrdB Sig where { (<*) = on2 (<*) ; (>*) = on2 (>*); (<=*) = on2 (<=*); (>=*) = on2 (>=*) }
instance OrdB D where { (<*) = on2 (<*) ; (>*) = on2 (>*); (<=*) = on2 (<=*); (>=*) = on2 (>=*) }
when1 :: BoolSig -> SE () -> SE ()
when1 p body = do
ifBegin p
body
ifEnd
whens :: [(BoolSig, SE ())] -> SE () -> SE ()
whens bodies el = case bodies of
[] -> el
a:as -> do
ifBegin (fst a)
snd a
elseIfs as
elseBegin
el
foldl1 (>>) $ replicate (length bodies) ifEnd
where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBegin p >> body)
ifBegin :: BoolSig -> SE ()
ifBegin a = fromDep_ $ D.ifBegin =<< lift (toGE a)
ifEnd :: SE ()
ifEnd = fromDep_ D.ifEnd
elseBegin :: SE ()
elseBegin = fromDep_ D.elseBegin
untilDo :: BoolSig -> SE () -> SE ()
untilDo p body = do
untilBegin p
body
untilEnd
whileDo :: BoolSig -> SE () -> SE ()
whileDo p = untilDo (notB p)
untilBegin :: BoolSig -> SE ()
untilBegin a = fromDep_ $ D.untilBegin =<< lift (toGE a)
untilEnd :: SE ()
untilEnd = fromDep_ D.untilEnd
boolSig :: BoolD -> BoolSig
boolSig = fromGE . toGE
nsamp :: Tab -> D
nsamp = on1 $ opr1 "nsamp"
ftlen :: Tab -> D
ftlen = on1 $ opr1 "ftlen"
ftchnls :: Tab -> D
ftchnls = on1 $ opr1 "ftchnls"
ftsr :: Tab -> D
ftsr = on1 $ opr1 "ftsr"
ftcps :: Tab -> D
ftcps = on1 $ opr1 "ftcps"