Helix.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
module Test.Synthesizer.LLVM.Helix (tests) where

import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix
import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Interpolation as Interpolation
import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )
import Synthesizer.LLVM.CausalParameterized.Process (($*), )
import Synthesizer.LLVM.Parameter (($#), )

import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import Data.StorableVector.Lazy (ChunkSize, )

import Test.Synthesizer.LLVM.Utility
          (CheckSimilarity, checkSimilarity, rangeFromInt, )

import Control.Category ((<<<), )
import Control.Arrow (arr, (***), (^<<), (<<^), )
import Control.Applicative (pure, )

import LLVM.Core (Value, )

import Foreign.Storable (Storable, )

import qualified System.Random as Rnd
import Data.Word (Word32, )

-- import qualified Graphics.Gnuplot.Simple as Gnuplot
import Test.QuickCheck (quickCheck, )

import NumericPrelude.Numeric
import NumericPrelude.Base


type SimFloat = CheckSimilarity Float

signalLength :: Int
signalLength = 500


limitFloat :: (Storable a) => SVL.Vector a -> SVL.Vector a
limitFloat = SVL.take signalLength


randomSpeed :: Param.T p (Int, Int) -> SigP.T p (Value Float)
randomSpeed p =
   SigP.fromStorableVectorLazy
      ((\(len, seed) ->
          SVL.cycle $
          SVL.fromChunks
             [fst $ SV.packN len $ Rnd.randomRs (0,10::Float) seed])
       ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)

randomPhase :: Param.T p (Int, Int) -> SigP.T p (Value Float)
randomPhase p =
   SigP.fromStorableVectorLazy
      ((\(len, seed) ->
          SVL.cycle $
          SVL.fromChunks
             [fst $ SV.packN len $ Rnd.randomRs (0,1::Float) seed])
       ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)

staticDynamic ::
   IO (ChunkSize -> (((Int, Int), (Int, Int)), (Int, Word32)) -> SimFloat)
staticDynamic =
   let len = 1000
       speedParam = arr $ fst.fst
       phaseParam = arr $ snd.fst
       noiseParam = arr $ snd.snd
       period = rangeFromInt (1,32::Float) <<^ fst.snd
       noise :: Param.T p Word32 -> SigP.T p (Value Float)
       noise seed = CausalP.take (pure len) $* SigP.noise seed 1

       static =
          Helix.static Interpolation.linear Interpolation.linear
             (fmap round period) period
             (fmap (\seed -> SigP.render (noise (arr id)) len seed :: SV.Vector Float) noiseParam)
          $&
          Func.fromSignal
             ((CausalP.integrate $# (0::Float)) $* randomSpeed speedParam)
          &|&
          Func.fromSignal (randomPhase phaseParam)

       dynamic =
          Helix.dynamic Interpolation.linear Interpolation.linear
             (fmap round period) period (noise noiseParam)
          $&
          Func.fromSignal (randomSpeed speedParam)
          &|&
          Func.fromSignal (randomPhase phaseParam)

   in  checkSimilarity 5e-3 limitFloat
          (Func.compileSignal static)
          (Func.compileSignal dynamic)

{-
plot :: IO ()
plot = do
   render <- staticDynamic
   case render (SVL.chunkSize 1) (((111,0),(0,23)),(107,11)) of
      CheckSimilarity _tol xs ys ->
         Gnuplot.plotLists [] [SVL.unpack xs, SVL.unpack ys]
         >>
         Gnuplot.plotList [] (zipWith (-) (SVL.unpack xs) (SVL.unpack ys))
-}


tests :: [(String, IO ())]
tests =
   ("staticDynamic", quickCheck =<< staticDynamic) :
   []