summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorConalElliott <>2008-12-08 23:17:59 (GMT)
committerLuite Stegeman <luite@luite.com>2008-12-08 23:17:59 (GMT)
commit14ba4c5925a159d0aba1aea00ba75997cf82ada4 (patch)
treee0864b8c5508d218d83b3f4856eb177a2c3dbaa3 /src
parenta507fd28bc7a74231670d0d7a1866b1953892abe (diff)
version 0.9.100.9.10
Diffstat (limited to 'src')
-rwxr-xr-xsrc/Data/AddBounds.hs38
-rwxr-xr-xsrc/FRP/Reactive/Behavior.hs14
-rwxr-xr-xsrc/FRP/Reactive/PrimReactive.hs8
-rwxr-xr-xsrc/FRP/Reactive/Reactive.hs21
4 files changed, 62 insertions, 19 deletions
diff --git a/src/Data/AddBounds.hs b/src/Data/AddBounds.hs
index a02311a..1d4b752 100755
--- a/src/Data/AddBounds.hs
+++ b/src/Data/AddBounds.hs
@@ -15,6 +15,8 @@ module Data.AddBounds (AddBounds(..)) where
import Control.Applicative (pure,(<$>))
+-- import Data.Unamb (unamb)
+
-- Testing
import Test.QuickCheck
import Test.QuickCheck.Checkers
@@ -63,6 +65,42 @@ instance Ord a => Ord (AddBounds a) where
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.
+
+-- 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.
+
+
instance Arbitrary a => Arbitrary (AddBounds a) where
arbitrary = frequency [ (1 ,pure MinBound)
, (10, NoBound <$> arbitrary)
diff --git a/src/FRP/Reactive/Behavior.hs b/src/FRP/Reactive/Behavior.hs
index 5bc9f15..fe4fbac 100755
--- a/src/FRP/Reactive/Behavior.hs
+++ b/src/FRP/Reactive/Behavior.hs
@@ -101,8 +101,8 @@ b `switcher` eb = beh (unb b `R.switcher` (unb <$> eb))
-- > snapshotWith :: (a -> b -> c) -> Event a -> Behavior b -> Event c
snapshotWith :: Ord t =>
(a -> b -> c)
- -> EventI t a -> BehaviorI t b -> EventI t c
-snapshotWith h e b = f <$> (withTimeE e `R.snapshot` unb b)
+ -> BehaviorI t b -> EventI t a -> EventI t c
+snapshotWith h b e = f <$> (unb b `R.snapshot` withTimeE e)
where
f ((a,t),tfun) = h a (tfun `apply` t)
@@ -117,7 +117,7 @@ snapshotWith h e b = f <$> (withTimeE e `R.snapshot` unb b)
-- | Snapshot a behavior whenever an event occurs. See also 'snapshotWith'.
--
-- > snapshot :: Event a -> Behavior b -> Event (a,b)
-snapshot :: Ord t => EventI t a -> BehaviorI t b -> 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
@@ -131,7 +131,7 @@ snapshot = snapshotWith (,)
-- | Like 'snapshot' but discarding event data (often @a@ is '()').
--
-- > snapshot_ :: Event a -> Behavior b -> Event b
-snapshot_ :: Ord t => EventI t a -> BehaviorI t b -> EventI t b
+snapshot_ :: Ord t => BehaviorI t b -> EventI t a -> EventI t b
snapshot_ = snapshotWith (flip const)
-- Alternative implementations
@@ -142,7 +142,7 @@ snapshot_ = snapshotWith (flip const)
--
-- > whenE :: Event a -> Behavior Bool -> Event a
whenE :: Ord t => EventI t a -> BehaviorI t Bool -> EventI t a
-whenE e = joinMaybes . fmap h . snapshot e
+whenE e = joinMaybes . fmap h . flip snapshot e
where
h (a,True) = Just a
h (_,False) = Nothing
@@ -183,7 +183,7 @@ accumB = (result.result) rToB R.accumR
-- monoidB :: Monoid a => Event (Behavior a) -> Behavior a
-- monoidB = scanlB mappend mempty
--- -- I doubt these definitions work well. They accumulate reactives without
+-- -- I doubt the above definitions work well. They accumulate reactives without
-- -- aging them. See 'accumE'.
@@ -248,7 +248,7 @@ countB = result rToB R.countR
-- > Event () -> Behavior v -> Behavior v
integral :: (Scalar v ~ t, Ord t, VectorSpace v, Num t) =>
EventI t a -> BehaviorI t v -> BehaviorI t v
-integral t = sumB . snapshotWith (*^) (diffE (t `snapshot_` time))
+integral t b = sumB (snapshotWith (*^) b (diffE (time `snapshot_` t)))
-- Yow! That's a mouth full!
diff --git a/src/FRP/Reactive/PrimReactive.hs b/src/FRP/Reactive/PrimReactive.hs
index c2b4799..7f68aae 100755
--- a/src/FRP/Reactive/PrimReactive.hs
+++ b/src/FRP/Reactive/PrimReactive.hs
@@ -438,9 +438,9 @@ atTimeG = atTimesG . pure
-- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@
-- didn't.
snap :: forall a b t. Ord t =>
- EventG t a -> ReactiveG t b -> EventG t (Maybe a, b)
-Event (Future (Max MaxBound, _)) `snap` _ = mempty
-ea `snap` (b0 `Stepper` eb) =
+ 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)
@@ -451,7 +451,7 @@ ea `snap` (b0 `Stepper` eb) =
-- | Snapshot a reactive value whenever an event occurs and apply a
-- combining function to the event and reactive's values.
snapshotWith :: Ord t =>
- (a -> b -> c) -> EventG t a -> ReactiveG t b -> EventG t c
+ (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
diff --git a/src/FRP/Reactive/Reactive.hs b/src/FRP/Reactive/Reactive.hs
index 5bc82dd..fb337b3 100755
--- a/src/FRP/Reactive/Reactive.hs
+++ b/src/FRP/Reactive/Reactive.hs
@@ -166,8 +166,13 @@ 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 :: Event a -> Event b -> Event (a, Event b)
-snapRemainderE ea eb = ea `snapshot` remainderR eb
+snapRemainderE :: Ord t =>
+ EventG t b -> EventG t a -> EventG t (a, EventG t b)
+snapRemainderE = snapshot . remainderR
+
+-- snapRemainderE eb = snapshot (remainderR eb)
+
+-- eb `snapRemainderE` ea = remainderR eb `snapshot` ea
-- withTailE ea eb = error "withTailE: undefined" ea eb
@@ -266,11 +271,11 @@ type Reactive = ReactiveG ITime
-- | Snapshot a reactive value whenever an event occurs.
-snapshot :: Ord t => EventG t a -> ReactiveG t b -> EventG t (a,b)
+snapshot :: Ord 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 => EventG t a -> ReactiveG t b -> EventG t b
+snapshot_ :: Ord t => ReactiveG t b -> EventG t a -> EventG t b
snapshot_ = snapshotWith (flip const)
-- Alternative implementations
@@ -279,7 +284,7 @@ snapshot_ = snapshotWith (flip const)
-- | Filter an event according to whether a reactive boolean is true.
whenE :: Ord t => EventG t a -> ReactiveG t Bool -> EventG t a
-whenE e = joinMaybes . fmap h . snapshot e
+whenE e = joinMaybes . fmap h . flip snapshot e
where
h (a,True) = Just a
h (_,False) = Nothing
@@ -320,8 +325,8 @@ countR :: (Ord 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 a -> EventG t b -> EventG t (a, EventG t b)
-ea `splitE` eb = h <$> (withRestE ea `snapshot` remainderR eb)
+splitE :: Ord 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')
@@ -334,7 +339,7 @@ switchE = join . fmap (uncurry untilE) . withRestE
-- | Euler integral.
integral :: forall v t. (VectorSpace v, t ~ Scalar v, Num t) =>
t -> Event t -> Reactive v -> Reactive v
-integral t0 newT r = sumR (snapshotWith (*^) deltaT r)
+integral t0 newT r = sumR (snapshotWith (*^) r deltaT)
where
deltaT :: Event t
deltaT = diffE (pure t0 `mappend` newT)