module Sound.SC3.UGen.Type where
import Data.Bits
import Data.List
import Data.Maybe
import Safe
import System.Random
import Sound.SC3.Common.Math
import Sound.SC3.UGen.MCE
import Sound.SC3.UGen.Operator
import Sound.SC3.UGen.Rate
type UID_t = Int
data UGenId = NoId | UId UID_t
deriving (Eq,Read,Show)
no_id :: UGenId
no_id = NoId
type Sample = Double
data Constant = Constant {constantValue :: Sample}
deriving (Eq,Ord,Read,Show)
data C_Meta n =
C_Meta {ctl_min :: n
,ctl_max :: n
,ctl_warp :: String
,ctl_step :: n
,ctl_units :: String
}
deriving (Eq,Read,Show)
type C_Meta_T5 n = (n,n,String,n,String)
c_meta_t5 :: (n -> m) -> C_Meta_T5 n -> C_Meta m
c_meta_t5 f (l,r,w,stp,u) = C_Meta (f l) (f r) w (f stp) u
data Control = Control {controlOperatingRate :: Rate
,controlIndex :: Maybe Int
,controlName :: String
,controlDefault :: Sample
,controlTriggered :: Bool
,controlMeta :: Maybe (C_Meta Sample)}
deriving (Eq,Read,Show)
data Label = Label {ugenLabel :: String}
deriving (Eq,Read,Show)
type Output = Rate
newtype Special = Special Int
deriving (Eq,Read,Show)
data Primitive = Primitive {ugenRate :: Rate
,ugenName :: String
,ugenInputs :: [UGen]
,ugenOutputs :: [Output]
,ugenSpecial :: Special
,ugenId :: UGenId}
deriving (Eq,Read,Show)
data Proxy = Proxy {proxySource :: Primitive
,proxyIndex :: Int}
deriving (Eq,Read,Show)
data MRG = MRG {mrgLeft :: UGen
,mrgRight :: UGen}
deriving (Eq,Read,Show)
data UGen = Constant_U Constant
| Control_U Control
| Label_U Label
| Primitive_U Primitive
| Proxy_U Proxy
| MCE_U (MCE UGen)
| MRG_U MRG
deriving (Eq,Read,Show)
parse_constant :: String -> Maybe UGen
parse_constant = fmap constant . parse_double
un_constant :: UGen -> Maybe Constant
un_constant u =
case u of
Constant_U c -> Just c
_ -> Nothing
u_constant :: UGen -> Maybe Sample
u_constant = fmap constantValue . un_constant
u_constant_err :: UGen -> Sample
u_constant_err = fromMaybe (error "u_constant") . u_constant
mrg :: [UGen] -> UGen
mrg u =
case u of
[] -> error "mrg: []"
[x] -> x
(x:xs) -> MRG_U (MRG x (mrg xs))
mrg_leftmost :: UGen -> UGen
mrg_leftmost u =
case u of
MRG_U m -> mrg_leftmost (mrgLeft m)
_ -> u
isConstant :: UGen -> Bool
isConstant = isJust . un_constant
isSink :: UGen -> Bool
isSink u =
case mrg_leftmost u of
Primitive_U p -> null (ugenOutputs p)
MCE_U m -> all isSink (mce_elem m)
_ -> False
un_proxy :: UGen -> Maybe Proxy
un_proxy u =
case u of
Proxy_U p -> Just p
_ -> Nothing
isProxy :: UGen -> Bool
isProxy = isJust . un_proxy
mce :: [UGen] -> UGen
mce xs =
case xs of
[] -> error "mce: []"
[x] -> x
_ -> MCE_U (MCE_Vector xs)
mceProxies :: MCE UGen -> [UGen]
mceProxies = mce_elem
isMCE :: UGen -> Bool
isMCE u =
case mrg_leftmost u of
MCE_U _ -> True
_ -> False
mceChannels :: UGen -> [UGen]
mceChannels u =
case u of
MCE_U m -> mce_elem m
MRG_U (MRG x y) -> let r:rs = mceChannels x in MRG_U (MRG r y) : rs
_ -> [u]
mceDegree :: UGen -> Maybe Int
mceDegree u =
case mrg_leftmost u of
MCE_U m -> Just (length (mceProxies m))
_ -> Nothing
mceDegree_err :: UGen -> Int
mceDegree_err = fromMaybe (error "mceDegree: not mce") . mceDegree
mceExtend :: Int -> UGen -> [UGen]
mceExtend n u =
case u of
MCE_U m -> mceProxies (mce_extend n m)
MRG_U (MRG x y) -> let (r:rs) = mceExtend n x
in MRG_U (MRG r y) : rs
_ -> replicate n u
mceInputTransform :: [UGen] -> Maybe [[UGen]]
mceInputTransform i =
if any isMCE i
then let n = maximum (map mceDegree_err (filter isMCE i))
in Just (transpose (map (mceExtend n) i))
else Nothing
mceBuild :: ([UGen] -> UGen) -> [UGen] -> UGen
mceBuild f i =
case mceInputTransform i of
Nothing -> f i
Just i' -> MCE_U (MCE_Vector (map (mceBuild f) i'))
mce_is_direct_proxy :: MCE UGen -> Bool
mce_is_direct_proxy m =
case m of
MCE_Unit _ -> False
MCE_Vector v ->
let p = map un_proxy v
p' = catMaybes p
in all isJust p &&
length (nub (map proxySource p')) == 1 &&
map proxyIndex p' `isPrefixOf` [0..]
checkInput :: UGen -> UGen
checkInput u =
if isSink u
then error ("checkInput: " ++ show u)
else u
constant :: Real n => n -> UGen
constant = Constant_U . Constant . realToFrac
int_to_ugen :: Int -> UGen
int_to_ugen = constant
float_to_ugen :: Float -> UGen
float_to_ugen = constant
double_to_ugen :: Double -> UGen
double_to_ugen = constant
proxy :: UGen -> Int -> UGen
proxy u n =
case u of
Primitive_U p -> Proxy_U (Proxy p n)
_ -> error "proxy: not primitive?"
rateOf :: UGen -> Rate
rateOf u =
case u of
Constant_U _ -> IR
Control_U c -> controlOperatingRate c
Label_U _ -> IR
Primitive_U p -> ugenRate p
Proxy_U p -> ugenRate (proxySource p)
MCE_U _ -> maximum (map rateOf (mceChannels u))
MRG_U m -> rateOf (mrgLeft m)
proxify :: UGen -> UGen
proxify u =
case u of
MCE_U m -> mce (map proxify (mce_elem m))
MRG_U m -> mrg [proxify (mrgLeft m), mrgRight m]
Primitive_U p ->
let o = ugenOutputs p
in case o of
_:_:_ -> mce (map (proxy u) [0..(length o - 1)])
_ -> u
Constant_U _ -> u
_ -> error "proxify: illegal ugen"
mkUGen :: Maybe ([Sample] -> Sample) -> [Rate] -> Either Rate [Int] ->
String -> [UGen] -> Maybe [UGen] -> Int -> Special -> UGenId -> UGen
mkUGen cf rs r nm i i_mce o s z =
let i' = maybe i ((i ++) . concatMap mceChannels) i_mce
f h = let r' = either id (maximum . map (rateOf . atNote ("mkUGen: " ++ nm) h)) r
o' = replicate o r'
u = Primitive_U (Primitive r' nm h o' s z)
in if r' `elem` rs
then case cf of
Just cf' ->
if all isConstant h
then constant (cf' (mapMaybe u_constant h))
else u
Nothing -> u
else error ("mkUGen: rate restricted: " ++ show (r,rs,nm))
in proxify (mceBuild f (map checkInput i'))
mkOperator :: ([Sample] -> Sample) -> String -> [UGen] -> Int -> UGen
mkOperator f c i s =
let ix = [0 .. length i - 1]
in mkUGen (Just f) all_rates (Right ix) c i Nothing 1 (Special s) NoId
mkUnaryOperator :: Unary -> (Sample -> Sample) -> UGen -> UGen
mkUnaryOperator i f a =
let g [x] = f x
g _ = error "mkUnaryOperator: non unary input"
in mkOperator g "UnaryOpUGen" [a] (fromEnum i)
mkBinaryOperator_optimize_constants :: Binary -> (Sample -> Sample -> Sample) ->
(Either Sample Sample -> Bool) ->
UGen -> UGen -> UGen
mkBinaryOperator_optimize_constants i f o a b =
let g [x,y] = f x y
g _ = error "mkBinaryOperator: non binary input"
r = case (a,b) of
(Constant_U (Constant a'),_) ->
if o (Left a') then Just b else Nothing
(_,Constant_U (Constant b')) ->
if o (Right b') then Just a else Nothing
_ -> Nothing
in fromMaybe (mkOperator g "BinaryOpUGen" [a, b] (fromEnum i)) r
mkBinaryOperator :: Binary -> (Sample -> Sample -> Sample) -> UGen -> UGen -> UGen
mkBinaryOperator i f a b =
let g [x,y] = f x y
g _ = error "mkBinaryOperator: non binary input"
in mkOperator g "BinaryOpUGen" [a, b] (fromEnum i)
mul_add_optimise_direct :: UGen -> UGen
mul_add_optimise_direct u =
case u of
Primitive_U
(Primitive r _ [Primitive_U (Primitive _ "BinaryOpUGen" [i,j] [_] (Special 2) NoId),k] [_] _ NoId) ->
Primitive_U (Primitive r "MulAdd" [i,j,k] [r] (Special 0) NoId)
Primitive_U
(Primitive r _ [k,Primitive_U (Primitive _ "BinaryOpUGen" [i,j] [_] (Special 2) NoId)] [_] _ NoId) ->
Primitive_U (Primitive r "MulAdd" [i,j,k] [r] (Special 0) NoId)
_ -> u
sum3_optimise_direct :: UGen -> UGen
sum3_optimise_direct u =
case u of
Primitive_U
(Primitive r _ [Primitive_U (Primitive _ "BinaryOpUGen" [i,j] [_] (Special 0) NoId),k] [_] _ NoId) ->
Primitive_U (Primitive r "Sum3" [i,j,k] [r] (Special 0) NoId)
Primitive_U
(Primitive r _ [k,Primitive_U (Primitive _ "BinaryOpUGen" [i,j] [_] (Special 0) NoId)] [_] _ NoId) ->
Primitive_U (Primitive r "Sum3" [i,j,k] [r] (Special 0) NoId)
_ -> u
add_optimise_direct :: UGen -> UGen
add_optimise_direct = sum3_optimise_direct . mul_add_optimise_direct
instance Num UGen where
negate = mkUnaryOperator Neg negate
(+) = fmap add_optimise_direct .
mkBinaryOperator_optimize_constants Add (+) (`elem` [Left 0,Right 0])
(-) = mkBinaryOperator_optimize_constants Sub (-) (Right 0 ==)
(*) = mkBinaryOperator_optimize_constants Mul (*) (`elem` [Left 1,Right 1])
abs = mkUnaryOperator Abs abs
signum = mkUnaryOperator Sign signum
fromInteger = Constant_U . Constant . fromInteger
instance Fractional UGen where
recip = mkUnaryOperator Recip recip
(/) = mkBinaryOperator_optimize_constants FDiv (/) (Right 1 ==)
fromRational = Constant_U . Constant . fromRational
instance Floating UGen where
pi = Constant_U (Constant pi)
exp = mkUnaryOperator Exp exp
log = mkUnaryOperator Log log
sqrt = mkUnaryOperator Sqrt sqrt
(**) = mkBinaryOperator_optimize_constants Pow (**) (Right 1 ==)
logBase a b = log b / log a
sin = mkUnaryOperator Sin sin
cos = mkUnaryOperator Cos cos
tan = mkUnaryOperator Tan tan
asin = mkUnaryOperator ArcSin asin
acos = mkUnaryOperator ArcCos acos
atan = mkUnaryOperator ArcTan atan
sinh = mkUnaryOperator SinH sinh
cosh = mkUnaryOperator CosH cosh
tanh = mkUnaryOperator TanH tanh
asinh x = log (sqrt (x*x+1) + x)
acosh x = log (sqrt (x*x-1) + x)
atanh x = (log (1+x) - log (1-x)) / 2
instance Real UGen where
toRational (Constant_U (Constant n)) = toRational n
toRational _ = error "UGen.toRational: non-constant"
instance Integral UGen where
quot = mkBinaryOperator IDiv (error "UGen.quot")
rem = mkBinaryOperator Mod (error "UGen.rem")
quotRem a b = (quot a b, rem a b)
div = mkBinaryOperator IDiv (error "UGen.div")
mod = mkBinaryOperator Mod (error "UGen.mod")
toInteger (Constant_U (Constant n)) = floor n
toInteger _ = error "UGen.toInteger: non-constant"
instance RealFrac UGen where
properFraction = error "UGen.properFraction, see properFractionE"
round = error "UGen.round, see roundE"
ceiling = error "UGen.ceiling, see ceilingE"
floor = error "UGen.floor, see floorE"
instance Ord UGen where
(Constant_U a) < (Constant_U b) = a < b
_ < _ = error "UGen.<, see <*"
(Constant_U a) <= (Constant_U b) = a <= b
_ <= _ = error "UGen.<= at, see <=*"
(Constant_U a) > (Constant_U b) = a > b
_ > _ = error "UGen.>, see >*"
(Constant_U a) >= (Constant_U b) = a >= b
_ >= _ = error "UGen.>=, see >=*"
min = mkBinaryOperator Min min
max = mkBinaryOperator Max max
instance Enum UGen where
succ u = u + 1
pred u = u - 1
toEnum n = Constant_U (Constant (fromIntegral n))
fromEnum (Constant_U (Constant n)) = truncate n
fromEnum _ = error "UGen.fromEnum: non-constant"
enumFrom = iterate (+1)
enumFromThen n m = iterate (+(m-n)) n
enumFromTo n m = takeWhile (<= m+1/2) (enumFrom n)
enumFromThenTo n n' m =
let p = if n' >= n then (>=) else (<=)
in takeWhile (p (m + (n'-n)/2)) (enumFromThen n n')
instance Random UGen where
randomR (Constant_U (Constant l),Constant_U (Constant r)) g =
let (n, g') = randomR (l,r) g
in (Constant_U (Constant n), g')
randomR _ _ = error "UGen.randomR: non constant (l,r)"
random = randomR (-1.0, 1.0)
instance Bits UGen where
(.&.) = mkBinaryOperator BitAnd undefined
(.|.) = mkBinaryOperator BitOr undefined
xor = mkBinaryOperator BitXor undefined
complement = mkUnaryOperator BitNot undefined
shift = error "UGen.shift"
rotate = error "UGen.rotate"
bitSize = error "UGen.bitSize"
bit = error "UGen.bit"
testBit = error "UGen.testBit"
popCount = error "UGen.popCount"
bitSizeMaybe = error "UGen.bitSizeMaybe"
isSigned _ = True