Mce.hs

-- | The Sc3 multiple channel expansion (Mce) rules over an abstract type.
module Sound.Sc3.Common.Mce where

import qualified Sound.Sc3.Common.Base {- hsc3 -}

{- | Multiple channel expansion.
The Mce type is a tree, however in hsc3 Mce_Vector will always hold Mce_Scalar elements.
-}
data Mce t = Mce_Scalar t | Mce_Vector [Mce t]
  deriving (Ord, Eq, Read, Show)

{- | There are two invariants:
1. Mce should not be empty, ie. Mce_Vector should not have a null list.
2. Scalar Mce values should not be written as one-place vectors.

>>> mce_is_well_formed (Mce_Vector [])
False

>>> mce_is_well_formed (Mce_Vector [Mce_Scalar 1])
False
-}
mce_is_well_formed :: Mce t -> Bool
mce_is_well_formed m =
  case m of
    Mce_Scalar _ -> True
    Mce_Vector v -> length v > 1 && all mce_is_well_formed v

-- | Is Mce scalar.
mce_is_scalar :: Mce t -> Bool
mce_is_scalar m =
  case m of
    Mce_Scalar _ -> True
    _ -> False

-- | fromList for Mce, generates well-formed Mce.
mce_from_list :: [t] -> Mce t
mce_from_list l =
  case l of
    [] -> error "mce_from_list: null?"
    [e] -> Mce_Scalar e
    _ -> Mce_Vector (map Mce_Scalar l)

{- | toList for Mce.

>>> let v = Mce_Vector
>>> mce_to_list (v[v[1, 2], 3, v[4, 5]])
[1,2,3,4,5]
-}
mce_to_list :: Mce t -> [t]
mce_to_list m =
  case m of
    Mce_Scalar e -> [e]
    Mce_Vector e -> concatMap mce_to_list e

{- | Pretty printer for Mce.

>>> let v = Mce_Vector
>>> mce_show (v[1, 2, v[3, 4]] * 5 + v[6, 7, 8])
"[11, 17, [23, 28]]"
-}
mce_show :: Show t => Mce t -> String
mce_show m =
  let bracketed (l, r) x = l : x ++ [r]
  in case m of
      Mce_Scalar e -> show e
      Mce_Vector e -> bracketed ('[', ']') (Sound.Sc3.Common.Base.concat_intersperse ", " (map mce_show e))

-- | Read value from Mce_Scalar, error if Mce is Mce_Vector
mce_scalar_value :: Mce t -> t
mce_scalar_value m =
  case m of
    Mce_Scalar x -> x
    Mce_Vector _ -> error "mce_scalar_value: not Mce_Scalar"

{- | Length, or perhaps rather width, of Mce.
Considers only the outermost level, i.e. mce_length is not necessarily the length of mce_to_list.
-}
mce_length :: Mce a -> Int
mce_length m =
  case m of
    Mce_Scalar _ -> 1
    Mce_Vector e -> length e

{- | The depth of an Mce is the longest sequence of nested Mce_Vector nodes.

>>> mce_depth 1
1

>>> mce_depth (Mce_Vector [1, 2])
1

>>> let v = Mce_Vector
>>> mce_depth (v[v[1, 2], 3, v[4, 5]])
2

>>> mce_depth (v[v[1, 2, 3, v[4, 5], 6], 7])
3
-}
mce_depth :: Mce a -> Int
mce_depth m =
  case m of
    Mce_Scalar _ -> 1
    Mce_Vector v -> if all mce_is_scalar v then 1 else 1 + maximum (map mce_depth v)

{- | Extend Mce to specified degree.
Considers only the outermost level.
-}
mce_extend :: Int -> Mce t -> Mce t
mce_extend n m =
  case m of
    Mce_Scalar _ -> Mce_Vector (replicate n m)
    Mce_Vector e -> if length e > n then error "mce_extend?" else Mce_Vector (take n (cycle e))

-- | fmap for Mce, apply /f/ at elements of /m/.
mce_map :: (a -> b) -> Mce a -> Mce b
mce_map f m =
  case m of
    Mce_Scalar e -> Mce_Scalar (f e)
    Mce_Vector e -> Mce_Vector (map (mce_map f) e)

instance Functor Mce where fmap = mce_map

{- | Apply /f/ pairwise at elements of /m1/ and /m2/.
     At each level this extends the shorter of the two operands.
-}
mce_binop :: (a -> b -> c) -> Mce a -> Mce b -> Mce c
mce_binop f m1 m2 =
  case (m1, m2) of
    (Mce_Scalar e1, Mce_Scalar e2) -> Mce_Scalar (f e1 e2)
    (Mce_Scalar _, Mce_Vector e2) -> Mce_Vector (map (mce_binop f m1) e2)
    (Mce_Vector e1, Mce_Scalar _) -> Mce_Vector (map (flip (mce_binop f) m2) e1)
    (Mce_Vector e1, Mce_Vector e2) ->
      let n = max (length e1) (length e2)
          ext = take n . cycle
      in Mce_Vector (zipWith (mce_binop f) (ext e1) (ext e2))

instance Num n => Num (Mce n) where
  (+) = mce_binop (+)
  (-) = mce_binop (-)
  (*) = mce_binop (*)
  abs = mce_map abs
  negate = mce_map negate
  signum = mce_map signum
  fromInteger = Mce_Scalar . fromInteger

instance Fractional n => Fractional (Mce n) where
  (/) = mce_binop (/)
  fromRational = Mce_Scalar . fromRational

instance Floating n => Floating (Mce n) where
  pi = Mce_Scalar pi
  exp = fmap exp
  log = fmap log
  sqrt = fmap sqrt
  (**) = mce_binop (**)
  logBase = mce_binop logBase
  sin = fmap sin
  cos = fmap cos
  asin = fmap asin
  acos = fmap acos
  atan = fmap atan
  sinh = fmap sinh
  cosh = fmap cosh
  asinh = fmap asinh
  acosh = fmap acosh
  atanh = fmap atanh

{-

If Ugen is any of Functor, Foldable, Traversable, then Mce must be as well.

{-# Language DeriveFunctor, DeriveFoldable, DeriveTraversable #-}

-}