RingBufferForward.hs

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

import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.CausalParameterized.RingBufferForward as RingBuffer
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import Synthesizer.LLVM.CausalParameterized.Process (($*), )

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

import Test.Synthesizer.LLVM.Utility
          (CheckEquality, checkEquality, rangeFromInt, )

import Control.Category ((<<<), )
import Control.Arrow (arr, (***), (^<<), (<<^), )
import Control.Applicative (pure, )
import Data.Tuple.HT (fst3, snd3, thd3, )

import qualified LLVM.Extra.Arithmetic as A

import qualified LLVM.Core as LLVM
import LLVM.Core (Value, )

import Foreign.Storable (Storable, )

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

import Test.QuickCheck (quickCheck, )

import NumericPrelude.Numeric
import NumericPrelude.Base


type EquFloat = CheckEquality Float

signalLength :: Int
signalLength = 10000


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


trackId :: IO (ChunkSize -> (Int, Word32) -> EquFloat)
trackId =
   let bufferSize = rangeFromInt (1,1000) <<^ fst
       noise = SigP.noise (arr snd) 1
   in  checkEquality limitFloat
          noise
          (CausalP.mapSimple (RingBuffer.index A.zero) $*
           RingBuffer.track bufferSize noise)

trackTail :: IO (ChunkSize -> (Int, Word32) -> EquFloat)
trackTail =
   let bufferSize = rangeFromInt (2,1000) <<^ fst
       noise = SigP.noise (arr snd) 1
   in  checkEquality limitFloat
          (SigP.tail noise)
          (CausalP.mapSimple (RingBuffer.index A.one) $*
           RingBuffer.track bufferSize noise)

trackDrop :: IO (ChunkSize -> (Int, Word32) -> EquFloat)
trackDrop =
   let n = rangeFromInt (0,1000) <<^ fst
       noise = SigP.noise (arr snd) 1
   in  checkEquality limitFloat
          (SigP.drop n noise)
          (CausalP.map RingBuffer.index (fmap (fromIntegral :: Int -> Word32) n) $*
           RingBuffer.track (fmap succ n) noise)

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

trackSkip :: IO (ChunkSize -> ((Int,Int), Word32) -> EquFloat)
trackSkip =
   let skips = randomSkips (arr fst)
       noise = SigP.noise (arr snd) 1
   in  checkEquality limitFloat
          (CausalP.skip noise $* skips)
          (CausalP.mapSimple (RingBuffer.index A.one) $*
           (RingBuffer.trackSkip 1 noise $* skips))

trackSkip1 :: IO (ChunkSize -> (Int, Word32) -> EquFloat)
trackSkip1 =
   let bufferSize = 1000
       k = rangeFromInt (0, fromIntegral bufferSize-1 :: Word32) <<^ fst
       noise = SigP.noise (arr snd) 1
   in  checkEquality limitFloat
          (CausalP.map RingBuffer.index k $*
           (RingBuffer.track (pure bufferSize) noise))
          (CausalP.map RingBuffer.index k $*
           (RingBuffer.trackSkip (pure bufferSize) noise $* 1))

trackSkipHold ::
   IO (ChunkSize -> ((Int,Int), Int, Word32) -> CheckEquality (Bool, Float))
trackSkipHold =
   let bufferSize = 1000
       skips = randomSkips (arr fst3)
       k = rangeFromInt (0, fromIntegral bufferSize-1 :: Word32) <<^ snd3
       noise = SigP.noise (arr thd3) 1
   in  checkEquality limitFloat
          (fmap ((,) (LLVM.valueOf True)) $
           (CausalP.map RingBuffer.index k $*
            (RingBuffer.trackSkip (pure bufferSize) noise $* skips)))
          (CausalP.map
              (\ki ((b,_s),buf) -> fmap ((,) b) $ RingBuffer.index ki buf) k $*
           (RingBuffer.trackSkipHold (pure bufferSize) noise $* skips))

{-
To do:

test that trackSkipHold returns False forever after it has returned False once.
-}


tests :: [(String, IO ())]
tests =
   ("trackId", quickCheck =<< trackId) :
   ("trackTail", quickCheck =<< trackTail) :
   ("trackDrop", quickCheck =<< trackDrop) :
   ("trackSkip", quickCheck =<< trackSkip) :
   ("trackSkip1", quickCheck =<< trackSkip1) :
   ("trackSkipHold", quickCheck =<< trackSkipHold) :
   []