csound-expression 0.0.3 → 0.1.0

raw patch · 14 files changed

+343/−84 lines, 14 filesdep +BooleanPVP ok

version bump matches the API change (PVP)

Dependencies added: Boolean

API changes (from Hackage documentation)

Files

• Changelog +11/−0
• csound-expression.cabal +7/−2
• src/CsoundExpr/Base.hs +2/−0
• src/CsoundExpr/Base/Arithmetic.hs +30/−12
• src/CsoundExpr/Base/Boolean.hs +85/−0
• src/CsoundExpr/Base/Imperative.hs +3/−1
• src/CsoundExpr/Base/Types.hs +4/−2
• src/CsoundExpr/Base/UserDefined.hs +21/−4
• src/CsoundExpr/Translator/AssignmentElimination.hs +1/−1
• src/CsoundExpr/Translator/Cs/CsBoolean.hs +139/−0
• src/CsoundExpr/Translator/Cs/CsTree.hs +12/−29
• src/CsoundExpr/Translator/Cs/CsoundFile.hs +15/−22
• src/CsoundExpr/Translator/Types.hs +10/−10
• src/CsoundExpr/Tutorial/Orchestra.hs +3/−1

@@ -0,0 +1,11 @@+-> 0.1.0    new type BoolRate, functional if/then/else is possible+			new operators : <^>, <%>+			scaling becomes ^* (due to <* is defined as lower then for signals)++-> 0.0.3    fix a bug with p-fields assignment++-> 0.0.2    fix a bug in dependencies++-> 0.0.1    add Tutorial++0.0

@@ -1,5 +1,5 @@ Name:          csound-expression-Version:       0.0.3+Version:       0.1.0 Cabal-Version: >= 1.2 License:       BSD3 License-File:  LICENSE@@ -12,16 +12,20 @@ Tested-With:   GHC==6.12.1 Build-Type:    Simple +Extra-Source-Files : +              Changelog  Library   Build-Depends:-        base >= 4, base < 5, containers, mtl == 2.0.1.0, pretty, filepath, directory, haskell98, temporal-media == 0.0+        base >= 4, base < 5, containers, mtl == 2.0.1.0, pretty, +        filepath, directory, haskell98, Boolean, temporal-media == 0.0   Hs-Source-Dirs:      src/   Exposed-Modules:         CsoundExpr -- Base         CsoundExpr.Base         CsoundExpr.Base.Types+        CsoundExpr.Base.Boolean         CsoundExpr.Base.Imperative         CsoundExpr.Base.MultiOut         CsoundExpr.Base.SideEffect@@ -159,6 +163,7 @@ -- Cs         CsoundExpr.Translator.Cs.CsoundFile         CsoundExpr.Translator.Cs.CsTree+        CsoundExpr.Translator.Cs.CsBoolean         CsoundExpr.Translator.Cs.IM         CsoundExpr.Translator.Cs.Utils -- Translator

@@ -5,6 +5,7 @@ -- and "CsoundExpr.Base.Pitch". module CsoundExpr.Base ( 	module CsoundExpr.Base.Types,+	module CsoundExpr.Base.Boolean, 	module CsoundExpr.Base.Imperative, 	module CsoundExpr.Base.MultiOut, 	module CsoundExpr.Base.Arithmetic,@@ -17,6 +18,7 @@ where  import CsoundExpr.Base.Types+import CsoundExpr.Base.Boolean import CsoundExpr.Base.Imperative import CsoundExpr.Base.MultiOut import CsoundExpr.Base.Arithmetic

@@ -6,7 +6,7 @@ -- | Arithmetic operators  module CsoundExpr.Base.Arithmetic -	(Opr2, (<+>), neg, (<->), (<*>), (</>), (<*))+	(Opr2, (<+>), neg, (<->), (<*>), (</>), (<^>), (<%>), (^*)) where  import Prelude hiding (div)@@ -21,16 +21,19 @@  import CsoundExpr.Base.Types (Irate(..), Krate(..), Arate(..)) -infixr 8  <* +import CsoundExpr.Base.Boolean++infixr 9  ^* +infixr 8  <^> infixr 7  <*>, </>-infixr 6  <+>, <->+infixr 6  <+>, <->, <%>   subst :: (IM d a, IM d b, IM d c) => (d -> d -> c) -> (a -> b -> c) subst f x y = f (to x) (to y)  opr1 :: IM CsTree a => Name -> (Double -> Double) -> CsTree -> a-opr1 name fun a = maybe (infixOperation name $ return a) +opr1 name fun a = maybe (unaryInfixOperation name a)  			from (optim1 fun a)  opr1p :: IM CsTree a => Name -> (Double -> Double) -> CsTree -> a@@ -59,21 +62,33 @@ ---------------------------------------------------------- -- Type inference -(<+>), (<->), (<*>), (</>) :: (X a, X b, X (Opr2 a b)) => a -> b -> Opr2 a b+(<+>), (<->), (<*>), (</>), (<^>), (<%>) :: (X a, X b, X (Opr2 a b)) => a -> b -> Opr2 a b  (<+>) = subst $ opr2 "+" (+) (<->) = subst $ opr2 "-" (-) (<*>) = subst $ opr2 "*" (*) (</>) = subst $ opr2 "/" (/) +-- | "power of" operator+(<^>) = subst $ opr2 "^" (**)++-- | modulus operator+(<%>) = subst $ opr2 "%" modDouble+ -- | negation neg :: (X a) => a -> a neg = opr1 "-" negate . to --- | Scaling-(<*) :: X a => Irate -> a -> a-(<*) = subst $ opr2 "*" (*)+-- | scaling+(^*) :: X a => Irate -> a -> a+(^*) = subst $ opr2 "*" (*) ++modDouble :: Double -> Double -> Double+modDouble a b = signum a * until ( < b') (+ (-b')) a'+    where a' = abs a+          b' = abs b+ ---------------------------------------------------------- -- Num instances --@@ -96,7 +111,7 @@     (+) = (<+>)     (*) = (<*>)     abs = opr1p "abs" abs . to-    signum = error "is undefined"+    signum x = ifB (krate x >* num 0) 1 $ ifB (krate x <* num 0) (-1) 0     (-) = (<->)     fromInteger = double . fromInteger @@ -110,7 +125,7 @@     (+) = (<+>)     (*) = (<*>)     abs = opr1p "abs" abs . to-    signum = error "is undefined"+    signum x = ifB (x >* num 0) 1 $ ifB (x <* num 0) (-1) 0      (-) = (<->)     fromInteger = double . fromInteger @@ -124,13 +139,16 @@     (+) = (<+>)     (*) = (<*>)     abs = opr1p "abs" abs . to-    signum = error "is undefined"+    signum x = ifB (x >* num 0) 1 $ ifB (x <* num 0) (-1) 0      (-) = (<->)     fromInteger = double . fromInteger +num :: Irate -> Irate+num = id  instance Fractional Irate where     (/) = (</>)     fromRational = double . fromRational -+--------------------------------------------------+--

@@ -0,0 +1,85 @@+-- | replica of "Data.Boolean" module. Booleans for csound signals+module CsoundExpr.Base.Boolean (+     BoolRate,+     true, false, notB, (&&*), (||*),+     (==*), (/=*), (<*), (>*), (<=*), (>=*),+     ifB, minB, maxB, cond, crop+    )+ where++import CsoundExpr.Translator.Types+import CsoundExpr.Translator.Cs.IM++import qualified CsoundExpr.Translator.Cs.CsTree as La+import CsoundExpr.Translator.Cs.CsBoolean++import qualified Data.Boolean as B+import Data.Monoid+import Control.Applicative hiding ((<*))+++--------------------------------------------+-- Boolean instances++toCs :: X a => a -> La.CsTree+toCs = to++-----------------------------------------+-- BoolRate++infixr 3  &&*+infixr 2  ||*++true    = BoolRate B.true+false   = BoolRate B.false+notB (BoolRate a) = BoolRate $ B.notB a+BoolRate a &&* BoolRate b = BoolRate $ a B.&&* b+BoolRate a ||* BoolRate b = BoolRate $ a B.||* b++-- IfB++ifB :: X a => BoolRate -> a -> a -> a+ifB (BoolRate c) a b = from $ B.ifB c (toCs a) (toCs b)++-- EqB++infix  4  ==*, /=*++biOp :: (K a, K b) => +       (La.CsTree -> La.CsTree -> CsBool) +    -> a -> b -> BoolRate+biOp op a b = BoolRate $ toCs a `op` toCs b+++(==*), (/=*) :: (K a, K b) => a -> b -> BoolRate++(==*) = biOp (B.==*)+(/=*) = biOp (B./=*)++-- OrdB++infix  4  <*, <=*, >=*, >*++(<*), (>*), (>=*), (<=*) :: (K a, K b) => a -> b -> BoolRate++(<*) = biOp (B.<*)+(>*) = biOp (B.>*)++(>=*) = biOp (B.>=*)+(<=*) = biOp (B.<=*)++-- aux++cond :: (Applicative f, K a) => f BoolRate -> f a -> f a -> f a+cond f a b = fmap from $ B.cond (fmap (\(BoolRate a) -> a) f) (fmap toCs a) (fmap toCs b)++crop :: (Applicative f, Monoid (f a), K a) => f BoolRate -> f a -> f a+crop f a = cond f a mempty+++minB, maxB :: K a => a -> a -> a++minB a b = ifB (a <=* b) a b+maxB a b = ifB (a >=* b) a b++

@@ -43,7 +43,8 @@ gir :: Name -> Irate gir = argIn GI                 - ++ fromArgIn :: (IM CsTree a) => a -> (Rate, Name) fromArgIn a   | isArg e = (argRate e, argName e)@@ -59,6 +60,7 @@                   class Assign a where+                   (<=>) :: a -> a -> SignalOut                                                                        

@@ -1,7 +1,10 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+     module CsoundExpr.Base.Types      (X(..), K,      Arate, Krate, Irate, SignalOut, -     itime, idur, num, double, string)+     itime, idur, num, double, string+    ) where  import Text.PrettyPrint(Doc, vcat, text, space)@@ -56,5 +59,4 @@ instance Show SignalOut where     show x = show $ vcat [title , ppCsTrees $ fromSignalOut x]         where title = text "; SignalOut expression :"- 

@@ -13,8 +13,8 @@  module CsoundExpr.Base.UserDefined     (IM(..), Opr2(..),  -     opcode, outOpcode, -     infixOperation, prefixOperation)+     opcode, outOpcode, operation,+     infixOperation, prefixOperation, unaryInfixOperation) where  import CsoundExpr.Translator.Cs.IM@@ -61,6 +61,19 @@ outOpcode :: String -> [CsTree] -> SignalOut outOpcode name = SignalOut . return . opcode name +-- | operation constructor+--+-- names can be anywhere between arguments+--+-- > operation names args +--+-- in csound code becomes+--+-- > names !! 0 ++ show (args !! 0) ++ names !! 1 ++ show (args !! 1) ++ ... +operation :: IM CsTree a => [String] -> [CsTree] -> a+operation names = from . pure (opr names) ++ -- | Infix operation constructor -- -- Example : @@ -70,8 +83,9 @@ -- > add :: (X a, X b, X (Opr2 a b)) => a -> b -> Opr2 a b -- > add a b = infixOperation "+" [to a, to b] --+ infixOperation :: IM CsTree a => String -> [CsTree] -> a-infixOperation name = from . pure (oprInfix name)+infixOperation name = from . pure (opr ["(", name, ")"])                        -- | Prefix operation constructor --@@ -83,8 +97,11 @@ -- > csSin a = prefixOperation "sin" [to a] -- prefixOperation :: IM CsTree a => String -> [CsTree] -> a-prefixOperation name = from . pure (oprPrefix name)+prefixOperation name = from . pure (opr [name ++ "(", ")"]) ++unaryInfixOperation :: IM CsTree a => String -> CsTree -> a+unaryInfixOperation name = from . pure (opr ["(" ++ name, ")"]) . return  -- | 'Opr2' @a@ @b@  - defines output type of binary arithmetic operator --

@@ -98,7 +98,7 @@  oprArgOut     x = Just $ numArgName (toCsRate $ head $ rates x) (layerOut x) oprRateInfo   x = SingleOut $ toCsRate $ head $ rates x-oprBody     m x = ("=", [Cs.ArgInOpr (La.oprName $ op x) (toOprType $ La.oprType $ op x) args])+oprBody     m x = ("=", [Cs.ArgInOpr (La.oprName $ op x) args])     where args = map (substArg m) $ layerIn x  oprSubstTableValue m x = (oprRateInfo x, oprBody m x)

@@ -0,0 +1,139 @@+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-}++module CsoundExpr.Translator.Cs.CsBoolean (CsBool) +where++import Data.Boolean+import CsoundExpr.Translator.Cs.CsTree+import CsoundExpr.Translator.ExprTree.ExprTree++----------------------------------------------+-- low level operations++mkAnd, mkOr :: CsTree -> CsTree -> CsTree++mkAnd a b = pure (oprInfix "&&") [a, b]+mkOr  a b = pure (oprInfix "||") [a, b]++mkComp :: CompOp -> CsTree -> CsTree -> CsTree+mkComp op a b = pure (oprInfix $ show op) [a, b]++mkIf :: CsTree -> CsTree -> CsTree -> CsTree+mkIf cond th el = pure ifOpr [cond, th, el]++oprInfix :: Name -> CsExpr+oprInfix name = opr ["(", name, ")"]++ifOpr :: CsExpr +ifOpr = opr ["(", "?", ":",")"]++-------------------------------------------------+-- Booleans++data CsBool = CsBPrim CsComp+            | CsTrue +            | CsFalse +            | CsNot CsBool +            | CsAnd CsBool CsBool +            | CsOr CsBool CsBool++data CsComp = CsComp CompOp CsTree CsTree++data CompOp = CsEq | CsNeq | CsLt | CsGt | CsElt | CsEgt++instance Show CompOp where+    show x = case x of+                CsEq  -> "=="+                CsNeq -> "!="+                CsLt  -> "<"+                CsGt  -> ">"+                CsElt -> "<="+                CsEgt -> ">="++notCompOp :: CompOp -> CompOp+notCompOp x = case x of+                CsEq  -> CsNeq+                CsNeq -> CsEq+                CsLt  -> CsEgt+                CsGt  -> CsElt+                CsElt -> CsGt+                CsEgt -> CsLt++instance Boolean CsBool where+    true    = CsTrue+    false   = CsFalse+    notB    = CsNot++    a &&* b = case (a, b) of+                (CsTrue,  _)  -> b+                (CsFalse, _)  -> CsFalse+                (_, CsTrue )  -> a+                (_, CsFalse)  -> CsFalse+                _             -> CsAnd a b++    a ||* b = case (a, b) of+                (CsTrue,  _)  -> CsTrue+                (CsFalse, _)  -> b+                (_, CsTrue )  -> CsTrue+                (_, CsFalse)  -> a+                _             -> CsOr a b+++------------------------------------------------------+-- nots elimination++data Ctx = N | P++elimNots :: Ctx -> CsBool -> CsBool+elimNots P x = +    case x of+        CsNot a   -> elimNots N a+        CsAnd a b -> CsAnd (elimNots P a) (elimNots P b)+        CsOr  a b -> CsOr  (elimNots P a) (elimNots P b)    +        _         -> x++elimNots N x =+    case x of+        CsBPrim (CsComp op a b) -> CsBPrim (CsComp (notCompOp op) a b)+        CsTrue                  -> CsFalse+        CsFalse                 -> CsTrue+        CsNot a                 -> elimNots P a+        CsAnd a b               -> CsOr  (elimNots N a) (elimNots N b)+        CsOr  a b               -> CsAnd (elimNots N a) (elimNots N b)++---------------------------------------------------++instance IfB CsBool CsTree where+    ifB cond a b = let cond' = elimNots P cond +                   in  case cond' of+                          CsTrue  -> a+                          CsFalse -> b+                          CsNot c -> ifB c b a+                          _       -> mkIf (getCondCsTree cond') a b+++getCondCsTree :: CsBool -> CsTree+getCondCsTree x = +    case x of+        CsBPrim a -> getCompCsTree a+        CsAnd a b -> mkAnd (getCondCsTree a) (getCondCsTree b)+        CsOr  a b -> mkOr  (getCondCsTree a) (getCondCsTree b)++getCompCsTree :: CsComp -> CsTree+getCompCsTree (CsComp op a b) = mkComp op a b+++bOp :: CompOp -> CsTree -> CsTree -> CsBool+bOp op a b = CsBPrim $ CsComp op a b+++instance EqB CsBool CsTree where+    (==*) = bOp CsEq+    (/=*) = bOp CsNeq+++instance OrdB CsBool CsTree where+    (<*)  = bOp CsLt+    (>*)  = bOp CsGt+    (<=*) = bOp CsElt+    (>=*) = bOp CsEgt

@@ -7,9 +7,9 @@   -- types      CsTree,       Rate(..), CsExpr(..),-     Value(..), OprType(..), Ftable(..), GEN(..), Name, Label,+     Value(..), Ftable(..), GEN(..), Name, Label,   -- constructors-     opc, oprPrefix, oprInfix,+     opc, opr,       int, double, string, ftable, param,      argIn, argOut,   -- predicates@@ -18,7 +18,7 @@      equalStructure, equalStructureByParams,    -- selectors      toFtable, ftableGENArgs, ftableSize, ftableGENId, getFtable, -     mapFtable, toDouble, opcName, oprName, oprType, paramId, value, +     mapFtable, toDouble, opcName, oprName, paramId, value,       argName, argRate     ) where@@ -44,20 +44,16 @@             | Param Id             | Arg Rate Name             | Opc Name-            | Opr Name OprType+            | Opr [Name]  		deriving (Show, Eq, Ord)   data Value = ValueInt Int            | ValueDouble Double            | ValueString String-	   | ValueFtable Ftable+	       | ValueFtable Ftable 		deriving (Show, Eq, Ord) -data OprType = Infix | Prefix-             deriving (Show, Eq, Ord)-- data Ftable = EmptyFtable             | Ftable Size GEN               deriving (Show, Eq, Ord)@@ -65,11 +61,6 @@ data GEN = GEN Id [CsTree]          deriving (Show, Eq, Ord) -----type Id   = Int---type Size = Int- type Name  = String type Label = Int @@ -116,11 +107,8 @@ opc :: Name -> CsExpr opc = Opc  -oprPrefix :: Name -> CsExpr-oprPrefix = flip Opr Prefix--oprInfix :: Name -> CsExpr-oprInfix = flip Opr Infix+opr :: [Name] -> CsExpr+opr = Opr  ------------------------------------------ -- CsTree Selectors@@ -157,15 +145,10 @@               (Opc x) -> x               _       -> error "expr is no Opc"  -oprName :: CsExpr -> Name+oprName :: CsExpr -> [Name] oprName x = case x of-              (Opr x _) -> x-              _         -> error "expr is no Opr" --oprType :: CsExpr -> OprType-oprType x = case x of-              (Opr _ x) -> x-              _         -> error "expr is no Opr" +              (Opr x) -> x+              _       -> error "expr is no Opr"    argName :: CsExpr -> Name@@ -224,8 +207,8 @@  isOpr :: CsExpr -> Bool isOpr x = case x of-            (Opr _  _) -> True-            _          -> False+            (Opr _) -> True+            _       -> False  isArg :: CsExpr -> Bool isArg x = case x of

@@ -2,7 +2,7 @@     CsoundFile(..),     Flags, Orchestra(..), Scores(..),     Value(..), Rate(..), ArgName(..), Param(..),-    Header(..), Instr(..), OpcodeExpr(..), ArgOut, ArgIn(..), OprType(..),+    Header(..), Instr(..), OpcodeExpr(..), ArgOut, ArgIn(..),      Ftable(..), FtableInits(..), GEN(..), TotalDuration(..), Note(..), NoteInits(..),     defTempo )@@ -53,12 +53,9 @@ data ArgIn = ArgInName ArgName            | ArgInParam Param            | ArgInValue Value-           | ArgInOpr Name OprType [ArgIn]+           | ArgInOpr [Name] [ArgIn]              deriving (Eq, Ord) -data OprType = Infix | Prefix-               deriving (Eq, Ord)- -- Scores subtypes data Ftable = Ftable Id FtableInits GEN @@ -253,23 +250,19 @@     show (ArgInParam x) = show x     show (ArgInValue x) = show x -- operators-    show (ArgInOpr op opType xs) = printOperator op opType xs---        if (Map.member op operators)---        then ---        else error "no such operator"-           -printOperator :: Name -> OprType -> [ArgIn] -> String-printOperator op desc args = -    case desc of-      Prefix -> show $ opStr <> (parens $ hcat $ argsStr)              -      Infix  -> show $ parens $ hcat $ punctuate space [arg1Str, opStr, arg2Str]-    where opStr   = text op-          argsStr = punctuate (comma <> space) $ map (text . show) args-          (arg1Str, arg2Str) = -              if length args == 1-              then (text "", parens $ text $ show $ head args)-              else (text $ show (args !! 0), text $ show (args !! 1))-                                      +    show (ArgInOpr op xs) = printOperator op xs+          +printOperator :: [Name] -> [ArgIn] -> String+printOperator op args = show $ hcat $ mergeLists opDoc argsDoc+    where argsDoc = map (text . show) args+          opDoc   = map text op++mergeLists :: [a] -> [a] -> [a]+mergeLists x x' = case (x, x') of+                    ([],      _) -> x'+                    (_ ,     []) -> x+                    (a:as, b:bs) -> a : b : mergeLists as bs+  ---------------------------------------------------- ----------------------------------------------------

@@ -15,7 +15,8 @@    SignalOut(..), outList, fromSignalOut,    Header, SignalInit(..),    Arate(..), Krate(..), Irate(..), X(..), K(..), MO(..),-   toValue, toCsRate, gRate, isArgOut, toOprType+   BoolRate(..), +   toValue, toCsRate, gRate, isArgOut  ) where @@ -26,6 +27,7 @@ import CsoundExpr.Translator.Cs.IM import qualified CsoundExpr.Translator.Cs.CsTree     as La import qualified CsoundExpr.Translator.Cs.CsoundFile as Cs+import CsoundExpr.Translator.Cs.CsBoolean   type Time = Double type Dur  = Time@@ -80,6 +82,10 @@ -- | init variable data Irate = Irate La.CsTree ++-- | boolean signal. Type for comparison of control or init rate signals.+data BoolRate = BoolRate CsBool+ -- rate classes  -- IM@@ -132,16 +138,16 @@ instance X Arate where 	arate = id 	krate = from . pure (La.opc "downsamp") . return . toCsTree-	irate = from . pure (La.oprPrefix "i")  . return . toCsTree . krate +	irate = from . pure (La.opr ["i(", ")"])  . return . toCsTree . krate   instance X Krate where 	arate = from . pure (La.opc "upsamp") . return . toCsTree 	krate = id-	irate = from . pure (La.oprPrefix "i") . return . toCsTree+	irate = from . pure (La.opr ["i(", ")"]) . return . toCsTree 	 instance X Irate where 	arate = from . pure (La.opc "upsamp")  . return . toCsTree-	krate = from . pure (La.oprPrefix "k") . return . toCsTree+	krate = from . pure (La.opr ["k(", ")"]) . return . toCsTree 	irate = id  toCsTree :: X a => a -> La.CsTree@@ -226,10 +232,4 @@             Cs.A -> Cs.GA             Cs.K -> Cs.GK             Cs.I -> Cs.GI--toOprType :: La.OprType -> Cs.OprType-toOprType x = case x of-                La.Infix  -> Cs.Infix-                La.Prefix -> Cs.Prefix- 

@@ -25,7 +25,7 @@     Signals are represented with trees. Tree contains information about how      signal was build.      -    There are four types for signals ("CsoundExpr.Base.Types").+    There are five types for signals ("CsoundExpr.Base.Types").      'Arate' is audio rate signal @@ -34,6 +34,8 @@     'Irate' is init value         'SignalOut' is no output at all (it's produced by opcodes like out, outs, xtratim) ++    'BoolRate' is comparision of two control or init rate signals           There are two classes to allow csound's polymorphism : 'X' and 'K'