module Sound.DF.Node where
import Control.Monad
import Data.Unique
data R_ID = R_ID Int
deriving (Eq)
data Type = Real_Type
| Integer_Type
| Boolean_Type
deriving (Eq, Show)
data Constant = Real_Constant Double
| Integer_Constant Int
deriving (Eq)
instance Show Constant where
show (Real_Constant x) = show x
show (Integer_Constant x) = show x
data Port = Port { port_data_type :: Type
, port_tokens :: Int }
deriving (Eq)
data Node = S { constant :: Constant }
| A { operator :: String
, inputs :: [Node]
, outputs :: [Port] }
| R { identifier :: R_ID
, input :: Either Constant (Node, Node) }
| P { proxy :: Node
, port :: Int }
| M { mleft :: Node
, mright :: Node }
deriving (Eq)
type NodeID = Int
type PortID = Int
mrg :: Node -> Node -> Node
mrg = M
instance Show Node where
show (S x) = show x
show (A p _ _) = p
show (R (R_ID d) (Left i)) = "rR_" ++ show d ++ ":" ++ show i
show (R (R_ID d) (Right _)) = "wR_" ++ show d
show (P _ p) = "proxy_" ++ show p
show (M l r) = "m(" ++ show l ++ "," ++ show r ++ ")"
constant_type :: Constant -> Type
constant_type (Real_Constant _) = Real_Type
constant_type (Integer_Constant _) = Integer_Type
node_type :: Node -> Type
node_type (S c) = constant_type c
node_type (A _ _ [Port t _]) = t
node_type (A _ _ _) = error "node_type: A: non unary output"
node_type (R _ (Left c)) = constant_type c
node_type (R _ (Right (n, _))) = node_type n
node_type (P n i) = port_data_type (outputs n !! i)
node_type (M l _) = node_type l
n_real_constant :: Double -> Node
n_real_constant = S . Real_Constant
n_integer_constant :: Int -> Node
n_integer_constant = S . Integer_Constant
numerical_unary_operator :: String -> Node -> Node
numerical_unary_operator s p = A s [p] [Port (node_type p) 1]
numerical_binary_operator :: String -> Node -> Node -> Node
numerical_binary_operator s p q =
let pt = node_type p
qt = node_type q
in if pt /= qt
then error (show ("binary operator", s, pt, qt, p, q))
else A s [p, q] [Port pt 1]
real_unary_operator :: String -> Node -> Node
real_unary_operator s p =
if node_type p == Real_Type
then A s [p] [Port Real_Type 1]
else error (show ("real unary operator", s, p))
real_binary_operator :: String -> Node -> Node -> Node
real_binary_operator s p q =
if node_type p == Real_Type && node_type q == Real_Type
then A s [p, q] [Port Real_Type 1]
else error (show ("real binary operator", s, p, q))
n_add :: Node -> Node -> Node
n_add = numerical_binary_operator "df_add"
n_mul :: Node -> Node -> Node
n_mul = numerical_binary_operator "df_mul"
n_sub :: Node -> Node -> Node
n_sub = numerical_binary_operator "df_sub"
n_negate :: Node -> Node
n_negate = numerical_unary_operator "df_negate"
n_abs :: Node -> Node
n_abs p | node_type p == Real_Type = A "df_fabs" [p] [Port Real_Type 1]
| node_type p == Integer_Type = A "df_iabs" [p] [Port Integer_Type 1]
| otherwise = error "n_abs"
n_signum :: Node -> Node
n_signum = numerical_unary_operator "df_signum"
instance Num Node where
(+) = n_add
(*) = n_mul
() = n_sub
negate = n_negate
abs = n_abs
signum = n_signum
fromInteger = n_integer_constant . fromInteger
n_div :: Node -> Node -> Node
n_div = real_binary_operator "df_div"
n_recip :: Node -> Node
n_recip = real_unary_operator "df_recip"
instance Fractional Node where
(/) = n_div
recip = n_recip
fromRational = n_real_constant . fromRational
n_exp :: Node -> Node
n_exp = real_unary_operator "df_exp"
n_sqrt :: Node -> Node
n_sqrt = real_unary_operator "df_sqrt"
n_log :: Node -> Node
n_log = real_unary_operator "df_log"
n_pow :: Node -> Node -> Node
n_pow = real_binary_operator "df_pow"
n_sin :: Node -> Node
n_sin = real_unary_operator "df_sin"
n_cos :: Node -> Node
n_cos = real_unary_operator "df_cos"
n_tan :: Node -> Node
n_tan = real_unary_operator "df_tan"
instance Floating Node where
pi = n_real_constant pi
exp = n_exp
sqrt = n_sqrt
log = n_log
(**) = n_pow
logBase = undefined
sin = n_sin
tan = n_tan
cos = n_cos
asin = undefined
atan = undefined
acos = undefined
sinh = undefined
tanh = undefined
cosh = undefined
asinh = undefined
atanh = undefined
acosh = undefined
numerical_comparison_operator :: String -> Node -> Node -> Node
numerical_comparison_operator s p q =
let pt = node_type p
qt = node_type q
in if pt == qt && (pt == Integer_Type || pt == Real_Type)
then A s [p, q] [Port Boolean_Type 1]
else error (show ("comparison operator", s, pt, qt, p, q))
n_lt :: Node -> Node -> Node
n_lt = numerical_comparison_operator "df_lt"
n_gte :: Node -> Node -> Node
n_gte = numerical_comparison_operator "df_gte"
n_gt :: Node -> Node -> Node
n_gt = numerical_comparison_operator "df_gt"
n_lte :: Node -> Node -> Node
n_lte = numerical_comparison_operator "df_lte"
n_max :: Node -> Node -> Node
n_max = numerical_binary_operator "df_max"
n_min :: Node -> Node -> Node
n_min = numerical_binary_operator "df_min"
instance Ord Node where
compare = undefined
(<) = undefined
(>=) = undefined
(>) = undefined
(<=) = undefined
max = n_max
min = n_min
n_floor :: Node -> Node
n_floor = real_unary_operator "df_floor"
n_lrint :: Node -> Node
n_lrint p
| node_type p == Real_Type = A "df_lrint" [p] [Port Integer_Type 1]
| otherwise = error "n_lrint"
class (Monad m) => ID m where
generateID :: m Int
instance ID IO where
generateID = liftM hashUnique newUnique
rec_r :: R_ID -> Constant -> (Node -> (Node, Node)) -> Node
rec_r n i f = R n (Right (f (R n (Left i))))
rec :: ID m => Constant -> (Node -> (Node, Node)) -> m Node
rec i f = do n <- generateID
return (rec_r (R_ID n) i f)
recm :: ID m => Constant -> (Node -> m (Node, Node)) -> m Node
recm i f =
do n <- generateID
let r_r = R (R_ID n) (Left i)
r <- f r_r
return (R (R_ID n) (Right r))