module Sound.SC3.UGen.UGen where
import Control.Monad
import qualified Data.Char as C
import qualified Data.HashTable as H
import Data.List
import Sound.SC3.UGen.Operator
import Sound.SC3.UGen.Rate
import Sound.SC3.UGen.UId
import System.Random
class ID a where
resolveID :: a -> Int
instance ID Int where
resolveID = id
instance ID Char where
resolveID = C.ord
instance ID UGen where
resolveID = hashUGen
data UGen = Constant { constantValue :: Double }
| Control { controlOperatingRate :: Rate
, controlName :: String
, controlDefault :: Double
, controlTriggered :: Bool }
| Primitive { ugenRate :: Rate
, ugenName :: String
, ugenInputs :: [UGen]
, ugenOutputs :: [Output]
, ugenSpecial :: Special
, ugenId :: Int }
| Proxy { proxySource :: UGen
, proxyIndex :: Int }
| MCE { mceProxies :: [UGen] }
| MRG { mrgLeft :: UGen
, mrgRight :: UGen }
deriving (Eq, Show)
type Output = Rate
newtype Special = Special Int
deriving (Eq, Show)
defaultID :: Int
defaultID = (1)
hashUGen :: UGen -> Int
hashUGen = fromIntegral . H.hashString . show
constant :: (Real a) => a -> UGen
constant = Constant . realToFrac
control :: Rate -> String -> Double -> UGen
control r n d = Control r n d False
tr_control :: String -> Double -> UGen
tr_control n d = Control KR n d True
mce :: [UGen] -> UGen
mce [] = error "mce: empty list"
mce xs = MCE xs
mrg2 :: UGen -> UGen -> UGen
mrg2 = MRG
proxy :: UGen -> Int -> UGen
proxy = Proxy
isConstant :: UGen -> Bool
isConstant (Constant _) = True
isConstant _ = False
isControl :: UGen -> Bool
isControl (Control _ _ _ _) = True
isControl _ = False
isUGen :: UGen -> Bool
isUGen (Primitive _ _ _ _ _ _) = True
isUGen _ = False
isProxy :: UGen -> Bool
isProxy (Proxy _ _) = True
isProxy _ = False
isMCE :: UGen -> Bool
isMCE (MCE _) = True
isMCE _ = False
isMRG :: UGen -> Bool
isMRG (MRG _ _) = True
isMRG _ = False
mce2 :: UGen -> UGen -> UGen
mce2 x y = mce [x, y]
clone :: (UId m) => Int -> m UGen -> m UGen
clone n = liftM mce . replicateM n
mceDegree :: UGen -> Int
mceDegree (MCE l) = length l
mceDegree (MRG u _) = mceDegree u
mceDegree _ = error "mceDegree: illegal ugen"
mceExtend :: Int -> UGen -> [UGen]
mceExtend n (MCE l) = take n (cycle l)
mceExtend n (MRG x y) =
let (r:rs) = mceExtend n x
in MRG r y : rs
mceExtend n u = replicate n u
mceTransform :: UGen -> UGen
mceTransform (Primitive r n i o s d) =
let f j = Primitive r n j o s d
upr = maximum (map mceDegree (filter isMCE i))
i' = transpose (map (mceExtend upr) i)
in MCE (map f i')
mceTransform _ = error "mceTransform: illegal ugen"
mceExpand :: UGen -> UGen
mceExpand (MCE l) = MCE (map mceExpand l)
mceExpand (MRG x y) = MRG (mceExpand x) y
mceExpand u =
let required (Primitive _ _ i _ _ _) = not (null (filter isMCE i))
required _ = False
in if required u
then mceExpand (mceTransform u)
else u
mceMap :: (UGen -> UGen) -> UGen -> UGen
mceMap f u = mce (map f (mceChannels u))
mceEdit :: ([UGen] -> [UGen]) -> UGen -> UGen
mceEdit f (MCE l) = MCE (f l)
mceEdit _ _ = error "mceEdit: non MCE value"
mceReverse :: UGen -> UGen
mceReverse = mceEdit reverse
mceChannel :: Int -> UGen -> UGen
mceChannel n (MCE l) = l !! n
mceChannel _ _ = error "mceChannel: non MCE value"
mceChannels :: UGen -> [UGen]
mceChannels (MCE l) = l
mceChannels (MRG x y) = let (r:rs) = mceChannels x in MRG r y : rs
mceChannels u = [u]
mceTranspose :: UGen -> UGen
mceTranspose =
mce . map mce . transpose . map mceChannels . mceChannels
mceSum :: UGen -> UGen
mceSum = sum . mceChannels
mrg :: [UGen] -> UGen
mrg [] = undefined
mrg [x] = x
mrg (x:xs) = MRG x (mrg xs)
proxify :: UGen -> UGen
proxify u
| isMCE u = mce (map proxify (mceProxies u))
| isMRG u = mrg [proxify (mrgLeft u), mrgRight u]
| isUGen u =
let o = ugenOutputs u
in case o of
(_:_:_) -> mce (map (proxy u) [0..(length o 1)])
_ -> u
| otherwise = error "proxify: illegal ugen"
rateOf :: UGen -> Rate
rateOf u
| isConstant u = IR
| isControl u = controlOperatingRate u
| isUGen u = ugenRate u
| isProxy u = rateOf (proxySource u)
| isMCE u = maximum (map rateOf (mceProxies u))
| isMRG u = rateOf (mrgLeft u)
| otherwise = undefined
is_sink :: UGen -> Bool
is_sink u
| isUGen u = null (ugenOutputs u)
| isMCE u = all is_sink (mceProxies u)
| isMRG u = is_sink (mrgLeft u)
| otherwise = False
check_input :: UGen -> UGen
check_input u = if is_sink u
then error ("illegal input: " ++ show u)
else u
mkUGen :: (ID a) =>
Rate -> String -> [UGen] -> [Output] -> Special -> a -> UGen
mkUGen r n i o s z =
let u = Primitive r n (map check_input i) o s (resolveID z)
in proxify (mceExpand u)
mkOperator :: String -> [UGen] -> Int -> UGen
mkOperator c i s =
let r = maximum (map rateOf i)
in mkUGen r c i [r] (Special s) defaultID
mkUnaryOperator :: Unary -> (Double -> Double) -> UGen -> UGen
mkUnaryOperator i f a
| isConstant a = constant (f (constantValue a))
| otherwise = mkOperator "UnaryOpUGen" [a] (fromEnum i)
mkBinaryOperator :: Binary -> (Double -> Double -> Double) ->
UGen -> UGen -> UGen
mkBinaryOperator i f a b =
if isConstant a && isConstant b
then let a' = constantValue a
b' = constantValue b
in constant (f a' b')
else mkOperator "BinaryOpUGen" [a, b] (fromEnum i)
mk_osc :: (ID a) =>
[Rate] -> a ->
Rate -> String -> [UGen] -> Int -> UGen
mk_osc rs z r c i o =
if r `elem` rs
then mkUGen r c i (replicate o r) (Special 0) z
else error ("mk_osc: rate restricted: " ++ show (r, rs, c))
mkOsc :: Rate -> String -> [UGen] -> Int -> UGen
mkOsc = mk_osc [minBound .. maxBound] defaultID
mkOscR :: [Rate] -> Rate -> String -> [UGen] -> Int -> UGen
mkOscR rs = mk_osc rs defaultID
mkOscId :: (ID a) =>
a -> Rate -> String -> [UGen] -> Int -> UGen
mkOscId = mk_osc [minBound .. maxBound]
mk_osc_mce :: (ID a) =>
a -> Rate -> String -> [UGen] -> UGen -> Int -> UGen
mk_osc_mce z r c i j =
let i' = i ++ mceChannels j
in mk_osc [minBound .. maxBound] z r c i'
mkOscMCE :: Rate -> String -> [UGen] -> UGen -> Int -> UGen
mkOscMCE = mk_osc_mce defaultID
mkOscMCEId :: (ID a) =>
a -> Rate -> String -> [UGen] -> UGen -> Int -> UGen
mkOscMCEId = mk_osc_mce
mk_filter :: (ID a) =>
[Rate] -> a -> String -> [UGen] -> Int -> UGen
mk_filter rs z c i o =
let r = maximum (map rateOf i)
o'= replicate o r
in if r `elem` rs
then mkUGen r c i o' (Special 0) z
else error ("mk_filter: rate restriceted: " ++ show (r, rs, c))
all_rates :: [Rate]
all_rates = [minBound .. maxBound]
mkFilter :: String -> [UGen] -> Int -> UGen
mkFilter = mk_filter all_rates defaultID
mkFilterR :: [Rate] -> String -> [UGen] -> Int -> UGen
mkFilterR rs = mk_filter rs defaultID
mkFilterId :: (ID a) => a -> String -> [UGen] -> Int -> UGen
mkFilterId = mk_filter all_rates
mkFilterKeyed :: String -> Int -> [UGen] -> Int -> UGen
mkFilterKeyed c k i o =
let r = rateOf (i !! k)
o' = replicate o r
in mkUGen r c i o' (Special 0) defaultID
mk_filter_mce :: (ID a) => [Rate] -> a ->
String -> [UGen] -> UGen -> Int -> UGen
mk_filter_mce rs z c i j = mk_filter rs z c (i ++ mceChannels j)
mkFilterMCER :: [Rate] -> String -> [UGen] -> UGen -> Int -> UGen
mkFilterMCER rs = mk_filter_mce rs defaultID
mkFilterMCE :: String -> [UGen] -> UGen -> Int -> UGen
mkFilterMCE = mk_filter_mce all_rates defaultID
mkFilterMCEId :: (ID a) =>
a -> String -> [UGen] -> UGen -> Int -> UGen
mkFilterMCEId = mk_filter_mce all_rates
mkInfo :: String -> UGen
mkInfo name = mkOsc IR name [] 1
instance Num UGen where
negate = mkUnaryOperator Neg negate
(+) = mkBinaryOperator Add (+)
() = mkBinaryOperator Sub ()
(*) = mkBinaryOperator Mul (*)
abs = mkUnaryOperator Abs abs
signum = mkUnaryOperator Sign signum
fromInteger = Constant . fromInteger
instance Fractional UGen where
recip = mkUnaryOperator Recip recip
(/) = mkBinaryOperator FDiv (/)
fromRational = Constant . fromRational
instance Floating UGen where
pi = Constant pi
exp = mkUnaryOperator Exp exp
log = mkUnaryOperator Log log
sqrt = mkUnaryOperator Sqrt sqrt
(**) = mkBinaryOperator Pow (**)
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*x1) + x)
atanh x = (log (1+x) log (1x)) / 2
instance Real UGen where
toRational (Constant n) = toRational n
toRational _ = error "toRational at non-constant UGen"
instance Integral UGen where
quot = mkBinaryOperator IDiv undefined
rem = mkBinaryOperator Mod undefined
quotRem a b = (quot a b, rem a b)
div = mkBinaryOperator IDiv undefined
mod = mkBinaryOperator Mod undefined
toInteger (Constant n) = floor n
toInteger _ = error "toInteger at non-constant UGen"
instance Ord UGen where
(Constant a) < (Constant b) = a < b
_ < _ = error "< at UGen is partial, see <*"
(Constant a) <= (Constant b) = a <= b
_ <= _ = error "<= at UGen is partial, see <=*"
(Constant a) > (Constant b) = a < b
_ > _ = error "> at UGen is partial, see >*"
(Constant a) >= (Constant b) = a >= b
_ >= _ = error ">= at UGen is partial, see >=*"
min = mkBinaryOperator Min min
max = mkBinaryOperator Max max
instance Enum UGen where
succ u = u + 1
pred u = u 1
toEnum = constant
fromEnum (Constant n) = truncate n
fromEnum _ = error "cannot enumerate non-constant UGens"
enumFrom = iterate (+1)
enumFromThen n m = iterate (+(mn)) 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 l, Constant r) g =
let (n, g') = randomR (l,r) g
in (Constant n, g')
randomR _ _ = error "randomR: non constant (l,r)"
random = randomR (1.0, 1.0)