summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorConalElliott <>2008-03-18 18:00:57 (GMT)
committerLuite Stegeman <luite@luite.com>2008-03-18 18:00:57 (GMT)
commit051cf8541921e2a2ec7badae76d8f126783ffa86 (patch)
tree8484fb997b17012318b2cf0ecc7e4a09db038bfb /src
parent39d70bfae3072637632a49263805af0a1ade676b (diff)
version 0.50.5
Diffstat (limited to 'src')
-rwxr-xr-xsrc/Data/EventExtras.hs107
-rwxr-xr-xsrc/Data/Fun.hs6
-rwxr-xr-xsrc/Data/Future.hs4
-rwxr-xr-xsrc/Data/Improving.hs53
-rwxr-xr-xsrc/Data/MEvent.hs72
-rwxr-xr-xsrc/Data/Reactive.hs29
-rwxr-xr-xsrc/Data/SEvent.hs168
-rwxr-xr-xsrc/Data/SFuture.hs76
-rwxr-xr-xsrc/Data/SImproving.hs60
-rwxr-xr-xsrc/Data/SReactive.hs169
-rwxr-xr-xsrc/Data/Unamb.hs83
-rwxr-xr-xsrc/Examples.hs69
12 files changed, 873 insertions, 23 deletions
diff --git a/src/Data/EventExtras.hs b/src/Data/EventExtras.hs
new file mode 100755
index 0000000..c21306a
--- /dev/null
+++ b/src/Data/EventExtras.hs
@@ -0,0 +1,107 @@
+{-# OPTIONS_GHC -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Data.EventExtras
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Event "extras", i.e., independent of representation
+----------------------------------------------------------------------
+
+module Data.EventExtras
+ (
+ module Data.SEvent
+ -- * Event extras
+ , EventD, EventI
+ , traceE, pairE, scanlE, monoidE
+ , withPrevE, countE, countE_, diffE
+ -- * To be moved elsewhere
+ , joinMaybes, filterMP
+ ) where
+
+import Control.Monad (liftM)
+import Control.Applicative ((<$>),liftA2)
+import Data.Pair (pairEdit)
+import Data.Monoid
+import Control.Monad (MonadPlus(..))
+import Debug.Trace (trace)
+
+import Data.SEvent
+-- import Data.MEvent
+
+import Data.Improving
+
+-- | Event, using Double for time
+type EventD = Event' Double
+
+-- | Event, using an /improving/ double for time
+type EventI = Event' (Improving Double)
+
+-- | Tracing of events.
+traceE :: (a -> String) -> Event' t a -> Event' t a
+traceE shw = fmap (\ a -> trace (shw a) a)
+
+pairE :: Ord t => (c,d) -> (Event' t c, Event' t d) -> Event' t (c,d)
+pairE cd cde = cd `accumE` pairEdit cde
+
+-- | Like 'scanl' for events. See also 'scanlR'.
+scanlE :: Ord t => (a -> b -> a) -> a -> Event' t b -> Event' t a
+scanlE f a e = a `accumE` (flip f <$> e)
+
+-- | Accumulate values from a monoid-valued event. Specialization of
+-- 'scanlE', using 'mappend' and 'mempty'. See also 'monoidR'.
+monoidE :: (Ord t, Monoid o) => Event' t o -> Event' t o
+monoidE = scanlE mappend mempty
+
+-- | Pair each event value with the previous one, given an initial value.
+withPrevE :: Ord t => Event' t a -> Event' 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 :: u -> (u,u) -> (u,u)
+ shift new (_,old) = (old,new)
+ combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v)
+ combineMaybes = uncurry (liftA2 (,))
+
+-- | Count occurrences of an event, remembering the occurrence values.
+-- See also 'countE_'.
+countE :: (Ord t, Num n) => Event' t b -> Event' t (b,n)
+countE = scanlE h (b0,0)
+ where
+ b0 = error "withCountE: no initial value"
+ h (_,n) b = (b,n+1)
+
+-- | Count occurrences of an event, forgetting the occurrence values. See
+-- also 'countE'. See also 'countR'.
+countE_ :: (Ord t, Num n) => Event' t b -> Event' t n
+countE_ e = snd <$> countE e
+
+-- | Difference of successive event occurrences.
+diffE :: (Ord t, Num n) => Event' t n -> Event' t n
+diffE e = uncurry (-) <$> withPrevE e
+
+
+{--------------------------------------------------------------------
+ To be moved elsewhere
+--------------------------------------------------------------------}
+
+-- | Pass through @Just@ occurrences.
+joinMaybes :: MonadPlus m => m (Maybe a) -> m a
+joinMaybes = (>>= maybe mzero return)
+
+-- | Pass through values satisfying @p@.
+filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a
+filterMP p m = joinMaybes (liftM f m)
+ where
+ f a | p a = Just a
+ | otherwise = Nothing
+
+-- Alternatively:
+-- filterMP p m = m >>= guarded p
+-- where
+-- guarded p x = guard (p x) >> return x
+
diff --git a/src/Data/Fun.hs b/src/Data/Fun.hs
index 9c15d94..53a0fbf 100755
--- a/src/Data/Fun.hs
+++ b/src/Data/Fun.hs
@@ -13,6 +13,7 @@
module Data.Fun (Fun(..), apply) where
+import Data.Monoid (Monoid(..))
import Control.Applicative (Applicative(..))
import Control.Arrow hiding (pure)
@@ -25,6 +26,11 @@ apply :: Fun t a -> (t -> a)
apply (K a) = const a
apply (Fun f) = f
+instance Monoid a => Monoid (Fun t a) where
+ mempty = K mempty
+ K a `mappend` K a' = K (a `mappend` a')
+ funa `mappend` funb = Fun (apply funa `mappend` apply funb)
+
instance Functor (Fun t) where
fmap f (K a) = K (f a)
fmap f (Fun g) = Fun (f.g)
diff --git a/src/Data/Future.hs b/src/Data/Future.hs
index 66126c2..561c23e 100755
--- a/src/Data/Future.hs
+++ b/src/Data/Future.hs
@@ -1,7 +1,6 @@
-- {-# LANGUAGE RecursiveDo #-}
-- For ghc-6.6 compatibility
{-# OPTIONS_GHC -fglasgow-exts #-}
-{-# OPTIONS -fno-warn-orphans #-}
----------------------------------------------------------------------
-- |
@@ -152,7 +151,9 @@ Never `race` b = b
a `race` Never = a
a `race` b = unsafePerformIO $
do (c,sink) <- newFuture
+ lock <- newEmptyMVar -- to avoid double-kill
let run fut tid = forkIO $ do x <- force fut
+ putMVar lock ()
killThread tid
sink x
mdo ta <- run a tb
@@ -168,4 +169,3 @@ a `race` b = unsafePerformIO $
-- | Run an 'IO'-action-valued 'Future'.
runFuture :: Future (IO ()) -> IO ()
runFuture = join . force
-
diff --git a/src/Data/Improving.hs b/src/Data/Improving.hs
new file mode 100755
index 0000000..1d7eca6
--- /dev/null
+++ b/src/Data/Improving.hs
@@ -0,0 +1,53 @@
+----------------------------------------------------------------------
+-- |
+-- Module : Data.Improving
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Improving values -- efficient version
+----------------------------------------------------------------------
+
+module Data.Improving
+ (
+ Improving(..), minI
+ ) where
+
+
+import Data.Unamb (unamb,assuming)
+
+{----------------------------------------------------------
+ Improving values
+----------------------------------------------------------}
+
+-- | An improving value.
+data Improving a = IV a (a -> Ordering)
+
+-- | A known improving value (which doesn't really improve)
+exactly :: Ord a => a -> Improving a
+exactly a = IV a (compare a)
+
+instance Eq a => Eq (Improving a) where
+ IV a _ == IV b _ = a == b
+
+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)
+IV u uComp `minI` IV v vComp = (IV uMinV wComp, uLeqV)
+ where
+ 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.
+ minComp = if uLeqV then uComp else vComp
+ wComp t = minComp t `unamb`
+ assuming (uCompT == vCompT) uCompT
+ where
+ uCompT = uComp t
+ vCompT = vComp t
diff --git a/src/Data/MEvent.hs b/src/Data/MEvent.hs
new file mode 100755
index 0000000..2106ef1
--- /dev/null
+++ b/src/Data/MEvent.hs
@@ -0,0 +1,72 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE TypeOperators, TypeSynonymInstances, MultiParamTypeClasses #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module : Data.MEvent
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Event implementation via semantics & Maybe
+----------------------------------------------------------------------
+
+module Data.MEvent
+ (
+ -- * Event primitives
+ Event', accumE
+ ) where
+
+import Data.Monoid
+import Data.Maybe
+import Control.Monad (MonadPlus(..))
+
+-- TypeCompose
+import Control.Compose ((:.)(..),inO,inO2)
+
+import qualified Data.SEvent as SR -- semantics
+
+
+{----------------------------------------------------------
+ Event primitives
+----------------------------------------------------------}
+
+-- | General events. 'Functor', 'Applicative', and 'Monoid' by
+-- construction. See also 'Event\''.
+-- In this representation, an event is a list of time/maybe pairs. The
+-- 'Just's correspond to occurrences and the 'Nothing's to
+-- non-occurrences.
+type Event' t = SR.Event' t :. Maybe
+
+-- The 'Monad' instance is thanks to Data.SEvent:
+--
+-- instance Ord t => DistribM (Event' t) Maybe where ...
+
+-- TODO: revisit Phooey. Can I use :. in place of monad transformers?
+-- How to monad transformers relate to the monad instance of (:.)?
+-- Follow up on references from my chat with Cale on 2008-03-02.
+
+-- One of the standard Monoid instances for type compositions. This one
+-- interleaves occurrences.
+instance Ord t => Monoid (Event' t a) where
+ mempty = O mempty
+ mappend = inO2 mappend -- interleave
+
+-- This MonadPlus instance could go in EventExtras, but it would be an
+-- orphan there.
+instance Ord t => MonadPlus (Event' t) where { mzero = mempty; mplus = mappend }
+
+
+-- | Accumulating event, starting from an initial value and a
+-- update-function event.
+accumE :: Ord t => a -> Event' t (a -> a) -> Event' t a
+accumE a = inO $ fmap Just . SR.accumE a . fmap (fromMaybe id)
+
+-- TODO: redefine accumE to preserve 'Nothing's, for later optimization.
+
+-- (<*>) :: Fut (a->a) -> Fut a -> Fut a
+
+-- (<*>) (on futures) does some unnecessary work here, since the function
+-- is guaranteed to be at least as new as the argument.
diff --git a/src/Data/Reactive.hs b/src/Data/Reactive.hs
index d47ea30..216d6cf 100755
--- a/src/Data/Reactive.hs
+++ b/src/Data/Reactive.hs
@@ -5,7 +5,6 @@
-- For ghc-6.6 compatibility
{-# OPTIONS_GHC -fglasgow-exts #-}
-
----------------------------------------------------------------------
-- |
-- Module : Data.Reactive
@@ -60,7 +59,9 @@ import Control.Applicative
import Control.Monad
import Debug.Trace (trace)
import Data.IORef
-import Control.Concurrent (forkIO,ThreadId)
+import Control.Concurrent -- (forkIO,ThreadId)
+
+import Data.Maybe
-- TypeCompose
import Control.Compose (Unop,(:.)(..), inO2, Monoid_f(..))
@@ -99,7 +100,9 @@ import Data.Fun
-- we're playing Asteroids and tracking collisions. Each collision can
-- break an asteroid into more of them, each of which has to be tracked
-- for more collisions. Another example: A chat room has an /enter/
--- event, whose occurrences contain new events like /speak/.
+-- event, whose occurrences contain new events like /speak/. An
+-- especially useful monad-based function is 'joinMaybes', which filters a
+-- Maybe-valued event.
--
newtype Event a = Event { eFuture :: Future (Reactive a) }
@@ -186,8 +189,17 @@ instance Applicative Event where { pure = return; (<*>) = ap }
instance Applicative Reactive where
pure a = a `stepper` mempty
- rf@(f `Stepper` Event vf) <*> rx@(x `Stepper` Event vx) =
- f x `stepper` Event (((<*> rx) <$> vf) `mappend` ((rf <*>) <$> vx))
+ rf@(f `Stepper` Event futf) <*> rx@(x `Stepper` Event futx) =
+ f x `stepper` Event fut
+ where
+ fut = fmap (\ rf' -> rf' <*> rx ) futf `mappend`
+ fmap (\ rx' -> rf <*> rx') futx
+
+-- More succinctly,
+--
+-- rf@(f `Stepper` Event futf) <*> rx@(x `Stepper` Event futx) =
+-- f x `stepper` Event (((<*> rx) <$> futf) `mappend` ((rf <*>) <$> futx))
+
-- A wonderful thing about the <*> definition for Reactive is that it
-- automatically caches the previous value of the function or argument
@@ -281,7 +293,7 @@ forkR (act `Stepper` e) = act >> forkE e
accumE :: a -> Event (a -> a) -> Event a
accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e'
--- | Like 'scanl' for events. See also 'scanE'.
+-- | Like 'scanl' for events. See also 'scanlR'.
scanlE :: (a -> b -> a) -> a -> Event b -> Event a
scanlE f a e = a `accumE` (flip f <$> e)
@@ -373,11 +385,12 @@ eventX = first join <$> mkEvent
mkReactive :: a -> IO (Reactive a, Sink a)
mkReactive a0 = first (a0 `stepper`) <$> mkEvent
--- | Reactive value from an initial value and an updater event. See also 'accumE'.
+-- | Reactive value from an initial value and an updater event. See also
+-- 'accumE'.
accumR :: a -> Event (a -> a) -> Reactive a
a `accumR` e = a `stepper` (a `accumE` e)
--- | Like 'scanl' for reactive values. See also 'scanE'.
+-- | Like 'scanl' for reactive values. See also 'scanlE'.
scanlR :: (a -> b -> a) -> a -> Event b -> Reactive a
scanlR f a e = a `stepper` scanlE f a e
diff --git a/src/Data/SEvent.hs b/src/Data/SEvent.hs
new file mode 100755
index 0000000..36b0f2c
--- /dev/null
+++ b/src/Data/SEvent.hs
@@ -0,0 +1,168 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving
+ , FlexibleInstances, FlexibleContexts, TypeSynonymInstances
+ , MultiParamTypeClasses
+ #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module : Data.SEvent
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Denotational semantics for events
+----------------------------------------------------------------------
+
+module Data.SEvent
+ (
+ -- * Event primitives
+ Event'(..), accumE
+ ) where
+
+import Data.Monoid
+import Control.Applicative
+import Control.Monad
+
+-- TypeCompose
+import Control.Compose (Binop,DistribM(..))
+
+import Data.SFuture
+
+
+{----------------------------------------------------------
+ Event primitives
+----------------------------------------------------------}
+
+-- | Generalized 'Event' over arbitrary (ordered) time type. See also
+-- 'Event\''.
+newtype Event' t a = E { unE :: [Future t a] }
+
+-- | Apply a unary function within the 'Ascend' constructor.
+inE :: ([Future t a] -> [Future t b]) -> (Event' t a -> Event' t b)
+inE f = E . f . unE
+
+-- | Apply a binary function within the 'E' constructor.
+inE2 :: ([Future t a] -> [Future t b] -> [Future t c])
+ -> (Event' t a -> Event' t b -> Event' t c)
+inE2 f = inE . f . unE
+
+
+-- Note: the semantics of Applicative and Monad are not consistent with
+--
+-- type Event = [] :. Fut
+--
+-- because that composition would combine future values with []-style
+-- backtracking instead of temporal interleaving.
+--
+-- However, maybe there's a []-wrapping newtype I can use instead.
+
+instance Ord t => Monoid (Event' t a) where
+ mempty = E []
+ mappend = inE2 merge
+
+instance Functor (Event' t) where
+ fmap f = inE ((fmap.fmap) f)
+
+instance Ord t => Applicative (Event' t) where
+ pure = return
+ (<*>) = ap
+
+instance Ord t => Monad (Event' t) where
+ return a = E ((return.return) a)
+ e >>= f = joinE (f <$> e)
+
+-- This MonadPlus instance could go in EventExtras, but it would be an
+-- orphan there.
+instance Ord t => MonadPlus (Event' t) where { mzero = mempty; mplus = mappend }
+
+-- For monad compositions.
+-- We'll need this instance in MEvent. It'd be an orphan there.
+instance Ord t => DistribM (Event' t) Maybe where
+ -- distribM :: Maybe (Event' t b) -> Event' t (Maybe b)
+ distribM = maybe mempty (fmap Just)
+
+-- | Equivalent to 'join' for 'Event'. More efficient?
+joinE :: Ord t => Event' t (Event' t a) -> Event' t a
+joinE = inE $ concatF . (fmap.fmap) unE
+
+-- Derivation:
+--
+-- Event (Event a)
+-- --> [Fut (Event a)] -- unE
+-- --> [Fut [Fut a]] -- (fmap.fmap) unE
+-- --> [Fut a] -- concatF
+-- --> Event a -- E
+
+-- My previous attempt:
+
+-- joinE :: Ord t => Event' t (Event' t a) -> Event' t a
+-- joinE = mconcat . fmap (E . fmap join . sequenceF . fmap unE) . unE
+--
+-- Derivation:
+--
+-- Event (Event a)
+-- --> [Fut (Event a)] -- unE
+-- --> [Fut [Fut a]] -- (fmap.fmap) unE
+-- --> [[Fut (Fut a)]] -- fmap sequenceF
+-- --> [[Fut a]] -- (fmap.fmap) join
+-- --> [Event a] -- fmap E
+-- --> Event a -- mconcat
+
+-- I don't think joinE works as I want. The join on Fut makes sure that
+-- the inner occurrences follow the outer, but I don't think fact is
+-- visible to the implementation. Also, note that the mconcat could have
+-- an infinite number of lists to merge.
+
+flatFFs :: Ord t => Future t [Future t a] -> [Future t a]
+flatFFs = fmap join . sequenceF
+
+concatF :: Ord t => [Future t [Future t a]] -> [Future t a]
+concatF = futVal . foldr mergeF (pure [])
+
+-- Binary merge. The second argument is required to have the property
+-- that sub-futures are all at least as late as the containing future.
+-- The result is then guaranteed to have the same property, which allows
+-- use of futVal instead of flatFFs in concatF.
+mergeF :: Ord t => Binop (Future t [Future t a])
+ffa `mergeF` Future (tb,futbs) =
+ -- First the a values before tb, then interleave the rest of the a
+ -- values with the b values.
+ Future (futTime ffa, prefa ++ (suffa `merge` futbs))
+ where
+ (prefa,suffa) = span ((<= tb).futTime) (flatFFs ffa)
+
+-- TODO: try out a more efficient version of mergeF that doesn't use
+-- (++). Idea: add a span to Data.DList and use it. Efficient &
+-- elegant.
+
+
+-- | Accumulating event, starting from an initial value and a
+-- update-function event. See also 'accumR'.
+accumE :: Ord t => a -> Event' t (a -> a) -> Event' t a
+accumE a = inE $ \ futfs -> accum (pure a) (fmap (<*>) futfs)
+
+
+{--------------------------------------------------------------------
+ Misc utilities
+--------------------------------------------------------------------}
+
+-- | Merge two ordered lists into an ordered list.
+merge :: Ord a => [a] -> [a] -> [a]
+[] `merge` vs = vs
+us `merge` [] = us
+us@(u:us') `merge` vs@(v:vs') =
+ if u <= v then
+ u : (us' `merge` vs )
+ else
+ v : (us `merge` vs')
+
+
+accum :: a -> [a->a] -> [a]
+accum _ [] = []
+accum a (f:fs) = a' : accum a' fs where a' = f a
+
+-- or
+-- accum a = tail . scanl (flip ($)) a
diff --git a/src/Data/SFuture.hs b/src/Data/SFuture.hs
index 4375a1d..ba4bed9 100755
--- a/src/Data/SFuture.hs
+++ b/src/Data/SFuture.hs
@@ -50,13 +50,27 @@
-- Please keep in mind that this module specifies the interface and
-- semantics, rather than a useful implementation. See "Data.Future" for
-- an implementation that nearly implements the semantics described here.
+--
+-- On second thought, I'm experimenting with using this module in an
+-- usable implementation of events. See Data.MEvent.
----------------------------------------------------------------------
-module Data.SFuture where
+module Data.SFuture
+ (
+ -- * Time & futures
+ Time, Future(..), futTime, futVal, sequenceF
+ -- * To go elsewhere
+ , Max(..), Min(..), AddBounds(..)
+ ) where
import Data.Monoid (Monoid(..))
import Control.Applicative (Applicative(..))
--- import Data.Function (on)
+import Data.Function (on)
+
+
+{----------------------------------------------------------
+ Time and futures
+----------------------------------------------------------}
-- | Time of some event occurrence, which can be any @Ord@ type. In an
-- actual implementation, we would not usually have access to the time
@@ -70,23 +84,61 @@ type Time t = Max (AddBounds t)
-- | A future value of type @a@ with time type @t@. Semantically, just a
-- time\/value pair, but those values would not be available until
-- 'force'd, which could block.
-newtype Future t a = Future (Time t, a)
+newtype Future t a = Future { unFuture :: (Time t, a) }
deriving (Functor, Applicative, Monad, Show)
-- The 'Applicative' instance relies on the 'Monoid' instance of 'Max'.
--- | Force a future. The real version blocks until knowable.
-force :: Future t a -> (Time t,a)
-force (Future p) = p
+-- | A future's time
+futTime :: Future t a -> Time t
+futTime = fst . unFuture
+
+-- | A future's value
+futVal :: Future t a -> a
+futVal = snd . unFuture
+
+
+-- -- The Monoid instance picks the earlier future
+-- instance Ord t => Monoid (Future t a) where
+-- mempty = Future (maxBound, error "it'll never happen, buddy")
+-- fut@(Future (t,_)) `mappend` fut'@(Future (t',_)) =
+-- if t <= t' then fut else fut'
+
+-- or:
+
+
+instance Eq (Future t a) where
+ (==) = error "sorry, no (==) for futures"
+
+instance Ord t => Ord (Future t a) where
+ (<=) = (<=) `on` futTime
+ -- We could leave 'min' to the default in terms of '(<=)', but the
+ -- following can yield partial time info, as much as allowed by the time
+ -- parameter type @t@ and its 'min'.
+ Future (s,a) `min` Future (t,b) =
+ Future (s `min` t, if s <= t then a else b)
+
+-- For some choices of @t@, there may be an efficient combination of 'min'
+-- and '(<=)'. In particular, 'Improving' has 'minI'.
--- The Monoid instance picks the earlier future
instance Ord t => Monoid (Future t a) where
mempty = Future (maxBound, error "it'll never happen, buddy")
- fut@(Future (t,_)) `mappend` fut'@(Future (t',_)) =
- if t <= t' then fut else fut'
+ mappend = min
+
+-- 'sequenceF' is like 'sequenceA' from "Data.Traversable". However,
+-- the @Traversable@ class assumes @Foldable@, which I'm not confident
+-- how to implement usefully. (I could of course just strip off the
+-- 'Future' constructor and the time. Why is Foldable required?
+
+-- | Make a future container into a container of futures.
+sequenceF :: Functor f => Future t (f a) -> f (Future t a)
+sequenceF (Future (tt, f)) = fmap (Future . ((,) tt)) f
+
--------- To go elsewhere
+{----------------------------------------------------------
+ To go elsewhere
+----------------------------------------------------------}
-- For Data.Monoid:
@@ -115,8 +167,8 @@ instance (Ord a, Bounded a) => Monoid (Min a) where
-- Equivalent to the Monad Writer instance.
-- import Data.Monoid
instance Monoid o => Monad ((,) o) where
- return = pure
- (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a
+ return = pure
+ (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a
-- Alternatively,
-- m >>= f = join (fmap f m)
diff --git a/src/Data/SImproving.hs b/src/Data/SImproving.hs
new file mode 100755
index 0000000..eb4e0e5
--- /dev/null
+++ b/src/Data/SImproving.hs
@@ -0,0 +1,60 @@
+{-# OPTIONS -Wall #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Data.Improving
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- \"Improving values\" from Warren Burton's \"Encapsulating Nondeterminacy
+-- in an Abstract Data Type with Deterministic Semantics\".
+--
+-- TODO: an efficient, referentially transparent, side-effecting version.
+----------------------------------------------------------------------
+
+module Data.Improving
+ (
+ Improving(..), exact
+ -- , Improves, merge
+ -- , Future(..)
+ ) where
+
+import Data.Function (on)
+
+-- | Progressive information about a value (e.g., a time)
+data Improving t = AtLeast t (Improving t) | Exactly t deriving Show
+
+-- | Extract an exact value from an improving value
+exact :: Improving t -> t
+exact (AtLeast _ u) = exact u
+exact (Exactly t) = t
+
+instance Eq t => Eq (Improving t) where
+ (==) = (==) `on` exact
+
+instance Ord t => Ord (Improving t) where
+ Exactly s `compare` Exactly t = s `compare` t
+ AtLeast s u' `compare` v@(Exactly t) =
+ if s > t then GT else u' `compare` v
+ u@(Exactly s) `compare` AtLeast t v' =
+ if s < t then LT else u `compare` v'
+ u@(AtLeast s u') `compare` v@(AtLeast t v') =
+ -- move forward where we know less
+ if s <= t then
+ u' `compare` v
+ else
+ u `compare` v'
+
+ Exactly s `min` Exactly t = Exactly (s `min` t)
+ AtLeast s u' `min` v@(Exactly t) =
+ if s > t then v else u' `min` v
+ u@(Exactly s) `min` AtLeast t v' =
+ if s < t then u else u `min` v'
+ u@(AtLeast s u') `min` v@(AtLeast t v') =
+ -- move forward where we know less
+ if s <= t then
+ u' `min` v
+ else
+ u `min` v'
diff --git a/src/Data/SReactive.hs b/src/Data/SReactive.hs
new file mode 100755
index 0000000..3a95baf
--- /dev/null
+++ b/src/Data/SReactive.hs
@@ -0,0 +1,169 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Data.SReactive
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Simple, semantics-based reactive values
+----------------------------------------------------------------------
+
+module Data.SReactive
+ (
+ -- * Primitives
+ Reactive'(..), stepper
+ , joinR
+ -- * Extras (defined via primitives)
+ , Reactive
+ , switcher, snapshot, snapshot_, whenE
+ , accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR
+ ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.Monoid
+
+-- TypeCompose
+import Control.Compose (Unop)
+import Data.Pair (Pair(..),pairEdit)
+
+import Data.EventExtras
+import Data.Improving
+
+
+{----------------------------------------------------------
+ Primitives
+----------------------------------------------------------}
+
+data Reactive' t a =
+ Stepper {
+ rInit :: a -- ^ initial value
+ , rEvent :: Event' t a -- ^ waiting for event
+ }
+
+-- | Reactive value from an initial value and a new-value event.
+stepper :: a -> Event' t a -> Reactive' t a
+stepper = Stepper
+
+
+instance Ord t => Pair (Reactive' t) where
+ -- pair :: Reactive' t a -> Reactive' t b -> Reactive' t (a,b)
+ (c `Stepper` ce) `pair` (d `Stepper` de) =
+ (c,d) `accumR` pairEdit (ce,de)
+
+instance Functor (Reactive' t) where
+ fmap f (a `Stepper` e) = f a `stepper` fmap f e
+
+instance Ord t => Applicative (Reactive' t) where
+ pure a = a `stepper` mempty
+ -- Standard definition. See 'Pair'.
+ rf <*> rx = uncurry ($) <$> (rf `pair` rx)
+
+-- A wonderful thing about the <*> definition for Reactive' t is that it
+-- automatically caches the previous value of the function or argument
+-- when the argument or function changes.
+
+instance Ord t => Monad (Reactive' t) where
+ return = pure
+ r >>= f = joinR (f <$> r)
+
+-- | Reactive' t 'join' (equivalent to 'join' but slightly more efficient, I think)
+joinR :: Ord t => Reactive' t (Reactive' t a) -> Reactive' t a
+joinR ((a `Stepper` e) `Stepper` er) =
+ a `stepper` (e `mappend` join (rToE <$> er))
+
+-- | Turn a reactive value into an event, given a time for the initial
+-- occurrence.
+rToE :: Ord t => Reactive' t a -> Event' t a
+rToE (a `Stepper` e) = pure a `mappend` e
+
+-- e :: Event' t a
+-- er :: Event' t (Reactive' t a)
+--
+-- rToE <$> er ::: Event' t (Event' t a)
+-- join (rToE <$> er) ::: Event' t a
+
+-- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@
+-- didn't.
+snap :: forall a b t. Ord t =>
+ Event' t a -> Reactive' t b -> Event' t (Maybe a, b)
+ea `snap` (b0 `Stepper` eb) =
+ (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)
+
+
+{----------------------------------------------------------
+ Extras (defined via primitives)
+----------------------------------------------------------}
+
+type Reactive = Reactive' (Improving Double)
+
+-- | Snapshot a reactive value whenever an event occurs.
+snapshot :: Ord t => Event' t a -> Reactive' t b -> Event' t (a,b)
+e `snapshot` r = joinMaybes $ fmap f (e `snap` r)
+ where
+ f (Nothing,_) = Nothing
+ f (Just a ,b) = Just (a,b)
+
+-- | Switch between reactive values.
+switcher :: Ord t => Reactive' t a -> Event' t (Reactive' t a) -> Reactive' t a
+r `switcher` e = joinR (r `stepper` e)
+
+-- | Like 'snapshot' but discarding event data (often @a@ is @()@).
+snapshot_ :: Ord t => Event' t a -> Reactive' t b -> Event' t b
+e `snapshot_` src = snd <$> (e `snapshot` src)
+
+-- | Filter an event according to whether a boolean source is true.
+whenE :: Ord t => Event' t a -> Reactive' t Bool -> Event' t a
+whenE e = joinMaybes . fmap h . snapshot e
+ where
+ h (a,True) = Just a
+ h (_,False) = Nothing
+
+
+-- | Reactive' t value from an initial value and an updater event. See also
+-- 'accumE'.
+accumR :: Ord t => a -> Event' t (a -> a) -> Reactive' t a
+a `accumR` e = a `stepper` (a `accumE` e)
+
+-- | Like 'scanl' for reactive values. See also 'scanlE'.
+scanlR :: Ord t => (a -> b -> a) -> a -> Event' t b -> Reactive' 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) => Event' t a -> Reactive' t a
+monoidR = scanlR mappend mempty
+
+-- | 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 => Event' t a -> Event' t b -> Reactive' t (Maybe a)
+maybeR get lose =
+ Nothing `stepper` (fmap Just get `mappend` (Nothing <$ lose))
+
+-- | Flip-flopping source. Turns true when @ea@ occurs and false when
+-- @eb@ occurs.
+flipFlop :: Ord t => Event' t a -> Event' t b -> Reactive' t Bool
+flipFlop ea eb =
+ False `stepper` ((True <$ ea) `mappend` (False <$ eb))
+
+-- TODO: generalize 'maybeR' & 'flipFlop'. Perhaps using 'Monoid'.
+-- Note that Nothing and (Any False) are mempty.
+
+-- | Count occurrences of an event. See also 'countE'.
+countR :: (Ord t, Num n) => Event' t a -> Reactive' t n
+countR e = 0 `stepper` countE_ e
+
+-- | Tracing of reactive values
+traceR :: (a -> String) -> Unop (Reactive' t a)
+traceR shw (a `Stepper` e) = a `Stepper` traceE shw e
+
diff --git a/src/Data/Unamb.hs b/src/Data/Unamb.hs
new file mode 100755
index 0000000..1be8ff4
--- /dev/null
+++ b/src/Data/Unamb.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE RecursiveDo #-}
+----------------------------------------------------------------------
+-- |
+-- Module : Data.Unamb
+-- Copyright : (c) Conal Elliott 2008
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+--
+-- Unambiguous choice
+----------------------------------------------------------------------
+
+module Data.Unamb
+ (
+ unamb, amb, race, assuming
+ ) where
+
+-- For hang
+import Control.Monad (forever)
+import System.IO.Unsafe
+
+-- For unamb
+import Control.Concurrent
+import Control.Exception (evaluate)
+
+
+-- | Unambiguous choice operator. Equivalent to the ambiguous choice
+-- operator, but with arguments restricted to be equal where not bottom,
+-- so that the choice doesn't matter. See also 'amb'.
+unamb :: a -> a -> a
+a `unamb` b = unsafePerformIO (a `amb` b)
+
+
+-- | Ambiguous choice operator. Yield either value. Evaluates in
+-- separate threads and picks whichever finishes first. See also
+-- 'unamb' and 'race'.
+amb :: a -> a -> IO a
+a `amb` b = evaluate a `race` evaluate b
+
+-- | Race two actions against each other in separate threads, and pick
+-- whichever finishes first. See also 'amb'.
+race :: IO a -> IO a -> IO a
+a `race` b =
+ -- Evaluate a and b in concurrent threads. Whichever thread finishes
+ -- first kill the other thread.
+ do v <- newEmptyMVar -- to hold a or b
+ lock <- newEmptyMVar -- to avoid double-kill
+ -- Evaluate one value and kill the other.
+ let run io tid = forkIO $ do x <- io
+ putMVar lock ()
+ killThread tid
+ putMVar v x
+ mdo ta <- run a tb
+ tb <- run b ta
+ return ()
+ readMVar v
+
+-- Without using unsafePerformIO, is there a way to define a
+-- non-terminating but non-erroring pure value that consume very little
+-- resources while not terminating?
+
+-- | Never yield an answer. Like 'undefined' or 'error "whatever"', but
+-- don't raise an error, and don't consume computational resources.
+hang :: a
+hang = unsafePerformIO hangIO
+
+-- | Block forever
+hangIO :: IO a
+hangIO = do -- putStrLn "warning: blocking forever."
+ -- Any never-terminating computation goes here
+ -- This one can yield an exception "thread blocked indefinitely"
+ -- newEmptyMVar >>= takeMVar
+ -- sjanssen suggests this alternative:
+ forever $ threadDelay maxBound
+ -- forever's return type is (), though it could be fully
+ -- polymorphic. Until it's fixed, I need the following line.
+ return undefined
+
+
+-- | Yield a value if a condition is true. Otherwise wait forever.
+assuming :: Bool -> a -> a
+assuming c a = if c then a else hang
diff --git a/src/Examples.hs b/src/Examples.hs
index ad2b7e9..28ccef2 100755
--- a/src/Examples.hs
+++ b/src/Examples.hs
@@ -17,7 +17,7 @@
-- base
import Data.Monoid
import Data.IORef
-import Control.Monad ((>=>),forM_)
+import Control.Monad
import Control.Applicative
import Control.Arrow (first,second)
import Control.Concurrent (yield, forkIO, killThread, threadDelay, ThreadId)
@@ -242,3 +242,70 @@ sw1 = do (e, snk) <- mkEvent
-- two different previous GUI examples.
main = t6
+
+
+updPair :: Either c d -> (c,d) -> (c,d)
+updPair = (first.const) `either` (second.const)
+
+-- updPair (Left c') (_,d) = (c',d)
+-- updPair (Right d') (c,_) = (c,d')
+
+-- mixEither :: (Event c, Event d) -> Event (Either c d)
+-- mixEither :: (Functor f, Monoid (f (Either a b))) =>
+-- (f a, f b) -> f (Either a b)
+mixEither :: MonadPlus m => (m a, m b) -> m (Either a b)
+mixEither (ec,ed) = liftM Left ec `mplus` liftM Right ed
+
+-- unmixEither :: Event (Either c d) -> (Event c, Event d)
+unmixEither :: MonadPlus m => m (Either c d) -> (m c, m d)
+unmixEither ecd = (filt left, filt right)
+ where
+ filt f = joinMaybes (liftM f ecd)
+
+left :: Either c d -> Maybe c
+left (Left c) = Just c
+left _ = Nothing
+
+right :: Either c d -> Maybe d
+right (Right d) = Just d
+right _ = Nothing
+
+
+-- pairEditE :: (Event c, Event d) -> Event ((c,d) -> (c,d))
+
+-- pairEditE :: (Functor f, Monoid (f ((d, a) -> (d, a)))) =>
+-- (f d, f a) -> f ((d, a) -> (d, a))
+-- pairEditE (ce,de) =
+-- ((first.const) <$> ce) `mappend` ((second.const) <$> de)
+
+-- pairEditE :: (Functor m, MonadPlus m) => (m d, m a) -> m ((d, a) -> (d, a))
+-- pairEditE (ce,de) =
+-- ((first.const) <$> ce) `mplus` ((second.const) <$> de)
+
+pairEditE :: MonadPlus m => (m c,m d) -> m ((c,d) -> (c,d))
+pairEditE = liftM updPair . mixEither
+
+-- pairEditE cde = liftM updPair (mixEither cde)
+
+-- or, skipping sums
+
+-- pairEditE (ce,de) =
+-- liftM (first.const) ce `mplus` liftM (second.const) de
+
+pairE :: (c,d) -> (Event c, Event d) -> Event (c,d)
+pairE cd cde = cd `accumE` pairEditE cde
+
+pairR :: Reactive c -> Reactive d -> Reactive (c,d)
+
+-- (c `Stepper` ce) `pairR` (d `Stepper` de) =
+-- (c,d) `stepper` pairE (c,d) (ce,de)
+
+-- More directly:
+
+(c `Stepper` ce) `pairR` (d `Stepper` de) =
+ (c,d) `accumR` pairEditE (ce,de)
+
+-- pairR' :: Reactive c -> Reactive d -> Reactive (c,d)
+-- (c `Stepper` ce) `pairR'` (d `Stepper` de) =
+-- (c,d) `accumR` pairEditE (ce,de)
+