packages feed

x-dsp 0.2 → 0.2.3

raw patch · 13 files changed

+381/−285 lines, 13 filesdep ~arraydep ~transformers

Dependency ranges changed: array, transformers

Files

src/Language/XDsp/Implementations/Csound.hs view
@@ -3,6 +3,7 @@     ,DoRec     ,ExtendedDefaultRules     ,TypeFamilies+    ,TypeOperators     ,DeriveDataTypeable     ,DeriveFunctor     ,GeneralizedNewtypeDeriving@@ -11,6 +12,7 @@     ,FlexibleInstances     ,TupleSections     ,OverlappingInstances+    ,UndecidableInstances     ,TypeSynonymInstances #-}  module Language.XDsp.Implementations.Csound (@@ -24,6 +26,8 @@  ,makeInstrument  ,TList  ,unTList'+ ,mkTbl+ ,writeCard  ,module Language.XDsp.Semantics.CsoundExt ) @@ -221,12 +225,13 @@ writeCard :: Card -> S n () writeCard = tellSco . card2str -mkTbl :: Int -> Int -> Int -> [Int] -> Card-mkTbl nm time sz args = Card T . map show $ nm:time:sz:args+mkTbl :: Int -> Double -> Int -> Int -> [Double] -> Card+mkTbl nm time sz gen args = Card T $+  show nm:show time:show sz:show gen:map show args  -- |Create a 0-filled f-statement in the score section. mkScoreBuf :: Int -> Int -> S n ()-mkScoreBuf nm sz = writeCard $ mkTbl nm 0 sz [17,0,0]+mkScoreBuf nm sz = writeCard $ mkTbl nm 0 sz 17 [0,0]  -- | Holds data on a score item for memoization purposes. data CardM = CardM VarType String String deriving (Eq, Ord, Show)@@ -360,6 +365,10 @@   genName   :: S n (s, String)   getVarLbl :: s -> String +instance Varable s => Var s where+  type VarRep s = String+  getVarRep s = getVarLbl s+ class Varable s => PVar s where  class Varable s => KVar s where@@ -381,15 +390,23 @@ instance Dsp (S n) where   data (ASig (S n)) = S_A CVar   data (KSig (S n)) = S_K CVar-  data (INum (S n)) = S_IN CVar+  data (INum (S n)) = S_I CVar   getSr    = fst <$> ask   getKsmps = snd <$> ask  instance Constants (S n) where-  cnst = return . S_IN . Cnst+  cnst = return . S_I . Cnst   ckig = return . S_K . Cnst   csig = return . S_A . Cnst +instance Cast (S n) where+  ik ivar = mkOp1 "=" ivar+  ia ivar = mkOp1 "=" ivar+  ki kvar = do+    (out, outname) <- genName+    tellOrc $ printf "%s = i(%s)\n" outname (getVarLbl kvar)+    return out+ instance Varable (ASig (S n)) where   genName = do     SState omap gen imap <- get@@ -419,8 +436,8 @@     let num = fromMaybe 1 $ M.lookup I gen         nm  = 'i' : show num     put $ SState omap (M.alter (const $ Just (succ num)) I gen) imap-    return (S_IN $ CVar nm, nm)-  getVarLbl (S_IN c) = getLbl c+    return (S_I $ CVar nm, nm)+  getVarLbl (S_I c) = getLbl c  instance Varable () where   genName            = return ((), "")@@ -499,6 +516,7 @@  instance StringVar (S n) where   data VString (S n) = S_VS CVar+  fromStr = S_VS . CStr  -- --------------------------------- -- ---------------------------------@@ -507,6 +525,30 @@   nchnls n   = tellOrc (printf "nchnls = %i\n" n) >> return n   set0dbfs n = tellOrc (printf "0dbfs = %f\n" n) >> return n +instance CsFunctions (ASig (S n)) where+  octcps (S_A a) = S_A . CVar $ printf "(octcps(%s))" (getLbl a)+  octpch (S_A a) = S_A . CVar $ printf "(octpch(%s))" (getLbl a)+  cpspch (S_A a) = S_A . CVar $ printf "(cpspch(%s))" (getLbl a)+  cpsoct (S_A a) = S_A . CVar $ printf "(cpsoct(%s))" (getLbl a)+  pchoct (S_A a) = S_A . CVar $ printf "(pchoct(%s))" (getLbl a)+  pchcps (S_A a) = S_A . CVar $ printf "(pchcps(%s))" (getLbl a)++instance CsFunctions (KSig (S n)) where+  octcps (S_K a) = S_K . CVar $ printf "(octcps(%s))" (getLbl a)+  octpch (S_K a) = S_K . CVar $ printf "(octpch(%s))" (getLbl a)+  cpspch (S_K a) = S_K . CVar $ printf "(cpspch(%s))" (getLbl a)+  cpsoct (S_K a) = S_K . CVar $ printf "(cpsoct(%s))" (getLbl a)+  pchoct (S_K a) = S_K . CVar $ printf "(pchoct(%s))" (getLbl a)+  pchcps (S_K a) = S_K . CVar $ printf "(pchcps(%s))" (getLbl a)++instance CsFunctions (INum (S n)) where+  octcps (S_I a) = S_I . CVar $ printf "(octcps(%s))" (getLbl a)+  octpch (S_I a) = S_I . CVar $ printf "(octpch(%s))" (getLbl a)+  cpspch (S_I a) = S_I . CVar $ printf "(cpspch(%s))" (getLbl a)+  cpsoct (S_I a) = S_I . CVar $ printf "(cpsoct(%s))" (getLbl a)+  pchoct (S_I a) = S_I . CVar $ printf "(pchoct(%s))" (getLbl a)+  pchcps (S_I a) = S_I . CVar $ printf "(pchcps(%s))" (getLbl a)+ -- --------------------------------- -- --------------------------------- -- Numeric support for signals@@ -520,7 +562,7 @@   (S_A a) + (S_A b) = S_A . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)   (S_A a) - (S_A b) = S_A . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)   (S_A a) * (S_A b) = S_A . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)-  abs _       = error "abs called on (ASig (S n))"+  abs (S_A a)       = S_A . CVar $ printf "(abs %s)" (getLbl a)   signum      = error "signum called on (ASig (S n))"   fromInteger = S_A . Cnst . fromInteger @@ -538,7 +580,7 @@   (S_K a) + (S_K b) = S_K . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)   (S_K a) - (S_K b) = S_K . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)   (S_K a) * (S_K b) = S_K . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)-  abs _       = error "abs called on (KSig (S n))"+  abs (S_K a)       = S_K . CVar $ printf "(abs %s)" (getLbl a)   signum      = error "signum called on (KSig (S n))"   fromInteger = S_K . Cnst . fromInteger @@ -547,26 +589,26 @@   fromRational = S_K . Cnst . fromRational  instance Show (INum (S n)) where-  show (S_IN s) = show s+  show (S_I s) = show s  instance Eq (INum (S n)) where-  (S_IN a) == (S_IN b) = a == b+  (S_I a) == (S_I b) = a == b  instance Num (INum (S n)) where-  (S_IN (Cnst a)) + (S_IN (Cnst b)) = S_IN $ Cnst (a+b)-  (S_IN a) + (S_IN b) = S_IN . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)-  (S_IN (Cnst a)) - (S_IN (Cnst b)) = S_IN $ Cnst (a-b)-  (S_IN a) - (S_IN b) = S_IN . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)-  (S_IN (Cnst a)) * (S_IN (Cnst b)) = S_IN $ Cnst (a*b)-  (S_IN a) * (S_IN b) = S_IN . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)-  abs _       = error "abs called on (INum (S n))"+  (S_I (Cnst a)) + (S_I (Cnst b)) = S_I $ Cnst (a+b)+  (S_I a) + (S_I b) = S_I . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)+  (S_I (Cnst a)) - (S_I (Cnst b)) = S_I $ Cnst (a-b)+  (S_I a) - (S_I b) = S_I . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)+  (S_I (Cnst a)) * (S_I (Cnst b)) = S_I $ Cnst (a*b)+  (S_I a) * (S_I b) = S_I . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)+  abs (S_I a)        = S_I . CVar $ printf "(abs %s)" (getLbl a)   signum      = error "signum called on (INum (S n))"-  fromInteger = S_IN . Cnst . fromInteger+  fromInteger = S_I . Cnst . fromInteger  instance Fractional (INum (S n)) where-  (S_IN (Cnst a)) / (S_IN (Cnst b)) = S_IN . Cnst $ a/b-  (S_IN a) / (S_IN b) = S_IN . CVar $ printf "(%s / %s)" (getLbl a) (getLbl b)-  fromRational = S_IN . Cnst . fromRational+  (S_I (Cnst a)) / (S_I (Cnst b)) = S_I . Cnst $ a/b+  (S_I a) / (S_I b) = S_I . CVar $ printf "(%s / %s)" (getLbl a) (getLbl b)+  fromRational = S_I . Cnst . fromRational  instance Show s => Show ((S n) s) where   show s = show $ evalS s defaultRType@@ -589,6 +631,11 @@  -- --------------------------------- -- ---------------------------------+-- Csound functions+++-- ---------------------------------+-- --------------------------------- -- core language extensions  -- | supports assignment@@ -628,21 +675,66 @@   vbuf lbl sz = do     (SState cmap gen imap) <- get     case M.lookup (CKC $ cacheBuf lbl sz) cmap of-      Just nm -> return $ S_IN nm+      Just nm -> return $ S_I nm       Nothing -> do         bufNum <- mkName T         mkScoreBuf bufNum sz         tellHost . HostOut (TblBus sz) lbl $ show bufNum         let res = Cnst $ fromIntegral bufNum         cache (CKC $ cacheBuf lbl sz) res-        return $ S_IN res+        return $ S_I res +mkOp str l r = printf ("(%s " ++ str ++ " %s)") (getLbl l) (getLbl r)++instance RCmpr (KSig (S n)) where+  data RBool (KSig (S n)) = K_Bool String+  req (S_K l) (S_K r) = K_Bool $ mkOp "==" l r+  rne (S_K l) (S_K r) = K_Bool $ mkOp "!=" l r+  rlt (S_K l) (S_K r) = K_Bool $ mkOp "<" l r+  rle (S_K l) (S_K r) = K_Bool $ mkOp "<=" l r+  rgt (S_K l) (S_K r) = K_Bool $ mkOp ">" l r+  rge (S_K l) (S_K r) = K_Bool $ mkOp ">=" l r++instance RCmpr (INum (S n)) where+  data RBool (INum (S n)) = I_Bool String+  req (S_I l) (S_I r) = I_Bool $ mkOp "==" l r+  rne (S_I l) (S_I r) = I_Bool $ mkOp "!=" l r+  rlt (S_I l) (S_I r) = I_Bool $ mkOp "<" l r+  rle (S_I l) (S_I r) = I_Bool $ mkOp "<=" l r+  rgt (S_I l) (S_I r) = I_Bool $ mkOp ">" l r+  rge (S_I l) (S_I r) = I_Bool $ mkOp ">=" l r++instance Varable a => RCtrl (S n) (KSig (S n)) a where+  rIf (K_Bool b) m = runIf1 b m+  rIfElse (K_Bool b) m1 m2 = runIf b m1 m2++instance Varable a => RCtrl (S n) (INum (S n)) a where+  rIf (I_Bool b) m = runIf1 b m+  rIfElse (I_Bool b) m1 m2 = runIf b m1 m2++runIf1 test m1 = do+  tellOrc $ printf "if %s then\n" test+  a <- m1+  tellOrc "endif\n"+  return a++runIf test m1 m2 = do+  tellOrc $ printf "if %s then\n" test+  a <- m1+  let aLbl = getVarRep a+  tellOrc "else\n"+  b <- m2+  let bLbl = getVarRep b+  tellOrc $ printf "%s = %s\n" aLbl bLbl+  tellOrc "endif\n"+  return a+ -- --------------------------------- -- --------------------------------- -- Instruments  instance (Nat m, Nat n, Show n, m :>=: n) => NumArgs S m n where-  getArg n = return . S_IN . CVar $ 'p': show n+  getArg n = return . S_I . CVar $ 'p': show n  -- | Labelled blocks (basic instrument creation) instance LblBlock (S n) where@@ -711,6 +803,31 @@  -- --------------------------------- -- ---------------------------------+-- Math ops++instance Math (S n) (ASig (S n)) where+  log2  (S_A a) = asn $ S_A . CVar $ printf "(logbtwo(%s))" (getLbl a)+  sqrt  (S_A a) = asn $ S_A . CVar $ printf "(sqrt(%s))" (getLbl a)+  int   (S_A a) = asn $ S_A . CVar $ printf "(int(%s))" (getLbl a)+  frac  (S_A a) = asn $ S_A . CVar $ printf "(frac(%s))" (getLbl a)+  floor (S_A a) = asn $ S_A . CVar $ printf "(floor(%s))" (getLbl a)++instance Math (S n) (KSig (S n)) where+  log2  (S_K a) = asn $ S_K . CVar $ printf "(logbtwo(%s))" (getLbl a)+  sqrt  (S_K a) = asn $ S_K . CVar $ printf "(sqrt(%s))" (getLbl a)+  int   (S_K a) = asn $ S_K . CVar $ printf "(int(%s))" (getLbl a)+  frac  (S_K a) = asn $ S_K . CVar $ printf "(frac(%s))" (getLbl a)+  floor (S_K a) = asn $ S_K . CVar $ printf "(floor(%s))" (getLbl a)++instance Math (S n) (INum (S n)) where+  log2  (S_I a) = asn $ S_I . CVar $ printf "(logbtwo(%s))" (getLbl a)+  sqrt  (S_I a) = asn $ S_I . CVar $ printf "(sqrt(%s))" (getLbl a)+  int   (S_I a) = asn $ S_I . CVar $ printf "(int(%s))" (getLbl a)+  frac  (S_I a) = asn $ S_I . CVar $ printf "(frac(%s))" (getLbl a)+  floor (S_I a) = asn $ S_I . CVar $ printf "(floor(%s))" (getLbl a)++-- ---------------------------------+-- --------------------------------- -- phasor instance Phasor (S n) (KSig (S n)) (KSig (S n)) where   phasor = mkOp1 "phasor"@@ -767,12 +884,6 @@   v <- csig 1000   outs v v --- | allocate a "variable buffer" (i.e. host-updated buffer)-t2 = do-  buf <- vbuf "a buffer" 8192-  so <- oscil 1000 440 buf-  outs so so- -- | delay networks  -- | simple delay with constant signal@@ -780,47 +891,9 @@   so <- runDelay 1 1000 (tapK 1)   outs so so -t4 = do-  buf <- vbuf "a buffer" 8192-  so <- oscil 1000 440 buf-  let d = (\d1 d2 -> 0.5*d1+0.25*d2) <$> tapI 1 <*> tapI 2-  dl <- runDelay 2 so d-  sig <- asn $ so + dl-  outs sig sig--t5 = do-  buf <- vbuf "a buffer" 8192-  so  <- oscil 1000 440 buf-  let d = (\d1 d2 -> 0.5*d1+0.25*d2) <$> tapI 1 <*> tapI 2-  rec dl <- runDelay 2 (so+dl) d-  sig <- asn $ so + dl-  outs sig sig--t5' = do-  buf <- vbuf "a buffer" 8192-  so  <- oscil 1000 440 buf-  let d = (\d1 d2 -> 0.5*d1+0.25*d2) <$> tapI 1 <*> tapI 2-  rec dl <- runDelay 2 (so + 0.1*dl) d-  sig <- asn $ so + dl-  outs sig sig---- | additive synthesis.  Shared buffer, uses the Num instance for signals.-t6 = do-  so  <- zipWithM (\fq buf -> oscil 1000 (fq*110) buf) [4..] (replicate 20 1)-  so' <- asn $ sum so-  outs so' so'---- | using fold to make an oscil stack.  Note that emptyBuffer is *not*--- memoized.-t8 = do-  buf <- emptyBuffer 8192-  stack <- foldM (\a f -> f a) (40)-                       (replicate 4 (\fq -> oscil 1000 fq buf))-  outs stack stack- -- | It's necessary to use monadic sequencing (here implicit in makeInstruments) -- to chain instruments together-all1 = mapM makeInstrument [t1,t2, t3, t4, t5', t6, t8]+all1 = mapM makeInstrument [t1,t3] instance  CsATSadd (S n)  where   aTSadd = mkOp5 "aTSadd"   aTSadd' = mkOp8 "aTSadd"@@ -894,18 +967,6 @@   aCS = mkOp1 "aCS"  -instance  CsAbs (S n) (ASig (S n)) (ASig (S n)) where-  abs = mkOp1 "abs"---instance  CsAbs (S n) (KSig (S n)) (KSig (S n)) where-  abs = mkOp1 "abs"---instance  CsAbs (S n) (INum (S n)) (INum (S n)) where-  abs = mkOp1 "abs"-- instance (Varable a, Varable b) => CsAdd (S n) (ASig (S n)) a b where   add = mkOp2 "add" @@ -1420,26 +1481,6 @@   cpsmidinn = mkOp1 "cpsmidinn"  -instance  CsCpsoct (S n) (ASig (S n)) (ASig (S n)) where-  cpsoct = mkOp1 "cpsoct"---instance  CsCpsoct (S n) (KSig (S n)) (KSig (S n)) where-  cpsoct = mkOp1 "cpsoct"---instance  CsCpsoct (S n) (INum (S n)) (INum (S n)) where-  cpsoct = mkOp1 "cpsoct"---instance  CsCpspch (S n) (KSig (S n)) where-  cpspch = mkOp1 "cpspch"---instance  CsCpspch (S n) (INum (S n)) where-  cpspch = mkOp1 "cpspch"-- instance  CsCpstmid (S n)  where   cpstmid = mkOp1 "cpstmid" @@ -1920,18 +1961,6 @@   flooper3' = mkOp10 "flooper3"  -instance  CsFloor (S n) (ASig (S n)) (ASig (S n)) where-  floor = mkOp1 "floor"---instance  CsFloor (S n) (KSig (S n)) (KSig (S n)) where-  floor = mkOp1 "floor"---instance  CsFloor (S n) (INum (S n)) (INum (S n)) where-  floor = mkOp1 "floor"-- instance  CsFmb3 (S n)  where   fmb3 = mkOp11 "fmb3" @@ -2026,18 +2055,6 @@   fprints = mkOp3 "fprints"  -instance  CsFrac (S n) (ASig (S n)) (ASig (S n)) where-  frac = mkOp1 "frac"---instance  CsFrac (S n) (KSig (S n)) (KSig (S n)) where-  frac = mkOp1 "frac"---instance  CsFrac (S n) (INum (S n)) (INum (S n)) where-  frac = mkOp1 "frac"-- instance  CsFreeverb (S n)  where   freeverb = mkOp4 "freeverb"   freeverb' = mkOp6 "freeverb"@@ -2289,18 +2306,6 @@   instr = mkOp0 "instr"  -instance  CsInt (S n) (ASig (S n)) (ASig (S n)) where-  int = mkOp1 "int"---instance  CsInt (S n) (KSig (S n)) (KSig (S n)) where-  int = mkOp1 "int"---instance  CsInt (S n) (INum (S n)) (INum (S n)) where-  int = mkOp1 "int"-- instance (PVar out, Varable a) => CsInteg (S n) out a where   integ = mkOp1 "integ"   integ' = mkOp2 "integ"@@ -2428,18 +2433,6 @@   log10 = mkOp1 "log10"  -instance  CsLogbtwo (S n) (ASig (S n)) (ASig (S n)) where-  logbtwo = mkOp1 "logbtwo"---instance  CsLogbtwo (S n) (KSig (S n)) (KSig (S n)) where-  logbtwo = mkOp1 "logbtwo"---instance  CsLogbtwo (S n) (INum (S n)) (INum (S n)) where-  logbtwo = mkOp1 "logbtwo"-- instance  CsLogcurve (S n)  where   logcurve = mkOp2 "logcurve" @@ -2993,14 +2986,6 @@   octave = mkOp1 "octave"  -instance  CsOctcps (S n) (KSig (S n)) where-  octcps = mkOp1 "octcps"---instance  CsOctcps (S n) (INum (S n)) where-  octcps = mkOp1 "octcps"-- instance  CsOctmidi (S n)  where   octmidi = mkOp0 "octmidi" @@ -3023,14 +3008,6 @@   octmidinn = mkOp1 "octmidinn"  -instance  CsOctpch (S n) (KSig (S n)) where-  octpch = mkOp1 "octpch"---instance  CsOctpch (S n) (INum (S n)) where-  octpch = mkOp1 "octpch"-- instance  CsOpcode (S n)  where   opcode = mkOp0 "opcode" @@ -3306,14 +3283,6 @@   pchmidinn = mkOp1 "pchmidinn"  -instance  CsPchoct (S n) (KSig (S n)) where-  pchoct = mkOp1 "pchoct"---instance  CsPchoct (S n) (INum (S n)) where-  pchoct = mkOp1 "pchoct"-- instance (Nat d) => CsPconvolve (S n) d where   pconvolve = mkOp2 "pconvolve"   pconvolve' = mkOp4 "pconvolve"@@ -4256,18 +4225,6 @@  instance  CsSpsend (S n)  where   spsend = mkOp0 "spsend"---instance  CsSqrt (S n) (ASig (S n)) (ASig (S n)) where-  sqrt = mkOp1 "sqrt"---instance  CsSqrt (S n) (KSig (S n)) (KSig (S n)) where-  sqrt = mkOp1 "sqrt"---instance  CsSqrt (S n) (INum (S n)) (INum (S n)) where-  sqrt = mkOp1 "sqrt"   instance  CsStack (S n)  where
src/Language/XDsp/Implementations/HaskellNative.hs view
@@ -137,7 +137,7 @@ lookupInterp :: UArray Int Double -> Double -> Double lookupInterp arr d1 = v1 + frc * (v2-v1)  where-  i  = floor d1+  i  = Prelude.floor d1   v1 = arr ! i   v2 = arr ! i+1   frc = d1 - (fromIntegral i)@@ -162,7 +162,7 @@ phasor' :: Integer -> Double -> Double -> Double phasor' sr frq last = if next <= 1   then next-  else next-(fromIntegral $ floor next)+  else next-(fromIntegral $ Prelude.floor next)  where next = last + (frq/(fromIntegral sr))  instance Phasor HN (KSig HN) (INum HN) where
src/Language/XDsp/Semantics.hs view
@@ -1,11 +1,15 @@ module Language.XDsp.Semantics (-  module Language.XDsp.Semantics.Core+   module Language.XDsp.Semantics.Core   ,module Language.XDsp.Semantics.BasicExtensions+  ,module Language.XDsp.Semantics.CtrlExtensions   ,module Language.XDsp.Semantics.Extras+  ,module Language.XDsp.Semantics.Math )  where  import Language.XDsp.Semantics.Core import Language.XDsp.Semantics.BasicExtensions+import Language.XDsp.Semantics.CtrlExtensions import Language.XDsp.Semantics.Extras+import Language.XDsp.Semantics.Math
src/Language/XDsp/Semantics/BasicExtensions.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies+            ,TypeOperators             ,MultiParamTypeClasses             ,FlexibleContexts             ,DeriveFunctor #-}@@ -12,6 +13,7 @@  ,LblBlock (..)  ,NumArgs (..)  ,TList (..)+ ,tlist0  ,unTList  ,unTList'  ,unsafeTList@@ -36,6 +38,7 @@ -- | Support for string variables. class Dsp repr => StringVar repr where   data VString repr :: *+  fromStr :: String -> VString repr  -- | Audio buffer or other data table. class Dsp repr => Buffer repr where@@ -74,7 +77,7 @@   -> repr () defaultRunBlock blk st dr = runBlock blk st dr tlist0 -tlist0 :: TList D3 a+tlist0 :: (Nat n, n :>=: D3) => TList n a tlist0 = TList []  unTList :: TList n a -> [a]
src/Language/XDsp/Semantics/Core.hs view
@@ -20,6 +20,11 @@   ckig :: Double -> repr (KSig repr)   csig :: Double -> repr (ASig repr) +-- | Named variables in a backend.+class Var a where+  type VarRep a :: *+  getVarRep :: a -> VarRep a+ -- --------------------------------- -- --------------------------------- -- Very common extensions.@@ -28,3 +33,7 @@ class Dsp repr => Asn repr a where   asn   :: a -> repr a +class Dsp repr => Cast repr where+  ik :: INum repr -> repr (KSig repr)+  ia :: INum repr -> repr (ASig repr)+  ki :: KSig repr -> repr (INum repr)
src/Language/XDsp/Semantics/CsoundExt.hs view
@@ -1,5 +1,6 @@ module Language.XDsp.Semantics.CsoundExt (   CsoundClass (..)+ ,CsFunctions (..)  ,Out (..)  ,module Language.XDsp.Semantics.CsoundExt.All )
src/Language/XDsp/Semantics/CsoundExt/All.hs view
@@ -185,12 +185,6 @@     -> repr (ASig repr)  -class (CsoundClass repr) => CsAbs repr out a where-  abs ::-    a-    -> repr out-- class (CsoundClass repr) => CsAdd repr out a b where   add ::     a@@ -1036,18 +1030,6 @@     -> repr out  -class (CsoundClass repr) => CsCpsoct repr out a where-  cpsoct ::-    a-    -> repr out---class (CsoundClass repr) => CsCpspch repr out  where-  cpspch ::-    KSig repr-    -> repr out-- class (CsoundClass repr) => CsCpstmid repr  where   cpstmid ::     INum repr@@ -2003,12 +1985,6 @@     -> repr (ASig repr)  -class (CsoundClass repr) => CsFloor repr out a where-  floor ::-    a-    -> repr out-- class (CsoundClass repr) => CsFmb3 repr  where   fmb3 ::     KSig repr@@ -2349,12 +2325,6 @@     -> repr ()  -class (CsoundClass repr) => CsFrac repr out a where-  frac ::-    a-    -> repr out-- class (CsoundClass repr) => CsFreeverb repr  where   freeverb ::     ASig repr@@ -3035,12 +3005,6 @@     repr ()  -class (CsoundClass repr) => CsInt repr out a where-  int ::-    a-    -> repr out-- class (CsoundClass repr) => CsInteg repr out a where   integ ::     a@@ -3217,12 +3181,6 @@     -> repr out  -class (CsoundClass repr) => CsLogbtwo repr out a where-  logbtwo ::-    a-    -> repr out-- class (CsoundClass repr) => CsLogcurve repr  where   logcurve ::     KSig repr@@ -4362,12 +4320,6 @@     -> repr out  -class (CsoundClass repr) => CsOctcps repr out  where-  octcps ::-    KSig repr-    -> repr out-- class (CsoundClass repr) => CsOctmidi repr  where   octmidi ::     repr (INum repr)@@ -4386,12 +4338,6 @@     -> repr out  -class (CsoundClass repr) => CsOctpch repr out  where-  octpch ::-    KSig repr-    -> repr out-- class (CsoundClass repr) => CsOpcode repr  where   opcode ::     repr ()@@ -4946,12 +4892,6 @@     -> repr out  -class (CsoundClass repr) => CsPchoct repr out  where-  pchoct ::-    KSig repr-    -> repr out-- class (CsoundClass repr) => CsPconvolve repr d  where   pconvolve ::     ASig repr@@ -7290,12 +7230,6 @@ class (CsoundClass repr) => CsSpsend repr  where   spsend ::     repr (ASig repr, ASig repr, ASig repr, ASig repr)---class (CsoundClass repr) => CsSqrt repr out a where-  sqrt ::-    a-    -> repr out   class (CsoundClass repr) => CsStack repr  where
src/Language/XDsp/Semantics/CsoundExt/Core.hs view
@@ -1,5 +1,6 @@ module Language.XDsp.Semantics.CsoundExt.Core (   CsoundClass (..)+ ,CsFunctions (..) )  where@@ -16,3 +17,12 @@   nchnls   :: Int -> repr Int   set0dbfs :: Double -> repr Double +-- csound functions++class CsFunctions a where+  octcps :: a -> a+  octpch :: a -> a+  cpspch :: a -> a+  cpsoct :: a -> a+  pchcps :: a -> a+  pchoct :: a -> a
+ src/Language/XDsp/Semantics/CtrlExtensions.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}++module Language.XDsp.Semantics.CtrlExtensions (+  RCmpr (..)+ ,RCtrl (..)+)++where++import Language.XDsp.Semantics.Core++-- control extensions, e.g. if-then-else++class RCmpr el where+  data RBool el :: *+  req :: el -> el -> RBool el+  rne :: el -> el -> RBool el+  rlt :: el -> el -> RBool el+  rle :: el -> el -> RBool el+  rgt :: el -> el -> RBool el+  rge :: el -> el -> RBool el++class (Dsp repr, Var a) => RCtrl repr el a where+  rIf     :: RBool el -> repr a -> repr a+  rIfElse :: RBool el -> repr a -> repr a -> repr a
+ src/Language/XDsp/Semantics/Math.hs view
@@ -0,0 +1,22 @@+-- | Mathematics operations+-- very minimal for the moment++{-# LANGUAGE TypeFamilies+            ,MultiParamTypeClasses+            ,FlexibleContexts+            ,DeriveFunctor #-}++module Language.XDsp.Semantics.Math (+  Math (..)+)++where++import           Language.XDsp.Semantics.Core++class Math repr a where+  log2  :: a -> repr a+  sqrt  :: a -> repr a+  int   :: a -> repr a+  frac  :: a -> repr a+  floor :: a -> repr a
tools/CsMaps.hs view
@@ -24,6 +24,17 @@ noReuseSet :: S.Set String noReuseSet = S.fromList ["vdelay3"                         ,"vdelay"+                        ,"abs"+                        ,"int"+                        ,"floor"+                        ,"frac"+                        ,"logbtwo"+                        ,"octcps"+                        ,"octpch"+                        ,"cpsoct"+                        ,"cpspch"+                        ,"pchcps"+                        ,"pchoct"                         ,"out"                         ,"outs"                         ,"outq"@@ -32,7 +43,8 @@                         ,"slider32table"                         ,"slider32tablef"                         ,"slider64table"-                        ,"slider64tablef" ]+                        ,"slider64tablef"+                        ,"sqrt" ]  -- | if a function needs a special context, add it addCtxt :: String -> [String]
tools/CsoundImplTemplate.hs view
@@ -3,6 +3,7 @@     ,DoRec     ,ExtendedDefaultRules     ,TypeFamilies+    ,TypeOperators     ,DeriveDataTypeable     ,DeriveFunctor     ,GeneralizedNewtypeDeriving@@ -11,6 +12,7 @@     ,FlexibleInstances     ,TupleSections     ,OverlappingInstances+    ,UndecidableInstances     ,TypeSynonymInstances #-}  module Language.XDsp.Implementations.Csound (@@ -24,6 +26,8 @@  ,makeInstrument  ,TList  ,unTList'+ ,mkTbl+ ,writeCard  ,module Language.XDsp.Semantics.CsoundExt ) @@ -221,12 +225,13 @@ writeCard :: Card -> S n () writeCard = tellSco . card2str -mkTbl :: Int -> Int -> Int -> [Int] -> Card-mkTbl nm time sz args = Card T . map show $ nm:time:sz:args+mkTbl :: Int -> Double -> Int -> Int -> [Double] -> Card+mkTbl nm time sz gen args = Card T $+  show nm:show time:show sz:show gen:map show args  -- |Create a 0-filled f-statement in the score section. mkScoreBuf :: Int -> Int -> S n ()-mkScoreBuf nm sz = writeCard $ mkTbl nm 0 sz [17,0,0]+mkScoreBuf nm sz = writeCard $ mkTbl nm 0 sz 17 [0,0]  -- | Holds data on a score item for memoization purposes. data CardM = CardM VarType String String deriving (Eq, Ord, Show)@@ -360,6 +365,10 @@   genName   :: S n (s, String)   getVarLbl :: s -> String +instance Varable s => Var s where+  type VarRep s = String+  getVarRep s = getVarLbl s+ class Varable s => PVar s where  class Varable s => KVar s where@@ -381,15 +390,23 @@ instance Dsp (S n) where   data (ASig (S n)) = S_A CVar   data (KSig (S n)) = S_K CVar-  data (INum (S n)) = S_IN CVar+  data (INum (S n)) = S_I CVar   getSr    = fst <$> ask   getKsmps = snd <$> ask  instance Constants (S n) where-  cnst = return . S_IN . Cnst+  cnst = return . S_I . Cnst   ckig = return . S_K . Cnst   csig = return . S_A . Cnst +instance Cast (S n) where+  ik ivar = mkOp1 "=" ivar+  ia ivar = mkOp1 "=" ivar+  ki kvar = do+    (out, outname) <- genName+    tellOrc $ printf "%s = i(%s)\n" outname (getVarLbl kvar)+    return out+ instance Varable (ASig (S n)) where   genName = do     SState omap gen imap <- get@@ -419,8 +436,8 @@     let num = fromMaybe 1 $ M.lookup I gen         nm  = 'i' : show num     put $ SState omap (M.alter (const $ Just (succ num)) I gen) imap-    return (S_IN $ CVar nm, nm)-  getVarLbl (S_IN c) = getLbl c+    return (S_I $ CVar nm, nm)+  getVarLbl (S_I c) = getLbl c  instance Varable () where   genName            = return ((), "")@@ -499,6 +516,7 @@  instance StringVar (S n) where   data VString (S n) = S_VS CVar+  fromStr = S_VS . CStr  -- --------------------------------- -- ---------------------------------@@ -507,6 +525,30 @@   nchnls n   = tellOrc (printf "nchnls = %i\n" n) >> return n   set0dbfs n = tellOrc (printf "0dbfs = %f\n" n) >> return n +instance CsFunctions (ASig (S n)) where+  octcps (S_A a) = S_A . CVar $ printf "(octcps(%s))" (getLbl a)+  octpch (S_A a) = S_A . CVar $ printf "(octpch(%s))" (getLbl a)+  cpspch (S_A a) = S_A . CVar $ printf "(cpspch(%s))" (getLbl a)+  cpsoct (S_A a) = S_A . CVar $ printf "(cpsoct(%s))" (getLbl a)+  pchoct (S_A a) = S_A . CVar $ printf "(pchoct(%s))" (getLbl a)+  pchcps (S_A a) = S_A . CVar $ printf "(pchcps(%s))" (getLbl a)++instance CsFunctions (KSig (S n)) where+  octcps (S_K a) = S_K . CVar $ printf "(octcps(%s))" (getLbl a)+  octpch (S_K a) = S_K . CVar $ printf "(octpch(%s))" (getLbl a)+  cpspch (S_K a) = S_K . CVar $ printf "(cpspch(%s))" (getLbl a)+  cpsoct (S_K a) = S_K . CVar $ printf "(cpsoct(%s))" (getLbl a)+  pchoct (S_K a) = S_K . CVar $ printf "(pchoct(%s))" (getLbl a)+  pchcps (S_K a) = S_K . CVar $ printf "(pchcps(%s))" (getLbl a)++instance CsFunctions (INum (S n)) where+  octcps (S_I a) = S_I . CVar $ printf "(octcps(%s))" (getLbl a)+  octpch (S_I a) = S_I . CVar $ printf "(octpch(%s))" (getLbl a)+  cpspch (S_I a) = S_I . CVar $ printf "(cpspch(%s))" (getLbl a)+  cpsoct (S_I a) = S_I . CVar $ printf "(cpsoct(%s))" (getLbl a)+  pchoct (S_I a) = S_I . CVar $ printf "(pchoct(%s))" (getLbl a)+  pchcps (S_I a) = S_I . CVar $ printf "(pchcps(%s))" (getLbl a)+ -- --------------------------------- -- --------------------------------- -- Numeric support for signals@@ -520,7 +562,7 @@   (S_A a) + (S_A b) = S_A . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)   (S_A a) - (S_A b) = S_A . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)   (S_A a) * (S_A b) = S_A . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)-  abs _       = error "abs called on (ASig (S n))"+  abs (S_A a)       = S_A . CVar $ printf "(abs %s)" (getLbl a)   signum      = error "signum called on (ASig (S n))"   fromInteger = S_A . Cnst . fromInteger @@ -538,7 +580,7 @@   (S_K a) + (S_K b) = S_K . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)   (S_K a) - (S_K b) = S_K . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)   (S_K a) * (S_K b) = S_K . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)-  abs _       = error "abs called on (KSig (S n))"+  abs (S_K a)       = S_K . CVar $ printf "(abs %s)" (getLbl a)   signum      = error "signum called on (KSig (S n))"   fromInteger = S_K . Cnst . fromInteger @@ -547,26 +589,26 @@   fromRational = S_K . Cnst . fromRational  instance Show (INum (S n)) where-  show (S_IN s) = show s+  show (S_I s) = show s  instance Eq (INum (S n)) where-  (S_IN a) == (S_IN b) = a == b+  (S_I a) == (S_I b) = a == b  instance Num (INum (S n)) where-  (S_IN (Cnst a)) + (S_IN (Cnst b)) = S_IN $ Cnst (a+b)-  (S_IN a) + (S_IN b) = S_IN . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)-  (S_IN (Cnst a)) - (S_IN (Cnst b)) = S_IN $ Cnst (a-b)-  (S_IN a) - (S_IN b) = S_IN . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)-  (S_IN (Cnst a)) * (S_IN (Cnst b)) = S_IN $ Cnst (a*b)-  (S_IN a) * (S_IN b) = S_IN . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)-  abs _       = error "abs called on (INum (S n))"+  (S_I (Cnst a)) + (S_I (Cnst b)) = S_I $ Cnst (a+b)+  (S_I a) + (S_I b) = S_I . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)+  (S_I (Cnst a)) - (S_I (Cnst b)) = S_I $ Cnst (a-b)+  (S_I a) - (S_I b) = S_I . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)+  (S_I (Cnst a)) * (S_I (Cnst b)) = S_I $ Cnst (a*b)+  (S_I a) * (S_I b) = S_I . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)+  abs (S_I a)        = S_I . CVar $ printf "(abs %s)" (getLbl a)   signum      = error "signum called on (INum (S n))"-  fromInteger = S_IN . Cnst . fromInteger+  fromInteger = S_I . Cnst . fromInteger  instance Fractional (INum (S n)) where-  (S_IN (Cnst a)) / (S_IN (Cnst b)) = S_IN . Cnst $ a/b-  (S_IN a) / (S_IN b) = S_IN . CVar $ printf "(%s / %s)" (getLbl a) (getLbl b)-  fromRational = S_IN . Cnst . fromRational+  (S_I (Cnst a)) / (S_I (Cnst b)) = S_I . Cnst $ a/b+  (S_I a) / (S_I b) = S_I . CVar $ printf "(%s / %s)" (getLbl a) (getLbl b)+  fromRational = S_I . Cnst . fromRational  instance Show s => Show ((S n) s) where   show s = show $ evalS s defaultRType@@ -589,6 +631,11 @@  -- --------------------------------- -- ---------------------------------+-- Csound functions+++-- ---------------------------------+-- --------------------------------- -- core language extensions  -- | supports assignment@@ -628,21 +675,66 @@   vbuf lbl sz = do     (SState cmap gen imap) <- get     case M.lookup (CKC $ cacheBuf lbl sz) cmap of-      Just nm -> return $ S_IN nm+      Just nm -> return $ S_I nm       Nothing -> do         bufNum <- mkName T         mkScoreBuf bufNum sz         tellHost . HostOut (TblBus sz) lbl $ show bufNum         let res = Cnst $ fromIntegral bufNum         cache (CKC $ cacheBuf lbl sz) res-        return $ S_IN res+        return $ S_I res +mkOp str l r = printf ("(%s " ++ str ++ " %s)") (getLbl l) (getLbl r)++instance RCmpr (KSig (S n)) where+  data RBool (KSig (S n)) = K_Bool String+  req (S_K l) (S_K r) = K_Bool $ mkOp "==" l r+  rne (S_K l) (S_K r) = K_Bool $ mkOp "!=" l r+  rlt (S_K l) (S_K r) = K_Bool $ mkOp "<" l r+  rle (S_K l) (S_K r) = K_Bool $ mkOp "<=" l r+  rgt (S_K l) (S_K r) = K_Bool $ mkOp ">" l r+  rge (S_K l) (S_K r) = K_Bool $ mkOp ">=" l r++instance RCmpr (INum (S n)) where+  data RBool (INum (S n)) = I_Bool String+  req (S_I l) (S_I r) = I_Bool $ mkOp "==" l r+  rne (S_I l) (S_I r) = I_Bool $ mkOp "!=" l r+  rlt (S_I l) (S_I r) = I_Bool $ mkOp "<" l r+  rle (S_I l) (S_I r) = I_Bool $ mkOp "<=" l r+  rgt (S_I l) (S_I r) = I_Bool $ mkOp ">" l r+  rge (S_I l) (S_I r) = I_Bool $ mkOp ">=" l r++instance Varable a => RCtrl (S n) (KSig (S n)) a where+  rIf (K_Bool b) m = runIf1 b m+  rIfElse (K_Bool b) m1 m2 = runIf b m1 m2++instance Varable a => RCtrl (S n) (INum (S n)) a where+  rIf (I_Bool b) m = runIf1 b m+  rIfElse (I_Bool b) m1 m2 = runIf b m1 m2++runIf1 test m1 = do+  tellOrc $ printf "if %s then\n" test+  a <- m1+  tellOrc "endif\n"+  return a++runIf test m1 m2 = do+  tellOrc $ printf "if %s then\n" test+  a <- m1+  let aLbl = getVarRep a+  tellOrc "else\n"+  b <- m2+  let bLbl = getVarRep b+  tellOrc $ printf "%s = %s\n" aLbl bLbl+  tellOrc "endif\n"+  return a+ -- --------------------------------- -- --------------------------------- -- Instruments  instance (Nat m, Nat n, Show n, m :>=: n) => NumArgs S m n where-  getArg n = return . S_IN . CVar $ 'p': show n+  getArg n = return . S_I . CVar $ 'p': show n  -- | Labelled blocks (basic instrument creation) instance LblBlock (S n) where@@ -708,6 +800,31 @@  setSR n       = tellOrc (printf "sr = %i\n" n) >> return n setKSmps n    = tellOrc (printf "ksmps = %i\n" n) >> return n++-- ---------------------------------+-- ---------------------------------+-- Math ops++instance Math (S n) (ASig (S n)) where+  log2  (S_A a) = asn $ S_A . CVar $ printf "(logbtwo(%s))" (getLbl a)+  sqrt  (S_A a) = asn $ S_A . CVar $ printf "(sqrt(%s))" (getLbl a)+  int   (S_A a) = asn $ S_A . CVar $ printf "(int(%s))" (getLbl a)+  frac  (S_A a) = asn $ S_A . CVar $ printf "(frac(%s))" (getLbl a)+  floor (S_A a) = asn $ S_A . CVar $ printf "(floor(%s))" (getLbl a)++instance Math (S n) (KSig (S n)) where+  log2  (S_K a) = asn $ S_K . CVar $ printf "(logbtwo(%s))" (getLbl a)+  sqrt  (S_K a) = asn $ S_K . CVar $ printf "(sqrt(%s))" (getLbl a)+  int   (S_K a) = asn $ S_K . CVar $ printf "(int(%s))" (getLbl a)+  frac  (S_K a) = asn $ S_K . CVar $ printf "(frac(%s))" (getLbl a)+  floor (S_K a) = asn $ S_K . CVar $ printf "(floor(%s))" (getLbl a)++instance Math (S n) (INum (S n)) where+  log2  (S_I a) = asn $ S_I . CVar $ printf "(logbtwo(%s))" (getLbl a)+  sqrt  (S_I a) = asn $ S_I . CVar $ printf "(sqrt(%s))" (getLbl a)+  int   (S_I a) = asn $ S_I . CVar $ printf "(int(%s))" (getLbl a)+  frac  (S_I a) = asn $ S_I . CVar $ printf "(frac(%s))" (getLbl a)+  floor (S_I a) = asn $ S_I . CVar $ printf "(floor(%s))" (getLbl a)  -- --------------------------------- -- ---------------------------------
x-dsp.cabal view
@@ -1,5 +1,5 @@ Name:                x-dsp-Version:             0.2+Version:             0.2.3 Synopsis:            A embedded DSL for manipulating DSP languages in Haskell Description:         Provides a tagless-final language family for manipulating                      audio programming languages (e.g. Csound, Supercollider).@@ -27,18 +27,20 @@                      Language.XDsp.Semantics.CsoundExt                      Language.XDsp.Semantics.CsoundExt.All                      Language.XDsp.Semantics.CsoundExt.Core+                     Language.XDsp.Semantics.CtrlExtensions                      Language.XDsp.Semantics.Extras                      Language.XDsp.Semantics.Extras.Delay                      Language.XDsp.Semantics.Extras.FSig+                     Language.XDsp.Semantics.Math                      Language.XDsp.Implementations.Csound                      Language.XDsp.Implementations.HaskellNative   Build-depends:     base             >= 3   && < 5-                    ,array            >= 0.2 && < 0.4+                    ,array            >= 0.2 && < 0.5                     ,bytestring       >= 0.9 && < 0.10                     ,containers       >= 0.2 && < 0.5                     ,monads-tf        >= 0.1 && < 0.2                     ,text             >= 0.7 && < 0.13-                    ,transformers     >= 0.2 && < 0.3+                    ,transformers     >= 0.2 && < 0.4                     ,type-level       >= 0.2 && < 0.3  source-repository head