{-# Language FlexibleInstances,DeriveDataTypeable #-}
-- | Data flow nodes.
module Sound.DF.Uniform.PhT.Node where

import Data.Bits
import Data.Int
import Data.Typeable

import Sound.DF.Uniform.LL
import Sound.DF.Uniform.UDF

-- * Types

-- | Constant with phantom type.
data KT ty = KT {kt_k :: K} deriving (Eq)

-- | Data flow node with phantom type.
data DF ty = DF {df_udf :: UDF} deriving (Eq)

-- * Construct, destruct & predicate

-- | Lift 'Int32' to constant, ie. 'KT' of 'I'.
k_Int32 :: Int32 -> KT Int32
k_Int32 = KT . I

-- | Lift 'Float' to constant, ie. 'KT' of 'F'.
k_Float :: Float -> KT Float
k_Float = KT . F

-- | A zero with unresolved type, ie. 'KT' of 'F' of @0@.
k_zero :: KT ty
k_zero = KT (F 0)

-- | Lift 'Int32' to 'DF'.
df_Int32 :: Int32 -> DF Int32
df_Int32 = DF . UDF_K . I

-- | Lift 'Float' to 'DF'.
df_Float :: Float -> DF Float
df_Float = DF . UDF_K . F

-- | Tables have a guard point.
df_tbl_size :: DF a -> Maybe Int
df_tbl_size df =
    case df of
      DF (UDF_A (Vec _ k _)) -> Just (k - 1)
      _ -> Nothing

-- | Multiple root graph.
mrg :: DF a -> DF () -> DF a
mrg p q = DF (UDF_M (df_udf p) (df_udf q))

-- * Querying data type on ports

-- | 'typeOf' 'DF'.
df_type :: DF a -> TypeRep
df_type = udf_typeOf . df_udf

-- * Operator cons

-- | 'DF' of 'UDF_P'.
mk_a :: String -> [DF a] -> TypeRep -> DF ty
mk_a s i ty = DF (UDF_P s ty (map df_udf i))

-- | Primitive unary operator.
unary_operator :: String -> DF a -> DF a
unary_operator s p = mk_a s [p] (df_type p)

-- | Primitive binary operator.
binary_operator :: String -> DF a -> DF a -> DF a
binary_operator s p q = mk_a s [p,q] (df_type p)

-- | Primitive comparator.
comparison_operator :: String -> DF a -> DF a -> DF Bool
comparison_operator s p q = mk_a s [p,q] bool_t

-- | Primitive sink.
sink_node :: String -> [DF a] -> DF ()
sink_node s ps = mk_a s ps nil_t

-- | Primitive unary operator with separate primitives for integral
-- and floating types.
alt_unary_operator :: (String,String) -> DF a -> DF a
alt_unary_operator (nm_i,nm_f) n =
    let ty = df_type n
    in if ty == int32_t
       then mk_a nm_i [n] int32_t
       else if ty == float_t
            then mk_a nm_f [n] float_t
            else error "alt_unary_operator"

-- | Lift list of float to 'DF' 'Vec'.
df_vec_m :: UId m => [Float] -> m (DF (Vec Float))
df_vec_m v = do
  k <- generateId
  return (DF (UDF_A (Vec (V_Id k) (length v) v)))

instance Num n => Num (DF n) where
    (+) = binary_operator "df_add"
    (*) = binary_operator "df_mul"
    (-) = binary_operator "df_sub"
    negate = unary_operator "df_negate"
    abs = alt_unary_operator ("df_labs","df_fabsf")
    signum = unary_operator "df_signum"
    fromInteger = DF . UDF_K . I . fromInteger

instance Fractional (DF Float) where
    (/) = binary_operator "df_div"
    recip = unary_operator "df_recip"
    fromRational = DF . UDF_K . F . fromRational

instance Floating (DF Float) where
  pi = DF (UDF_K (F pi))
  exp = unary_operator "df_exp"
  sqrt = unary_operator "df_sqrt"
  log = unary_operator "df_log"
  (**) = binary_operator "df_pow"
  logBase = undefined
  sin = unary_operator "df_sin"
  tan = unary_operator "df_tan"
  cos = unary_operator "df_cos"
  asin = undefined
  atan = undefined
  acos = undefined
  sinh = undefined
  tanh = undefined
  cosh = undefined
  asinh = undefined
  atanh = undefined
  acosh = undefined

instance Eq a => Bits (DF a) where
    (.&.) = binary_operator "df_and"
    (.|.) = binary_operator "df_or"
    xor = undefined
    complement = undefined
    bit = undefined
    testBit = undefined
    bitSize = undefined
    isSigned = undefined
    popCount = undefined

-- * Ord

-- | '==', equal to.
df_eq :: DF a -> DF a -> DF Bool
df_eq = comparison_operator "df_eq"

-- | '<', less than.
df_lt :: Num a => DF a -> DF a -> DF Bool
df_lt = comparison_operator "df_lt"

-- | '>=', greater than or equal to.
df_gte :: Num a => DF a -> DF a -> DF Bool
df_gte = comparison_operator "df_gte"

-- | '>', greater than.
df_gt :: Num a => DF a -> DF a -> DF Bool
df_gt = comparison_operator "df_gt"

-- | '<=', less than or equal to.
n_lte :: Num a => DF a -> DF a -> DF Bool
n_lte = comparison_operator "df_lte"

instance Eq a => Ord (DF a) where
  compare = undefined
  (<) = undefined
  (>=) = undefined
  (>) = undefined
  (<=) = undefined
  max = binary_operator "df_max"
  min = binary_operator "df_min"

-- * RealFrac

-- | ceilf(3)
df_ceilingf :: DF Float -> DF Float
df_ceilingf = unary_operator "df_ceilf"

-- | floorf(3)
df_floorf :: DF Float -> DF Float
df_floorf = unary_operator "df_floorf"

-- | lrintf(3)
df_lrintf :: DF Float -> DF Int32
df_lrintf p = mk_a "df_lrintf" [p] int32_t

-- | roundf(3)
df_roundf :: DF Float -> DF Float
df_roundf = unary_operator "df_roundf"

-- * Primitives

-- | Single channel output.
out1 :: DF Float -> DF ()
out1 p = sink_node "df_out1" [p]

-- | Two channel output.
out2 :: DF Float -> DF Float -> DF ()
out2 p q = sink_node "df_out2" [p,q]

-- | Three channel output.
out3 :: DF Float -> DF Float -> DF Float -> DF ()
out3 p q r = sink_node "df_out3" [p,q,r]

-- | Single control input.
ctl1 :: DF Int32 -> DF Float
ctl1 p = mk_a "df_ctl1" [p] float_t

-- | If /p/ then /q/ else /r/.  /p/ must have type bool, and /q/
-- and /r/ must have equal types.
select2 :: DF Bool -> DF a -> DF a -> DF a
select2 p q r = DF (UDF_P "df_select2" (df_type q) [df_udf p,df_udf q,df_udf r])

-- | Operating sample rate.
w_sample_rate :: DF Float
w_sample_rate = mk_a "df_sample_rate" [] float_t

-- | Buffer read, read from buffer /p/ at index /q/.
b_read :: DF Int32 -> DF Int32 -> DF Float
b_read p q = mk_a "df_b_read" [p,q] float_t

-- | Buffer write, write to buffer /p/ at index /q/ value /r/.
b_write :: DF Int32 -> DF Int32 -> DF Float -> DF ()
b_write p q r = DF (UDF_P "df_b_write" nil_t [df_udf p,df_udf q,df_udf r])

-- | Array read.
a_read :: DF (Vec Float)-> DF Int32 -> DF Float
a_read p q = DF (UDF_P "df_a_read" float_t [df_udf p,df_udf q])

-- | Array write.
a_write :: DF (Vec Float) -> DF Int32 -> DF Float -> DF ()
a_write p q r = DF (UDF_P "df_a_write" nil_t [df_udf p,df_udf q,df_udf r])

-- * Backward arcs

-- | Introduce backward arc with implicit unit delay.
rec_r :: R_Id -> KT a -> (DF a -> (DF a,DF a)) -> DF a
rec_r n i f =
    let (p,q) = f (DF (UDF_R n (Left (kt_k i))))
    in DF (UDF_R n (Right (df_udf p,df_udf q)))

-- | Monadic variant of rec_r.
rec :: UId m => KT a -> (DF a -> (DF a,DF a)) -> m (DF a)
rec i f = do
  n <- generateId
  return (rec_r (R_Id n) i f)

-- | Variant or rec with monadic action in backward arc.
recm :: UId m => KT a -> (DF a -> m (DF a,DF a)) -> m (DF a)
recm i f = do
  n <- generateId
  let r_r = DF (UDF_R (R_Id n) (Left (kt_k i)))
  (p,q) <- f r_r
  return (DF (UDF_R (R_Id n) (Right (df_udf p,df_udf q))))