Utility.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
module Test.Synthesizer.LLVM.Utility where

import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameter as Param

import qualified Synthesizer.State.Signal as SigS

import Control.Arrow (arr, )
import Control.Monad (liftM, liftM2, )

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

import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Class as Class

import System.Random (Random, randomR, mkStdGen, )

import qualified Test.QuickCheck as QC

import qualified Algebra.RealRing as RealRing
import qualified Algebra.Absolute as Absolute

import NumericPrelude.Numeric
import NumericPrelude.Base


rangeFromInt :: Random a => (a,a) -> Param.T Int a
rangeFromInt rng =
   arr $ fst . randomR rng . mkStdGen


render ::
   (Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.C al) =>
   (SVL.Vector a -> sig) ->
   SigP.T p (Class.ValueTuple a) -> IO (ChunkSize -> p -> sig)
render limit sig =
   fmap
      (\func chunkSize ->
         limit . func chunkSize) $
   SigP.runChunky sig


data CheckSimilarityState a =
   CheckSimilarityState a (SVL.Vector a) (SigS.T a)

instance (Storable a, Ord a, Absolute.C a) =>
      QC.Testable (CheckSimilarityState a) where
   property (CheckSimilarityState tol xs ys) =
      QC.property $
         SigS.foldR (&&) True $
         -- dangerous, since shortened signals would be tolerated
         SigS.zipWith (\x y -> abs(x-y) < tol)
            (SigS.fromStorableSignal xs) ys

{-# INLINE checkSimilarityState #-}
checkSimilarityState ::
   (RealRing.C a, Storable a,
    Class.MakeValueTuple a, Class.ValueTuple a ~ av,
    Memory.C av) =>
   a ->
   (SVL.Vector a -> SVL.Vector a) ->
   SigP.T p av ->
   (p -> SigS.T a) ->
   IO (ChunkSize -> p -> CheckSimilarityState a)
checkSimilarityState tol limit gen0 sig1 =
   liftM
      (\sig0 chunkSize p ->
         CheckSimilarityState tol (sig0 chunkSize p) (sig1 p))
      (render limit gen0)


data CheckSimilarity a =
   CheckSimilarity a (SVL.Vector a) (SVL.Vector a)

instance (Storable a, Ord a, Absolute.C a) => QC.Testable (CheckSimilarity a) where
   property (CheckSimilarity tol xs ys) =
      QC.property $
         SigS.foldR (&&) True $
         -- dangerous, since shortened signals would be tolerated
         SigS.zipWith (\x y -> abs(x-y) < tol)
            (SigS.fromStorableSignal xs)
            (SigS.fromStorableSignal ys)

{-# INLINE checkSimilarity #-}
checkSimilarity ::
   (RealRing.C b, Storable b,
    Storable a,
    Class.MakeValueTuple a, Class.ValueTuple a ~ av, Memory.C av) =>
   b ->
   (SVL.Vector a -> SVL.Vector b) ->
   SigP.T p av -> SigP.T p av ->
   IO (ChunkSize -> p -> CheckSimilarity b)
checkSimilarity tol limit gen0 gen1 =
   liftM2
      (\sig0 sig1 chunkSize p ->
         CheckSimilarity tol (sig0 chunkSize p) (sig1 chunkSize p))
      (render limit gen0)
      (render limit gen1)


{- |
Instead of testing on equality immediately
we use this interim data type.
This allows us to inspect the signals that are compared.
-}
data CheckEquality a =
   CheckEquality (SVL.Vector a) (SVL.Vector a)

instance (Storable a, Eq a) => QC.Testable (CheckEquality a) where
   property (CheckEquality x y) = QC.property (x==y)

checkEquality ::
   (Eq a, Storable a,
    Class.MakeValueTuple a, Class.ValueTuple a ~ av,
    Memory.C av) =>
   (SVL.Vector a -> SVL.Vector a) ->
   SigP.T p av -> SigP.T p av ->
   IO (ChunkSize -> p -> CheckEquality a)
checkEquality limit gen0 gen1 =
   liftM2
      (\sig0 sig1 chunkSize p ->
         CheckEquality (sig0 chunkSize p) (sig1 chunkSize p))
      (render limit gen0)
      (render limit gen1)