Vanilla.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Simple.Vanilla where

import qualified Synthesizer.LLVM.Simple.Signal as Sig
import qualified LLVM.Extra.Memory as Memory
import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.MaybeContinuation as Maybe

import qualified Synthesizer.Basic.Phase as Phase
import qualified Synthesizer.Basic.Wave  as Wave

{-
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB
-}

-- import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import LLVM.Core

-- import Control.Monad (liftM2, liftM3, )

-- import qualified Algebra.Transcendental as Trans
import qualified Algebra.RealRing as RealRing
-- import qualified Algebra.Field as Field
-- import qualified Algebra.Ring as Ring
-- import qualified Algebra.Additive as Additive

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


iterateVal ::
   (Memory.FirstClass a am, IsSized a asize, IsSized am amsize) =>
   (Value.T a -> Value.T a) ->
   Value.T a -> Sig.T (Value.T a)
iterateVal f initial =
   Sig.simple
      (\y ->
         Maybe.lift $
         fmap (\y1 -> (Value.constantValue y, y1))
              (Value.decons (f (Value.constantValue y))))
      (Value.decons initial)

iterate ::
   (Value.Flatten a reg, Memory.C reg packed, IsSized packed size) =>
   (a -> a) ->
   (a -> Sig.T a)
iterate f initial =
   Sig.simple
      (\y ->
         Maybe.lift $
         fmap (\y1 -> (Value.unfold y, y1))
              (Value.flatten (f (Value.unfold y))))
      (Value.flatten initial)



map ::
   (a -> b) ->
   Sig.T a -> Sig.T b
map f = Sig.map (return . f)


osciReg ::
   (RealRing.C (Value.T t),
    Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize,
    SoV.Fraction t, IsConst t,
    IsFirstClass y) =>
   Wave.T (Value.T t) (Value.T y) ->
   Value t -> Value t -> Sig.T (Value y)
osciReg wave phase freq =
   Sig.map
      (Value.decons . Wave.apply wave .
       Phase.fromRepresentative . Value.constantValue) $
   Sig.iterate (SoV.incPhase freq) phase

osciVal ::
   (RealRing.C (Value.T t),
    Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize,
    SoV.Fraction t, IsConst t) =>
   Wave.T (Value.T t) y ->
   Value.T t -> Value.T t -> Sig.T y
osciVal wave phase freq =
   map (Wave.apply wave . Phase.fromRepresentative) $
   iterateVal (incPhaseVal freq) phase

incPhaseVal ::
   (SoV.Fraction a, IsArithmetic a) =>
   Value.T a -> Value.T a -> Value.T a
incPhaseVal = Value.lift2 SoV.incPhase

osci ::
   (RealRing.C t,
    Value.Flatten t reg,
    Memory.C reg struct, IsSized struct size,
    SoV.Fraction t, IsConst t) =>
   Wave.T t y ->
   Phase.T t -> t -> Sig.T y
osci wave phase freq =
   map (Wave.apply wave) $
   iterate (Phase.increment freq) phase