yampa-test 0.14.1 → 0.14.2
raw patch · 8 files changed
+474/−248 lines, 8 filesdep ~Yampa
Dependency ranges changed: Yampa
Files
- CHANGELOG +5/−0
- examples/Testing.hs +212/−0
- src/FRP/Yampa/Debug.hs +13/−7
- src/FRP/Yampa/LTLFuture.hs +39/−28
- src/FRP/Yampa/LTLPast.hs +14/−37
- src/FRP/Yampa/QuickCheck.hs +106/−125
- src/FRP/Yampa/Stream.hs +81/−47
- yampa-test.cabal +4/−4
CHANGELOG view
@@ -1,3 +1,8 @@+2023-04-07 Ivan Perez <ivan.perez@keera.co.uk>+ * Yampa.cabal: Version bump (0.14.2) (#259).+ * examples/: Introduce testing example from Yampa library (#257).+ * src:/ Conformance with style guide (#256).+ 2023-02-07 Ivan Perez <ivan.perez@keera.co.uk> * Yampa.cabal: Version bump (0.14.1) (#251). * tests/: add tests for module FRP.Yampa.Hybrid (#243), add tests for
+ examples/Testing.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : FRP.Yampa+-- Copyright : (c) Ivan Perez, 2017-2023+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : ivan.perez@keera.co.uk+-- Stability : provisional+-- Portability : non-portable (GHC extensions)+module Testing where++-- Examples accompanying the ICFP 2017 paper.+--+-- Changes with respect to the paper:+--+-- - The signature of ballTrulyFalling' in the paper was SF () Double. It's+-- been changed to the intended meaning: TPred ()++-- - The function uniDistStreamMaxDT had the wrong type and the name on the+-- paper was: uniDistStream. This has been fixed.+--++import FRP.Yampa+import FRP.Yampa.Stream+import FRP.Yampa.QuickCheck+import FRP.Yampa.LTLFuture+import Test.QuickCheck++-- * Sample temporal predicates++-- fallingBall :: Double -> SF () Double+-- fallingBall p0 = proc () -> do+-- v <- integral0 -< -9.8+-- p <- integral0 -< v+-- returnA -< (p0 + p)++ballFellLower :: Double -> TPred ()+ballFellLower p0 = SP (fallingBall p0 >>> arr (\p1 -> p1 <= p0))++-- > evalT (ballFellLower 100) stream01+-- True++ballFallingLower :: Double -> TPred ()+ballFallingLower p0 = Always (ballFellLower p0)++-- > evalT (ballFallingLower 100) stream01+-- True++-- fallingBallPair :: Double -> SF () (Double, Double)+-- fallingBallPair p0 = fallingBall p0 >>> (identity &&& iPre p0)++ballTrulyFalling :: Double -> TPred ()+ballTrulyFalling p0 =+ Always (SP (fallingBallPair p0 >>> arr (\(pn, po) -> pn < po)))++-- > evalT (ballTrulyFalling 100) stream01+-- False++ballTrulyFalling' :: Double -> TPred ()+ballTrulyFalling' p0 =+ Next (Always (SP (fallingBallPair p0 >>> arr (\(pn, po) -> pn < po))))++-- > evalT (ballTrulyFalling ′ 100) stream01+-- True++bouncingBall :: Double -> Double -> SF () (Double, Double)+bouncingBall p0 v0 = switch (fallingBall'' p0 v0 >>> (identity &&& hit))+ (\(p0', v0') -> bouncingBall p0' (-v0'))+--+-- fallingBall'' :: Double -> Double -> SF () (Double, Double)+-- fallingBall'' p0 v0 = proc () -> do+-- v <- arr (v0+) <<< integral -< -9.8+-- p <- arr (p0+) <<< integral -< v+-- returnA -< (p, v)+--+-- hit :: SF (Double, Double) (Event (Double, Double))+-- hit = arr+-- (\(p0, v0) -> if ((p0 <= 0) && (v0 < 0)) then Event (p0, v0) else NoEvent)++ballLower :: Double -> TPred ()+ballLower p0 = Always (SP (bouncingBall p0 0 >>> arr (\(p1, v1) -> p1 <= p0)))++-- > evalT (ballBouncingLower 100) stream05+-- False++ballBouncingLower = ballLower++ballOverFloor :: Double -> TPred ()+ballOverFloor p0 =+ Always (SP (bouncingBall p0 0 >>> arr (\(p1, v1) -> p1 >= 0)))++-- > evalT (ballOverFloor 100) stream05+-- False++fallingBall :: Double -> SF () Double+fallingBall p0 = constant (-9.8) >>> integral0 >>> integral0 >>> arr (+p0)++-- ballFellLower :: Double -> TPred ()+-- ballFellLower p0 = SP (fallingBall p0, (\_ p1 -> p1 <= p0))++testFellBall = evalT (ballFellLower 100) stream0_1++testFellBall2 = evalT (ballFellLower 100) stream0_2++testFallingBall = evalT (ballFallingLower 100) stream0_1++fallingBallPair :: Double -> SF () (Double, Double)+fallingBallPair p0 = fallingBall p0 >>> (identity &&& iPre p0)++-- ballTrulyFalling :: Double -> TPred ()+-- ballTrulyFalling p0 =+-- Always $ SP (fallingBallPair p0, \() (pn,po) -> pn < po)++testBallTrulyFalling = evalT (ballTrulyFalling 100) stream0_1++-- ballTrulyFalling' :: Double -> TPred ()+-- ballTrulyFalling' p0 =+-- Next $ Always $ SP (fallingBallPair p0, \() (pn,po) -> pn < po)++testBallTrulyFalling' = evalT (ballTrulyFalling' 100) stream0_1++fallingBall'' :: Double -> Double -> SF () (Double, Double)+fallingBall'' p0 v0 = proc () -> do+ v <- arr (v0 +) <<< integral -< -9.8+ p <- arr (p0 +) <<< integral -< v+ returnA -< (p, v)++hit :: SF (Double, Double) (Event (Double, Double))+hit =+ arr (\(p0, v0) -> if (p0 <= 0 && v0 < 0) then Event (p0, v0) else NoEvent)++-- bouncingBall :: Double -> Double -> SF () (Double, Double)+-- bouncingBall p0 v0 = switch (fallingBall'' p0 v0 >>> (identity &&& hit))+-- (\(p0', v0') -> bouncingBall p0' (-v0'))++-- ballBouncingLower :: Double -> TPred ()+-- ballBouncingLower p0 =+-- Always $ SP (bouncingBall p0 0, (\_ (p1,_) -> p1 <= p0))++testBallBouncing = evalT (ballBouncingLower 100) stream0_5++showBallBouncing =+ embed+ (bouncingBall 100 0 >>> arr fst )+ ((), map (second Just) (replicate 39 (0.5, ())))++-- ballOverFloor :: Double -> TPred ()+-- ballOverFloor p0 = Always $ SP (bouncingBall p0 0, (\_ (p1, v1) -> p1 >= 0))++testBallOverFloor = evalT (ballOverFloor 100) stream0_5'++showBallBouncing1 =+ embed+ (bouncingBall 110.24999999999999 0 >>> arr fst )+ ((), map (second Just) (replicate 102 (0.5, ())))++testBallOverFloor' = evalT (ballOverFloor 110.24999999999999) stream0_5'++propTestBallOverFloor =+ forAll myStream (evalT (ballOverFloor 110.24999999999999))+ where myStream :: Gen (SignalSampleStream ())+ myStream = uniDistStream++propTestBallOverFloorFixed =+ forAll myStream (evalT (ballOverFloor 110.24999999999999))+ where myStream :: Gen (SignalSampleStream ())+ myStream = fixedDelayStream (1/60)++bouncingBall' p0 v0 = bouncingBall p0 v0 >>> arr fst++ballAboveFloor :: Double -> Double -> SF () (Double, Bool)+ballAboveFloor p0 v0 = proc () -> do+ ballPos <- bouncingBall' p0 v0 -< ()+ let aboveFloor = ballPos >= 0+ returnA -< (ballPos, aboveFloor)++-- * Sample streams++stream0_1 = ((), replicate 21 (0.1, ()))++stream0_2 = ((), (replicate 20 (0.1, ())) ++ [(-1000000, ())])++stream0_5 = ((), replicate 39 (0.5, ()))++stream0_5' = ((), replicate 20 (0.5, ()))++-- ** Extended SFs++integral0 = imIntegral 0++-- * Talk++greaterThan :: SF (Int, Int) Bool+greaterThan = arr $ \(x,y) -> x > y++alwaysGreater :: TPred (Int, Int)+alwaysGreater = Always $ SP greaterThan++-- > evalT alwaysGreater ((5,1), [(0.001, (6, 1)), (0.001, (9, 2))])+-- True+eval1 = evalT alwaysGreater ((5,1), [(0.001, (6, 1)), (0.001, (9, 2))])++-- > evalT alwaysGreater ((1,5), [(0.001, (6, 1)), (0.001, (9, 2))])+-- False+eval2 = evalT alwaysGreater ((1,5), [(0.001, (6, 1)), (0.001, (9, 2))])++alwaysGreaterProperty :: Property+alwaysGreaterProperty = forAll arbitrary (evalT alwaysGreater)++evalQ1 = quickCheck alwaysGreaterProperty
src/FRP/Yampa/Debug.hs view
@@ -1,20 +1,26 @@--- | Debug FRP networks by inspecting their behaviour inside.+-- |+-- Copyright : (c) Ivan Perez, 2017-2022+-- License : BSD-style (see the LICENSE file in the distribution)+-- Maintainer : ivan.perez@keera.co.uk+--+-- Debug FRP networks by inspecting their behaviour inside. module FRP.Yampa.Debug where -import Debug.Trace-import FRP.Yampa-import System.IO.Unsafe+-- External imports+import Debug.Trace (trace)+import FRP.Yampa (SF, arr)+import System.IO.Unsafe (unsafePerformIO) -- | Signal Function that prints the value passing through using 'trace'. traceSF :: Show a => SF a a traceSF = traceSFWith show --- | Signal Function that prints the value passing through using 'trace',--- and a customizable 'show' function.+-- | Signal Function that prints the value passing through using 'trace', and a+-- customizable 'show' function. traceSFWith :: (a -> String) -> SF a a traceSFWith f = arr (\x -> trace (f x) x) -- | Execute an IO action using 'unsafePerformIO' at every step, and ignore the -- result. traceSFWithIO :: (a -> IO b) -> SF a a-traceSFWithIO f = arr (\x -> (unsafePerformIO (f x >> return x)))+traceSFWithIO f = arr (\x -> unsafePerformIO (f x >> return x))
src/FRP/Yampa/LTLFuture.hs view
@@ -1,31 +1,32 @@ {-# LANGUAGE GADTs #-}--- | Linear Temporal Logics based on SFs.+-- |+-- Copyright : (c) Ivan Perez, 2017-2022+-- License : BSD-style (see the LICENSE file in the distribution)+-- Maintainer : ivan.perez@keera.co.uk --+-- Linear Temporal Logics based on SFs.+-- -- This module contains a definition of LTL with Next on top of Signal -- Functions. ----- LTL predicates are parameterized over an input. A basic proposition--- is a Signal Function that produces a boolean function.---- Important question: because this FRP implement uses CPS,--- it is stateful, and sampling twice in one time period--- is not necessarily the same as sampling once. This means that--- tauApp, or next, might not work correctly. It's important to--- see what is going on there... :(-+-- LTL predicates are parameterized over an input. A basic proposition is a+-- Signal Function that produces a boolean function. module FRP.Yampa.LTLFuture ( TPred(..) , evalT ) where -import FRP.Yampa-import FRP.Yampa.Stream+-- External imports+import FRP.Yampa (DTime, SF, evalFuture) +-- Internal imports+import FRP.Yampa.Stream (SignalSampleStream, evalSF, firstSample)+ -- | Type representing future-time linear temporal logic predicates with until -- and next. data TPred a where- SP :: SF a Bool -> TPred a+ SP :: SF a Bool -> TPred a And :: TPred a -> TPred a -> TPred a Or :: TPred a -> TPred a -> TPred a Not :: TPred a -> TPred a@@ -39,31 +40,41 @@ -- -- Returns 'True' if the temporal proposition is currently true. evalT :: TPred a -> SignalSampleStream a -> Bool-evalT (SP sf) = \stream -> firstSample $ fst $ evalSF sf stream+evalT (SP sf) = \stream -> firstSample $ fst $ evalSF sf stream evalT (And t1 t2) = \stream -> evalT t1 stream && evalT t2 stream evalT (Or t1 t2) = \stream -> evalT t1 stream || evalT t2 stream evalT (Not t1) = \stream -> not (evalT t1 stream) evalT (Implies t1 t2) = \stream -> not (evalT t1 stream) || evalT t2 stream-evalT (Always t1) = \stream -> evalT t1 stream && evalT (Next (Always t1)) stream-evalT (Eventually t1) = \stream -> case stream of- (a,[]) -> evalT t1 stream- (a1,(dt,a2):as) -> evalT t1 stream || evalT (tauApp (Eventually t1) a1 dt) (a2, as)-evalT (Until t1 t2) = \stream -> (evalT t1 stream && evalT (Next (Until t1 t2)) stream)- || evalT t2 stream-evalT (Next t1) = \stream -> case stream of- (a,[]) -> True -- This is important. It determines how- -- always and next behave at the- -- end of the stream, which affects that is and isn't- -- a tautology. It should be reviewed very carefully.- (a1,(dt, a2):as) -> evalT (tauApp t1 a1 dt) (a2, as)+evalT (Always t1) = \stream ->+ evalT t1 stream && evalT (Next (Always t1)) stream +evalT (Eventually t1) = \stream ->+ case stream of+ (a, []) -> evalT t1 stream+ (a1, (dt, a2) : as) -> evalT t1 stream+ || evalT (tauApp (Eventually t1) a1 dt) (a2, as)++evalT (Until t1 t2) = \stream ->+ (evalT t1 stream && evalT (Next (Until t1 t2)) stream)+ || evalT t2 stream++evalT (Next t1) = \stream ->+ case stream of+ (a, []) -> True -- This is important. It determines how+ -- always and next behave at the end of the+ -- stream, which affects that is and isn't a+ -- tautology. It should be reviewed very+ -- carefully.+ (a1, (dt, a2) : as) -> evalT (tauApp t1 a1 dt) (a2, as)+ -- | Tau-application (transportation to the future) tauApp :: TPred a -> a -> DTime -> TPred a-tauApp pred sample dtime = tPredMap (\sf -> snd (evalFuture sf sample dtime)) pred+tauApp pred sample dtime =+ tPredMap (\sf -> snd (evalFuture sf sample dtime)) pred -- | Apply a transformation to the leaves (to the SFs) tPredMap :: (SF a Bool -> SF a Bool) -> TPred a -> TPred a-tPredMap f (SP sf) = SP (f sf)+tPredMap f (SP sf) = SP (f sf) tPredMap f (And t1 t2) = And (tPredMap f t1) (tPredMap f t2) tPredMap f (Or t1 t2) = Or (tPredMap f t1) (tPredMap f t2) tPredMap f (Not t1) = Not (tPredMap f t1)
src/FRP/Yampa/LTLPast.hs view
@@ -1,16 +1,20 @@-{-# LANGUAGE Arrows #-}--- | Past-time Linear Temporal Logics based on SFs.+-- |+-- Copyright : (c) Ivan Perez, 2017-2022+-- License : BSD-style (see the LICENSE file in the distribution)+-- Maintainer : ivan.perez@keera.co.uk --+-- Past-time Linear Temporal Logics based on SFs.+-- -- This module contains a definition of ptLTL with prev/last on top of Signal -- Functions. -- -- The difference between the future time and the past time LTL is that the -- former needs a trace for evaluation, and the latter can be embedded into a -- signal function network without additional support for evaluation.- module FRP.Yampa.LTLPast where -import FRP.Yampa+-- External imports+import FRP.Yampa (Event (..), SF, arr, iPre, loopPre, switch, (>>>)) -- | True if both inputs are True. andSF :: SF (Bool, Bool) Bool@@ -26,15 +30,15 @@ -- | True if the first signal is False or the second one is True. impliesSF :: SF (Bool, Bool) Bool-impliesSF = arr $ \(i,p) -> not i || p+impliesSF = arr $ \(i, p) -> not i || p -- | True a a time if the input signal has been always True so far. sofarSF :: SF Bool Bool-sofarSF = loopPre True $ arr $ \(n,o) -> let n' = o && n in (n', n')+sofarSF = loopPre True $ arr $ \(n, o) -> let n' = o && n in (n', n') -- | True at a time if the input signal has ever been True before. everSF :: SF Bool Bool-everSF = loopPre False $ arr $ \(n,o) -> let n' = o || n in (n', n')+everSF = loopPre False $ arr $ \(n, o) -> let n' = o || n in (n', n') -- | True if the signal was True in the last sample. False at time zero. lastSF :: SF Bool Bool@@ -44,34 +48,7 @@ -- True, if ever. untilSF :: SF (Bool, Bool) Bool untilSF = switch- (loopPre True $ arr (\((i,u),o) -> let n = o && i- in ((n, if (o && u) then Event () else NoEvent), n)))+ (loopPre True $ arr (\((i, u), o) ->+ let n = o && i+ in ((n, if o && u then Event () else NoEvent), n))) (\_ -> arr snd >>> sofarSF)---- -- * SF combinators that implement temporal combinators------ type SPred a = SF a Bool------ andSF' :: SPred a -> SPred a -> SPred a--- andSF' sf1 sf2 = (sf1 &&& sf2) >>> arr (uncurry (&&))------ orSF' :: SPred a -> SPred a -> SPred a--- orSF' sf1 sf2 = (sf1 &&& sf2) >>> arr (uncurry (||))------ notSF' :: SPred a -> SPred a--- notSF' sf = sf >>> arr (not)------ implySF' :: SPred a -> SPred a -> SPred a--- implySF' sf1 sf2 = orSF' sf2 (notSF' sf1)------ history' :: SPred a -> SPred a--- history' sf = loopPre True $ proc (a, last) -> do--- b <- sf -< a--- let cur = last && b--- returnA -< (cur, cur)------ ever' :: SPred a -> SPred a--- ever' sf = loopPre False $ proc (a, last) -> do--- b <- sf -< a--- let cur = last || b--- returnA -< (cur, cur)
src/FRP/Yampa/QuickCheck.hs view
@@ -1,21 +1,20 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-}--- | QuickCheck generators for input streams.+-- |+-- Copyright : (c) Ivan Perez, 2017-2022+-- License : BSD-style (see the LICENSE file in the distribution)+-- Maintainer : ivan.perez@keera.co.uk --+-- QuickCheck generators for input streams.+-- -- Random stream generation can be customized usin three parameters: -- -- - The distribution for the random time deltas ('Distribution'). -- - The maximum and minimum bounds for the time deltas ('Range'). -- - The maximum stream length ('Length'). ----- The main function to generate streams is 'generateStream'. The specific--- time deltas can be customized further using 'generateStreamWith'. Some--- helper functions are provided to facilitate testing.---- The function uniDistStreamMaxDT had the wrong type and the name on the--- paper was: uniDistStream. This has been fixed.-+-- The main function to generate streams is 'generateStream'. The specific time+-- deltas can be customized further using 'generateStreamWith'. Some helper+-- functions are provided to facilitate testing. module FRP.Yampa.QuickCheck ( -- * Random stream generation@@ -35,55 +34,96 @@ ) where -import Control.Applicative ((<$>), pure)-import Data.Random.Normal-import FRP.Yampa-import Test.QuickCheck-import Test.QuickCheck.Gen+-- External imports+import Control.Applicative (pure, (<$>))+import Data.Random.Normal (normal')+import FRP.Yampa (DTime)+import Test.QuickCheck (Arbitrary (arbitrary), choose, getPositive,+ suchThat)+import Test.QuickCheck.Gen (Gen (MkGen)) -import FRP.Yampa.Stream+-- Internal imports+import FRP.Yampa.Stream (SignalSampleStream, groupDeltas) --- | Distributions used for time delta (DT) generation.-data Distribution = DistConstant -- ^ Constant DT for the whole stream.- | DistNormal (DTime, DTime) -- ^ Variable DT following normal distribution,- -- with an average and a standard deviation.- | DistRandom -- ^ Completely random (positive) DT.+-- * Random stream generation --- | Upper and lower bounds of time deltas for random DT generation.-type Range = (Maybe DTime, Maybe DTime)+-- | Generate random stream.+generateStream :: Arbitrary a+ => Distribution -> Range -> Length -> Gen (SignalSampleStream a)+generateStream = generateStreamWith (\_ _ -> arbitrary) --- | Optional maximum length for a stream, given as a time, or a number of--- samples.-type Length = Maybe (Either Int DTime)+-- | Generate random stream, parameterized by the value generator.+generateStreamWith :: Arbitrary a+ => (Int -> DTime -> Gen a)+ -> Distribution+ -> Range+ -> Length+ -> Gen (SignalSampleStream a)+generateStreamWith arb DistConstant range len =+ generateConstantStream arb =<< generateStreamLenDT range len+generateStreamWith arb dist (m, n) len = do+ ds <- generateDeltas len+ let l = length ds+ let f n = arb n (ds !! (n - 1))+ xs <- vectorOfWith l f --- | Generate a random delta according to some required specifications.-generateDeltas :: Distribution -> Range -> Length -> Gen DTime-generateDeltas DistConstant (mn, mx) len = generateDelta mn mx-generateDeltas DistRandom (mn, mx) len = generateDelta mn mx-generateDeltas (DistNormal (avg, dev)) (mn, mx) len = generateDSNormal avg dev mn mx+ x <- arb 0 0+ return $ groupDeltas (x:xs) ds + where++ deltaF :: Gen DTime+ deltaF = case dist of+ DistRandom -> generateDelta m n+ DistNormal (avg, stddev) -> generateDSNormal avg stddev m n+ _ -> error "yampa-test: generateStreamWith"++ generateDeltas :: Length -> Gen [DTime]+ generateDeltas Nothing = do l <- arbitrary+ vectorOfWith l (\_ -> deltaF)+ generateDeltas (Just (Left l)) = vectorOfWith l (\_ -> deltaF)+ generateDeltas (Just (Right maxds)) = timeStampsUntilWith deltaF maxds++-- | Generate arbitrary stream with fixed length and constant delta.+generateConstantStream :: (Int -> DTime -> Gen a)+ -> (DTime, Int)+ -> Gen (SignalSampleStream a)+generateConstantStream arb (x, length) = do+ ys <- vectorOfWith length (\n -> arb n x)+ return $ groupDeltas ys ds+ where+ ds = repeat x++-- | Generate arbitrary stream+generateStreamLenDT :: (Maybe DTime, Maybe DTime)+ -> Maybe (Either Int DTime)+ -> Gen (DTime, Int)+generateStreamLenDT range len = do+ x <- uncurry generateDelta range+ l <- case len of+ Nothing -> (1 +) . getPositive <$> arbitrary+ Just (Left l) -> pure l+ Just (Right ds) -> max 1 <$> pure (floor (ds / x))+ return (x, l)+ -- | Generate one random delta, possibly within a range. generateDelta :: Maybe DTime -> Maybe DTime -> Gen DTime-generateDelta (Just x) (Just y) = choose (x, y)-generateDelta (Just x) (Nothing) = (x+) <$> arbitrary-generateDelta (Nothing) (Just y) = choose (2.2251e-308, y)-generateDelta (Nothing) (Nothing) = getPositive <$> arbitrary+generateDelta (Just x) (Just y) = choose (x, y)+generateDelta (Just x) Nothing = (x +) <$> arbitrary+generateDelta Nothing (Just y) = choose (2.2251e-308, y)+generateDelta Nothing Nothing = getPositive <$> arbitrary --- | Generate a random delta following a normal distribution,--- and possibly within a given range.+-- | Generate a random delta following a normal distribution, and possibly+-- within a given range. generateDSNormal :: DTime -> DTime -> Maybe DTime -> Maybe DTime -> Gen DTime generateDSNormal avg stddev m n = suchThat gen (\x -> mx x && mn x) where- gen = MkGen (\r _ -> let (x,_) = normal' (avg, stddev) r in x)+ gen = MkGen (\r _ -> fst $ normal' (avg, stddev) r) mn = maybe (\_ -> True) (<=) m mx = maybe (\_ -> True) (>=) n --- | Generate random samples up until a max time.-timeStampsUntil :: DTime -> Gen [DTime]-timeStampsUntil = timeStampsUntilWith arbitrary- -- | Generate random samples up until a max time, with a given time delta--- generation function.+-- generation function. timeStampsUntilWith :: Gen DTime -> DTime -> Gen [DTime] timeStampsUntilWith arb ds = timeStampsUntilWith' arb [] ds where@@ -96,104 +136,45 @@ let acc' = acc `seq` (d:acc) acc' `seq` timeStampsUntilWith' arb acc' (ds - d) --- | Generate random stream.-generateStream :: Arbitrary a- => Distribution -> Range -> Length -> Gen (SignalSampleStream a)-generateStream = generateStreamWith (\_ _ -> arbitrary)---- | Generate random stream, parameterized by the value generator.-generateStreamWith :: Arbitrary a- => (Int -> DTime -> Gen a) -> Distribution -> Range -> Length -> Gen (SignalSampleStream a)-generateStreamWith arb DistConstant range len = generateConstantStream arb =<< generateStreamLenDT range len-generateStreamWith arb DistRandom (m, n) Nothing = do- l <- arbitrary- x <- arb 0 0- ds <- vectorOfWith l (\_ -> generateDelta m n)- let f n = arb n (ds!!(n-1))- xs <- vectorOfWith l f- return $ groupDeltas (x:xs) ds--generateStreamWith arb DistRandom (m, n) (Just (Left l)) = do- x <- arb 0 0- ds <- vectorOfWith l (\_ -> generateDelta m n)- let f n = arb n (ds!!(n-1))- xs <- vectorOfWith l f- return $ groupDeltas (x:xs) ds--generateStreamWith arb DistRandom (m, n) (Just (Right maxds)) = do- ds <- timeStampsUntilWith (generateDelta m n) maxds- let l = length ds- x <- arb 0 0- let f n = arb n (ds!!(n-1))- xs <- vectorOfWith l f- return $ groupDeltas (x:xs) ds--generateStreamWith arb (DistNormal (avg, stddev)) (m, n) Nothing = do- l <- arbitrary- x <- arb 0 0- ds <- vectorOfWith l (\_ -> generateDSNormal avg stddev m n)- let f n = arb n (ds!!(n-1))- xs <- vectorOfWith l f- return $ groupDeltas (x:xs) ds--generateStreamWith arb (DistNormal (avg, stddev)) (m, n) (Just (Left l)) = do- x <- arb 0 0- ds <- vectorOfWith l (\_ -> generateDSNormal avg stddev m n)- let f n = arb n (ds!!(n-1))- xs <- vectorOfWith l f- return $ groupDeltas (x:xs) ds+-- ** Parameters used to generate random input streams -generateStreamWith arb (DistNormal (avg, stddev)) (m, n) (Just (Right maxds)) = do- ds <- timeStampsUntilWith (generateDSNormal avg stddev m n) maxds- let l = length ds- x <- arb 0 0- let f n = arb n (ds!!(n-1))- xs <- vectorOfWith l f- return $ groupDeltas (x:xs) ds+-- | Distributions used for time delta (DT) generation.+data Distribution+ = DistConstant -- ^ Constant DT for the whole stream.+ | DistNormal (DTime, DTime) -- ^ Variable DT following normal distribution,+ -- with an average and a standard deviation.+ | DistRandom -- ^ Completely random (positive) DT. --- | Generate arbitrary stream with fixed length and constant delta.-generateConstantStream :: (Int -> DTime -> Gen a) -> (DTime, Int) -> Gen (SignalSampleStream a)-generateConstantStream arb (x, length) = do- ys <- vectorOfWith length (\n -> arb n x)- let ds = repeat x- return $ groupDeltas ys ds+-- | Upper and lower bounds of time deltas for random DT generation.+type Range = (Maybe DTime, Maybe DTime) --- | Generate arbitrary stream-generateStreamLenDT :: (Maybe DTime, Maybe DTime) -> Maybe (Either Int DTime) -> Gen (DTime, Int)-generateStreamLenDT range len = do- x <- uncurry generateDelta range- l <- case len of- Nothing -> ((1 +) . getPositive) <$> arbitrary- Just (Left l) -> pure l- Just (Right ds) -> (max 1) <$> (pure (floor (ds / x)))- return (x, l)+-- | Optional maximum length for a stream, given as a time, or a number of+-- samples.+type Length = Maybe (Either Int DTime) --- generateStreamLenDT (Just x, Just y) (Just (Left l)) = (,) <$> choose (x, y) <*> pure l--- generateStreamLenDT (Just x, Nothing) (Just (Left l)) = (,) <$> ((x+) <$> arbitrary) <*> pure l--- generateStreamLenDT (Nothing, Just y) (Just (Left l)) = (,) <$> choose (0, y) <*> pure l--- generateStreamLenDT (Just x, _) (Just (Right ts)) = (,) <$> pure x <*> pure (floor (ts / x))--- generateStreamLenDT (Just x, _) Nothing = (,) <$> pure x <*> arbitrary--- generateStreamLenDT (Nothing, Nothing) Nothing = (,) <$> arbitrary <*> arbitrary--- generateStreamLenDT (Nothing, Nothing) (Just (Left l)) = (,) <$> arbitrary <*> pure l--- generateStreamLenDT (Nothing, Nothing) (Just (Right ds)) = f2 <$> arbitrary--- where--- f2 l = (ds / fromIntegral l, l)+-- ** Helpers for common cases -- | Generate a stream of values with uniformly distributed time deltas. uniDistStream :: Arbitrary a => Gen (SignalSampleStream a) uniDistStream = generateStream DistRandom (Nothing, Nothing) Nothing --- | Generate a stream of values with uniformly distributed time deltas, with a max DT.+-- | Generate a stream of values with uniformly distributed time deltas, with a+-- max DT. uniDistStreamMaxDT :: Arbitrary a => DTime -> Gen (SignalSampleStream a)-uniDistStreamMaxDT maxDT = generateStream DistRandom (Nothing, Just maxDT ) Nothing+uniDistStreamMaxDT maxDT =+ generateStream DistRandom (Nothing, Just maxDT ) Nothing -- | Generate a stream of values with a fixed time delta. fixedDelayStream :: Arbitrary a => DTime -> Gen (SignalSampleStream a) fixedDelayStream dt = generateStream DistConstant (Just dt, Just dt) Nothing -- | Generate a stream of values with a fixed time delta.-fixedDelayStreamWith :: Arbitrary a => (DTime -> a) -> DTime -> Gen (SignalSampleStream a)-fixedDelayStreamWith f dt = generateStreamWith f' DistConstant (Just dt, Just dt) Nothing+fixedDelayStreamWith :: Arbitrary a+ => (DTime -> a)+ -> DTime+ -> Gen (SignalSampleStream a)+fixedDelayStreamWith f dt =+ generateStreamWith f' DistConstant (Just dt, Just dt) Nothing where f' n t = return $ f (fromIntegral n * t)
src/FRP/Yampa/Stream.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE MultiWayIf #-}--- | Streams and stream manipulation API.+-- |+-- Copyright : (c) Ivan Perez, 2017-2022+-- License : BSD-style (see the LICENSE file in the distribution)+-- Maintainer : ivan.perez@keera.co.uk --+-- Streams and stream manipulation API.+-- -- The evaluation of Yampa SFs, especially for testing purposes, needs the -- generation of suitable input streams. --@@ -15,7 +19,8 @@ -- continuation SF. module FRP.Yampa.Stream where -import FRP.Yampa (DTime, SF, FutureSF, evalAtZero, evalAt)+-- External imports+import FRP.Yampa (DTime, FutureSF, SF, evalAt, evalAtZero) -- * Types @@ -35,7 +40,9 @@ -- dropped. groupDeltas :: [a] -> [DTime] -> SignalSampleStream a groupDeltas (x:xs) ds = (x, zip ds xs)-groupDeltas xs ds = error $ "groupDeltas: called me with lists with lengths" ++ show (length xs) ++ " and " ++ show (length ds)+groupDeltas xs ds =+ error $ "groupDeltas: called me with lists with lengths"+ ++ show (length xs) ++ " and " ++ show (length ds) -- * Examination @@ -55,20 +62,29 @@ -- | Merge two streams, using an auxilary function to merge samples that fall -- at the exact same sampling time.-sMerge :: (a -> a -> a) -> SignalSampleStream a -> SignalSampleStream a -> SignalSampleStream a+sMerge :: (a -> a -> a)+ -> SignalSampleStream a+ -> SignalSampleStream a+ -> SignalSampleStream a sMerge f (x1, xs1) (x2, xs2) = (f x1 x2, sMergeTail f xs1 xs2) where- sMergeTail :: (a -> a -> a) -> FutureSampleStream a -> FutureSampleStream a -> FutureSampleStream a+ sMergeTail :: (a -> a -> a)+ -> FutureSampleStream a+ -> FutureSampleStream a+ -> FutureSampleStream a sMergeTail f [] xs2 = xs2 sMergeTail f xs1 [] = xs1- sMergeTail f ((dt1, x1):xs1) ((dt2, x2):xs2)+ sMergeTail f ((dt1, x1) : xs1) ((dt2, x2) : xs2) | dt1 == dt2 = (dt1, f x1 x2) : sMergeTail f xs1 xs2- | dt1 < dt2 = (dt1, x1) : sMergeTail f xs1 ((dt2-dt1, x2):xs2)- | otherwise = (dt2, x2) : sMergeTail f ((dt1-dt2, x1):xs1) xs2+ | dt1 < dt2 = (dt1, x1) : sMergeTail f xs1 ((dt2 - dt1, x2) : xs2)+ | otherwise = (dt2, x2) : sMergeTail f ((dt1 - dt2, x1) : xs1) xs2 -- | Concatenate two sample streams, separating them by a given time delta.-sConcat :: SignalSampleStream a -> DTime -> SignalSampleStream a -> SignalSampleStream a-sConcat (x1, xs1) dt (x2, xs2) = (x1 , xs1 ++ ((dt, x2):xs2))+sConcat :: SignalSampleStream a+ -> DTime+ -> SignalSampleStream a+ -> SignalSampleStream a+sConcat (x1, xs1) dt (x2, xs2) = (x1, xs1 ++ ((dt, x2) : xs2)) -- | Refine a stream by establishing the maximum time delta. --@@ -77,10 +93,14 @@ sRefine :: DTime -> SignalSampleStream a -> SignalSampleStream a sRefine maxDT (a, as) = (a, sRefineFutureStream maxDT a as) where- sRefineFutureStream :: DTime -> a -> FutureSampleStream a -> FutureSampleStream a+ sRefineFutureStream :: DTime+ -> a+ -> FutureSampleStream a+ -> FutureSampleStream a sRefineFutureStream maxDT _ [] = []- sRefineFutureStream maxDT a0 ((dt, a):as)- | dt > maxDT = (maxDT, a0) : sRefineFutureStream maxDT a0 ((dt - maxDT, a):as)+ sRefineFutureStream maxDT a0 ((dt, a) : as)+ | dt > maxDT =+ (maxDT, a0) : sRefineFutureStream maxDT a0 ((dt - maxDT, a) : as) | otherwise = (dt, a) : sRefineFutureStream maxDT a as -- | Refine a stream by establishing the maximum time delta.@@ -88,49 +108,61 @@ -- If two samples are separated by a time delta bigger than the given max DT, -- the auxiliary interpolation function is used to determine the intermendiate -- sample.-sRefineWith :: (a -> a -> a) -> DTime -> SignalSampleStream a -> SignalSampleStream a-sRefineWith interpolate maxDT (a, as) = (a, refineFutureStreamWith interpolate maxDT a as)+sRefineWith :: (a -> a -> a)+ -> DTime+ -> SignalSampleStream a+ -> SignalSampleStream a+sRefineWith interpolate maxDT (a, as) =+ (a, refineFutureStreamWith interpolate maxDT a as) where- refineFutureStreamWith :: (a -> a -> a) -> DTime -> a -> FutureSampleStream a -> FutureSampleStream a+ refineFutureStreamWith :: (a -> a -> a)+ -> DTime+ -> a+ -> FutureSampleStream a+ -> FutureSampleStream a refineFutureStreamWith interpolate maxDT _ [] = []- refineFutureStreamWith interpolate maxDT a0 ((dt, a):as)- | dt > maxDT = let a' = interpolate a0 a- in (maxDT, interpolate a0 a) : refineFutureStreamWith interpolate maxDT a' ((dt - maxDT, a):as)- | otherwise = (dt, a) : refineFutureStreamWith interpolate maxDT a as+ refineFutureStreamWith interpolate maxDT a0 ((dt, a) : as)+ | dt > maxDT+ = (maxDT, a')+ : refineFutureStreamWith interpolate maxDT a' ((dt - maxDT, a) : as)+ | otherwise+ = (dt, a) : refineFutureStreamWith interpolate maxDT a as+ where+ a' = interpolate a0 a -- | Clip a sample stream at a given number of samples.-sClipAfterFrame :: Int -> SignalSampleStream a -> SignalSampleStream a-sClipAfterFrame 0 (x,_) = (x, [])-sClipAfterFrame n (x,xs) = (x, xs')+sClipAfterFrame :: Int -> SignalSampleStream a -> SignalSampleStream a+sClipAfterFrame 0 (x, _) = (x, [])+sClipAfterFrame n (x, xs) = (x, xs') where- xs' = take (n-1) xs+ xs' = take (n - 1) xs -- | Clip a sample stream after a certain (non-zero) time.-sClipAfterTime :: DTime -> SignalSampleStream a -> SignalSampleStream a-sClipAfterTime dt (x,xs) = (x, sClipAfterTime' dt xs)+sClipAfterTime :: DTime -> SignalSampleStream a -> SignalSampleStream a+sClipAfterTime dt (x, xs) = (x, sClipAfterTime' dt xs) where sClipAfterTime' dt [] = []- sClipAfterTime' dt ((dt',x):xs)+ sClipAfterTime' dt ((dt', x) : xs) | dt < dt' = []- | otherwise = ((dt',x):sClipAfterTime' (dt - dt') xs)+ | otherwise = (dt', x) : sClipAfterTime' (dt - dt') xs -- | Drop the first n samples of a signal stream. The time -- deltas are not re-calculated. sClipBeforeFrame :: Int -> SignalSampleStream a -> SignalSampleStream a-sClipBeforeFrame 0 (x,xs) = (x,xs)-sClipBeforeFrame n (x,[]) = (x,[])-sClipBeforeFrame n (_,(dt,x):xs) = sClipBeforeFrame (n-1) (x, xs)+sClipBeforeFrame 0 (x, xs) = (x, xs)+sClipBeforeFrame n (x, []) = (x, [])+sClipBeforeFrame n (_, (dt, x) : xs) = sClipBeforeFrame (n - 1) (x, xs) -- | Drop the first samples of a signal stream up to a given time. The time -- deltas are not re-calculated to match the original stream.-sClipBeforeTime :: DTime -> SignalSampleStream a -> SignalSampleStream a+sClipBeforeTime :: DTime -> SignalSampleStream a -> SignalSampleStream a sClipBeforeTime dt xs- | dt <= 0 = xs- | otherwise = case xs of- (x,[]) -> (x,[])- (_,(dt',x'):xs') -> if | dt < dt' -> -- (dt' - dt, x'):xs'- (x',xs')- | otherwise -> sClipBeforeTime (dt - dt') (x', xs')+ | dt <= 0 = xs+ | null (snd xs) = xs+ | dt < dt' = (x', xs')+ | otherwise = sClipBeforeTime (dt - dt') (x', xs')+ where+ (_fstSample, ((dt', x') : xs')) = xs -- ** Stream-based evaluation @@ -143,9 +175,10 @@ -> SignalSampleStream a -> (SignalSampleStream b, FutureSF a b) evalSF sf (a, as) = (outputStrm, fsf')- where (b, fsf) = evalAtZero sf a- (bs, fsf') = evalFutureSF fsf as- outputStrm = (b, bs)+ where+ (b, fsf) = evalAtZero sf a+ (bs, fsf') = evalFutureSF fsf as+ outputStrm = (b, bs) -- | Evaluate an initialised SF with a 'FutureSampleStream', obtaining -- an output stream and a continuation.@@ -155,8 +188,9 @@ evalFutureSF :: FutureSF a b -> FutureSampleStream a -> (FutureSampleStream b, FutureSF a b)-evalFutureSF fsf [] = ([], fsf)-evalFutureSF fsf ((dt, a):as) = (outputStrm, fsf'')- where (b, fsf') = evalAt fsf dt a- (bs, fsf'') = evalFutureSF fsf' as- outputStrm = (dt, b) : bs+evalFutureSF fsf [] = ([], fsf)+evalFutureSF fsf ((dt, a) : as) = (outputStrm, fsf'')+ where+ (b, fsf') = evalAt fsf dt a+ (bs, fsf'') = evalFutureSF fsf' as+ outputStrm = (dt, b) : bs
yampa-test.cabal view
@@ -31,7 +31,7 @@ build-type: Simple name: yampa-test-version: 0.14.1+version: 0.14.2 author: Ivan Perez maintainer: ivan.perez@keera.co.uk homepage: http://github.com/ivanperez-keera/Yampa@@ -56,8 +56,8 @@ <https://dl.acm.org/citation.cfm?id=3110246 Testing and Debugging Functional Reactive Programming>. extra-source-files:- CHANGELOG-+ CHANGELOG+ , examples/Testing.hs source-repository head type: git@@ -84,7 +84,7 @@ base >= 4 && < 5 , normaldistribution , QuickCheck- , Yampa >= 0.14.1 && < 0.15+ , Yampa >= 0.14.2 && < 0.15 default-language: Haskell2010