summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorConalElliott <>2009-05-21 23:43:16 (GMT)
committerLuite Stegeman <luite@luite.com>2009-05-21 23:43:16 (GMT)
commit704f644010d96882ede7fbcb7b37e25ceede6dd1 (patch)
tree90ee7661e4b3bd658a348dba087d442fc4b98884 /src
parent8449c2fa0fc00450bc882f30486a64c9f3a41945 (diff)
version 0.10.70.10.7
Diffstat (limited to 'src')
-rwxr-xr-xsrc/Data/AddBounds.hs137
-rwxr-xr-xsrc/FRP/Reactive.hs2
-rwxr-xr-xsrc/FRP/Reactive/Behavior.hs39
-rwxr-xr-xsrc/FRP/Reactive/Future.hs33
-rwxr-xr-xsrc/FRP/Reactive/Improving.hs75
-rwxr-xr-xsrc/FRP/Reactive/Internal/Behavior.hs2
-rwxr-xr-xsrc/FRP/Reactive/Internal/Future.hs41
-rwxr-xr-xsrc/FRP/Reactive/Internal/IVar.hs3
-rwxr-xr-xsrc/FRP/Reactive/Internal/Reactive.hs101
-rwxr-xr-xsrc/FRP/Reactive/Internal/TVal.hs110
-rwxr-xr-xsrc/FRP/Reactive/Internal/Timing.hs41
-rwxr-xr-xsrc/FRP/Reactive/LegacyAdapters.hs5
-rw-r--r--src/FRP/Reactive/Num-inc.hs15
-rwxr-xr-xsrc/FRP/Reactive/PrimReactive.hs402
-rwxr-xr-xsrc/FRP/Reactive/Reactive.hs119
-rw-r--r--src/Test/Integ.hs48
-rw-r--r--src/Test/Merge.hs89
-rwxr-xr-xsrc/Test/Reactive.hs2
-rw-r--r--src/Test/SimpleFilter.hs92
19 files changed, 951 insertions, 405 deletions
diff --git a/src/Data/AddBounds.hs b/src/Data/AddBounds.hs
index 1d4b752..262085c 100755
--- a/src/Data/AddBounds.hs
+++ b/src/Data/AddBounds.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
@@ -15,7 +16,9 @@ module Data.AddBounds (AddBounds(..)) where
import Control.Applicative (pure,(<$>))
--- import Data.Unamb (unamb)
+import Data.Unamb (unamb)
+
+import Data.AffineSpace
-- Testing
import Test.QuickCheck
@@ -44,61 +47,81 @@ instance Bounded (AddBounds a) where
-- (NoBound a) `min` (NoBound b) can return partial information from
-- a `min` b while the default implementation cannot.
-instance Ord a => Ord (AddBounds a) where
- MinBound <= _ = True
- NoBound _ <= MinBound = False
- NoBound a <= NoBound b = a <= b
- NoBound _ <= MaxBound = True
- MaxBound <= MaxBound = True
- MaxBound <= _ = False -- given previous
+-- instance Ord a => Ord (AddBounds a) where
+-- MinBound <= _ = True
+-- NoBound _ <= MinBound = False
+-- NoBound a <= NoBound b = a <= b
+-- NoBound _ <= MaxBound = True
+-- MaxBound <= MaxBound = True
+-- MaxBound <= _ = False -- given previous
- MinBound `min` _ = MinBound
- _ `min` MinBound = MinBound
- NoBound a `min` NoBound b = NoBound (a `min` b)
- u `min` MaxBound = u
- MaxBound `min` v = v
+-- MinBound `min` _ = MinBound
+-- _ `min` MinBound = MinBound
+-- NoBound a `min` NoBound b = NoBound (a `min` b)
+-- u `min` MaxBound = u
+-- MaxBound `min` v = v
- MinBound `max` v = v
- u `max` MinBound = u
- NoBound a `max` NoBound b = NoBound (a `max` b)
- _ `max` MaxBound = MaxBound
- MaxBound `max` _ = MaxBound
+-- MinBound `max` v = v
+-- u `max` MinBound = u
+-- NoBound a `max` NoBound b = NoBound (a `max` b)
+-- _ `max` MaxBound = MaxBound
+-- MaxBound `max` _ = MaxBound
--- Richard Smith (lilac) contributed this code for lazier methods.
--- MaxBound `max` undefined can return full information while the default
--- implementation cannot. And likewise undefined `max` MaxBound.
+-- The definition above is too strict for some uses. Here's a parallel
+-- version.
--- instance Ord a => Ord (AddBounds a) where
--- a <= b = c1 a b `unamb` c2 a b
--- where c1 MinBound _ = True
--- c1 _ MinBound = False
--- c1 (NoBound a') (NoBound b') = a' < b'
--- c1 MaxBound (NoBound _) = False
--- c1 _ _ = undefined
--- c2 _ MaxBound = True
--- c2 _ _ = undefined
--- a `min` b = c1 a b `unamb` c2 a b
--- where c1 MinBound _ = MinBound
--- c1 (NoBound a') (NoBound b') = NoBound $ a' `max` b'
--- c1 (NoBound _ ) MaxBound = a
--- c1 MaxBound (NoBound _ ) = b
--- c1 MaxBound MaxBound = MaxBound
--- c1 _ _ = undefined
--- c2 _ MinBound = MinBound
--- c2 _ _ = undefined
--- a `max` b = c1 a b `unamb` c2 a b
--- where c1 MaxBound _ = MaxBound
--- c1 (NoBound a') (NoBound b') = NoBound $ a' `max` b'
--- c1 (NoBound _ ) MinBound = a
--- c1 MinBound (NoBound _ ) = b
--- c1 MinBound MinBound = MinBound
--- c1 _ _ = undefined
--- c2 _ MaxBound = MaxBound
--- c2 _ _ = undefined
-
--- This second instance has a strange delays in a reactive-fieldtrip
--- program. My mouse click isn't responded to until I move the mouse.
+
+-- Alternatively, make a non-parallel definition here and use 'pmin'
+-- instead of 'min' where I want.
+
+
+-- General recipe for Ord methods: use unamb to try two strategies. The
+-- first one, "justB", only examines b. The second one first examines
+-- only examines a and then examines both. I take care that the two
+-- strategies handle disjoint inputs. I could instead let the second
+-- strategy handle the first one redundantly, being careful that they
+-- agree.
+
+-- This instance is very like the one Richard Smith (lilac) constructed.
+-- It fixes a couple of small bugs and follows a style that helps me see
+-- that I'm covering all of the cases with the evaluation order I want.
+
+instance Ord a => Ord (AddBounds a) where
+ a <= b = justB b `unamb` (a <=* b)
+ where
+ justB MaxBound = True
+ justB _ = undefined
+
+ MinBound <=* _ = True
+ _ <=* MinBound = False
+ NoBound u <=* NoBound v = u <= v
+ MaxBound <=* NoBound _ = False
+ _ <=* MaxBound = undefined
+
+ a `min` b = justB b `unamb` (a `min'` b)
+ where
+ justB MinBound = MinBound
+ justB MaxBound = a
+ justB (NoBound _) = undefined
+
+ MinBound `min'` _ = MinBound
+ MaxBound `min'` v = v
+ NoBound u `min'` NoBound v = NoBound (u `min` v)
+ _ `min'` MinBound = undefined
+ _ `min'` MaxBound = undefined
+
+ a `max` b = justB b `unamb` (a `max'` b)
+ where
+ justB MaxBound = MaxBound
+ justB MinBound = a
+ justB (NoBound _) = undefined
+
+ MaxBound `max'` _ = MaxBound
+ MinBound `max'` v = v
+ NoBound u `max'` NoBound v = NoBound (u `max` v)
+ _ `max'` MaxBound = undefined
+ _ `max'` MinBound = undefined
instance Arbitrary a => Arbitrary (AddBounds a) where
@@ -112,3 +135,15 @@ instance Arbitrary a => Arbitrary (AddBounds a) where
instance (EqProp a, Eq a) => EqProp (AddBounds a) where
NoBound a =-= NoBound b = a =-= b
u =-= v = u `eq` v
+
+
+-- Hm. I'm dissatisfied with this next instance. I'd like to tweak my
+-- type definitions to eliminate these partial definitions.
+
+instance AffineSpace t => AffineSpace (AddBounds t) where
+ type Diff (AddBounds t) = Diff t
+ NoBound u .-. NoBound v = u .-. v
+ -- I don't know what to do here
+ _ .-. _ = error "(.-.) on AddBounds: only defined on NoBound args"
+ NoBound u .+^ v = NoBound (u .+^ v)
+ _ .+^ _ = error "(.+^) on AddBounds: only defined on NoBound args"
diff --git a/src/FRP/Reactive.hs b/src/FRP/Reactive.hs
index 46aaad3..1840651 100755
--- a/src/FRP/Reactive.hs
+++ b/src/FRP/Reactive.hs
@@ -22,12 +22,12 @@ module FRP.Reactive
, mealy, mealy_, countE, countE_, diffE
, withPrevE, withPrevEWith
, eitherE
+ , justE, filterE
-- ** More esoteric
, listE, atTimes, atTime, once
, firstRestE, firstE, restE, snapRemainderE
, withRestE, untilE
, splitE, switchE
- , justE, filterE
-- ** Useful with events.
, joinMaybes, filterMP
-- * Behaviors
diff --git a/src/FRP/Reactive/Behavior.hs b/src/FRP/Reactive/Behavior.hs
index 76793d6..0b4eb95 100755
--- a/src/FRP/Reactive/Behavior.hs
+++ b/src/FRP/Reactive/Behavior.hs
@@ -34,18 +34,23 @@ import Control.Comonad
import Control.Compose ((:.)(..))
import Data.VectorSpace
+import Data.AffineSpace
import qualified FRP.Reactive.Reactive as R
import FRP.Reactive.Reactive
- ( TimeT, EventG, ReactiveG
+ ( ImpBounds, TimeT, EventG, ReactiveG
, withTimeE,onceRestE,diffE,joinMaybes,result)
import FRP.Reactive.Fun
-import FRP.Reactive.Improving
+-- import FRP.Reactive.Improving
import FRP.Reactive.Internal.Behavior
-type EventI t = EventG (Improving t)
-type ReactiveI t = ReactiveG (Improving t)
-type BehaviorI t = BehaviorG (Improving t) t
+-- type EventI t = EventG (Improving t)
+-- type ReactiveI t = ReactiveG (Improving t)
+-- type BehaviorI t = BehaviorG (Improving t) t
+
+type EventI t = EventG (ImpBounds t)
+type ReactiveI t = ReactiveG (ImpBounds t)
+type BehaviorI t = BehaviorG (ImpBounds t) t
-- | Time-specialized behaviors.
-- Note: The signatures of all of the behavior functions can be generalized. Is
@@ -59,7 +64,7 @@ type Behaviour = Behavior
-- | The identity generalized behavior. Has value @t@ at time @t@.
--
-- > time :: Behavior TimeT
-time :: Ord t => BehaviorI t t
+time :: (Ord t) => BehaviorI t t
time = beh (pure (fun id))
-- Turn a reactive value into a discretly changing behavior.
@@ -89,7 +94,7 @@ stepper = (result.result) rToB R.stepper
-- | Switch between behaviors.
--
-- > switcher :: Behavior a -> Event (Behavior a) -> Behavior a
-switcher :: (Ord tr) =>
+switcher :: (Ord tr, Bounded tr) =>
BehaviorG tr tf a
-> EventG tr (BehaviorG tr tf a)
-> BehaviorG tr tf a
@@ -100,7 +105,7 @@ b `switcher` eb = beh (unb b `R.switcher` (unb <$> eb))
-- arguments and results.
--
-- > snapshotWith :: (a -> b -> c) -> Behavior b -> Event a -> Event c
-snapshotWith :: Ord t =>
+snapshotWith :: (Ord t) =>
(a -> b -> c)
-> BehaviorI t b -> EventI t a -> EventI t c
snapshotWith h b e = f <$> (unb b `R.snapshot` withTimeE e)
@@ -120,7 +125,7 @@ snapshotWith h b e = f <$> (unb b `R.snapshot` withTimeE e)
-- results.
--
-- > snapshot :: Behavior b -> Event a -> Event (a,b)
-snapshot :: Ord t => BehaviorI t b -> EventI t a -> EventI t (a,b)
+snapshot :: (Ord t) => BehaviorI t b -> EventI t a -> EventI t (a,b)
snapshot = snapshotWith (,)
-- TODO: tweak withTimeE so that 'snapshotWith' and 'snapshot' can have
@@ -134,7 +139,7 @@ snapshot = snapshotWith (,)
-- | Like 'snapshot' but discarding event data (often @a@ is '()').
--
-- > snapshot_ :: Behavior b -> Event a -> Event b
-snapshot_ :: Ord t => BehaviorI t b -> EventI t a -> EventI t b
+snapshot_ :: (Ord t) => BehaviorI t b -> EventI t a -> EventI t b
snapshot_ = snapshotWith (flip const)
-- Alternative implementations
@@ -144,7 +149,7 @@ snapshot_ = snapshotWith (flip const)
-- | Filter an event according to whether a reactive boolean is true.
--
-- > whenE :: Behavior Bool -> Event a -> Event a
-whenE :: Ord t => BehaviorI t Bool -> EventI t a -> EventI t a
+whenE :: (Ord t) => BehaviorI t Bool -> EventI t a -> EventI t a
b `whenE` e = joinMaybes (h <$> (b `snapshot` e))
where
h (a,True) = Just a
@@ -197,7 +202,7 @@ accumB = (result.result) rToB R.accumR
-- TODO: generalize scanlB's type
-scanlB :: forall a b tr tf. Ord tr =>
+scanlB :: forall a b tr tf. (Ord tr, Bounded tr) =>
(b -> BehaviorG tr tf a -> BehaviorG tr tf a)
-> BehaviorG tr tf a
-> EventG tr b -> BehaviorG tr tf a
@@ -213,7 +218,7 @@ scanlB plus zero = h
-- 'scanlB', using 'mappend' and 'mempty'. See also 'monoidE'.
--
-- > monoidB :: Monoid a => Event (Behavior a) -> Behavior a
-monoidB :: (Ord tr, Monoid a) => EventG tr (BehaviorG tr tf a)
+monoidB :: (Ord tr, Bounded tr, Monoid a) => EventG tr (BehaviorG tr tf a)
-> BehaviorG tr tf a
monoidB = scanlB mappend mempty
@@ -228,7 +233,7 @@ sumB = result rToB R.sumR
-- 'mempty' for the second event.
--
-- > maybeB :: Event a -> Event b -> Behavior (Maybe a)
-maybeB :: Ord t =>
+maybeB :: (Ord t) =>
EventI t a -> EventI t b -> BehaviorI t (Maybe a)
maybeB = (result.result) rToB R.maybeR
@@ -236,7 +241,7 @@ maybeB = (result.result) rToB R.maybeR
-- false whenever the second event occurs.
--
-- > flipFlop :: Event a -> Event b -> Behavior Bool
-flipFlop :: Ord t => EventI t a -> EventI t b -> BehaviorI t Bool
+flipFlop :: (Ord t) => EventI t a -> EventI t b -> BehaviorI t Bool
flipFlop = (result.result) rToB R.flipFlop
-- | Count occurrences of an event. See also 'countE'.
@@ -249,11 +254,11 @@ countB = result rToB R.countR
--
-- > integral :: (VectorSpace v, Scalar v ~ TimeT) =>
-- > Event () -> Behavior v -> Behavior v
-integral :: (Scalar v ~ t, Ord t, VectorSpace v, Num t) =>
+integral :: (VectorSpace v, AffineSpace t, Scalar v ~ Diff t, Ord t) =>
EventI t a -> BehaviorI t v -> BehaviorI t v
integral t b = sumB (snapshotWith (*^) b (diffE (time `snapshot_` t)))
--- Yow! That's a mouth full!
+-- TODO: This integral definition is piecewise-constant. Change to piecewise-linear.
-- TODO: find out whether this integral works recursively. If not, then
diff --git a/src/FRP/Reactive/Future.hs b/src/FRP/Reactive/Future.hs
index f655271..f09056e 100755
--- a/src/FRP/Reactive/Future.hs
+++ b/src/FRP/Reactive/Future.hs
@@ -44,11 +44,11 @@
-- values/.
----------------------------------------------------------------------
-module FRP.Reactive.Future
+module FRP.Reactive.Future
(
-- * Time & futures
Time, ftime
- , FutureG(..), inFuture, inFuture2, futTime, futVal, future
+ , FutureG(..), isNeverF, inFuture, inFuture2, futTime, futVal, future
, withTimeF
-- * Tests
, batch
@@ -57,7 +57,7 @@ module FRP.Reactive.Future
import Data.Monoid (Monoid(..))
import Data.Max
-import Data.AddBounds
+-- import Data.AddBounds
import FRP.Reactive.Internal.Future
-- Testing
@@ -71,14 +71,22 @@ import Test.QuickCheck.Classes
-- | Make a finite time
ftime :: t -> Time t
-ftime = Max . NoBound
+ftime = Max
-- FutureG representation in Internal.Future
-instance (EqProp t, Eq t, EqProp a) => EqProp (FutureG t a) where
- Future (Max MaxBound,_) =-= Future (Max MaxBound,_) = property True
+instance (Bounded t, Eq t, EqProp t, EqProp a) => EqProp (FutureG t a) where
+ u =-= v | isNeverF u && isNeverF v = property True
Future a =-= Future b = a =-= b
+-- I'd rather say:
+--
+-- instance (Bounded t, EqProp t, EqProp a) => EqProp (FutureG t a) where
+-- Future a =-= Future b =
+-- (fst a =-= maxBound && fst b =-= maxBound) .|. a =-= b
+--
+-- However, I don't know how to define disjunction on QuickCheck properties.
+
-- | A future's time
futTime :: FutureG t a -> Time t
futTime = fst . unFuture
@@ -102,7 +110,7 @@ withTimeF = inFuture $ \ (t,a) -> (t,(t,a))
-- below. For one thing, the current instance makes Future a monoid but
-- unFuture not be a monoid morphism.
-instance Ord t => Monoid (FutureG t a) where
+instance (Ord t, Bounded t) => Monoid (FutureG t a) where
mempty = Future (maxBound, error "Future mempty: it'll never happen, buddy")
-- Pick the earlier future.
Future (s,a) `mappend` Future (t,b) =
@@ -145,6 +153,11 @@ instance Ord t => Monoid (FutureG t a) where
newtype TimeInfo t = TimeInfo (Maybe t)
deriving EqProp
+instance Bounded t => Bounded (TimeInfo t) where
+ minBound = TimeInfo (Just minBound)
+ maxBound = TimeInfo Nothing
+
+
-- A time at a given instant can be some unknown time in the future
unknownTimeInFuture :: TimeInfo a
unknownTimeInFuture = TimeInfo Nothing
@@ -198,10 +211,14 @@ batch = ( "FRP.Reactive.Future"
]
)
where
- laziness :: NumT -> T -> Property
+ laziness :: BoundedT -> T -> Property
laziness t a = (uf `mappend` uf) `mappend` kf =-= kf
where
uf = unknownFuture
kf = knownFuture
knownFuture = future (knownTimeInPast t) a
unknownFuture = future unknownTimeInFuture (error "cannot retrieve value at unknown time at the future")
+
+
+-- Move to checkers
+type BoundedT = Int
diff --git a/src/FRP/Reactive/Improving.hs b/src/FRP/Reactive/Improving.hs
index 910d5b8..40588f6 100755
--- a/src/FRP/Reactive/Improving.hs
+++ b/src/FRP/Reactive/Improving.hs
@@ -21,9 +21,9 @@ module FRP.Reactive.Improving
import Data.Function (on)
import Text.Show.Functions ()
-import Control.Applicative (pure,(<$>))
+import Control.Applicative (pure,(<$>),liftA2)
-import Data.Unamb (unamb,asAgree,parCommute)
+import Data.Unamb (unamb,parCommute,pmin,pmax)
import Test.QuickCheck hiding (evaluate)
-- import Test.QuickCheck.Instances
@@ -52,14 +52,14 @@ before :: Ord a => a -> Improving a
before x = Imp undefined comp
where
comp y | x <= y = LT
- | otherwise = undefined
+ | otherwise = error "before: comparing before"
-- | A value known to be @> x@.
after :: Ord a => a -> Improving a
after x = Imp undefined comp
where
comp y | x >= y = GT
- | otherwise = undefined
+ | otherwise = error "after: comparing after"
instance Eq a => Eq (Improving a) where
@@ -68,15 +68,15 @@ instance Eq a => Eq (Improving a) where
-- exactly.
(==) = parCommute (\ u v -> u `compareI` exact v == EQ)
+-- TODO: experiment with these two versions of (==). The 'parCommute' one
+-- can return 'False' sooner than the simpler def, but I doubt it'll
+-- return 'True' any sooner.
+
instance Ord a => Ord (Improving a) where
min = (result.result) fst minI
(<=) = (result.result) snd minI
max = (result.result) fst maxI
--- instance Ord a => Ord (Improving a) where
--- s `min` t = fst (s `minI` t)
--- s <= t = snd (s `minI` t)
-
-- | Efficient combination of 'min' and '(<=)'
minI :: Ord a => Improving a -> Improving a -> (Improving a,Bool)
~(Imp u uComp) `minI` ~(Imp v vComp) = (Imp uMinV wComp, uLeqV)
@@ -84,13 +84,16 @@ minI :: Ord a => Improving a -> Improving a -> (Improving a,Bool)
uMinV = if uLeqV then u else v
-- u <= v: Try @v `compare` u /= LT@ and @u `compare` v /= GT@.
uLeqV = (vComp u /= LT) `unamb` (uComp v /= GT)
- -- (u `min` v) `compare` t: Try comparing according to whether u <= v,
- -- or go with either answer if they agree, e.g., if both say GT.
- wComp t = minComp `unamb` (uCt `asAgree` vCt)
- where
- minComp = if uLeqV then uCt else vCt
- uCt = uComp t
- vCt = vComp t
+ wComp = liftA2 pmin uComp vComp
+
+-- -- (u `min` v) `compare` t: Try comparing according to whether u <= v,
+-- -- or go with either answer if they agree, e.g., if both say GT.
+-- -- And say GT if either comp says LT.
+-- wComp t = (uCt `asAgree` LT `unamb` vCt `asAgree` LT) -- LT cases
+-- `unamb` (uCt `min` vCt) -- EQ and GT case
+-- where
+-- uCt = uComp t
+-- vCt = vComp t
-- | Efficient combination of 'max' and '(>=)'
maxI :: Ord a => Improving a -> Improving a -> (Improving a,Bool)
@@ -99,13 +102,18 @@ maxI :: Ord a => Improving a -> Improving a -> (Improving a,Bool)
uMaxV = if uGeqV then u else v
-- u >= v: Try @v `compare` u /= GT@ and @u `compare` v /= LT@.
uGeqV = (vComp u /= GT) `unamb` (uComp v /= LT)
- -- (u `max` v) `compare` t: Try comparing according to whether u >= v,
- -- or go with either answer if they agree, e.g., if both say LT.
- wComp t = maxComp `unamb` (uCt `asAgree` vCt)
- where
- maxComp = if uGeqV then uCt else vCt
- uCt = uComp t
- vCt = vComp t
+ wComp = liftA2 pmax uComp vComp
+
+-- -- (u `max` v) `compare` t: Try comparing according to whether u >= v,
+-- -- or go with either answer if they agree, e.g., if both say LT.
+-- -- And say LT if either comp says GT.
+-- wComp t = (uCt `asAgree` GT `unamb` vCt `asAgree` GT) -- GT cases
+-- `unamb` (uCt `max` vCt) -- EQ and LT case
+-- where
+-- uCt = uComp t
+-- vCt = vComp t
+
+-- TODO: reconsider these wComp tests and look for a smaller set.
-- TODO: factor commonality out of 'minI' and 'maxI' or combine into
-- a single function.
@@ -118,10 +126,25 @@ maxI :: Ord a => Improving a -> Improving a -> (Improving a,Bool)
-- advantage of a knowably infinite value, which I use in a lot of
-- optimization, including filter/join.
-instance Bounded (Improving a) where
- minBound = error "minBound not defined on Improving"
- maxBound = Imp (error "exact maxBound")
- (const GT)
+-- instance Bounded (Improving a) where
+-- minBound = error "minBound not defined on Improving"
+-- maxBound = Imp (error "exact maxBound")
+-- (const GT)
+
+instance (Ord a, Bounded a) => Bounded (Improving a) where
+ minBound = exactly minBound
+ maxBound = exactly maxBound
+
+-- Hack: use 0 as lower bound
+-- No, this one won't work, because I'll need to extract the exact value
+-- in order to compare with maxBound
+
+-- instance (Ord a, Num a) => Bounded (Improving a) where
+-- minBound = exactly 0
+-- maxBound = -- exactly maxBound
+-- Imp (error "Improving maxBound evaluated")
+-- (const GT)
+
-- TODO: consider 'undefined' instead 'error', for 'unamb'. However, we
-- lose valuable information if the 'undefined' gets forced with no
diff --git a/src/FRP/Reactive/Internal/Behavior.hs b/src/FRP/Reactive/Internal/Behavior.hs
index 132ec1b..ffec0d4 100755
--- a/src/FRP/Reactive/Internal/Behavior.hs
+++ b/src/FRP/Reactive/Internal/Behavior.hs
@@ -66,7 +66,7 @@ instance (Applicative (R.ReactiveG tr :. Fun tf), Monoid a)
{ mempty = pure mempty; mappend = liftA2 mappend }
-- Standard 'Zip' for an 'Applicative'
-instance Ord tr => Zip (BehaviorG tr tf) where zip = liftA2 (,)
+instance (Ord tr, Bounded tr) => Zip (BehaviorG tr tf) where zip = liftA2 (,)
-- Standard 'Unzip' for a 'Functor'
instance Unzip (BehaviorG tr tf) where {fsts = fmap fst; snds = fmap snd}
diff --git a/src/FRP/Reactive/Internal/Future.hs b/src/FRP/Reactive/Internal/Future.hs
index aa5b2f5..07d7ce3 100755
--- a/src/FRP/Reactive/Internal/Future.hs
+++ b/src/FRP/Reactive/Internal/Future.hs
@@ -16,7 +16,7 @@ module FRP.Reactive.Internal.Future
(
-- * Time & futures
Time
- , FutureG(..), inFuture, inFuture2
+ , FutureG(..), isNeverF, inFuture, inFuture2
, runF
) where
@@ -29,22 +29,40 @@ import Test.QuickCheck
import FRP.Reactive.Internal.Misc (Sink)
import Data.Max
-import Data.AddBounds
import Data.PairMonad ()
--- | Time used in futures. The parameter @t@ can be any @Ord@ type. The
--- added bounds represent -Infinity and +Infinity. Pure values have time
--- minBound (-Infinity), while never-occurring futures have time maxBound
--- (+Infinity).
-type Time t = Max (AddBounds t)
+-- | Time used in futures. The parameter @t@ can be any @Ord@ and
+-- @Bounded@ type. Pure values have time 'minBound', while
+-- never-occurring futures have time 'maxBound.'
+-- type Time t = Max (AddBounds t)
+
+type Time = Max
-- | A future value of type @a@ with time type @t@. Simply a
-- time\/value pair. Particularly useful with time types that have
-- non-flat structure.
newtype FutureG t a = Future { unFuture :: (Time t, a) }
- deriving (Functor, Applicative, Monad, Copointed, Comonad, Show, Arbitrary)
+ deriving (Functor, Applicative, Monad, Copointed, Comonad {-, Show-}, Arbitrary)
+
+isNeverF :: (Bounded t, Eq t) => FutureG t t1 -> Bool
+isNeverF (Future (t,_)) = t == maxBound
+
+instance (Eq t, Eq a, Bounded t) => Eq (FutureG t a) where
+ Future a == Future b =
+ (fst a == maxBound && fst b == maxBound) || a == b
+
+-- When I drop @AddBounds@, I use @maxBound@ as infinity/never. I'm
+-- uncomfortable with this choice, however. Consider a small type like
+-- @Bool@ for @t@.
+
+
+instance (Show t, Show a, Eq t, Bounded t) => Show (FutureG t a) where
+-- show (Future (Max t, a)) | t == maxBound = "<never>"
+-- | otherwise = "<" ++ show t ++ "," ++ show a ++ ">"
+ show u | isNeverF u = "<never>"
+ show (Future (Max t, a)) = "<" ++ show t ++ "," ++ show a ++ ">"
-- The 'Applicative' and 'Monad' instances rely on the 'Monoid' instance
-- of 'Max'.
@@ -64,9 +82,4 @@ inFuture2 f = inFuture . f . unFuture
-- | Run a future in the current thread. Use the given time sink to sync
-- time, i.e., to wait for an output time before performing the action.
runF :: Ord t => Sink t -> FutureG t (IO a) -> IO a
-runF sync (Future (Max t,io)) = tsync t >> io
- where
- tsync MinBound = putStrLn "runE: skipping MinBound"
- tsync (NoBound t') = sync t'
- tsync MaxBound = error "runE: infinite wait"
-
+runF sync (Future (Max t,io)) = sync t >> io
diff --git a/src/FRP/Reactive/Internal/IVar.hs b/src/FRP/Reactive/Internal/IVar.hs
index 3819440..6e77ce9 100755
--- a/src/FRP/Reactive/Internal/IVar.hs
+++ b/src/FRP/Reactive/Internal/IVar.hs
@@ -29,7 +29,8 @@ newIVar = IVar <$> newEmptyMVar
-- | Returns the value in the IVar. The *value* will block
-- until the variable becomes filled.
readIVar :: IVar a -> a
-readIVar (IVar v) = unsafePerformIO $ readMVar v
+readIVar (IVar v) = unsafePerformIO $ do -- putStrLn "readIVar"
+ readMVar v
-- | Returns Nothing if the IVar has no value yet, otherwise
-- returns the value.
diff --git a/src/FRP/Reactive/Internal/Reactive.hs b/src/FRP/Reactive/Internal/Reactive.hs
index 143af38..1eec1d0 100755
--- a/src/FRP/Reactive/Internal/Reactive.hs
+++ b/src/FRP/Reactive/Internal/Reactive.hs
@@ -21,19 +21,19 @@
module FRP.Reactive.Internal.Reactive
(
- EventG(..), inEvent, inEvent2, eFutures
+ EventG(..), isNeverE, inEvent, inEvent2, eFutures
, ReactiveG(..), inREvent, inFutR
, runE, runR, forkE, forkR
) where
-import Data.List (intersperse)
+-- import Data.List (intersperse)
import Control.Concurrent (forkIO,ThreadId)
import FRP.Reactive.Internal.Misc
import FRP.Reactive.Internal.Future
import Data.Max
-import Data.AddBounds
+-- import Data.AddBounds
-- | Events. Semantically: time-ordered list of future values.
-- Instances:
@@ -145,40 +145,66 @@ inFutR = inREvent . inEvent
Showing values (exposing rep)
--------------------------------------------------------------------}
+isNeverE :: (Bounded t, Eq t) => EventG t a -> Bool
+isNeverE = isNeverF . eFuture
+
-- | Make the event into a list of futures
-eFutures :: EventG t a -> [FutureG t a]
-eFutures (Event (Future (Max MaxBound,_))) = []
+eFutures :: (Bounded t, Eq t) => EventG t a -> [FutureG t a]
+eFutures e | isNeverE e = []
eFutures (Event (Future (t,a `Stepper` e))) = Future (t,a) : eFutures e
-- TODO: redefine 'eFutures' as an unfold
+-- TODO: does this isNeverE interfere with laziness? Does it need an unamb?
-- Show a future
sFuture :: (Show t, Show a) => FutureG t a -> String
-sFuture (Future (Max MinBound,a)) = "(-infty," ++ show a ++ ")"
-sFuture (Future (Max MaxBound,_)) = "(infty,_)"
-sFuture (Future (Max (NoBound t),a)) = "(" ++ show t ++ "," ++ show a ++ ")"
+sFuture = show . unFuture
+
+-- sFuture (Future (Max MinBound,a)) = "(-infty," ++ show a ++ ")"
+-- sFuture (Future (Max MaxBound,_)) = "(infty,_)"
+-- sFuture (Future (Max (NoBound t),a)) = "(" ++ show t ++ "," ++ show a ++ ")"
-- TODO: Better re-use in sFuture.
-- Truncated show
sFutures :: (Show t, Show a) => [FutureG t a] -> String
-sFutures fs =
- let maxleng = 20
- a = (intersperse "->" . map sFuture) fs
- inf = length (take maxleng a) == maxleng
- in
- if not inf then concat a
- else concat (take maxleng a) ++ "..."
+
+-- sFutures = show
+
+-- This next implementation blocks all output until far future occurrences
+-- are detected, which causes problems for debugging. I like the "...",
+-- so look for another implementation.
+
+-- sFutures fs =
+-- let maxleng = 20
+-- a = (intersperse "->" . map sFuture) fs
+-- inf = length (take maxleng a) == maxleng
+-- in
+-- if not inf then concat a
+-- else concat (take maxleng a) ++ "..."
+
+-- This version uses a lazier intersperse
+-- sFutures = take 100 . concat . intersperse' "->" . map sFuture
+
+-- The following version adds "..." in case of truncation.
+
+sFutures fs = leading early ++ trailing late
+ where
+ (early,late) = splitAt 20 fs
+ leading = concat . intersperse' "->" . map sFuture
+ trailing [] = ""
+ trailing _ = "-> ..."
+
-- TODO: clean up sFutures def: use intercalate, concat before trimming,
-- and define&use a general function for truncating and adding "...".
-- Test.
-instance (Show a, Show b) => Show (EventG a b) where
- show = sFutures . eFutures
+instance (Eq t, Bounded t, Show t, Show a) => Show (EventG t a) where
+ show = ("Event: " ++) . sFutures . eFutures
-instance (Show x, Show y) => Show (ReactiveG x y) where
+instance (Eq t, Bounded t, Show t, Show a) => Show (ReactiveG t a) where
show (x `Stepper` e) = show x ++ " `Stepper` " ++ show e
@@ -188,19 +214,17 @@ instance (Show x, Show y) => Show (ReactiveG x y) where
-- | Run an event in the current thread. Use the given time sink to sync
-- time, i.e., to wait for an output time before performing the action.
-runE :: forall t. Ord t => Sink t -> Sink (EventG t Action)
-runE sync ~(Event (Future (Max bt,r))) = tsync bt (runR sync r)
- where
- tsync :: AddBounds t -> Sink Action
- tsync MinBound = id -- no wait
- tsync (NoBound t) = (sync t >>) -- wait
- tsync MaxBound = const (return ()) -- finished!
+runE :: forall t. (Ord t, Bounded t) => Sink t -> Sink (EventG t Action)
+runE sync ~(Event (Future (Max t,r)))
+ | t == maxBound = return () -- finished!
+ | otherwise = sync t >> runR sync r
+
+-- In most cases, the value of t won't be known ahead of time, so just
+-- evaluating t will do the necessary waiting.
--- TODO: I'm not sure about the MaxBound case. We could instead just wait
--- forever (cheaply). Try out this terminating definition instead.
-- | Run an event in a new thread, using the given time sink to sync time.
-forkE :: Ord t => Sink t -> EventG t Action -> IO ThreadId
+forkE :: (Ord t, Bounded t) => Sink t -> EventG t Action -> IO ThreadId
forkE = (fmap.fmap) forkIO runE
-- TODO: Revisit this tsync definition. For instance, maybe the MaxBound
@@ -208,10 +232,27 @@ forkE = (fmap.fmap) forkIO runE
-- | Run a reactive value in the current thread, using the given time sink
-- to sync time.
-runR :: Ord t => Sink t -> Sink (ReactiveG t Action)
+runR :: (Bounded t, Ord t) => Sink t -> Sink (ReactiveG t Action)
runR sync (act `Stepper` e) = act >> runE sync e
-- | Run a reactive value in a new thread, using the given time sink to
-- sync time. The initial action happens in the current thread.
-forkR :: Ord t => Sink t -> ReactiveG t Action -> IO ThreadId
+forkR :: (Ord t, Bounded t) => Sink t -> ReactiveG t Action -> IO ThreadId
forkR = (fmap.fmap) forkIO runR
+
+-----
+
+-- intersperse :: a -> [a] -> [a]
+-- intersperse _ [] = []
+-- intersperse _ [x] = [x]
+-- intersperse sep (x:xs) = x : sep : intersperse sep xs
+
+-- Lazier intersperse
+
+intersperse' :: a -> [a] -> [a]
+intersperse' _ [] = []
+intersperse' sep (x:xs) = x : continue xs
+ where
+ continue [] = []
+ continue xs' = sep : intersperse' sep xs'
+
diff --git a/src/FRP/Reactive/Internal/TVal.hs b/src/FRP/Reactive/Internal/TVal.hs
index d5bf551..b331a0a 100755
--- a/src/FRP/Reactive/Internal/TVal.hs
+++ b/src/FRP/Reactive/Internal/TVal.hs
@@ -13,14 +13,11 @@
----------------------------------------------------------------------
module FRP.Reactive.Internal.TVal
- (
- makeEvent,
- ) where
+ ((:-->), (:+->), makeEvent) where
-
-import Control.Applicative ((<$>),liftA2)
--- import Control.Monad (when)
-import Control.Concurrent (forkIO,yield) -- ,ThreadId
+import Control.Applicative ((<$>)) -- ,liftA2
+-- import Control.Monad (forever)
+import Control.Concurrent (forkIO,yield) -- , ThreadId
-- import Control.Concurrent.Chan hiding (getChanContents)
import FRP.Reactive.Internal.Chan
@@ -28,10 +25,11 @@ import FRP.Reactive.Internal.Chan
--import System.Mem.Weak (mkWeakPtr,deRefWeak)
import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
-import Data.Stream (Stream(..))
+import Data.Stream (Stream(..)) -- ,streamToList
import Data.Unamb (unamb,assuming)
+import Data.AddBounds
import FRP.Reactive.Improving (Improving(..))
import FRP.Reactive.Future (FutureG,future)
import FRP.Reactive.Reactive (Event,TimeT,ITime)
@@ -41,6 +39,7 @@ import FRP.Reactive.Internal.Misc (Sink)
import FRP.Reactive.Internal.Clock
import FRP.Reactive.Internal.Timing (sleepPast)
import FRP.Reactive.Internal.IVar
+-- import FRP.Reactive.Internal.Reactive (isNeverE)
-- | An @a@ that's fed by a @b@
type b :--> a = (Sink b, a)
@@ -55,14 +54,16 @@ type b :+-> a = IO (b :--> a)
data TVal t a = TVal { timeVal :: (t,a), definedAt :: t -> Bool }
makeTVal :: Clock TimeT -> a :+-> TVal TimeT a
-makeTVal (Clock getT _) = f <$> newIVar
+makeTVal (Clock getT _) = do -- putStrLn "makeTVal"
+ f <$> newIVar
where
f v = (sink, TVal (readIVar v) (unsafePerformIO . undefAt))
where
undefAt t =
-- Read v after time t. If it's undefined, then it wasn't defined
-- at t. If it is defined, then see whether it was defined before t.
- do -- ser $ putStrLn $ "sleepPast " ++ show t
+ do -- putStrLn $ "undefAt " ++ show t
+ -- ser $ putStrLn $ "sleepPast " ++ show t
sleepPast getT t
-- maybe False ((< t) . fst) <$> tryReadIVar v
@@ -73,7 +74,8 @@ makeTVal (Clock getT _) = f <$> newIVar
-- If it became defined before t, then it's defined now.
Just (t',_) -> return (t' < t)
- sink a = do t <- getT
+ sink a = do -- putStrLn "sink"
+ t <- getT
writeIVar v (t,a)
-- sink a = getT >>= writeIVar v . flip (,) a
@@ -84,21 +86,23 @@ makeTVal (Clock getT _) = f <$> newIVar
-- We don't really have to avoid it, since makeTVal isn't exported.
-- | 'TVal' as 'Future'
-tValFuture :: Ord t => TVal t a -> FutureG (Improving t) a
+tValFuture :: Ord t => TVal t a -> FutureG (Improving (AddBounds t)) a
tValFuture v = future (tValImp v) (snd (timeVal v))
-- | 'TVal' as 'Improving'
-tValImp :: Ord t => TVal t a -> Improving t
-tValImp v = Imp ta (\ t' -> assuming (not (definedAt v t')) GT
+tValImp :: Ord t => TVal t a -> Improving (AddBounds t)
+tValImp v = Imp ta (\ t' -> assuming (not (definedAt' v t')) GT
`unamb` (ta `compare` t'))
where
- ta = fst (timeVal v)
+ ta = NoBound (fst (timeVal v))
+
+definedAt' :: TVal t a -> AddBounds t -> Bool
+definedAt' _ MinBound = False
+definedAt' tval (NoBound t) = definedAt tval t
+definedAt' _ MaxBound = True
+-- definedAt' _ _ = error "definedAt': non-NoBound"
--- The 'listSink' version of 'makeEvent' is not revealing the finiteness
--- of future times until those times are known exactly. Since many
--- 'Event' operations (including 'mappend' and 'join') check for infinite
--- time (Max MaxBound) before anything else, they'll get stuck immediately.
-- -- | Make a new event and a sink that writes to it. Uses the given
-- -- clock to serialize and time-stamp.
@@ -107,6 +111,8 @@ tValImp v = Imp ta (\ t' -> assuming (not (definedAt v t')) GT
-- do chanA <- newChan
-- chanF <- newChan
-- spin $ do
+-- -- Get the skeleton tval written out immediately. Details will
+-- -- be added
-- (tval,snka) <- makeTVal clock
-- writeChan chanF (tValFuture tval)
-- readChan chanA >>= snka
@@ -122,21 +128,41 @@ makeFuture = (fmap.fmap.fmap) tValFuture makeTVal
-- | Make a new event and a sink that writes to it. Uses the given
-- clock to serialize and time-stamp.
-makeEvent :: Clock TimeT -> (a :+-> Event a)
+makeEvent :: Clock TimeT -> forall a. Show a => (a :+-> Event a)
makeEvent clock = (fmap.fmap) futureStreamE (listSink (makeFuture clock))
+-- makeEvent clock =
+-- do (snk,s) <- listSink (makeFuture clock)
+-- let e = futureStreamE s
+-- putStrLn $ "isNeverE e == " ++ show (isNeverE e)
+-- -- putStrLn $ "makeEvent: e == " ++ show e
+-- return (snk, e)
+
+
-- Turn a single-feedable into a multi-feedable
-listSink :: (b :+-> a) -> (b :+-> Stream a)
+-- listSink :: (b :+-> a) -> (b :+-> [a])
-- listSink mk = do chanA <- newChan
-- chanB <- newChan
-- spin $ do
--- (a,snk) <- mk
+-- (snk,a) <- mk
+-- -- putStrLn "writing input"
-- writeChan chanA a
-- readChan chanB >>= snk
-- as <- getChanContents chanA
--- return (as, writeChanY chanB)
---
+-- return (writeChanY chanB, as)
+
+listSink :: Show a => (b :+-> a) -> (b :+-> Stream a)
+
+-- listSink mk = do chanA <- newChan
+-- chanB <- newChan
+-- spin $ do
+-- (snk,a) <- mk
+-- -- putStrLn "writing input"
+-- writeChan chanA a
+-- readChan chanB >>= snk
+-- as <- getChanStream chanA
+-- return (writeChanY chanB, as)
-- spin :: IO a -> IO ThreadId
-- spin = forkIO . forever
@@ -183,7 +209,8 @@ writeChanY ch x = writeChan ch x >> yield
-- http://haskell.org/ghc/docs/latest/html/libraries/base/System-Mem-Weak.html#v%3AaddFinalizer
-listSink mk = do chanA <- newChan
+listSink mk = do -- putStrLn "listSink"
+ chanA <- newChan
chanB <- newChan
-- let loop = do (snk,a) <- mk
@@ -208,14 +235,20 @@ listSink mk = do chanA <- newChan
do -- putStrLn "bailing"
return ()
Just writeA ->
- do (snk,a) <- mk
+ do -- putStrLn "writing to weak channel"
+ (snk,a) <- mk
writeA a
- -- yield
+ -- putStrLn "wrote"
+ yield
readChan chanB >>= snk
loop
forkIO loop
as <- getChanStream chanA
+
+ -- debugging. defeats freeing.
+ -- forkIO $ print $ streamToList as
+
return (writeChanY chanB, as)
@@ -227,12 +260,17 @@ listSink mk = do chanA <- newChan
-- hoping to get some extra laziness by using irrefutable 'Cons' pattern
-- when consuming the stream.
getChanStream :: Chan a -> IO (Stream a)
-getChanStream ch = unsafeInterleaveIO $
- liftA2 Cons (readChan ch) (getChanStream ch)
-
--- getChanStream ch
--- = unsafeInterleaveIO (do
--- x <- readChan ch
--- xs <- getChanStream ch
--- return (Cons x xs)
--- )
+
+-- getChanStream ch = unsafeInterleaveIO $
+-- liftA2 Cons (readChan ch) (getChanStream ch)
+
+getChanStream ch
+ = unsafeInterleaveIO (do
+ x <- readChan ch
+ xs <- getChanStream ch
+ return (Cons x xs)
+ )
+
+
+{-
+-}
diff --git a/src/FRP/Reactive/Internal/Timing.hs b/src/FRP/Reactive/Internal/Timing.hs
index 0c6ad4b..05db0e5 100755
--- a/src/FRP/Reactive/Internal/Timing.hs
+++ b/src/FRP/Reactive/Internal/Timing.hs
@@ -12,7 +12,9 @@
--
----------------------------------------------------------------------
-module FRP.Reactive.Internal.Timing (adaptE,mkUpdater,sleepPast) where
+module FRP.Reactive.Internal.Timing
+ (adaptE,mkUpdater,sleepPast)
+ where
import Data.Monoid (mempty)
import Control.Applicative ((<$>))
@@ -24,7 +26,9 @@ import Control.Concurrent.SampleVar
-- For IO monoid
import Control.Instances ()
-import FRP.Reactive.Reactive (TimeT,Event)
+import Data.AddBounds
+
+import FRP.Reactive.Reactive (exactNB,TimeT,Event)
import FRP.Reactive.Improving (Improving,exact)
import FRP.Reactive.Behavior (Behavior)
@@ -39,7 +43,7 @@ import FRP.Reactive.Internal.Clock (makeClock,cGetTime)
-- | Execute an action-valued event.
adaptE :: Sink (Event Action)
adaptE e = do clock <- makeClock
- runE (sleepPast (cGetTime clock) . exact) e
+ runE (sleepPast (cGetTime clock) . exactNB) e
-- | If a sample variable is full, act on the contents, leaving it empty.
@@ -60,7 +64,7 @@ mkUpdater getT acts =
-- The plan: Stash new phases (time functions) in a sample variable as
-- they arise. Every minPeriod, check the sample var for a new value.
do actSVar <- newEmptySampleVar
- _ <- forkR (sleepPast getT . exact)
+ _ <- forkR (sleepPast' getT . exact)
(writeSampleVar' actSVar <$> unb acts)
tfunRef <- newIORef (noSink :: Sink TimeT)
return $
@@ -85,17 +89,24 @@ mkUpdater getT acts =
sleep :: Sink TimeT
sleep = threadDelay . ceiling . (1.0e6 *)
+-- sleep = threadDelay . ceiling . (1.0e6 *)
+
-- | Sleep past a given time
sleepPast :: IO TimeT -> Sink TimeT
-sleepPast getT !target = loop
- where
+sleepPast getT !target =
-- Snooze until strictly after the target.
- loop = do -- The strict evaluation of target is essential here.
- -- (See bang pattern.) Otherwise, the next line will grab a
- -- time before a possibly long block, and then sleep much
- -- longer than necessary.
- now <- getT
- -- putStrLn $ "sleep loop: now == " ++ show now
- -- ++ ", target == " ++ show target
- unless (now > target) $
- sleep (target-now) -- >> loop
+ do -- The strict evaluation of target is essential here.
+ -- (See bang pattern.) Otherwise, the next line will grab a
+ -- time before a possibly long block, and then sleep much
+ -- longer than necessary.
+ now <- getT
+-- putStrLn $ "sleepPast: now == " ++ show now
+-- ++ ", target == " ++ show target
+ unless (now > target) $
+ sleep (target-now) -- >> loop
+
+-- | Variant of 'sleepPast', taking a possibly-infinite time
+sleepPast' :: IO TimeT -> Sink (AddBounds TimeT)
+sleepPast' _ MinBound = return ()
+sleepPast' getT (NoBound target) = sleepPast getT target
+sleepPast' _ MaxBound = error "sleepPast MaxBound. Expected??"
diff --git a/src/FRP/Reactive/LegacyAdapters.hs b/src/FRP/Reactive/LegacyAdapters.hs
index 26cf27b..026715a 100755
--- a/src/FRP/Reactive/LegacyAdapters.hs
+++ b/src/FRP/Reactive/LegacyAdapters.hs
@@ -15,11 +15,12 @@
module FRP.Reactive.LegacyAdapters
( Sink, Action
, Clock, makeClock, cGetTime
- , adaptE, makeEvent, mkUpdater
+ , adaptE, mkUpdater
+ , module FRP.Reactive.Internal.TVal
) where
import FRP.Reactive.Internal.Misc (Sink,Action)
import FRP.Reactive.Internal.Clock (Clock,makeClock,cGetTime)
-import FRP.Reactive.Internal.TVal (makeEvent)
+import FRP.Reactive.Internal.TVal
import FRP.Reactive.Internal.Timing (adaptE,mkUpdater)
diff --git a/src/FRP/Reactive/Num-inc.hs b/src/FRP/Reactive/Num-inc.hs
index d536341..bbbf121 100644
--- a/src/FRP/Reactive/Num-inc.hs
+++ b/src/FRP/Reactive/Num-inc.hs
@@ -13,6 +13,11 @@
-- "Control.Applicative".
----------------------------------------------------------------------
+-- This module still needs some think work. It now assumes that Eq, Ord,
+-- Enum, and Show are undefined, which is not a good assumption. For
+-- instance, Maybe.
+
+
noOv :: String -> String -> a
noOv ty meth = error $ meth ++ ": No overloading for " ++ ty
@@ -28,7 +33,7 @@ instance Ord b => Ord (APPLICATIVE b) where
min = liftA2 min
max = liftA2 max
-instance Enum a => Enum (APPLICATIVE a) where
+instance Enum b => Enum (APPLICATIVE b) where
succ = fmap succ
pred = fmap pred
toEnum = pure . toEnum
@@ -51,10 +56,10 @@ instance Num b => Num (APPLICATIVE b) where
abs = fmap abs
signum = fmap signum
-instance (Num a, Ord a) => Real (APPLICATIVE a) where
+instance (Num b, Ord b) => Real (APPLICATIVE b) where
toRational = noFun "toRational"
-instance Integral a => Integral (APPLICATIVE a) where
+instance Integral b => Integral (APPLICATIVE b) where
quot = liftA2 quot
rem = liftA2 rem
div = liftA2 div
@@ -83,14 +88,14 @@ instance Floating b => Floating (APPLICATIVE b) where
atanh = fmap atanh
acosh = fmap acosh
-instance RealFrac a => RealFrac (APPLICATIVE a) where
+instance RealFrac b => RealFrac (APPLICATIVE b) where
properFraction = noFun "properFraction"
truncate = noFun "truncate"
round = noFun "round"
ceiling = noFun "ceiling"
floor = noFun "floor"
-instance RealFloat a => RealFloat (APPLICATIVE a) where
+instance RealFloat b => RealFloat (APPLICATIVE b) where
floatRadix = noFun "floatRadix"
floatDigits = noFun "floatDigits"
floatRange = noFun "floatRange"
diff --git a/src/FRP/Reactive/PrimReactive.hs b/src/FRP/Reactive/PrimReactive.hs
index 7675515..2ecc3a1 100755
--- a/src/FRP/Reactive/PrimReactive.hs
+++ b/src/FRP/Reactive/PrimReactive.hs
@@ -44,7 +44,7 @@ module FRP.Reactive.PrimReactive
-- * Operations on events and reactive values
, stepper, switcher, withTimeGE, withTimeGR
, futuresE, futureStreamE, listEG, atTimesG, atTimeG
- , snap, snapshotWith, accumE, accumR, once
+ , snapshotWith, accumE, accumR, once
, withRestE, untilE
, justE, filterE
-- , traceE, traceR
@@ -55,27 +55,29 @@ module FRP.Reactive.PrimReactive
-- * To be removed when it gets used somewhere
, isMonotoneR
-- * Testing
- , batch, infE
+ , batch, infE, monoid_E
+ -- * Temporary exports, while debugging
+ -- , snap, merge
) where
import Prelude hiding (zip,zipWith)
import Data.Monoid
import Control.Applicative
-import Control.Arrow
+import Control.Arrow (first)
import Control.Monad
import Data.Function (on)
-- import Debug.Trace (trace)
-import Data.Stream (Stream(..))
-
-import Control.Comonad
-
-- TODO: eliminate the needs for this stuff.
import Control.Concurrent (threadDelay)
import Control.Exception (evaluate)
import System.IO.Unsafe
+import Data.Stream (Stream(..))
+
+import Control.Comonad
+
import Test.QuickCheck hiding (evaluate)
import Test.QuickCheck.Instances
import Test.QuickCheck.Checkers
@@ -87,10 +89,12 @@ import Control.Compose ((:.)(..), inO2, Monoid_f(..))
import Data.Zip
import Control.Instances () -- Monoid (IO ())
-import Data.Unamb (race)
-import Data.Max
-import Data.AddBounds
+import Data.Unamb (unamb, assuming)
+import Data.Unamb (race) -- eliminate
+
+-- import Data.Max
+-- import Data.AddBounds
import FRP.Reactive.Future hiding (batch)
import FRP.Reactive.Internal.Reactive
@@ -101,40 +105,43 @@ import FRP.Reactive.Internal.Reactive
-- Bogus EqProp instance. TODO: replace with a random equality test, such
-- that the collection of all generated tests covers equality.
-instance (Eq a, Eq b, EqProp a, EqProp b) => EqProp (EventG a b) where
+instance (Bounded t, Eq t, Eq a, EqProp t, EqProp a) => EqProp (EventG t a) where
a =-= b = foldr (.&.) (property True) $ zipWith (=-=) (f a) (f b)
where
f = take 20 . eFutures
-arbitraryE :: (Num t, Ord t, Arbitrary t, Arbitrary u) => Gen (EventG t u)
+-- TODO: work less and reach further per (=-=).
+
+arbitraryE :: (Num t, Ord t, Bounded t, Arbitrary t, Arbitrary u) => Gen (EventG t u)
arbitraryE = frequency
- [ (1, liftA2 ((liftA. liftA) futuresE addStart) arbitrary futureList)
- , (4, liftA futuresE futureList)
+ [ -- (1, liftA2 ((liftA. liftA) futuresE addStart) arbitrary futureList)
+ (4, liftA futuresE futureList)
]
where
- earliestFuture = Future . (,) (Max MinBound)
- addStart = (:).earliestFuture
- futureList = frequency [(10, futureListFinite), (1,futureListInf)]
+ -- earliestFuture = Future . (,) (Max MinBound)
+ -- addStart = (:).earliestFuture
+ futureList = futureListFinite
+ -- frequency [(10, futureListFinite), (1,futureListInf)]
futureListFinite = liftA2 (zipWith future) nondecreasing arbitrary
- futureListInf =
- liftA2 (zipWith future) (resize 10 nondecreasingInf)
- (infiniteList arbitrary)
+-- futureListInf =
+-- liftA2 (zipWith future) (resize 10 nondecreasingInf)
+-- (infiniteList arbitrary)
-instance (Arbitrary t, Ord t, Num t, Arbitrary a) => Arbitrary (EventG t a) where
+instance (Arbitrary t, Ord t, Bounded t, Num t, Arbitrary a) => Arbitrary (EventG t a) where
arbitrary = arbitraryE
coarbitrary = coarbitrary . eFuture
----
-- Arbitrary works just like pairs:
-instance (Arbitrary t, Arbitrary a, Num t, Ord t) => Arbitrary (ReactiveG t a) where
+instance (Arbitrary t, Arbitrary a, Num t, Ord t, Bounded t) => Arbitrary (ReactiveG t a) where
arbitrary = liftA2 Stepper arbitrary arbitrary
coarbitrary (a `Stepper` e) = coarbitrary e . coarbitrary a
-instance Ord t => Model (ReactiveG t a) (t -> a) where
+instance (Ord t, Bounded t) => Model (ReactiveG t a) (t -> a) where
model = rat
-instance (Ord t, Arbitrary t, Show t, EqProp a) => EqProp (ReactiveG t a)
+instance (Ord t, Bounded t, Arbitrary t, Show t, EqProp a) => EqProp (ReactiveG t a)
where
(=-=) = (=-=) `on` model
@@ -147,17 +154,17 @@ rInit (a `Stepper` _) = a
Instances
--------------------------------------------------------------------}
-instance Ord t => Monoid (EventG t a) where
+instance (Ord t, Bounded t) => Monoid (EventG t a) where
mempty = Event mempty
mappend = inEvent2 merge
-- Standard instance for Applicative of Monoid
-instance (Ord t, Monoid a) => Monoid (ReactiveG t a) where
+instance (Ord t, Bounded t, Monoid a) => Monoid (ReactiveG t a) where
mempty = pure mempty
mappend = liftA2 mappend
--- | Merge two 'Future' streams into one.
-merge :: Ord t => Binop (FutureG t (ReactiveG t a))
+-- | Merge two 'Future' reactives into one.
+merge :: (Ord t, Bounded t) => Binop (FutureG t (ReactiveG t a))
-- The following two lines seem to be too strict and are causing
-- reactive to lock up. I.e. the time argument of one of these
@@ -167,12 +174,22 @@ merge :: Ord t => Binop (FutureG t (ReactiveG t a))
-- On the other hand, they patch a massive space leak in filterE. Perhaps
-- there's an unamb solution.
-Future (Max MaxBound,_) `merge` v = v
-u `merge` Future (Max MaxBound,_) = u
-
-u `merge` v =
+u `merge` v =
+ assuming (isNeverF u) v `unamb`
+ assuming (isNeverF v) u `unamb`
(inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v)
+-- TODO: redefine via parIdentity from Data.Unamb
+
+-- u `merge` v | isNever u = v
+-- | isNever v = u
+
+-- Future (Max MaxBound,_) `merge` v = v
+-- u `merge` Future (Max MaxBound,_) = u
+
+-- u `merge` v =
+-- (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v)
+
-- What's going on in this 'merge' definition? Try two different
-- future paths. If u arrives before v (or simultaneously), then
-- begin as u begins and then merge v with the rest of u. Otherwise,
@@ -189,21 +206,22 @@ instance Functor (ReactiveG t) where
fmap f ~(a `Stepper` e) = f a `stepper` fmap f e
-- standard instance
-instance Ord t => Applicative (EventG t) where
+instance (Ord t, Bounded t) => Applicative (EventG t) where
pure = return
- _ <*> (Event (Future (Max MaxBound,_))) = mempty
- x <*> y = x `ap` y
+ (<*>) = ap
+-- _ <*> (Event (Future (Max MaxBound,_))) = mempty
+-- x <*> y = x `ap` y
-- standard instance
-instance Ord t => Alternative (EventG t) where
+instance (Ord t, Bounded t) => Alternative (EventG t) where
{ empty = mempty; (<|>) = mappend }
-instance Ord t => Zip (ReactiveG t) where
+instance (Ord t, Bounded t) => Zip (ReactiveG t) where
-- zip :: ReactiveG t a -> ReactiveG t b -> ReactiveG t (a,b)
(c `Stepper` ce) `zip` (d `Stepper` de) =
(c,d) `accumR` pairEdit (ce,de)
-instance Ord t => Applicative (ReactiveG t) where
+instance (Ord t, Bounded t) => Applicative (ReactiveG t) where
pure a = a `stepper` mempty
-- Standard definition. See 'Zip'.
rf <*> rx = zipWith ($) rf rx
@@ -213,11 +231,66 @@ instance Ord t => Applicative (ReactiveG t) where
-- when the argument or function changes.
-instance Ord t => Monad (EventG t) where
+instance (Ord t, Bounded t) => Monad (EventG t) where
return a = Event (pure (pure a))
e >>= f = joinE (fmap f e)
+-- From Jules Bean (quicksilver):
+
+-- joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a
+-- joinE (Event u) =
+-- Event . join $
+-- fmap (\ (e `Stepper` ee) ->
+-- let (Event uu) = (e `mappend` joinE ee) in uu)
+-- u
+
+-- plus some fiddling:
+
+joinE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a
+
+joinE (Event u) = Event (u >>= eFuture . g)
+ where
+ g (e `Stepper` ee) = e `mappend` joinE ee
+
+-- joinE = inEvent (>>= eFuture . g)
+-- where
+-- g (e `Stepper` ee) = e `mappend` joinE ee
+
+
+-- | Experimental specialization of 'joinMaybes'.
+justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a
+justE ~(Event (Future (t, mb `Stepper` e'))) =
+ assuming (t == maxBound) mempty `unamb`
+ (inEvent.inFuture.first) (max t) $
+ case mb of
+ Nothing -> justE e'
+ Just a -> Event (Future (t, a `Stepper` justE e'))
+
+
+-- This definition is much more efficient than the following.
+
+-- justE = (>>= maybe mzero return)
+
+-- On the other hand, this simpler definition inserts the necessary max
+-- applications so that we needn't find a Just in order to have a lower bound.
+
+-- TODO: find and fix the inefficiency.
+
+
+
+
+
+-- | Experimental specialization of 'filterMP'.
+filterE :: (Ord t, Bounded t) => (a -> Bool) -> EventG t a -> EventG t a
+filterE p m = justE (liftM f m)
+ where
+ f a | p a = Just a
+ | otherwise = Nothing
+
+
+{-
+
-- happy a t b. Same as (a `mappend` b) except takes advantage of knowledge
-- that t is a lower bound for the occurences of b. This allows for extra
-- laziness.
@@ -225,6 +298,12 @@ happy :: (Ord t) => EventG t a ->
Time t ->
EventG t a ->
EventG t a
+happy a t b =
+ assuming (isNeverE a) b `unamb`
+ assuming (isNeverF b) a `unamb`
+ happy' a t b ...
+
+
happy a (Max MaxBound) _ = a
happy (Event (Future (Max MaxBound, _))) _ b = b
happy a@(Event (Future (t0, e `Stepper` ee'))) t b
@@ -239,18 +318,31 @@ joinE (Event (Future (t0h, e `Stepper` ((Event (Future (Max MaxBound, _)))))))
= adjustE t0h e
joinE (Event (Future (t0h, e `Stepper` ee'@((Event (Future (t1h, _)))))))
= happy (adjustE t0h e) t1h (adjustTopE t0h (joinE ee'))
+-}
+
+{-
+-- Note, joinE should not be called with an infinite list of events that all
+-- occur at the same time. It can't decide which occurs first.
+joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a
+joinE (Event (Future (t0h, e `Stepper` ee'))) =
+ assuming (t0h == maxBound) mempty $
+ adjustE t0h (e `mappend` joinE ee')
+
+-- TODO: revisit this def.
+
-- Original Version:
-- joinE (Event (Future (t0h, e `Stepper` ee'))) =
-- adjustE t0h e `mappend` adjustTopE t0h (joinE ee')
-adjustTopE :: Ord t => Time t -> EventG t t1 -> EventG t t1
-adjustTopE t0h = (inEvent.inFuture.first) (max t0h)
+adjustTopE :: (Ord t, Bounded t) => Time t -> EventG t t1 -> EventG t t1
--- adjustTopE t0h (Event (Future (tah, r))) =
--- Event (Future (t0h `max` tah,r))
+-- adjustTopE t0h = (inEvent.inFuture.first) (max t0h)
-adjustE :: Ord t => Time t -> EventG t t1 -> EventG t t1
+adjustTopE t0h ~(Event (Future (tah, r))) =
+ Event (Future (t0h `max` tah,r))
+
+adjustE :: (Ord t, Bounded t) => Time t -> EventG t t1 -> EventG t t1
adjustE _ e@(Event (Future (Max MaxBound, _))) = e
@@ -259,6 +351,8 @@ adjustE t0h (Event (Future (tah, a `Stepper` e))) =
where
t1h = t0h `max` tah
+-}
+
-- The two-caseness of adjustE prevents the any info from coming out until
-- tah is known to be Max or non-Max. Problem?
@@ -277,7 +371,7 @@ adjustE t0h (Event (Future (tah, a `Stepper` e))) =
-- reactive to lock up. Need to verify correctness. (Does lock up with
-- the mappend optimization that eliminates a space/time leak.)
{-
-joinE :: Ord t => EventG t (EventG t a) -> EventG t a
+joinE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a
joinE (Event (Future (t0h, ~(e `Stepper` ee')))) =
adjustE t0h (e `mappend` joinE ee')
@@ -287,37 +381,31 @@ adjustE t0h (Event (Future (tah, ~(a `Stepper` e)))) =
t1h = t0h `max` tah
-}
--- From Jules Bean (quicksilver):
-
--- joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a
--- joinE (Event u) =
--- Event . join $
--- fmap (\ (e `Stepper` ee) ->
--- let (Event uu) = (e `mappend` joinE ee) in uu)
--- u
-
--- plus some fiddling:
-
--- joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a
--- joinE = inEvent (>>= g)
--- where
--- g ~(e `Stepper` ee) = eFuture (e `mappend` joinE ee)
-
-- These two joinE defs both lock up in my tests.
-instance Ord t => MonadPlus (EventG t) where { mzero = mempty; mplus = mappend }
+instance (Ord t, Bounded t) => MonadPlus (EventG t) where
+ { mzero = mempty; mplus = mappend }
-- Standard instance for Applicative w/ join
-instance Ord t => Monad (ReactiveG t) where
+instance (Ord t, Bounded t) => Monad (ReactiveG t) where
return = pure
r >>= f = joinR (f <$> r)
+-- -- Temporary
+-- justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a
+-- justE = joinMaybes
+
+-- filterE :: (Ord t, Bounded t, Show a) => (a -> Bool) -> EventG t a -> EventG t a
+-- filterE = filterMP
+
+{-
+
-- | Pass through the 'Just' occurrences, stripped. Experimental
-- specialization of 'joinMaybes'.
-justE :: Ord t => EventG t (Maybe a) -> EventG t a
+justE :: (Ord t, Bounded t) => EventG t (Maybe a) -> EventG t a
justE (Event (Future (ta, Just a `Stepper` e'))) =
Event (Future (ta, a `Stepper` justE e'))
justE (Event (Future (ta, Nothing `Stepper` e'))) =
@@ -337,12 +425,25 @@ filterE :: (Ord t, Show a) => (a -> Bool) -> EventG t a -> EventG t a
filterE _ e@(Event (Future (Max MaxBound, _))) = e
-filterE p (Event (Future (ta, a `Stepper` e'))) = h (filterE p e')
- where
- h | p a = -- trace ("pass " ++ show a) $
- \ e'' -> Event (Future (ta, a `Stepper` e''))
- | otherwise = -- trace ("skip " ++ show a) $
- adjustTopE ta
+filterE p (Event (Future (ta, a `Stepper` e'))) =
+ adjustTopE ta $
+ if p a then
+ Event (Future (ta, a `Stepper` filterE p e'))
+ else filterE p e'
+-}
+
+-- The adjustTopE ta guarantees a lower bound even before we've looked at a.
+
+-- filterE p (Event (Future (ta, a `Stepper` e')))
+-- | p a = Event (Future (ta, a `Stepper` filterE p e'))
+-- | otherwise = adjustTopE ta (filterE p e')
+
+-- filterE p (Event (Future (ta, a `Stepper` e'))) = h (filterE p e')
+-- where
+-- h | p a = -- trace ("pass " ++ show a) $
+-- \ e'' -> Event (Future (ta, a `Stepper` e''))
+-- | otherwise = -- trace ("skip " ++ show a) $
+-- adjustTopE ta
-- Or maybe move the adjustTopE to the second filterE
@@ -376,15 +477,15 @@ stepper = Stepper
-- --
-- -- Oops: breaks the semantic abstraction of 'Reactive' as a step
-- function.
--- rToE :: Ord t => ReactiveG t a -> EventG t a
+-- rToE :: (Ord t, Bounded t) => ReactiveG t a -> EventG t a
-- rToE (a `Stepper` e) = pure a `mappend` e
-- | Switch between reactive values.
-switcher :: Ord t => ReactiveG t a -> EventG t (ReactiveG t a) -> ReactiveG t a
+switcher :: (Ord t, Bounded t) => ReactiveG t a -> EventG t (ReactiveG t a) -> ReactiveG t a
r `switcher` e = join (r `stepper` e)
-- | Reactive 'join' (equivalent to 'join' but slightly more efficient, I think)
-joinR :: Ord t => ReactiveG t (ReactiveG t a) -> ReactiveG t a
+joinR :: (Ord t, Bounded t) => ReactiveG t (ReactiveG t a) -> ReactiveG t a
joinR ((a `Stepper` Event ur) `Stepper` e'@(Event urr)) = a `stepper` Event u
where
@@ -412,11 +513,11 @@ withTimeGR t (a `Stepper` e) = (a,t) `Stepper` withTimeGE e
-- | Convert a temporally monotonic list of futures to an event. See also
-- the specialization 'listE'
-listEG :: Ord t => [(t,a)] -> EventG t a
+listEG :: (Ord t, Bounded t) => [(t,a)] -> EventG t a
listEG = futuresE . map (uncurry future)
-- | Convert a temporally monotonic list of futures to an event
-futuresE :: Ord t => [FutureG t a] -> EventG t a
+futuresE :: (Ord t, Bounded t) => [FutureG t a] -> EventG t a
futuresE [] = mempty
futuresE (Future (t,a) : futs) =
-- trace ("l2E: "++show t) $
@@ -431,55 +532,55 @@ futuresE (Future (t,a) : futs) =
-- | Convert a temporally monotonic stream of futures to an event. Like
-- 'futuresE' but it can be lazier, because there's not empty case.
-futureStreamE :: Ord t => Stream (FutureG t a) -> EventG t a
+futureStreamE :: (Ord t, Bounded t) => Stream (FutureG t a) -> EventG t a
futureStreamE (~(Cons (Future (t,a)) futs)) =
Event (Future (t, a `stepper` futureStreamE futs))
-- | Event at given times. See also 'atTimeG'.
-atTimesG :: Ord t => [t] -> EventG t ()
+atTimesG :: (Ord t, Bounded t) => [t] -> EventG t ()
atTimesG = listEG . fmap (flip (,) ())
-- | Single-occurrence event at given time.
-atTimeG :: Ord t => t -> EventG t ()
+atTimeG :: (Ord t, Bounded t) => t -> EventG t ()
atTimeG = atTimesG . pure
-- | Snapshot a reactive value whenever an event occurs and apply a
-- combining function to the event and reactive's values.
-snapshotWith :: Ord t =>
+snapshotWith :: (Ord t, Bounded t) =>
(a -> b -> c) -> ReactiveG t b -> EventG t a -> EventG t c
-snapshotWith f e r = joinMaybes $ fmap h (e `snap` r)
- where
- h (Nothing,_) = Nothing
- h (Just a ,b) = Just (f a b)
-
--- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@
--- didn't.
-snap :: forall a b t. Ord t =>
- ReactiveG t b -> EventG t a -> EventG t (Maybe a, b)
-_ `snap` Event (Future (Max MaxBound, _)) = mempty
-(b0 `Stepper` eb) `snap` ea =
- (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb)
- where
- fa :: a -> Unop (Maybe a, b)
- fb :: b -> Unop (Maybe a, b)
- fa a (_,b) = (Just a , b)
- fb b _ = (Nothing, b)
+-- snapshotWith f e r = joinMaybes $ fmap h (e `snap` r)
+-- where
+-- h (Nothing,_) = Nothing
+-- h (Just a ,b) = Just (f a b)
+
+-- -- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@
+-- -- didn't.
+-- snap :: forall a b t. (Ord t, Bounded t) =>
+-- ReactiveG t b -> EventG t a -> EventG t (Maybe a, b)
+-- (b0 `Stepper` eb) `snap` ea =
+-- assuming (isNeverE ea) mempty $
+-- (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb)
+-- where
+-- fa :: a -> Unop (Maybe a, b)
+-- fb :: b -> Unop (Maybe a, b)
+-- fa a (_,b) = (Just a , b)
+-- fb b _ = (Nothing, b)
-- This next version from Chuan-kai Lin, so that snapshot is lazy enough
-- for recursive cases. It leaks when the reactive changes faster than
-- the event occurs.
--- snapshotWith f r e =
--- fmap snap $ accumE seed $ fmap advance $ withTimeGE e
--- where snap (a, sr) = f a (rInit sr)
--- seed = (undefined, r)
--- advance (a, t) (_, sr) = (a, skipRT sr t)
+snapshotWith f r e =
+ fmap snap $ accumE seed $ fmap advance $ withTimeGE e
+ where snap (a, sr) = f a (rInit sr)
+ seed = (error "snapshotWith seed", r)
+ advance (a, t) (_, sr) = (a, skipRT sr t)
--- -- | Skip reactive values until the given time.
--- skipRT :: Ord t => ReactiveG t a -> Time t -> ReactiveG t a
--- r@(_ `Stepper` Event (Future (t, r1))) `skipRT` start =
--- if t < start then r1 `skipRT` start else r
+-- | Skip reactive values until the given time.
+skipRT :: (Ord t, Bounded t) => ReactiveG t a -> Time t -> ReactiveG t a
+r@(_ `Stepper` Event (Future (t, r1))) `skipRT` start =
+ if t < start then r1 `skipRT` start else r
-- From Beelsebob:
@@ -505,7 +606,7 @@ accumR :: a -> EventG t (a -> a) -> ReactiveG t a
a `accumR` e = a `stepper` (a `accumE` e)
-- | Just the first occurrence of an event.
-once :: Ord t => EventG t a -> EventG t a
+once :: (Ord t, Bounded t) => EventG t a -> EventG t a
once = (inEvent.fmap) (pure . rInit)
-- | Extract a future representing the first occurrence of the event together
@@ -521,11 +622,11 @@ withRestE = (inEvent.fmap) $
-- | Truncate first event at first occurrence of second event.
-untilE :: Ord t => EventG t a -> EventG t b -> EventG t a
+untilE :: (Ord t, Bounded t) => EventG t a -> EventG t b -> EventG t a
ea `untilE` Event (Future ~(tb,_)) = ea `untilET` tb
-- | Truncate first event at the given time.
-untilET :: Ord t => EventG t a -> Time t -> EventG t a
+untilET :: (Ord t, Bounded t) => EventG t a -> Time t -> EventG t a
-- Event (Future (ta, ~(a `Stepper` e'))) `untilET` t =
@@ -554,7 +655,7 @@ Event (Future ~(ta, a `Stepper` e')) `untilET` t =
-- times. Deprecated, because it does not reveal when value is known to
-- be repeated in the output. Those values won't be recomputed, but they
-- may be re-displayed.
-rats :: Ord t => ReactiveG t a -> [t] -> [a] -- increasing times
+rats :: (Ord t, Bounded t) => ReactiveG t a -> [t] -> [a] -- increasing times
_ `rats` [] = []
@@ -563,7 +664,7 @@ r@(a `Stepper` Event (Future (tr',r'))) `rats` ts@(t:ts')
| otherwise = r' `rats` ts
-- Just for testing
-rat :: Ord t => ReactiveG t a -> t -> a
+rat :: (Ord t, Bounded t) => ReactiveG t a -> t -> a
rat r = head . rats r . (:[])
@@ -572,20 +673,20 @@ rat r = head . rats r . (:[])
--------------------------------------------------------------------}
-- Standard instances
-instance (Monoid_f f, Ord t) => Monoid_f (ReactiveG t :. f) where
+instance (Monoid_f f, Ord t, Bounded t) => Monoid_f (ReactiveG t :. f) where
{ mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }
-instance (Ord t, Zip f) => Zip (ReactiveG t :. f) where zip = apZip
+instance (Ord t, Bounded t, Zip f) => Zip (ReactiveG t :. f) where zip = apZip
instance Unzip (ReactiveG t) where {fsts = fmap fst; snds = fmap snd}
-- Standard instances
-instance Ord t => Monoid_f (EventG t) where
+instance (Ord t, Bounded t) => Monoid_f (EventG t) where
{ mempty_f = mempty ; mappend_f = mappend }
-instance Ord t => Monoid ((EventG t :. f) a) where
+instance (Ord t, Bounded t) => Monoid ((EventG t :. f) a) where
{ mempty = O mempty; mappend = inO2 mappend }
-instance Ord t => Monoid_f (EventG t :. f) where
+instance (Ord t, Bounded t) => Monoid_f (EventG t :. f) where
{ mempty_f = mempty ; mappend_f = mappend }
-instance (Ord t, Cozip f) => Zip (EventG t :. f) where
+instance (Ord t, Bounded t, Cozip f) => Zip (EventG t :. f) where
zip = cozip
-- Standard instance for functors
@@ -617,7 +718,7 @@ frTOrf ~(Future (ta,e)) = (Future . (,) ta) <$> e
-- TODO: Reconsider E = F :. R . Didn't work with absolute time. What
-- about relative time?
-instance Ord t => Pointed (ReactiveG t) where
+instance (Ord t, Bounded t) => Pointed (ReactiveG t) where
point = (`stepper` mempty)
-- TODO: I think we can bypass mempty and so eliminate the Ord
@@ -684,13 +785,24 @@ type ApTy f a b = f (a -> b) -> f a -> f b
batch :: TestBatch
batch = ( "Reactive.PrimReactive"
, concatMap unbatch
- [ ("monotonicity",
+ [
+ -- monad associativity fails
+ -- , monad (undefined :: EventG NumT (NumT,T,NumT))
+ monoid (undefined :: EventG NumT T)
+ , monoid (undefined :: ReactiveG NumT [T])
+ , monad (undefined :: ReactiveG NumT (NumT,T,NumT))
+-- , ("occurence count",
+-- [("joinE", joinEOccuranceCount)]
+-- )
+ , ("monotonicity",
[ monotonicity2 "<*>"
((<*>) :: ApTy (EventG NumT) T T)
+{-
, monotonicity2 "adjustE" (adjustE
:: Time NumT
-> EventG NumT NumT
-> EventG NumT NumT)
+-}
, monotonicity "join" (join
:: EventG NumT (EventG NumT T)
-> EventG NumT T)
@@ -728,17 +840,13 @@ batch = ( "Reactive.PrimReactive"
:: EventG NumT NumT
-> EventG NumT NumT)
])
- -- monad associativity fails
- -- , monad (undefined :: EventG NumT (NumT,T,NumT))
- , monad (undefined :: ReactiveG NumT (NumT,T,NumT))
- , monoid (undefined :: EventG NumT T)
- , monoid (undefined :: ReactiveG NumT [T])
--- , ("occurance count",
--- [("joinE", joinEOccuranceCount)]
--- )
]
)
+monoid_E :: TestBatch
+monoid_E = monoid (undefined :: EventG NumT T)
+
+
-- joinEOccuranceCount :: Property
-- joinEOccuranceCount =
-- forAll (finiteEvent $ finiteEvent arbitrary
@@ -756,25 +864,26 @@ toListE_ = map futVal . toListE
-}
monotonicity :: (Show a, Arbitrary a, Arbitrary t
- ,Num t, Ord t, Ord t')
+ ,Num t, Ord t, Bounded t, Ord t', Bounded t')
=> String -> (EventG t a -> EventG t' a')
-> (String,Property)
monotonicity n f = (n, property $ monotoneTest f)
monotonicity2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t
- ,Num t, Ord t, Ord t')
+ ,Num t, Ord t, Bounded t, Ord t', Bounded t')
=> String -> (b -> EventG t a -> EventG t' a')
-> (String,Property)
monotonicity2 n f = (n, property $ monotoneTest2 f)
-monotoneTest :: (Ord t') => (EventG t a -> EventG t' a')
- -> EventG t a
- -> Bool
+monotoneTest :: (Ord t', Bounded t') =>
+ (EventG t a -> EventG t' a')
+ -> EventG t a
+ -> Bool
monotoneTest f e = unsafePerformIO ( (evaluate (isMonotoneE . f $ e))
`race` slowTrue)
monotoneTest2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t
- ,Num t, Ord t, Ord t')
+ ,Num t, Ord t, Bounded t, Ord t', Bounded t')
=> (b -> EventG t a -> EventG t' a')
-> (b , EventG t a) -> Bool
monotoneTest2 f (x,e) =
@@ -788,43 +897,46 @@ slowTrue = do threadDelay 10
-- TODO: Replace this stuff with a use of delay from Data.Later in checkers.
-isMonotoneE :: (Ord t) => EventG t a -> Bool
-isMonotoneE = liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
+isMonotoneE :: (Ord t, Bounded t) => EventG t a -> Bool
+isMonotoneE = liftA2 (||) isNeverE
((uncurry isMonotoneR') . unFuture . eFuture)
-isMonotoneE' :: (Ord t) => (Time t) -> EventG t a -> Bool
+isMonotoneE' :: (Ord t, Bounded t) => (Time t) -> EventG t a -> Bool
isMonotoneE' t =
- liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
+ liftA2 (||) isNeverE
((\(t',r) -> t <= t' && isMonotoneR' t' r) . unFuture . eFuture)
-isMonotoneR :: (Ord t) => ReactiveG t a -> Bool
+isMonotoneR :: (Ord t, Bounded t) => ReactiveG t a -> Bool
isMonotoneR (_ `Stepper` e) = isMonotoneE e
-isMonotoneR' :: (Ord t) => (Time t) -> ReactiveG t a -> Bool
+isMonotoneR' :: (Ord t, Bounded t) => Time t -> ReactiveG t a -> Bool
isMonotoneR' t (_ `Stepper` e) = isMonotoneE' t e
-simulEventOrder :: (Arbitrary t, Num t, Ord t
- ,Arbitrary t', Num t', Ord t'
- ,Num t'', Ord t'', Num t''', Ord t''')
+simulEventOrder :: ( Arbitrary t, Num t, Ord t, Bounded t
+ , Arbitrary t', Num t', Ord t', Bounded t'
+ , Num t'', Ord t'', Bounded t''
+ , Num t''', Ord t''', Bounded t''')
=> String -> (EventG t t' -> EventG t'' t''')
-> (String, Property)
simulEventOrder n f =
(n,forAll genEvent (isStillOrderedE . f))
where
- genEvent :: (Arbitrary t1, Num t1, Ord t1, Arbitrary t2, Num t2, Ord t2)
+ genEvent :: ( Arbitrary t1, Num t1, Ord t1, Bounded t1
+ , Arbitrary t2, Num t2, Ord t2, Bounded t2)
=> Gen (EventG t1 t2)
genEvent = liftA futuresE (liftA2 (zipWith future) nondecreasing
increasing)
- isStillOrderedE :: (Num t1, Ord t1, Num t2, Ord t2) => EventG t1 t2 -> Bool
+ isStillOrderedE :: ( Num t1, Ord t1, Bounded t1
+ , Num t2, Ord t2, Bounded t2) => EventG t1 t2 -> Bool
isStillOrderedE =
- liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
+ liftA2 (||) isNeverE
(isStillOrderedR . futVal . eFuture)
isStillOrderedR (a `Stepper` e) =
isStillOrderedE' a e
isStillOrderedE' a =
- liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
+ liftA2 (||) isNeverE
(isStillOrderedR' a . futVal . eFuture)
isStillOrderedR' a (b `Stepper` e) =
diff --git a/src/FRP/Reactive/Reactive.hs b/src/FRP/Reactive/Reactive.hs
index f42d60b..f51cdf5 100755
--- a/src/FRP/Reactive/Reactive.hs
+++ b/src/FRP/Reactive/Reactive.hs
@@ -18,7 +18,7 @@
module FRP.Reactive.Reactive
(
module FRP.Reactive.PrimReactive
- , TimeT, ITime, Future
+ , ImpBounds, exactNB, {-TimeFinite,-} TimeT, ITime, Future
, traceF
-- * Event
, Event
@@ -53,6 +53,7 @@ import Test.QuickCheck.Classes ()
-- vector-space
import Data.VectorSpace
+import Data.AffineSpace
-- TypeCompose
import Data.Zip (pairEdit)
@@ -63,12 +64,30 @@ import FRP.Reactive.Future hiding (batch)
import FRP.Reactive.PrimReactive hiding (batch)
import FRP.Reactive.Improving hiding (batch)
--- | The type of finite time values.
+-- -- | The type of finite time values
+-- type TimeFinite = Double
+
+-- | The type of time values with additional min & max elements.
type TimeT = Double
+-- type TimeT = AddBounds TimeFinite
+
+type ImpBounds t = Improving (AddBounds t)
+
+-- | Exact & finite content of an 'ImpBounds'
+exactNB :: ImpBounds t -> t
+exactNB = unNo . exact
+ where
+ unNo (NoBound t) = t
+ unNo _ = error "exactNB: unNo on MinBound or maxBound"
+
+-- TODO: when I switch to relative time, I won't need MinBound, so
+-- introduce a HasInfinity class and use infinity in place of maxBound
--- | Improving doubles, as used for time values in 'Event', 'Reactive',
+-- | Improving times, as used for time values in 'Event', 'Reactive',
-- and 'ReactiveB'.
-type ITime = Improving TimeT
+type ITime = ImpBounds TimeT
+
+-- type ITime = Improving TimeT
-- | Type of future values. Specializes 'FutureG'.
type Future = FutureG ITime
@@ -97,76 +116,81 @@ type Event = EventG ITime
--
-- > withTimeE :: Event a -> Event (a, TimeT)
withTimeE :: Ord t =>
- EventG (Improving t) d -> EventG (Improving t) (d, t)
-withTimeE e = second (exact.timeT) <$> withTimeGE e
+ EventG (ImpBounds t) d -> EventG (ImpBounds t) (d, t)
+withTimeE e = second (exactNB.timeT) <$> withTimeGE e
-- | Access occurrence times in an event. Discard the rest. See also
-- 'withTimeE'.
--
-- > withTimeE_ :: Event a -> Event TimeT
withTimeE_ :: Ord t =>
- EventG (Improving t) d -> EventG (Improving t) t
+ EventG (ImpBounds t) d -> EventG (ImpBounds t) t
withTimeE_ = (result.fmap) snd withTimeE
timeT :: Ord t => Time t -> t
-timeT (Max (NoBound t)) = t
-timeT _ = error "timeT: non-finite time"
+timeT (Max t) = t
+
+-- timeT (Max (NoBound t)) = t
+-- timeT _ = error "timeT: non-finite time"
-- | Single-occurrence event at given time. See 'atTimes' and 'atTimeG'.
atTime :: TimeT -> Event ()
-atTime = atTimeG . exactly
+atTime = atTimes . pure
+
+-- atTime = atTimeG . exactly . NoBound
-- | Event occuring at given times. See also 'atTime' and 'atTimeG'.
atTimes :: [TimeT] -> Event ()
-atTimes = atTimesG . fmap exactly
+atTimes = atTimesG . fmap (exactly . NoBound)
+
-- | Convert a temporally monotonic list of timed values to an event. See also
-- the generalization 'listEG'
listE :: [(TimeT,a)] -> Event a
-listE = listEG . fmap (first exactly)
+listE = listEG . fmap (first (exactly . NoBound))
-- | Generate a pair-valued event, given a pair of initial values and a
-- pair of events. See also 'pair' on 'Reactive'. Not quite a 'zip',
-- because of the initial pair required.
-zipE :: Ord t => (c,d) -> (EventG t c, EventG t d) -> EventG t (c,d)
+zipE :: (Ord t, Bounded t) => (c,d) -> (EventG t c, EventG t d) -> EventG t (c,d)
zipE cd cde = cd `accumE` pairEdit cde
-- | Like 'scanl' for events.
-scanlE :: Ord t => (a -> b -> a) -> a -> EventG t b -> EventG t a
+scanlE :: (Ord t, Bounded t) => (a -> b -> a) -> a -> EventG t b -> EventG t a
scanlE f a e = a `accumE` (flip f <$> e)
-- | Accumulate values from a monoid-typed event. Specialization of
-- 'scanlE', using 'mappend' and 'mempty'.
-monoidE :: (Ord t, Monoid o) => EventG t o -> EventG t o
+monoidE :: (Ord t, Bounded t, Monoid o) => EventG t o -> EventG t o
monoidE = scanlE mappend mempty
-- | Decompose an event into its first occurrence value and a remainder
-- event. See also 'firstE' and 'restE'.
-firstRestE :: Ord t => EventG t a -> (a, EventG t a)
+firstRestE :: (Ord t, Bounded t) => EventG t a -> (a, EventG t a)
firstRestE = futVal . eventOcc
-- | Extract the first occurrence value of an event. See also
-- 'firstRestE' and 'restE'.
-firstE :: Ord t => EventG t a -> a
+firstE :: (Ord t, Bounded t) => EventG t a -> a
firstE = fst . firstRestE
-- | Extract the remainder an event, after its first occurrence. See also
-- 'firstRestE' and 'firstE'.
-restE :: Ord t => EventG t a -> EventG t a
+restE :: (Ord t, Bounded t) => EventG t a -> EventG t a
restE = snd . firstRestE
-- | Remaining part of an event. See also 'withRestE'.
-remainderR :: Ord t => EventG t a -> ReactiveG t (EventG t a)
+remainderR :: (Ord t, Bounded t) => EventG t a -> ReactiveG t (EventG t a)
remainderR e = e `stepper` (snd <$> withRestE e)
-- | Tack remainders a second event onto values of a first event. Occurs
-- when the first event occurs.
-snapRemainderE :: Ord t =>
+snapRemainderE :: (Ord t, Bounded t) =>
EventG t b -> EventG t a -> EventG t (a, EventG t b)
snapRemainderE = snapshot . remainderR
@@ -179,7 +203,7 @@ snapRemainderE = snapshot . remainderR
-- | Convert an event into a single-occurrence event, whose occurrence
-- contains the remainder.
-onceRestE :: Ord t => EventG t a -> EventG t (a, EventG t a)
+onceRestE :: (Ord t, Bounded t) => EventG t a -> EventG t (a, EventG t a)
onceRestE = once . withRestE
@@ -188,39 +212,39 @@ onceRestE = once . withRestE
-- the old one. Nothing will come out for the first occurrence of @e@,
-- but if you have an initial value @a@, you can do @withPrevE (pure a
-- `mappend` e)@.
-withPrevE :: Ord t => EventG t a -> EventG t (a,a)
+withPrevE :: (Ord t, Bounded t) => EventG t a -> EventG t (a,a)
withPrevE e = (joinMaybes . fmap combineMaybes) $
(Nothing,Nothing) `accumE` fmap (shift.Just) e
where
- -- Shift newer value into (old,new) pair if present.
+ -- Shift newer value into (new,old) pair if present.
shift :: u -> (u,u) -> (u,u)
- shift new (old,_) = (new,old)
+ shift newer (new,_) = (newer,new)
combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v)
combineMaybes = uncurry (liftA2 (,))
-- | Same as 'withPrevE', but allow a function to combine the values.
-- Provided for convenience.
-withPrevEWith :: Ord t => (a -> a -> b) -> EventG t a -> EventG t b
+withPrevEWith :: (Ord t, Bounded t) => (a -> a -> b) -> EventG t a -> EventG t b
withPrevEWith f e = fmap (uncurry f) (withPrevE e)
-- | Pair each event value with the next one one. The second result is
-- the next one.
-withNextE :: Ord t => EventG t a -> EventG t (a,a)
+withNextE :: (Ord t, Bounded t) => EventG t a -> EventG t (a,a)
withNextE = (result.fmap.second) firstE withRestE
-- Alt. def.
-- withNextE = fmap (second firstE) . withRestE
-- | Same as 'withNextE', but allow a function to combine the values.
-- Provided for convenience.
-withNextEWith :: Ord t => (a -> a -> b) -> EventG t a -> EventG t b
+withNextEWith :: (Ord t, Bounded t) => (a -> a -> b) -> EventG t a -> EventG t b
withNextEWith f e = fmap (uncurry f) (withNextE e)
-- | Mealy-style state machine, given initial value and transition
-- function. Carries along event data. See also 'mealy_'.
-mealy :: Ord t => s -> (s -> s) -> EventG t b -> EventG t (b,s)
+mealy :: (Ord t, Bounded t) => s -> (s -> s) -> EventG t b -> EventG t (b,s)
mealy s0 f = scanlE h (b0,s0)
where
b0 = error "mealy: no initial value"
@@ -228,7 +252,7 @@ mealy s0 f = scanlE h (b0,s0)
-- | Mealy-style state machine, given initial value and transition
-- function. Forgetful version of 'mealy'.
-mealy_ :: Ord t => s -> (s -> s) -> EventG t b -> EventG t s
+mealy_ :: (Ord t, Bounded t) => s -> (s -> s) -> EventG t b -> EventG t s
mealy_ = (result.result.result.fmap) snd mealy
-- mealy_ s0 f e = snd <$> mealy s0 f e
@@ -236,20 +260,21 @@ mealy_ = (result.result.result.fmap) snd mealy
-- | Count occurrences of an event, remembering the occurrence values.
-- See also 'countE_'.
-countE :: (Ord t, Num n) => EventG t b -> EventG t (b,n)
+countE :: (Ord t, Bounded t, Num n) => EventG t b -> EventG t (b,n)
countE = mealy 0 (+1)
-- | Count occurrences of an event, forgetting the occurrence values. See
-- also 'countE'.
-countE_ :: (Ord t, Num n) => EventG t b -> EventG t n
+countE_ :: (Ord t, Bounded t, Num n) => EventG t b -> EventG t n
countE_ = (result.fmap) snd countE
-- countE_ e = snd <$> countE e
-- | Difference of successive event occurrences. See 'withPrevE' for a
-- trick to supply an initial previous value.
-diffE :: (Ord t, Num n) => EventG t n -> EventG t n
-diffE = withPrevEWith (flip subtract)
+diffE :: (Ord t, Bounded t, AffineSpace a) =>
+ EventG t a -> EventG t (Diff a)
+diffE = withPrevEWith (.-.)
-- -- | Returns an event whose occurrence's value corresponds with the input
-- -- event's previous occurence's value.
@@ -271,11 +296,11 @@ type Reactive = ReactiveG ITime
-- | Snapshot a reactive value whenever an event occurs.
-snapshot :: Ord t => ReactiveG t b -> EventG t a -> EventG t (a,b)
+snapshot :: (Ord t, Bounded t) => ReactiveG t b -> EventG t a -> EventG t (a,b)
snapshot = snapshotWith (,)
-- | Like 'snapshot' but discarding event data (often @a@ is '()').
-snapshot_ :: Ord t => ReactiveG t b -> EventG t a -> EventG t b
+snapshot_ :: (Ord t, Bounded t) => ReactiveG t b -> EventG t a -> EventG t b
snapshot_ = snapshotWith (flip const)
-- Alternative implementations
@@ -283,72 +308,72 @@ snapshot_ = snapshotWith (flip const)
-- snapshot_ = (result.result.fmap) snd snapshot
-- | Filter an event according to whether a reactive boolean is true.
-whenE :: Ord t => EventG t a -> ReactiveG t Bool -> EventG t a
+whenE :: (Ord t, Bounded t) => EventG t a -> ReactiveG t Bool -> EventG t a
whenE e = joinMaybes . fmap h . flip snapshot e
where
h (a,True) = Just a
h (_,False) = Nothing
-- | Like 'scanl' for reactive values. See also 'scanlE'.
-scanlR :: Ord t => (a -> b -> a) -> a -> EventG t b -> ReactiveG t a
+scanlR :: (Ord t, Bounded t) => (a -> b -> a) -> a -> EventG t b -> ReactiveG t a
scanlR f a e = a `stepper` scanlE f a e
-- | Accumulate values from a monoid-valued event. Specialization of
-- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidE'.
-monoidR :: (Ord t, Monoid a) => EventG t a -> ReactiveG t a
+monoidR :: (Ord t, Bounded t, Monoid a) => EventG t a -> ReactiveG t a
monoidR = scanlR mappend mempty
-- Equivalently,
-- monoidR = stepper mempty . monoidE
-- | Combine two events into one.
-eitherE :: Ord t => EventG t a -> EventG t b -> EventG t (Either a b)
+eitherE :: (Ord t, Bounded t) => EventG t a -> EventG t b -> EventG t (Either a b)
eitherE ea eb = ((Left <$> ea) `mappend` (Right <$> eb))
-- | Start out blank ('Nothing'), latching onto each new @a@, and blanking
-- on each @b@. If you just want to latch and not blank, then use
-- 'mempty' for @lose@.
-maybeR :: Ord t => EventG t a -> EventG t b -> ReactiveG t (Maybe a)
+maybeR :: (Ord t, Bounded t) => EventG t a -> EventG t b -> ReactiveG t (Maybe a)
maybeR get lose =
Nothing `stepper` ((Just <$> get) `mappend` (Nothing <$ lose))
-- | Flip-flopping reactive value. Turns true when @ea@ occurs and false
-- when @eb@ occurs.
-flipFlop :: Ord t => EventG t a -> EventG t b -> ReactiveG t Bool
+flipFlop :: (Ord t, Bounded t) => EventG t a -> EventG t b -> ReactiveG t Bool
flipFlop ea eb =
False `stepper` ((True <$ ea) `mappend` (False <$ eb))
-- TODO: redefine maybeR and flipFlop in terms of eitherE.
-- | Count occurrences of an event. See also 'countE'.
-countR :: (Ord t, Num n) => EventG t a -> ReactiveG t n
+countR :: (Ord t, Bounded t, Num n) => EventG t a -> ReactiveG t n
countR e = 0 `stepper` countE_ e
-- | Partition an event into segments.
-splitE :: Ord t => EventG t b -> EventG t a -> EventG t (a, EventG t b)
+splitE :: (Ord t, Bounded t) => EventG t b -> EventG t a -> EventG t (a, EventG t b)
eb `splitE` ea = h <$> (eb `snapRemainderE` withRestE ea)
where
h ((a,ea'),eb') = (a, eb' `untilE` ea')
-- | Switch from one event to another, as they occur. (Doesn't merge, as
-- 'join' does.)
-switchE :: Ord t => EventG t (EventG t a) -> EventG t a
+switchE :: (Ord t, Bounded t) => EventG t (EventG t a) -> EventG t a
switchE = join . fmap (uncurry untilE) . withRestE
-- | Euler integral.
-integral :: forall v t. (VectorSpace v, t ~ Scalar v, Num t) =>
+integral :: forall v t. (VectorSpace v, AffineSpace t, Scalar v ~ Diff t) =>
t -> Event t -> Reactive v -> Reactive v
integral t0 newT r = sumR (snapshotWith (*^) r deltaT)
where
- deltaT :: Event t
+ deltaT :: Event (Diff t)
deltaT = diffE (pure t0 `mappend` newT)
-- TODO: find out whether this integral works recursively. If not, then
-- fix the implementation, rather than changing the semantics. (No
-- "delayed integral".)
-sumR :: Ord t => AdditiveGroup v => EventG t v -> ReactiveG t v
+sumR :: (Ord t, Bounded t) => AdditiveGroup v => EventG t v -> ReactiveG t v
sumR = scanlR (^+^) zeroV
diff --git a/src/Test/Integ.hs b/src/Test/Integ.hs
index 3718748..2d3997c 100644
--- a/src/Test/Integ.hs
+++ b/src/Test/Integ.hs
@@ -1,16 +1,52 @@
-- Simple test of recursive integrals, from Beelsebob
+import Control.Arrow (first)
+
+import Data.Max
+import Data.AddBounds
import FRP.Reactive.Behavior
import FRP.Reactive.PrimReactive
-import FRP.Reactive.Internal.Fun
+import FRP.Reactive.Internal.Reactive
+import FRP.Reactive.Internal.Behavior
+import FRP.Reactive.Future
import FRP.Reactive
import FRP.Reactive.Improving
-e = listE [(1,()),(2,()),(3,())]
-b = integral e b :: Behavior Double
-e' = listE [(0.5,0.5), (1,1), (1.5,1.5), (2,2), (2.5,2.5), (3,3)]
-snaps = b `snapshot_` e'
+-- For ticker
+import FRP.Reactive.Internal.Clock
+import FRP.Reactive.Internal.TVal
+import System.IO.Unsafe
+
+
+tick = atTimes [0,0.01 .. 2]
+it = integral tick
+
+ib = 1 + it ib :: Behavior Double
+e' = atTimes [0,0.1 .. 1.1]
+
+-- [(0.0,1.0),(0.1,1.1046221254112045),(0.2,1.2081089504435316),(0.30000000000000004,1.3345038765672335),(0.4000000000000001,1.4741225085031893),(0.5000000000000001,1.6283483384592894),(0.6000000000000001,1.7987096025387035),(0.7000000000000001,1.9868944241538458),(0.8,2.1947675417764927),(0.9,2.424388786780674),(1.0,2.67803349447676),(1.1,2.7048138294215276)]
+
+i1 = occs (ib `snapshot_` e')
+
+itst b = occs (it b `snapshot_` e')
+
+occs :: Event a -> [(TimeT, a)]
+occs = map (first (unNo . exact . getMax) . unFuture) . eFutures
+ where
+ unNo (NoBound a) = a
+
+-- [(0.0,0.0),(0.1,9.999999999999996e-2),(0.2,0.19),(0.30000000000000004,0.2900000000000001),(0.4000000000000001,0.3900000000000002),(0.5000000000000001,0.49000000000000027),(0.6000000000000001,0.5900000000000003),(0.7000000000000001,0.6900000000000004),(0.8,0.7900000000000005),(0.9,0.8900000000000006),(1.0,0.9900000000000007),(1.1,1.0000000000000007)]
+
+i2 = itst 1
+
+-- K 0.0 `Stepper` (1.0e-2,K 1.0e-2)->(2.0e-2,K 2.0e-2)->(3.0e-2,K 3.0e-2)->(3.9999999999999994e-2,K 3.9999999999999994e-2)->(4.999999999999999e-2,K 4.999999999999999e-2)->(5.9999999999999984e-2,K 5.9999999999999984e-2)->(6.999999999999998e-2,K 6.999999999999998e-2)->(7.999999999999997e-2,K 7.999999999999997e-2)->(8.999999999999997e-2,K 8.999999999999997e-2)->(9.999999999999996e-2,K 9.999999999999996e-2)->(0.10999999999999996,K 0.10999999999999996)->(0.11999999999999995,K 0.11999999999999995)->(0.12999999999999995,K 0.12999999999999995)->(0.13999999999999996,K 0.13999999999999996)->(0.14999999999999997,K 0.14999999999999997)->(0.15999999999999998,K 0.15999999999999998)->(0.16999999999999998,K 0.16999999999999998)->(0.18,K 0.18)->(0.19,K 0.19)->(0.2,K 0.2)-> ...
+
+r2 = unb (it 1)
+
+main = print i1
--- (0.5,0.0)->(1.0,0.0)->(1.5,0.0)->(2.0,0.0)->(2.5,0.0)->(3.0,0.0)
+-- Integration seems much slower than i'd expect it to be, even in the
+-- non-recursive case. Recursive and non-recursive examples slow down as
+-- they go.
diff --git a/src/Test/Merge.hs b/src/Test/Merge.hs
new file mode 100644
index 0000000..c3b76e0
--- /dev/null
+++ b/src/Test/Merge.hs
@@ -0,0 +1,89 @@
+-- Tracking down a problem with event merging
+
+import Data.Monoid (mappend)
+import Control.Applicative ((<$>))
+
+import FRP.Reactive.Improving
+import FRP.Reactive.Future
+import FRP.Reactive.PrimReactive
+import FRP.Reactive.Reactive
+import FRP.Reactive.Internal.Future
+import FRP.Reactive.Internal.Reactive
+
+
+-- (Imp 1.0,1)->(Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined
+e1 = listEG [(exactly 1,1),(exactly 2,2),(exactly 3,3),(after 4,17)]
+
+-- (Imp 1.5,100)->(Imp 2.5,200)
+e2 = listEG [(exactly 1.5, 100), (exactly 2.5, 200)]
+
+-- (Imp *** Exception: Prelude.undefined
+e3 = listEG [(after 2.5, 200)]
+
+-- (Imp 1.5,100)->(Imp 2.3,200)->(Imp *** Exception: Prelude.undefined
+e3' = listEG [(exactly 1.5, 100), (exactly 2.3, 200), (after 2.5, 300)]
+
+-- (Imp 1.0,1)->(Imp 1.5,100)->(Imp 2.0,2)->(Imp 2.5,200)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined
+e4 = e1 `mappend` e2
+
+-- (Imp 1.0,1)->(Imp 2.0,2)<interactive>: after: comparing after
+e5 = e1 `mappend` e3
+
+-- (Imp 1.0,1)->(Imp 1.5,100)->(Imp 2.0,2)->(Imp 2.3,200)<interactive>: after: comparing after
+e5' = e1 `mappend` e3'
+
+-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined
+f1 = eFuture e1
+
+-- <NoBound Imp 1.5,100 `Stepper` (Imp 2.5,200)>
+f2 = eFuture e2
+
+-- <NoBound Imp *** Exception: Prelude.undefined
+f3 = eFuture e3
+
+-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)->(Imp 3.0,3)->(Imp *** Exception: Prelude.undefined
+f4 = f1 `mappend` f3
+
+-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after
+f5 = f1 `merge` f3
+
+-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after
+f5' = eFuture e5
+
+
+
+--
+
+type Binop a = a -> a -> a
+
+mergeLR, mergeL, mergeR :: (Ord s) => Binop (FutureG s (ReactiveG s b))
+
+-- Same as 'merge'
+u `mergeLR` v =
+ (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v)
+
+u `mergeL` v = inFutR (`merge` v) <$> u
+
+u `mergeR` v = inFutR (u `merge`) <$> v
+
+-- inFutR :: (FutureG s (ReactiveG s b) -> FutureG t (ReactiveG t b))
+-- -> (ReactiveG s b -> ReactiveG t b)
+
+
+-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after
+f6 = f1 `mergeLR` f3
+
+-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after
+f7 :: Future (Reactive Integer)
+f7 = f1 `mergeL` f3
+
+-- <NoBound Imp *** Exception: Prelude.undefined
+f8 = f1 `mergeR` f3
+
+
+f7' :: Future (Reactive Integer)
+
+-- <NoBound Imp 1.0,1 `Stepper` (Imp 2.0,2)<interactive>: after: comparing after
+f7' = q <$> f1
+ where
+ q (a `Stepper` Event u') = a `Stepper` Event (u' `merge` f3)
diff --git a/src/Test/Reactive.hs b/src/Test/Reactive.hs
index aa0ba40..53c3f93 100755
--- a/src/Test/Reactive.hs
+++ b/src/Test/Reactive.hs
@@ -13,6 +13,8 @@
module Test.Reactive (batches,main) where
+-- import Test.QuickCheck
+
import Test.QuickCheck.Checkers
-- import qualified Data.Unamb
diff --git a/src/Test/SimpleFilter.hs b/src/Test/SimpleFilter.hs
new file mode 100644
index 0000000..a3ec25e
--- /dev/null
+++ b/src/Test/SimpleFilter.hs
@@ -0,0 +1,92 @@
+-- Tracking down a problem with event merging
+
+import Data.Monoid
+import Control.Applicative (pure,(<$>))
+import Control.Monad (join)
+
+import Data.Unamb
+
+import Data.Max
+import Data.AddBounds
+import FRP.Reactive.Improving
+import FRP.Reactive.Future
+import FRP.Reactive.PrimReactive -- hiding (filterE)
+import FRP.Reactive.Reactive -- hiding (filterE)
+import FRP.Reactive.Internal.Future
+import FRP.Reactive.Internal.Reactive
+
+-- For neverE
+import FRP.Reactive.Internal.Clock
+import FRP.Reactive.Internal.TVal
+import System.IO.Unsafe
+
+
+negateOdds :: Event Int -> Event Int
+negateOdds e =
+ (negate <$> filterE odd e) `mappend` (filterE even e)
+
+en :: TimeT -> Improving (AddBounds TimeT)
+en = exactly . NoBound
+
+an :: TimeT -> Improving (AddBounds TimeT)
+an = after . NoBound
+
+t :: (Bounded t, Eq t) => Int -> EventG t a -> [FutureG t a]
+t n = take n . eFutures
+
+e7 :: Event Int
+e7 = listEG [(en 1,1),(en 2,2),(en 3,3),(an 4,17)]
+t7 = t 3 e7
+
+e8 = filterE odd e7
+t8 = t 2 e8
+
+e9 = negate <$> e8
+t9 = t 2 e9
+
+e10 = filterE even e7
+t10 = t 1 e10
+
+e11 = e9 `mappend` e10
+t11 = t 3 e11
+
+e12 = filterE (const True) e7
+t12 = t 3 e12
+
+e13 = filterE (const True) e7 `mappend` mempty
+t13 = t 3 e13
+
+e14 = filterE (const True) e7 `mappend` listEG [(an 5, error "five")]
+t14 = t 3 e14
+
+-- One occurrence out per second
+e15 = filterE (const True) e7 `mappend` neverE
+t15 = t 3 e15
+
+-- This one finishes fine.
+e16 = filterE (const True) e7 `mappend` listEG [(maxBound, error "maxed out")]
+t16 = t 3 e16
+
+e17 = e7 `mappend` neverE
+t17 = t 3 e17
+
+
+-- Semantically equivalent to mappend
+neverE :: Event a
+neverE = unsafePerformIO $
+ do c <- makeClock
+ (_,never) <- makeEvent c
+ return never
+
+-- as expected: [<Imp NoBound C-c C-c
+tN = t 1 neverE
+
+-- Imp NoBound C-c C-c
+tinf :: ITime
+tinf = getMax (futTime (head tN))
+
+-- True
+p1 = en 0 <= tinf
+
+-- GT
+p2 = compareI tinf (NoBound 0)