SignalPrivate.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Parameterized.SignalPrivate where

import qualified Synthesizer.LLVM.Parameter as Param
import qualified LLVM.Extra.MaybeContinuation as Maybe
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A

import LLVM.Extra.Class (MakeValueTuple, )
import LLVM.Core (IsSized, CodeGenFunction, )
import LLVM.Util.Loop (Phi, )

import Control.Arrow ((&&&), )
import Control.Monad (liftM2, )
import Control.Applicative (Applicative, pure, (<*>), )

import Foreign.Storable.Tuple ()
import Foreign.Storable (Storable, )

import qualified Number.Ratio as Ratio
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive

import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )


{-
In this attempt we use a Haskell value as parameter supply.
This is okay, since the Haskell value will be converted to internal parameters
and then to LLVM values only once.
We can even have a storable vector as parameter.
However, this way we cannot easily implement
the Vanilla signal using Parameterized.Value as element type.

This separation is nice for maximum efficiency,
but it cannot be utilized by Generic.Signal methods.
Consider an expression like @iterate ((0.5 ** recip halfLife) *) 1@.
How shall we know, that the sub-expression @(0.5 ** recip halfLife)@
needs to be computated only once?
I do not try to do such optimization, instead I let LLVM do it.
However, this means that parameter initialization
will be performed (unnecessarily) at the beginning of every chunk.
For Generic.Signal method instances
we will always set the @(p -> paramTuple)@ to 'id'.

Could we drop parameterized signals at all
and rely entirely on Causal processes?
Unfortunately 'interpolateConstant' does not fit into the Causal process scheme.
(... although it would be causal for stretching factor being at least one.
It would have to maintain the waiting signal as state,
i.e. the state would grow linearly with time.)
Consider a signal algorithm, where the LFO frequency is a parameter.
-}
data T p a =
   forall state packed size ioContext
        startParamTuple startParamValue startParamPacked startParamSize
        nextParamTuple  nextParamValue  nextParamPacked  nextParamSize.
      (Storable startParamTuple,
       Storable nextParamTuple,
       MakeValueTuple startParamTuple startParamValue,
       MakeValueTuple nextParamTuple  nextParamValue,
       Memory.C     startParamValue startParamPacked,
       Memory.C     nextParamValue  nextParamPacked,
       IsSized        startParamPacked startParamSize,
       IsSized        nextParamPacked  nextParamSize,
       Memory.C state packed,
       IsSized packed size) =>
   Cons
      (forall r c.
       (Phi c) =>
       nextParamValue ->
       state -> Maybe.T r c (a, state))
          -- compute next value
      (forall r.
       startParamValue ->
       CodeGenFunction r state)
          -- initial state
      (p -> IO (ioContext, (nextParamTuple, startParamTuple)))
          {- initialization from IO monad
          This will be run within unsafePerformIO,
          so no observable In/Out actions please!
          -}
      (ioContext -> IO ())
          -- finalization from IO monad, also run within unsafePerformIO

simple ::
   (Storable startParamTuple,
    Storable nextParamTuple,
    MakeValueTuple startParamTuple startParamValue,
    MakeValueTuple nextParamTuple nextParamValue,
    Memory.C startParamValue startParamPacked,
    Memory.C nextParamValue nextParamPacked,
    IsSized    startParamPacked startParamSize,
    IsSized    nextParamPacked  nextParamSize,
    Memory.C state packed,
    IsSized packed size) =>
   (forall r c.
    (Phi c) =>
    nextParamValue ->
    state -> Maybe.T r c (al, state)) ->
   (forall r.
    startParamValue ->
    CodeGenFunction r state) ->
   Param.T p nextParamTuple ->
   Param.T p startParamTuple -> T p al
simple f start selectParam initial = Cons
   (f . Param.value selectParam)
   (start . Param.value initial)
   (return . (,) () . Param.get (selectParam &&& initial))
   (const $ return ())


map ::
   (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) =>
   (forall r. pl -> a -> CodeGenFunction r b) ->
   Param.T p ph ->
   T p a -> T p b
map f selectParamF
      (Cons next start createIOContext deleteIOContext) =
   Cons
      (\(parameterF, parameter) sa0 -> do
         (a,sa1) <- next parameter sa0
         b <- Maybe.lift $ f (Param.value selectParamF parameterF) a
         return (b, sa1))
      start
      (\p -> do
         (ioContext, (nextParam, startParam)) <- createIOContext p
         return (ioContext, ((Param.get selectParamF p, nextParam), startParam)))
      deleteIOContext

mapSimple ::
   (forall r. a -> CodeGenFunction r b) ->
   T p a -> T p b
mapSimple f = map (const f) (return ())


zipWith ::
   (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) =>
   (forall r. pl -> a -> b -> CodeGenFunction r c) ->
   Param.T p ph ->
   T p a -> T p b -> T p c
zipWith f selectParamF
      (Cons nextA startA createIOContextA deleteIOContextA)
      (Cons nextB startB createIOContextB deleteIOContextB) =
   Cons
      (\(parameterF, (parameterA, parameterB)) (sa0,sb0) -> do
         (a,sa1) <- nextA parameterA sa0
         (b,sb1) <- nextB parameterB sb0
         c <- Maybe.lift $ f (Param.value selectParamF parameterF) a b
         return (c, (sa1,sb1)))
      (\(parameterA, parameterB) ->
         liftM2 (,)
            (startA parameterA)
            (startB parameterB))
      (\p -> do
         (ca,(nextParamA,startParamA)) <- createIOContextA p
         (cb,(nextParamB,startParamB)) <- createIOContextB p
         return ((ca,cb),
            ((Param.get selectParamF p, (nextParamA,  nextParamB)),
             (startParamA, startParamB))))
      (\(ca,cb) ->
         deleteIOContextA ca >>
         deleteIOContextB cb)

zipWithSimple ::
   (forall r. a -> b -> CodeGenFunction r c) ->
   T p a -> T p b -> T p c
zipWithSimple f =
   zipWith (const f) (return ())


instance Functor (T p) where
   fmap f = mapSimple (return . f)

{- |
ZipList semantics
-}
instance Applicative (T p) where
   pure x =
      simple
         (\() () -> return (x, ()))
         return
         (return ())
         (return ())
   (<*>) = zipWithSimple (\f a -> return (f a))


instance (A.Additive a) => Additive.C (T p a) where
   zero = pure A.zero
   negate = mapSimple A.neg
   (+) = zipWithSimple A.add
   (-) = zipWithSimple A.sub

instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T p a) where
   one = pure A.one
   fromInteger n = pure (A.fromInteger' n)
   (*) = zipWithSimple A.mul

instance (A.Field a, A.RationalConstant a) => Field.C (T p a) where
   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)
   (/) = zipWithSimple A.fdiv


iterate ::
   (Storable ph, MakeValueTuple ph pl,
    Memory.C pl pp, IsSized pp ps,
    Storable a,  MakeValueTuple a al,
    Memory.C al packed, IsSized packed s) =>
   (forall r. pl -> al -> CodeGenFunction r al) ->
   Param.T p ph ->
   Param.T p a -> T p al
iterate f selectParam initial = simple
   (\pl al0 ->
      Maybe.lift $ fmap (\al1 -> (al0,al1)) (f pl al0))
   return
   selectParam
   initial