diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +2023-04-07 Ivan Perez + * 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 * Yampa.cabal: Version bump (0.14.1) (#251). * tests/: add tests for module FRP.Yampa.Hybrid (#243), add tests for diff --git a/examples/Testing.hs b/examples/Testing.hs new file mode 100644 --- /dev/null +++ b/examples/Testing.hs @@ -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 diff --git a/src/FRP/Yampa/Debug.hs b/src/FRP/Yampa/Debug.hs --- a/src/FRP/Yampa/Debug.hs +++ b/src/FRP/Yampa/Debug.hs @@ -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)) diff --git a/src/FRP/Yampa/LTLFuture.hs b/src/FRP/Yampa/LTLFuture.hs --- a/src/FRP/Yampa/LTLFuture.hs +++ b/src/FRP/Yampa/LTLFuture.hs @@ -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) diff --git a/src/FRP/Yampa/LTLPast.hs b/src/FRP/Yampa/LTLPast.hs --- a/src/FRP/Yampa/LTLPast.hs +++ b/src/FRP/Yampa/LTLPast.hs @@ -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) diff --git a/src/FRP/Yampa/QuickCheck.hs b/src/FRP/Yampa/QuickCheck.hs --- a/src/FRP/Yampa/QuickCheck.hs +++ b/src/FRP/Yampa/QuickCheck.hs @@ -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) diff --git a/src/FRP/Yampa/Stream.hs b/src/FRP/Yampa/Stream.hs --- a/src/FRP/Yampa/Stream.hs +++ b/src/FRP/Yampa/Stream.hs @@ -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 diff --git a/yampa-test.cabal b/yampa-test.cabal --- a/yampa-test.cabal +++ b/yampa-test.cabal @@ -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 @@ . 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