diff --git a/Control/Concurrent/CHP/Alt.hs b/Control/Concurrent/CHP/Alt.hs
--- a/Control/Concurrent/CHP/Alt.hs
+++ b/Control/Concurrent/CHP/Alt.hs
@@ -107,12 +107,15 @@
 import Control.Monad.State
 import Control.Monad.Trans
 import Data.List
+import qualified Data.Map as Map
 import Data.Maybe
+import Data.Unique
 import System.IO
 
 import Control.Concurrent.CHP.Base
 import Control.Concurrent.CHP.Event
 import Control.Concurrent.CHP.Guard
+import Control.Concurrent.CHP.Monad
 import Control.Concurrent.CHP.Parallel
 import Control.Concurrent.CHP.Poison
 import Control.Concurrent.CHP.Traces.Base
@@ -166,7 +169,7 @@
 -- Whichever channel is chosen by both processes will not satisfy the priority
 -- at one end (if such priority between channels was supported).
 priAlt :: [CHP a] -> CHP a
-priAlt items = (liftPoison $ priAlt' $ map wrapPoison items) >>= checkPoison
+priAlt items = unwrapPoison $ priAlt' $ map wrapPoison items
 
 -- | A useful operator to perform an 'alt'.  This operator is associative,
 -- and has arbitrary priority.  When you have lots of guards, it is probably easier
@@ -281,26 +284,37 @@
 -- behaviour as x.
 --
 -- Added in version 1.1.0
-every :: [CHP a] -> CHP [a]
-every [] = liftPoison $ AltableT (SkipGuard [], return []) (return [])
-every xs = liftPoison (AltableT (foldl1 merge $ map blankEvent gs, getEventPoison True) (return
-  $ NoPoison False)) >>= checkPoison >>= \b -> if b then runParallel (map (unwrapPoison . liftTrace) bodies) else alt [every xs]
+every :: forall a. [CHP a] -> CHP [a]
+every [] = skip >> return []
+every xs = liftPoison (AltableT (liftM ((:[]) . flip (,) (return True)) $ gs >>= foldM1 merge) (return
+   False)) >>= \b -> if b then runParallel (map (unwrapPoison . liftTrace) bodies) else alt [every xs]
   where
-    (gs, bodies) = unzip $ map (pullOutAltable . wrapPoison) xs
+    both :: Either String [(Guard, TraceT IO (WithPoison a))]
+    both = mapM (checkSingle . pullOutAltable . wrapPoison) xs
+    gs :: Either String [Guard]
+    gs = liftM (map fst) both
+    bodies = map snd $ fromRight both
+    fromRight (Right x) = x
+    fromRight _ = error "Reached unreachable code in every; bodies executed after bad guard"
 
-    blankEvent :: Guard -> Guard
-    blankEvent (EventGuard _ rec act es) = EventGuard [] rec act es
-    blankEvent g = g
+    checkSingle (Left err) = Left err
+    checkSingle (Right []) = Left "Bad guard in every"
+    checkSingle (Right [x]) = Right x
+    checkSingle (Right _) = Left "Alt inside every"
 
-    merge :: Guard -> Guard -> Guard
-    merge (SkipGuard _) g = g
-    merge g (SkipGuard _) = g
-    merge StopGuard _ = StopGuard
-    merge _ StopGuard = StopGuard
-    merge (EventGuard _ recx actx esx) (EventGuard _ recy acty esy)
-      = EventGuard [] (recx ++ recy) (actx >> acty) (esx ++ esy)
-    merge _ _ = BadGuard "merging unsupported guards"
+    merge :: Guard -> Guard -> Either String Guard
+    merge SkipGuard g = return g
+    merge g SkipGuard = return g
+    merge StopGuard _ = return StopGuard
+    merge _ StopGuard = return StopGuard
+    merge (EventGuard recx actx esx) (EventGuard recy acty esy)
+      = return $ EventGuard (\n -> recx n ++ recy n) (actx >> acty) (esx ++ esy)
+    merge _ _ = badGuard "merging unsupported guards"
 
+    foldM1 :: Monad m => (b -> b -> m b) -> [b] -> m b
+    foldM1 f (y:ys) = foldM f y ys
+    foldM1 _ _ = error "Reached unreachable code in every; guards empty in non-empty case"
+
 -- | A useful operator that acts like 'every'.  The operator is associative and
 -- commutative (see 'every' for notes on idempotence).  When you have lots of things
 -- to join with this operator, it's probably easier to use the 'every' function.
@@ -336,110 +350,52 @@
 -- I had some memory efficiency problems so I went with the state-monad-based
 -- approach instead.
 
-priAlt' :: forall a. [CHP' a] -> CHP' a
+priAlt' :: forall a. [CHP' (WithPoison a)] -> CHP' (WithPoison a)
 priAlt' items
   -- Our guard is a nested guard of all our sub-guards.
   -- Our action-if-not-guard is to do the selection ourselves.
-  -- Our body is to read the numbered list, strip one off and follow the path,
-  -- ignoring the action-if-not-guard of the chosen body
-  = AltableT (NestedGuards $ wrappedGuards
-               ,executeNumberedBody)
-             (selectFromGuards >> executeNumberedBody)
+  = AltableT flattenedGuards selectFromGuards
   where
-    wrappedGuards :: [Guard]
-    wrappedGuards = map wrap flattenedGuards
-      where
-        wrap :: (Int, Guard) -> Guard
-        wrap (n, SkipGuard ns) = SkipGuard $ n : ns
-        wrap (n, EventGuard ns e act ab) = EventGuard (n:ns) e act ab
-        wrap (n, TimeoutGuard g) = TimeoutGuard $
-          do g' <- g
-             return $ do ns <- g'
-                         return (n : ns)
-        wrap (_, g@(BadGuard _)) = g
-        wrap (_, _) = BadGuard "wrapped"
-
-    -- Polls the available guards, but ignores timeout guards and alting barrier
-    -- guards
-    checkNormalGuards :: STM (Maybe Int)
-    checkNormalGuards = foldl1 orElse $
-                          (map checkGuard flattenedGuards) ++ [return Nothing]
-      where
-        checkGuard :: (Int, Guard) -> STM (Maybe Int)
-        checkGuard (n, BadGuard _) = return $ Just n
-        checkGuard (n, SkipGuard {}) = return $ Just n
-        checkGuard (_, _) = retry
-
-    -- Waits for one of the normal (non-alting barrier) guards to be ready,
-    -- or the given transaction to complete
-    waitNormalGuards :: STM [Int] -> IO (Bool, [Int])
-    waitNormalGuards extra
-      = do guards <- mapM enable wrappedGuards
-           atomically $ foldl1 orElse (wrap True extra : map (wrap False) guards)
-      where
-        enable :: Guard -> IO (STM [Int])
-        enable (BadGuard _) = return $ return []
-        enable (SkipGuard ns) = return $ return ns
-        enable (TimeoutGuard g) = g
-        enable _ = return retry -- This effectively ignores other guards
-
-        wrap :: Bool -> STM [Int] -> STM (Bool, [Int])
-        wrap b m = do x <- m
-                      return (b, x)
-
-
     -- The list of guards without any NestedGuards or StopGuards:
-    flattenedGuards :: [(Int, Guard)]
-    flattenedGuards = (flatten $ zip [0..] $ map (fst . pullOutAltable) items)
+    flattenedGuards :: Either String [(Guard, TraceT IO (WithPoison a))]
+    flattenedGuards = liftM (filter (not . isStopGuard . fst)) altStuff
       where
-        flatten :: [(Int, Guard)] -> [(Int,Guard)]
-        flatten [] = []
-        flatten ((n,x):xs) = case x of
-          NestedGuards gs -> flatten $ zip (repeat n) gs ++ xs
-          StopGuard -> flatten xs
-          g -> (n, g) : flatten xs
+        altStuff :: Either String [(Guard, TraceT IO (WithPoison a))]
+        altStuff = liftM concat $ mapM pullOutAltable items
 
     -- The alting barrier guards:
-    eventGuards :: [([RecordedIndivEvent], [Int], STM (), [Event])]
-    eventGuards = [(rec,ns,act,ab) | EventGuard ns rec act ab <- wrappedGuards]
-
-    -- We must use isPrefixOf, because things are added in the case of poison
-    findEventAssoc :: [Int] -> [RecordedIndivEvent]
-    findEventAssoc x = case filter (\(_,y,_,_) -> y `isPrefixOf` x) eventGuards of
-      [(rec,_,_,_)] -> rec
-      _ -> error "Could not find associated event in alt, internal logic error" 
-                   
-        
-    
-
-    -- Stores a list of ints in the state
-    storeChoice :: [Int] -> TraceT IO ()
-    storeChoice ns = modify (\(_, es) -> (ns, es))
-
-    isBadGuard :: Guard -> Bool
-    isBadGuard (BadGuard _) = True
-    isBadGuard _ = False
+    eventGuards :: [Guard] -> [((Unique -> Integer) -> [RecordedIndivEvent Unique], Int, STM (), [Event])]
+    eventGuards guards = [(rec,n,act,ab) | (n, EventGuard rec act ab) <- zip [0..] guards]
 
-    -- Performs the select operation on all the guards.  The choice is stored
-    -- in the state ready to execute the bodies
-    selectFromGuards :: TraceT IO ()
-    selectFromGuards
-      | null eventGuards
-         = do (_,ns) <- liftIO $ waitNormalGuards retry
-              storeChoice ns
-      | any isBadGuard wrappedGuards
-         = let str = head [s | BadGuard s <- wrappedGuards]
-               err = "ALTing not supported on given guard: " ++ str
+    -- Performs the select operation on all the guards, and then executes the body
+    selectFromGuards :: TraceT IO (WithPoison a)
+    selectFromGuards = case flattenedGuards of
+      Left str ->
+           let err = "ALTing not supported on given guard: " ++ str
            in liftIO $ do hPutStrLn stderr err
                           ioError $ userError err
-      | otherwise
-         = do earliestReady <- liftIO $ atomically checkNormalGuards
+
+      Right both
+        | null (eventGuards $ map fst both) ->
+           join $ liftM snd $ liftIO $ waitNormalGuards both retry
+        | otherwise ->
+           do let (guards, bodies) = unzip both
+                  earliestReady = findIndex isSkipGuard guards
+                  recordAndRun _ (Signal PoisonItem)
+                    = return PoisonItem
+                  recordAndRun m (Signal (NoPoison n))
+                    = let (EventGuard rec _ _, body) = both !! n
+                      in recordEvent (rec $ makeLookup m) >> body
+                  justRun (Signal PoisonItem) = return PoisonItem
+                  justRun (Signal (NoPoison n)) = bodies !! n
+                  guardsAndSignal :: [(Guard, (SignalValue, Map.Map Unique Integer))]
+                  guardsAndSignal = zip guards (zip (map (Signal . NoPoison) [0..]) (repeat Map.empty))
               tv <- liftIO . atomically $ newTVar Nothing
               pid <- getProcessId
-              (_, tr) <- get
+              tr <- get
               mn <- liftIO . atomically $ do
                       ret <- enableEvents tv pid
-                        (maybe id take earliestReady [(x,y,z) | (_,x,y,z)<-eventGuards])
+                        (maybe id take earliestReady [(Signal $ NoPoison x,y,z) | (_,x,y,z)<-eventGuards guards])
                         (isNothing earliestReady)
                       maybe (return ()) (\(_,es) -> recordEventLast (nub es) tr) ret
                       return ret
@@ -447,47 +403,50 @@
                 -- An event -- and we were the last person to arrive:
                 -- The event must have been higher priority than any other
                 -- ready guards
-                (Just (ns, _), _) ->
-                    do recordEvent $ findEventAssoc ns
-                       storeChoice ns
+                (Just ((n, m), _), _) -> recordAndRun m n
                 -- No events were ready, but there was an available normal
                 -- guards.  Re-run the normal guards; at least one will be ready
                 (Nothing, Just _) ->
-                  do (_, ns) <- liftIO $ waitNormalGuards retry
-                     storeChoice ns
+                  join $ liftM snd $ liftIO $ waitNormalGuards both retry
                 -- No events ready, no other guards ready either
                 -- Events will have been enabled; wait for everything:
                 (Nothing, Nothing) ->
-                    do (wasAltingBarrier, ns) <- liftIO $ waitNormalGuards $ waitAlting tv
+                    do (wasAltingBarrier, (n, m)) <- liftIO $ waitNormalGuards
+                         guardsAndSignal $ waitAlting tv
                        if wasAltingBarrier
-                         then recordEvent (findEventAssoc ns) >> storeChoice ns -- It was a barrier, all done
+                         then recordAndRun m n -- It was a barrier, all done
                          else
                             -- Another guard fired, but we must check in case
                             -- we have meanwhile been committed to taking an
                             -- event:
-                            do mn' <- liftIO . atomically $ disableEvents tv (concatMap fourth eventGuards)
+                            do mn' <- liftIO . atomically $ disableEvents tv (concatMap fourth
+                                 $ eventGuards guards)
                                case mn' of
                                  -- An event overrides our non-event choice:
-                                 Just bns -> recordEvent (findEventAssoc bns) >> storeChoice bns
+                                 Just (x, m') -> recordAndRun m' x
                                  -- Go with the original option, no events
                                  -- became ready:
-                                 Nothing -> storeChoice ns
+                                 Nothing -> justRun n
       where
-        waitAlting :: TVar (Maybe [Int]) -> STM [Int]
+        waitAlting :: SignalVar -> STM (SignalValue, Map.Map Unique Integer)
         waitAlting tv = do b <- readTVar tv
                            case b of
                              Nothing -> retry
                              Just ns -> return ns
         fourth (_,_,_,c) = c
 
-    executeNumberedBody :: TraceT IO a
-    executeNumberedBody
-      = do st <- get
-           case st of
-             ((g:gs), es) ->
-               do put (gs, es)
-                  snd $ pullOutAltable (items !! g)
-             ([], _) -> liftIO $
-               do hPutStrLn stderr "ALTing not supported on given guard (no index)"
-                  ioError $ userError "ALTing not supported on given guard (no index)"
+        makeLookup :: Map.Map Unique Integer -> Unique -> Integer
+        makeLookup m u = fromMaybe (error "CHP: Unique not found in alt") $ Map.lookup u m
 
+
+-- Waits for one of the normal (non-alting barrier) guards to be ready,
+-- or the given transaction to complete
+waitNormalGuards :: [(Guard, b)] -> STM b -> IO (Bool, b)
+waitNormalGuards guards extra
+  = do enabled <- mapM enable guards
+       atomically $ foldl1 orElse (liftM ((,) True) extra : enabled)
+  where
+    enable :: (Guard, b) -> IO (STM (Bool, b))
+    enable (SkipGuard, x) = return $ return (False, x)
+    enable (TimeoutGuard g, x) = liftM (>> return (False, x)) g
+    enable _ = return retry -- This effectively ignores other guards
diff --git a/Control/Concurrent/CHP/Barriers.hs b/Control/Concurrent/CHP/Barriers.hs
--- a/Control/Concurrent/CHP/Barriers.hs
+++ b/Control/Concurrent/CHP/Barriers.hs
@@ -91,13 +91,13 @@
 -- | Synchronises on the given barrier.  You must be enrolled on a barrier in order
 -- to synchronise on it.  Returns the new phase, following the synchronisation.
 syncBarrier :: Enrolled PhasedBarrier phase -> CHP phase
-syncBarrier = syncBarrierWith (Just . BarrierSyncIndiv)
+syncBarrier = syncBarrierWith (indivRecJust BarrierSyncIndiv)
     
 -- | Finds out the current phase a barrier is on.
 currentPhase :: Enrolled PhasedBarrier phase -> CHP phase
 currentPhase (Enrolled (Barrier (_, tv, _))) = liftIO $ atomically $ readTVar tv
 
-repeatUntil :: (Monad m, Eq a) => (a -> Bool) -> m a -> m ()
+repeatUntil :: (Monad m) => (a -> Bool) -> m a -> m ()
 repeatUntil target comp = do x <- comp
                              unless (target x) $ repeatUntil target comp
 
diff --git a/Control/Concurrent/CHP/Base.hs b/Control/Concurrent/CHP/Base.hs
--- a/Control/Concurrent/CHP/Base.hs
+++ b/Control/Concurrent/CHP/Base.hs
@@ -33,20 +33,23 @@
 -- monads, and poison.  Not publicly visible.
 module Control.Concurrent.CHP.Base where
 
+import Control.Applicative
+import Control.Arrow
 import Control.Concurrent.STM
-#if __GLASGOW_HASKELL__ >= 609
+-- #if __GLASGOW_HASKELL__ >= 609
 -- I can't figure out the new Exception system in GHC 6.10 and how I catch all
 -- exceptions (see GHC bug #2655), so I'm just going to use the old system:
-import qualified Control.OldException as C
-#else
-import qualified Control.Exception as C
-#endif
+--import qualified Control.OldException as C
+-- #else
+--import qualified Control.Exception as C
+-- #endif
 import Control.Monad.Error
 import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Writer
 import Control.Monad.Trans
 import qualified Data.Map as Map
+import Data.Unique
 import qualified Text.PrettyPrint.HughesPJ
 
 import Control.Concurrent.CHP.Guard
@@ -72,11 +75,15 @@
 -- 'Control.Concurrent.CHP.Monad.runCHP_' to execute programs in this
 -- monad.
 newtype CHP a = PoisonT (ErrorT PoisonError CHP' a)
-  deriving (Monad, MonadIO)
+  deriving (Functor, Monad, MonadIO)
 
+instance Applicative CHP where
+  pure = return
+  (<*>) = ap
+
 data CHP' a = AltableTRet a | AltableT {
   -- The guard, and body to execute after the guard
-  getAltable :: (Guard, TraceT IO a),
+  getAltable :: Either String [(Guard, TraceT IO a)],
   -- The body to execute without a guard
   getStandard :: TraceT IO a }
 
@@ -94,17 +101,22 @@
 -- but because its type is only determined by its return type, you may wish
 -- to use the already-typed functions offered in each trace module -- see the
 -- modules in "Control.Concurrent.CHP.Traces".
-class Show t => Trace t where
+--
+-- The trace type involved became parameterised in version 1.3.0.
+class Trace t where
   -- | Runs the given CHP program, and returns its return value and the trace.
   --  The return value is a Maybe type because the process may have exited
   -- due to uncaught poison.  In that case Nothing is return as the result.
-  runCHPAndTrace :: CHP a -> IO (Maybe a, t)
+  runCHPAndTrace :: CHP a -> IO (Maybe a, t Unique)
   -- | The empty trace.
-  emptyTrace :: t
+  emptyTrace :: t u
   -- | Pretty-prints the given trace using the "Text.PrettyPrint.HughesPJ"
   -- module.
-  prettyPrint :: t -> Text.PrettyPrint.HughesPJ.Doc
+  prettyPrint :: Ord u => t u -> Text.PrettyPrint.HughesPJ.Doc
 
+  -- | Added in version 1.3.0.
+  labelAll :: Ord u => t u -> t String
+
 -- | A class indicating that something is poisonable.
 class Poisonable c where
   -- | Poisons the given item.
@@ -124,13 +136,13 @@
   AltableTRet x -> return x
   AltableT _ st -> st
 
-pullOutAltable :: CHP' a -> (Guard, TraceT IO a)
+pullOutAltable :: CHP' a -> Either String [(Guard, TraceT IO a)]
 pullOutAltable m = case m of
-  AltableTRet x -> (badGuard "return", return x)
+  AltableTRet _ -> badGuard "return"
   AltableT alt _ -> alt
 
 liftTrace :: TraceT IO a -> CHP' a
-liftTrace m = AltableT (badGuard "lifted action", m) m
+liftTrace m = AltableT (badGuard "lifted action") m
 
 wrapPoison :: CHP a -> CHP' (WithPoison a)
 wrapPoison (PoisonT m) = (liftM $ either (const PoisonItem) NoPoison) $
@@ -184,37 +196,28 @@
 liftSTM = liftIO . atomically
 
 getProcessId :: TraceT IO ProcessId
-getProcessId = do (_, x) <- get
+getProcessId = do x <- get
                   case x of
                     Trace (pid,_,_) -> return pid
                     NoTrace -> return emptyProcessId
 
 runCHPProgramWith :: TraceStore -> (TraceStore -> t) -> CHP a -> IO (Maybe a, t)
 runCHPProgramWith start f (PoisonT p)
-  = do (x, (_, t)) <- runStateT (liftM (either (const Nothing) Just) $ pullOutStandard $ runErrorT p) ([], start)
+  = do (x, t) <- runStateT (liftM (either (const Nothing) Just) $ pullOutStandard $ runErrorT p) start
        return (x, f t)
 
-runCHPProgramWith' :: SubTraceStore -> (ChannelLabels -> SubTraceStore -> IO t) -> CHP a -> IO (Maybe a, t)
+runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> SubTraceStore -> IO t) -> CHP a -> IO (Maybe a, t)
 runCHPProgramWith' subStart f p
   = do tv <- atomically $ newTVar Map.empty
        (x, Trace (_,_,t)) <- runCHPProgramWith
                                 (Trace (rootProcessId, tv, subStart))
                                 id p
-                             `C.catch` const (return (Nothing,
-                               Trace (undefined, undefined, subStart)))
+--                             `C.catch` const (return (Nothing,
+--                               Trace (undefined, undefined, subStart)))
        l <- atomically $ readTVar tv
        t' <- f l t
        return (x, t')
 
-getEventPoison :: a -> TraceT IO (WithPoison a)
-getEventPoison x
-        = do (ns,y) <- get
-             case ns of
-               [] -> return $ NoPoison x
-               _ -> do put ([],y)
-                       return PoisonItem
-
-
 -- ==========
 -- Instances: 
 -- ==========
@@ -243,10 +246,10 @@
   -- f :: a -> AltableT g m b
   m >>= f = case m of
              AltableTRet x -> f x
-             AltableT (grd, altBody) nonAlt ->
-              let altBody' = altBody >>= pullOutStandard . f
+             AltableT altBody nonAlt ->
+              let altBody' = liftM (map $ second (>>= pullOutStandard . f)) altBody
                   nonAlt' = nonAlt >>= pullOutStandard . f
-              in AltableT (grd, altBody') nonAlt'
+              in AltableT altBody' nonAlt'
   return x = AltableTRet x
 
 instance MonadIO CHP' where
diff --git a/Control/Concurrent/CHP/BroadcastChannels.hs b/Control/Concurrent/CHP/BroadcastChannels.hs
--- a/Control/Concurrent/CHP/BroadcastChannels.hs
+++ b/Control/Concurrent/CHP/BroadcastChannels.hs
@@ -119,24 +119,24 @@
 
 instance WriteableChannel BroadcastChanout where
   extWriteChannel (BO (BC (b, tv))) m
-    = do syncBarrierWith (Just . ChannelWrite)
+    = do syncBarrierWith (indivRecJust ChannelWrite)
            $ Enrolled b
          m >>= liftIO . atomically . writeTVar tv
-         syncBarrierWith (const Nothing)
+         syncBarrierWith (const $ const Nothing)
            $ Enrolled b
-         syncBarrierWith (const Nothing)
+         syncBarrierWith (const $ const Nothing)
            $ Enrolled b
          return ()
 
 instance ReadableChannel (Enrolled BroadcastChanin) where
   extReadChannel (Enrolled (BI (BC (b, tv)))) f
-    = do syncBarrierWith (Just . ChannelRead)
+    = do syncBarrierWith (indivRecJust ChannelRead)
            $ Enrolled b
-         syncBarrierWith (const Nothing)
+         syncBarrierWith (const $ const Nothing)
            $ Enrolled b
          x <- liftIO (atomically $ readTVar tv)
          y <- f x
-         syncBarrierWith (const Nothing)
+         syncBarrierWith (const $ const Nothing)
            $ Enrolled b
          return y
 
@@ -204,25 +204,25 @@
 
 instance WriteableChannel (Enrolled ReduceChanout) where
   extWriteChannel (Enrolled (GO (GC (b, tv, (f,_))))) m
-    = do syncBarrierWith (Just . ChannelWrite)
+    = do syncBarrierWith (indivRecJust ChannelWrite)
            $ Enrolled b
          m >>= liftIO . atomically . \x -> readTVar tv >>= writeTVar tv . f x
-         syncBarrierWith (const Nothing)
+         syncBarrierWith (const $ const Nothing)
            $ Enrolled b
-         syncBarrierWith (const Nothing)
+         syncBarrierWith (const $ const Nothing)
            $ Enrolled b
          return ()
 
 instance ReadableChannel ReduceChanin where
   extReadChannel (GI (GC (b, tv, (_, empty)))) f
-    = do syncBarrierWith (Just . ChannelRead)
+    = do syncBarrierWith (indivRecJust ChannelRead)
            $ Enrolled b
-         syncBarrierWith (const Nothing)
+         syncBarrierWith (const $ const Nothing)
            $ Enrolled b
          x <- liftIO (atomically $ readTVar tv)
          y <- f x
          liftIO (atomically $ writeTVar tv empty)
-         syncBarrierWith (const Nothing)
+         syncBarrierWith (const $ const Nothing)
            $ Enrolled b
          return y
 
diff --git a/Control/Concurrent/CHP/CSP.hs b/Control/Concurrent/CHP/CSP.hs
--- a/Control/Concurrent/CHP/CSP.hs
+++ b/Control/Concurrent/CHP/CSP.hs
@@ -48,20 +48,18 @@
 import Control.Concurrent.CHP.Enroll
 import Control.Concurrent.CHP.Guard
 import Control.Concurrent.CHP.Mutex
-import Control.Concurrent.CHP.Poison
 import Control.Concurrent.CHP.Traces.Base
 
 -- First engages in event, then executes the body.  The returned value is suitable
 -- for use in an alt
-buildOnEventPoison :: (Unique -> Maybe RecordedIndivEvent) -> Event.Event -> STM () -> CHP a -> CHP a
+buildOnEventPoison :: (Unique -> (Unique -> Integer) -> Maybe (RecordedIndivEvent Unique)) -> Event.Event -> STM () -> CHP a -> CHP a
 buildOnEventPoison rec e act body
-  = liftPoison (AltableT (theGuard, getEventPoison True)
-                   (return $ NoPoison False))
-    >>= checkPoison >>= \b -> if b then body else
-      alt [liftPoison $ AltableT (theGuard, getEventPoison ()) (return $ NoPoison())] >>=
-        checkPoison >> body
+  = liftPoison (AltableT (Right [(theGuard, return True)])
+                   (return False))
+    >>= \b -> if b then body else
+      alt [liftPoison $ AltableT (Right [(theGuard, return ())]) (return ())] >> body
     where
-      theGuard = EventGuard [] (maybeToList $ rec $ Event.getEventUnique e) act [e]
+      theGuard = EventGuard (maybeToList . rec (Event.getEventUnique e)) act [e]
 
 scopeBlock :: CHP a -> (a -> CHP b) -> IO () -> CHP b
 scopeBlock start body errorEnd
@@ -75,7 +73,7 @@
 
 -- | Synchronises on the given barrier.  You must be enrolled on a barrier in order
 -- to synchronise on it.  Returns the new phase, following the synchronisation.
-syncBarrierWith :: (Unique -> Maybe RecordedIndivEvent)
+syncBarrierWith :: (Unique -> (Unique -> Integer) -> Maybe (RecordedIndivEvent Unique))
   -> Enrolled PhasedBarrier phase -> CHP phase
 syncBarrierWith rec (Enrolled (Barrier (e,tv, fph)))
     = buildOnEventPoison rec e incPhase
@@ -115,13 +113,13 @@
     = do liftSTM (Event.enrollEvent e) >>= checkPoison
          x <- f $ Enrolled b
          liftSTM (Event.resignEvent e) >>= checkPoison >>= (\es ->
-           do (_,tr) <- liftPoison $ liftTrace get
+           do tr <- liftPoison $ liftTrace get
               when (not $ null es) $ liftSTM $ recordEventLast (nub es) tr)
          return x
 
   resign (Enrolled (Barrier (e, _, _))) m
     = do liftSTM (Event.resignEvent e) >>= checkPoison >>= (\es ->
-           do (_,tr) <- liftPoison $ liftTrace get
+           do tr <- liftPoison $ liftTrace get
               when (not $ null es) $ liftSTM $ recordEventLast (nub es) tr)
          x <- m
          liftSTM (Event.enrollEvent e) >>= checkPoison
diff --git a/Control/Concurrent/CHP/Channels.hs b/Control/Concurrent/CHP/Channels.hs
--- a/Control/Concurrent/CHP/Channels.hs
+++ b/Control/Concurrent/CHP/Channels.hs
@@ -322,7 +322,7 @@
 instance ReadableChannel Chanin where
   readChannel (Chanin c)
     = let (e, m) = startReadChannelC c in
-      buildOnEventPoison (Just . ChannelRead) e (return ()) (liftSTM $
+      buildOnEventPoison (indivRecJust ChannelRead) e (return ()) (liftSTM $
         do x <- m
            endReadChannelC c
            return x) >>= checkPoison
@@ -330,7 +330,7 @@
   extReadChannel (Chanin c) body
     = let (e, m) = startReadChannelC c in
       scopeBlock
-        (buildOnEventPoison (Just . ChannelRead) e (return ()) (liftSTM m) >>= checkPoison)
+        (buildOnEventPoison (indivRecJust ChannelRead) e (return ()) (liftSTM m) >>= checkPoison)
         (\val -> do x <- body val
                     liftSTM $ endReadChannelC c
                     return x)
@@ -339,7 +339,7 @@
 instance WriteableChannel Chanout where
   writeChannel (Chanout c) x
     = let (e, m) = startWriteChannelC c in
-        buildOnEventPoison (Just . ChannelWrite) e (return ())
+        buildOnEventPoison (indivRecJust ChannelWrite) e (return ())
           (liftM2 (++)
             (liftSTM $ sequence [m, sendWriteChannelC c x])
             (liftSTM $ sequence [endWriteChannelC c]))
@@ -347,7 +347,7 @@
   extWriteChannel (Chanout c) body
     = let (e, m) = startWriteChannelC c in
       scopeBlock
-        (buildOnEventPoison (Just . ChannelWrite)
+        (buildOnEventPoison (indivRecJust ChannelWrite)
           e (return ()) (liftSTM m) >>= checkPoison)
         (const $ sequence [body >>= liftSTM . sendWriteChannelC c
                           ,liftSTM (endWriteChannelC c)]
diff --git a/Control/Concurrent/CHP/Clocks.hs b/Control/Concurrent/CHP/Clocks.hs
--- a/Control/Concurrent/CHP/Clocks.hs
+++ b/Control/Concurrent/CHP/Clocks.hs
@@ -105,8 +105,10 @@
 -- This is also true if not every process enrolled on a barrier wants to take action
 -- every phase -- a clock allows those processes to remain sleeping, rather than
 -- wake up only to sleep again,
+-- 
 -- * Barriers support choice, but clocks do not.  This means clocks are both
 -- less powerful, but also faster than barriers.
+-- 
 -- * Barriers choose their next phase using their incrementing function.  Clocks
 -- are more flexible, in that their next phase is chosen solely by looking at the
 -- requests from the various processes.  Hence why Double is a suitable type for
@@ -120,11 +122,11 @@
 import Control.Monad hiding (mapM, mapM_)
 import Control.Monad.State (get)
 import Control.Monad.Trans
+import Data.Foldable (mapM_)
 -- Needed for testing:
 --import Data.Maybe
 import qualified Data.Sequence as Seq
 import qualified Data.Set as Set
-import Data.Traversable
 import Data.Unique
 import Prelude hiding (mapM, mapM_)
 
@@ -218,31 +220,30 @@
 poisonTVar :: TVar (WithPoison a) -> STM ()
 poisonTVar = flip writeTVar PoisonItem
 
--- Provides mapM_ for Traversable:
-mapM_ :: (Traversable t, Monad m) => (a -> m b) -> t a -> m ()
-mapM_ f x = mapM f x >> return ()
+type TimeVar time = TVar (WithPoison (Maybe (time, Integer)))
 
 data TimerData time
   = TimerData {
       curTime :: time
+     ,seqTime :: Integer
      ,enrolledOnTimer :: Int
      -- A slightly more efficient way of knowing current offers:
      ,offeredOnTimer :: Int
       -- Offers are held, sorted by time.  We rely on the fact that for all x,
       -- Nothing < Just x
-     ,timerOffersNext :: Maybe ([ProcessId], TVar (WithPoison (Maybe time)))
-     ,timerOffersBefore :: [([ProcessId], (time, TVar (WithPoison (Maybe time))))]
-     ,timerOffersAfter :: [([ProcessId], (time, TVar (WithPoison (Maybe time))))]
-     ,timerEventPool :: Seq.Seq (TVar (WithPoison (Maybe time)))
+     ,timerOffersNext :: Maybe ([ProcessId], TimeVar time)
+     ,timerOffersBefore :: [([ProcessId], (time, TimeVar time))]
+     ,timerOffersAfter :: [([ProcessId], (time, TimeVar time))]
+     ,timerEventPool :: Seq.Seq (TimeVar time)
      }
 -- Uncomment these lines while testing:
 --  deriving (Eq, Show)
 --instance Show (TVar (WithPoison (Maybe a))) where show = const "<tv>"
 
 emptyTimerData :: time -> TimerData time
-emptyTimerData t = TimerData t 0 0 Nothing [] [] Seq.empty
+emptyTimerData t = TimerData t 0 0 0 Nothing [] [] Seq.empty
 
-enrollTimerData :: Maybe (TVar (WithPoison (Maybe time))) -> TimerData time -> TimerData time
+enrollTimerData :: Maybe (TimeVar time) -> TimerData time -> TimerData time
 enrollTimerData me td
   = td {enrolledOnTimer = enrolledOnTimer td + 1
        -- It's important that the event goes on the front, so that we don't re-use
@@ -273,7 +274,7 @@
 
 
 offerTimerData :: forall time. Ord time => ProcessId -> Maybe time -> TimerData time
-  -> STM (TimerData time, TVar (WithPoison (Maybe time)))
+  -> STM (TimerData time, TimeVar time)
 offerTimerData pid Nothing td = case timerOffersNext td of
   Nothing -> do
     (e, pool) <- spareEvent $ timerEventPool td
@@ -326,14 +327,14 @@
          liftSTM (modifyTVar tv $ enrollTimerData $ Just ev)
            >>= checkPoison
          x <- f $ Enrolled tim
-         ts <- liftPoison $ liftTrace $ liftM snd get
+         ts <- liftPoison $ liftTrace $ get
          liftSTM (modifyTVar' tv $ checkCompletion u sh ts . resignTimerData True)
            >>= checkPoison
          return x
 
   -- For temporary resignations, we don't touch the event pool
   resign (Enrolled (Clock (tv, u, sh))) m
-    = do ts <- liftPoison $ liftTrace $ liftM snd get
+    = do ts <- liftPoison $ liftTrace $ get
          liftSTM (modifyTVar' tv (checkCompletion u sh ts . resignTimerData False))
            >>= checkPoison
          x <- m
@@ -346,12 +347,13 @@
   | offeredOnTimer td == enrolledOnTimer td =
       case timerOffersAfter td of
         ((pids, (newT, ev)):rest) -> do
-          writeTVar ev $ NoPoison $ Just newT
-          maybe (return ()) (flip writeTVar (NoPoison $ Just newT) . snd) (timerOffersNext td)
+          writeTVar ev $ NoPoison $ Just (newT, seqTime td)
+          maybe (return ()) (flip writeTVar (NoPoison $ Just (newT, seqTime td)) . snd) (timerOffersNext td)
           recordEventLast [((Event.ClockSync $ sh newT,u)
             , Set.fromList $ pids ++ maybe [] fst (timerOffersNext td))]
             ts
           return $ td { timerOffersAfter = rest
+                      , seqTime = succ $ seqTime td
                       , offeredOnTimer =
                           offeredOnTimer td
                             - (length pids + maybe 0 (length . fst) (timerOffersNext td))
@@ -367,8 +369,8 @@
                       }
         [] -> case timerOffersBefore td of
                 ((pids, (newT, ev)):rest) -> do
-                  writeTVar ev $ NoPoison $ Just newT
-                  maybe (return ()) (flip writeTVar (NoPoison $ Just newT) . snd) (timerOffersNext td)
+                  writeTVar ev $ NoPoison $ Just (newT, seqTime td)
+                  maybe (return ()) (flip writeTVar (NoPoison $ Just (newT, seqTime td)) . snd) (timerOffersNext td)
                   return $
                     td { timerOffersAfter = rest
                        , timerOffersBefore = []
@@ -376,6 +378,7 @@
                            offeredOnTimer td
                              - (length pids + maybe 0 (length . fst) (timerOffersNext td))
                        , curTime = newT
+                       , seqTime = succ $ seqTime td
                        , timerOffersNext = Nothing
                        -- The event will only be re-used once we get to the
                        -- end of the list, and thus all the people are ready
@@ -389,7 +392,7 @@
   | otherwise = return td
 
 waitClock :: Ord time =>
-  ProcessId -> TraceStore -> Enrolled Clock time -> Maybe time -> STM (STM (WithPoison time))
+  ProcessId -> TraceStore -> Enrolled Clock time -> Maybe time -> STM (STM (WithPoison (time, Integer)))
 waitClock pid ts (Enrolled (Clock (tv, u, sh))) ph
   = do x <- readTVar tv
        case x of
@@ -419,11 +422,11 @@
   getCurrentTime (Enrolled (Clock (tv, _, _)))
     = liftSTM (liftM (fmap curTime) $ readTVar tv) >>= checkPoison
   wait c@(Enrolled (Clock (_, u, sh))) mt
-    = do ts <- liftPoison $ liftTrace $ liftM snd get
+    = do ts <- liftPoison $ liftTrace $ get
          pid <- liftPoison $ liftTrace $ getProcessId
          waitAct <- liftSTM $ waitClock pid ts c mt
-         t <- liftSTM waitAct >>= checkPoison
-         liftPoison $ liftTrace $ recordEvent [ClockSyncIndiv u $ sh t]
+         (t, s) <- liftSTM waitAct >>= checkPoison
+         liftPoison $ liftTrace $ recordEvent [ClockSyncIndiv u s $ sh t]
          return t
 
 instance Ord time => Poisonable (Enrolled Clock time) where
diff --git a/Control/Concurrent/CHP/Event.hs b/Control/Concurrent/CHP/Event.hs
--- a/Control/Concurrent/CHP/Event.hs
+++ b/Control/Concurrent/CHP/Event.hs
@@ -28,7 +28,10 @@
 -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 --TODO document this (for internal purposes)
-module Control.Concurrent.CHP.Event where
+module Control.Concurrent.CHP.Event (RecordedEventType(..), Event, getEventUnique,
+  SignalVar, SignalValue(..), enableEvents, disableEvents,
+  newEvent, newEventUnique, enrollEvent, resignEvent, poisonEvent, checkEventForPoison,
+  testAll) where
 
 import Control.Concurrent.STM
 import Control.Monad
@@ -37,7 +40,9 @@
 import qualified Data.Map as Map
 import Data.Maybe
 import qualified Data.Set as Set
+import qualified Data.Traversable as T
 import Data.Unique
+import Prelude hiding (seq)
 
 
 import Control.Concurrent.CHP.Poison
@@ -55,6 +60,7 @@
   RecordedEventType, -- Event type for trace recording
   TVar (WithPoison
     (Int, -- Enrolled count
+     Integer, -- Event sequence count
     [OfferSet]) -- A list of offer sets
  ))
 
@@ -71,15 +77,32 @@
 getEventUnique :: Event -> Unique
 getEventUnique (Event (u,_,_)) = u
 
-getEventTVar :: Event -> TVar (WithPoison (Int, [OfferSet]))
+getEventTVar :: Event -> TVar (WithPoison (Int, Integer, [OfferSet]))
 getEventTVar (Event (_,_,tv)) = tv
 
 getEventType :: Event -> RecordedEventType
 getEventType (Event (_,t,_)) = t
 
-newtype OfferSet = OfferSet (TVar (Maybe [Int]) -- Variable to use to signal when committed
+-- The value used to pass information to a waiting process once one of their events
+-- has fired (and they have been committed to it).  The Int is an index into their
+-- list of guards
+newtype SignalValue = Signal (WithPoison Int)
+  deriving (Eq, Show)
+
+type SignalVar = TVar (Maybe (SignalValue, Map.Map Unique Integer))
+
+addPoison :: SignalValue -> SignalValue
+addPoison = const $ Signal PoisonItem
+
+nullSignalValue :: SignalValue
+nullSignalValue = Signal $ NoPoison (-1)
+
+isNullSignal :: SignalValue -> Bool
+isNullSignal (Signal n) = n == NoPoison (-1)
+
+newtype OfferSet = OfferSet (SignalVar -- Variable to use to signal when committed
                 , ProcessId -- Id of the process making the offer
-                , [([Int], Map.Map Event ())]) -- Value to send when committed
+                , [(SignalValue, Map.Map Event ())]) -- Value to send when committed
                                     -- A list of all sets of events currently offered
 
 instance Eq OfferSet where
@@ -98,9 +121,42 @@
 allEventsInOffer :: OfferSet -> Map.Map Event ()
 allEventsInOffer (OfferSet (_, _, eventSets)) = unionAll (map snd eventSets)
 
-search :: [OfferSet] -> Map.Map Event Bool -> Maybe (STM (), Map.Map Unique (RecordedEventType,
-  Set.Set ProcessId), [(TVar (Maybe [Int]), [Event])])
-search [] _ = Just (return (), Map.empty, [])
+getAndIncCounter :: Event -> a -> STM (WithPoison Integer)
+getAndIncCounter e _
+  = do x <- readTVar (getEventTVar e)
+       case x of
+         PoisonItem -> return PoisonItem
+         NoPoison (a, n, c) -> do writeTVar (getEventTVar e) $
+                                    NoPoison (a, succ n, c)
+                                  return $ NoPoison n
+
+-- | search is /not/ used for discovering offers.  It is used for looking for possible
+-- resolutions to a collection of offer sets.  It is pure; it performs no STM actions,
+-- it just searches the offer-sets (which will have been discovered through STM)
+-- for completions.
+--
+-- search performs a 2-dimensional traversal of the offers.  The search function
+-- is called with a list of offer-sets.  For the offer-set at the head, it calls
+-- tryAll.  tryAll searches through each offer in the offer-set, seeing if it can
+-- be completed.  If it can, it calls search on the remaining offer-sets.  If this
+-- fails, it reverts to trying the other offers in the list. The map of events passed through
+-- relates to the previous things found in the search.
+search :: [OfferSet]
+          -- ^ The collection of all the related offer-sets
+          -> Map.Map Event Bool
+          -- ^ This contains the events already decided upon in the search.  If
+          -- an event maps to True, it means it was chosen by an earlier part of
+          -- the search, and thus future parts of the search /must/ have this event
+          -- in the chosen offer (if the process offers it at all -- if it doesn't,
+          -- it can be ignored).  If an event maps to False, it was already ruled
+          -- out by not being chosen in another part of the search, and it cannot
+          -- be chosen by any future parts of the search.  Should be empty when first called from the outside.
+          -> Maybe ( [(SignalVar, SignalValue)]
+                   , Map.Map Event (RecordedEventType, Set.Set ProcessId)
+                   )
+             -- ^ The list of tvars involved with the completion and the signal
+             -- value for them, and the map with information about the completed events.
+search [] _ = Just ([], Map.empty)
 search (offer@(OfferSet (tv, pid, eventSets)) : offers) eventMap
       | Map.null mustChooseFromEventSets = tryAll eventSets
       | otherwise = tryAll filteredEventSets
@@ -122,16 +178,21 @@
                 es
             ]
 
+        -- Folds across a map, seeing if the given predicate holds for all values
+        -- in the map.
         mapdotall :: Ord k => (a -> Bool) -> Map.Map k a -> Bool
         mapdotall f = Map.fold (\x b -> f x && b) True
 
-        -- All events in the maps in the first parameter will be mapped to True
-        tryAll :: [([Int],Map.Map Event ())] ->
-          Maybe (STM (), Map.Map Unique (RecordedEventType, Set.Set ProcessId),
-            [(TVar (Maybe [Int]), [Event])])
+        and' :: Ord k => Map.Map k Bool -> Bool
+        and' = mapdotall id
+
+        tryAll :: [(SignalValue, Map.Map Event ())]
+          -> Maybe ( [(SignalVar, SignalValue)]
+                   , Map.Map Event (RecordedEventType, Set.Set ProcessId)
+                   )
         tryAll [] = Nothing
         tryAll ((ns, es):next)
-          | not $ mapdotall id (eventMap `Map.intersection` es)
+          | not $ and' (eventMap `Map.intersection` es)
               -- Contains an already-rejected event (one that mapped to False), skip:
               -- Need to reject the other events too though -- well, at least put
               -- them in the appropriate map and pass them through.  They will
@@ -140,10 +201,12 @@
               = tryAll next
           | otherwise = case search offers eventMap' of
             Nothing -> tryAll next
-            Just (act, resolved, retract) -> Just (if null ns then act else writeTVar tv (Just ns) >> act, foldl
-              (\m e -> Map.insertWith add (getEventUnique e) (getEventType
-                e, Set.singleton pid) m) resolved (Map.keys es), if null ns then retract else
-                  (tv, Map.keys allEventsInOfferMappedToFalse) : retract)
+            Just (act, resolved) -> Just
+              (if isNullSignal ns then act else (tv, ns) : act
+              , foldl (\m e -> Map.insertWith add e
+                                 (getEventType e, Set.singleton pid) m)
+                  resolved (Map.keys es)
+              )
               
           where
             -- All events that features in other offers by this process, but not
@@ -157,8 +220,6 @@
 
             add (tx, pidsx) (_, pidsy) = (tx, pidsx `Set.union` pidsy)
             
-data EventStatus = Fine | NotCompletable deriving (Eq, Show)
-
 -- Given a list of offers that could possibly complete, check if any set
 -- of offers can.  If so, complete it (including all retractions and
 -- notifications for each process), otherwise leave things untouched.
@@ -167,26 +228,28 @@
 -- list of all offer-sets that need to be considered (they will have come from
 -- all events in a connected sub-graph), the map of relevant events to their status,
 -- and returns the map of event-identifiers that did complete.
-resolveOffers :: Maybe (TVar (Maybe [Int])) -> [OfferSet] -> Set.Set Event -> STM (Map.Map Unique (RecordedEventType,
-  Set.Set ProcessId))
+resolveOffers :: Maybe SignalVar -> [OfferSet] -> Set.Set Event
+  -> STM (Map.Map Unique (RecordedEventType, Set.Set ProcessId))
 resolveOffers newTvid allOffers events
   = do let (offers', _) = trim (allOffers, events)
-           (act, ret, retract) = fromMaybe (return (), Map.empty, []) $ search (map addNullOffer
-             $ sortOffers offers') Map.empty
-       act
+           (act, ret) = fromMaybe ([], Map.empty) $
+             search (map addNullOffer $ sortOffers offers') Map.empty
+       eventCounts <- T.sequence $ Map.mapWithKey getAndIncCounter ret
+       let NoPoison uniqCounts = T.sequence $ Map.mapKeysMonotonic getEventUnique eventCounts
+       mapM_ (\(tv, x) -> writeTVar tv (Just (x, uniqCounts))) act
        -- do the retractions for all involved processes once the choice is made:
        -- TODO optimise:
-       retractOffers $ zip (map fst retract)
+       retractOffers $ zip (map fst act)
                            (repeat $ unionAll $ map allEventsInOffer allOffers)
-       return ret
+       return (Map.mapKeysMonotonic getEventUnique ret)
   where
     -- Don't add the null offer for the newest process, and null offer should be
     -- added to the end:
     addNullOffer :: OfferSet -> OfferSet
     addNullOffer (OfferSet (tv,y,zs)) = OfferSet (tv,y,if Just tv == newTvid then zs else zs++nullOffer)
 
-    nullOffer :: [([Int], Map.Map Event ())]
-    nullOffer = [([],Map.empty)]
+    nullOffer :: [(SignalValue, Map.Map Event ())]
+    nullOffer = [(nullSignalValue,Map.empty)]
 
     -- SMallest offers first to minimise backtracking:
     sortOffers :: [OfferSet] -> [OfferSet]
@@ -262,7 +325,7 @@
           = do x <- readTVar tv
                case x of
                  PoisonItem -> act >> return PoisonItem
-                 NoPoison (count, offers) ->
+                 NoPoison (count, _, offers) ->
                    let otherEvents = map allEventsInOffer offers in
                    if length offers == count
                      then -- It could be ready
@@ -273,19 +336,29 @@
                      else -- No way it could be ready, so ignore it:
                        discoverRelatedOffersAll a next
 
--- Given an optional waiting-tvar from the newest process to offer (if any), and
--- an event, spiders out, discovers all the offers, then resolves them and returns
--- a map containing all the completed events, mapping the identifier to the event
--- type and the set of process identifiers that participated in the succesfully
--- completed events.  The map will be empty if and only if no events were completed.
-discoverAndResolve :: Either OfferSet Event -> STM (WithPoison (Map.Map Unique (RecordedEventType,Set.Set
-  ProcessId)))
+-- Given an event, spiders out, discovers all the offers, then resolves them
+-- and returns a map containing all the completed events, mapping the
+-- identifier to the event type and the set of process identifiers that
+-- participated in the succesfully completed events.  The map will be empty if
+-- and only if no events were completed.
+discoverAndResolve :: Either OfferSet Event
+                        -- ^ Either an OfferSet to spider out from, or a single
+                        -- event.  The latter case is for when we are resigning
+                        -- from an event and need to check if that completes anything.
+                      -> STM (WithPoison (Map.Map Unique (RecordedEventType, Set.Set ProcessId)))
+                        -- ^ Gives back either poison, or a map from event identifiers
+                        -- to information about the completed event.  The map is
+                        -- empty if no events were completed.
 discoverAndResolve offOrEvent
   = do r <- discoverRelatedOffers $ case offOrEvent of
               Left off@(OfferSet (tv, _, nes)) ->
                 let retract = retractOffers [(tv, allEventsInOffer off)] in
-                      concat [zip (repeat $ retract >> writeTVar tv (Just $ ns
-                         ++ [0])) (Map.keys es) | (ns, es) <- nes]
+                      concat [zip
+                        -- This is the action to execute if an event is found to
+                        -- be poisoned:
+                        (repeat $ retract >> writeTVar tv (Just (addPoison ns, Map.empty)))
+                        (Map.keys es)
+                        | (ns, es) <- nes]
               Right e -> [(return (), e)]
        case r of
          PoisonItem -> return PoisonItem
@@ -298,7 +371,7 @@
 newEvent :: RecordedEventType -> Int -> IO Event
 newEvent t n
   = do u <- newUnique
-       atomically $ do tv <- newTVar (NoPoison (n, []))
+       atomically $ do tv <- newTVar (NoPoison (n, 0, []))
                        return $ Event (u, t, tv)
 
 newEventUnique :: IO Unique
@@ -309,30 +382,30 @@
   = do x <- readTVar $ getEventTVar e
        case x of
          PoisonItem -> return PoisonItem
-         NoPoison (count, offers) ->
-           do writeTVar (getEventTVar e) $ NoPoison (count + 1, offers)
+         NoPoison (count, seq, offers) ->
+           do writeTVar (getEventTVar e) $ NoPoison (count + 1, seq, offers)
               return $ NoPoison ()
 
 -- If the event completes, we return details related to it:
-resignEvent :: Event -> STM (WithPoison [((RecordedEventType, Unique), Set.Set
-    ProcessId)])
+resignEvent :: Event -> STM (WithPoison [((RecordedEventType, Unique), Set.Set ProcessId)])
 resignEvent e
   = do x <- readTVar $ getEventTVar e
        case x of
          PoisonItem -> return PoisonItem
-         NoPoison (count, offers) ->
-           do writeTVar (getEventTVar e) $ NoPoison (count - 1, offers)
+         NoPoison (count, seq, offers) ->
+           do writeTVar (getEventTVar e) $ NoPoison (count - 1, seq, offers)
               if (count - 1 == length offers)
                 then liftM (fmap $ \mu -> [((r,u),pids) | (u,(r,pids)) <- Map.toList mu])
                        $ discoverAndResolve $ Right e
                 else return $ NoPoison []
 
 -- Given the list of identifiers paired with all the events that that process might
--- be engaged in, retracts all the offers during a transaction.
-retractOffers :: [(TVar (Maybe [Int]), Map.Map Event ())] -> STM ()
+-- be engaged in, retracts all the offers that are associated with the given TVar;
+-- i.e. the TVar is used as an identifier for the process
+retractOffers :: [(SignalVar, Map.Map Event ())] -> STM ()
 retractOffers = mapM_ retractAll
   where
-    retractAll :: (TVar (Maybe [Int]), Map.Map Event ()) -> STM ()
+    retractAll :: (SignalVar, Map.Map Event ()) -> STM ()
     retractAll (tvid, evts) = mapM_ retract (Map.keys evts)
       where
         retract :: Event -> STM ()
@@ -340,15 +413,17 @@
           = do x <- readTVar $ getEventTVar e
                case x of
                  PoisonItem -> return ()
-                 NoPoison (enrolled, offers) ->
+                 NoPoison (enrolled, seq, offers) ->
                    let reducedOffers = filter (\(OfferSet (tvx,_,_)) -> tvx /= tvid) offers in
-                   writeTVar (getEventTVar e) $ NoPoison (enrolled, reducedOffers)
+                   writeTVar (getEventTVar e) $ NoPoison (enrolled, seq, reducedOffers)
 
 -- Simply adds the offers but doesn't check if that will complete an event:
 -- Returns PoisonItem if any of the events were poisoned
 makeOffers :: OfferSet -> STM (WithPoison ())
 makeOffers offers
   = do let allEvents = Map.keys $ allEventsInOffer offers
+       -- No need for nub, as having it come from a map guarantees there are no
+       -- duplicates in the list of events
        liftM mergeWithPoison $ mapM makeOffer allEvents
   where
     makeOffer :: Event -> STM (WithPoison ())
@@ -356,18 +431,38 @@
       = do x <- readTVar $ getEventTVar e
            case x of
              PoisonItem -> return PoisonItem
-             NoPoison (count, prevOffers) ->
-               do writeTVar (getEventTVar e) $ NoPoison (count, offers : prevOffers)
+             NoPoison (count, seq, prevOffers) ->
+               do writeTVar (getEventTVar e) $ NoPoison (count, seq, offers : prevOffers)
                   return $ NoPoison ()
 
--- Passed: True if allowed to commit to waiting
--- Returns: True if committed, False otherwise
-enableEvents :: TVar (Maybe [Int]) -> ProcessId -> [([Int], STM
-  (), [Event])] -> Bool -> STM (Maybe ([Int], [((RecordedEventType, Unique), Set.Set
-    ProcessId)]))
+-- Returns Nothing if no events were ready.  Returns Just with the signal value
+-- if an event was immediately available, followed by the information for each
+-- event involved in the synchronisation.  If poison was encounted, this list will
+-- be empty.
+enableEvents :: SignalVar
+                  -- ^ Variable used to signal the process once a choice is made
+                -> ProcessId
+                  -- ^ The id of the process making the choice
+                -> [(SignalValue, STM (), [Event])]
+                  -- ^ The list of options.  Each option has a signalvalue to return
+                  -- if chosen, an STM action to execute at the same time as the
+                  -- synchronisation, and a list of events (conjoined together).
+                  --  So this list is the disjunction of conjunctions, with a little
+                  -- more information.
+                -> Bool
+                  -- ^ True if it can commit to waiting.  If there is an event
+                  -- combination ready during the transaction, it will chosen regardless
+                  -- of the value of this flag.  However, if there no events ready,
+                  -- passing True will leave the offers there, but False will retract
+                  -- the offers.
+                -> STM (Maybe ((SignalValue, Map.Map Unique Integer), [((RecordedEventType, Unique), Set.Set ProcessId)]))
 enableEvents tvNotify pid events canCommitToWait
   = do let offer = OfferSet (tvNotify, pid, [(nid, Map.fromList (zip es (repeat ()))) | (nid, _, es) <- events])
+       -- First add our offer to all the events:
+       -- We don't check the result for poison, as discoverAndResolve will find
+       -- it anyway
        makeOffers offer
+       -- Then spider out and see if anything can be resolved:
        pmu <- discoverAndResolve (Left offer)
        case (canCommitToWait, pmu) of
          (_, PoisonItem) -> do Just chosen <- readTVar tvNotify
@@ -385,7 +480,12 @@
                    Just chosen <- readTVar tvNotify
                    return $ Just (chosen, [((r,u),pids) | (u,(r,pids)) <- Map.toList mu])
 
-disableEvents :: TVar (Maybe [Int]) -> [Event] -> STM (Maybe [Int])
+-- | Given the variable used to signal the process, and the list of events that
+-- were involved in its offers, attempts to disable the events.  If the variable
+-- has been signalled (i.e. has a Just value), that is returned and nothing is done, if the variable
+-- has not been signalled (i.e. is Nothing), the events are disabled and Nothing
+-- is returned.
+disableEvents :: SignalVar -> [Event] -> STM (Maybe (SignalValue, Map.Map Unique Integer))
 disableEvents tv events
   = do x <- readTVar tv
        -- Since the transaction will be atomic, we know
@@ -406,16 +506,16 @@
   = do x <- readTVar $ getEventTVar e
        case x of
          PoisonItem -> return ()
-         NoPoison (_, offers) ->
+         NoPoison (_, _, offers) ->
            do retractOffers [(tvw, unionAll $ map snd events)
                             | OfferSet (tvw, _, events) <- offers]
-              sequence_ [writeTVar tvw (Just $ pickInts events ++ [0])
+              sequence_ [writeTVar tvw (Just (addPoison $ pickInts events, Map.empty))
                         | OfferSet (tvw, _, events) <- offers]
               writeTVar (getEventTVar e) PoisonItem
   where
-    pickInts :: [([Int], Map.Map Event ())] -> [Int]
+    pickInts :: [(SignalValue, Map.Map Event ())] -> SignalValue
     pickInts es = case filter ((e `Map.member`) . snd) es of
-      [] -> [] -- Should never happen
+      [] -> nullSignalValue -- Should never happen
       ((ns,_):_) -> ns
 
 --TODO document how if it's poisoned, 0 will be appended to the list
@@ -568,7 +668,7 @@
                         " expected no poison but found it"
                       (PoisonItem, NoPoison _) -> putStrLn $ testName ++
                         " expected poison but found none"
-                      (NoPoison expOff, NoPoison (_, actOff)) ->
+                      (NoPoison expOff, NoPoison (_, _, actOff)) ->
                         when (map (realOffers !!) expOff **/=** actOff) $
                           putStrLn $ testName ++ " offers did not match"
                 | (n, (_, expect)) <- zip [0..] eventCounts]
@@ -595,7 +695,7 @@
            realOffers <- sequence
              [ do tv <- atomically $ newTVar Nothing
                   let pid = testProcessId processN
-                      offSub = [ ([processN, offerN],
+                      offSub = [ (Signal $ NoPoison (processN + offerN),
                                   Map.fromList [ (events !! indivEvent, ())
                                   | indivEvent <- singleOffer])
                                | (offerN, singleOffer) <- zip [0..] processOffers]
@@ -603,12 +703,12 @@
                   mapM_ (\e -> atomically $ do
                     x <- readTVar (getEventTVar e)
                     case x of
-                      NoPoison (count, offs) ->
-                        writeTVar (getEventTVar e) $ NoPoison (count, off : offs)
+                      NoPoison (count, s, offs) ->
+                        writeTVar (getEventTVar e) $ NoPoison (count, s, off : offs)
                       PoisonItem -> return ()
                     ) (Map.keys $ unionAll $ map snd offSub)
                   return off
-             | (processN, processOffers) <- zip [0..] offerSets]
+             | (processN, processOffers) <- zip (map (*1000) [0..]) offerSets]
            return (events, realOffers)
 
 testResolve :: IO ()
@@ -673,7 +773,7 @@
            actualResult <- atomically $ discoverAndResolve $ Left $ head realOffers
            let expectedResult = if poisoned then PoisonItem else NoPoison $
                                 Map.fromList [ (getEventUnique e, (ChannelComm,
-                                               Set.fromList $ map (testProcessId . fst) is))
+                                               Set.fromList $ map (testProcessId . (*1000) . fst) is))
                                              | (e, Left is) <- zip events (map snd eventCounts)]
            when (expectedResult /= actualResult) $
              putStrLn $ testName ++ " failed on direct result, expected: "
@@ -684,9 +784,10 @@
                do x <- atomically $ readTVar tv
                   case x of
                     Nothing -> putStrLn $ "Unexpected no-win for " ++ show (pn,en)
-                    Just v -> when (v /= (if poisoned then (++[0]) else id) [pn, en]) $
-                      putStrLn $ testName ++ " wrong choice: " ++ show v ++ " exp: " ++ show
-                        [pn, en]
+                    Just v -> when (fst v /= (if poisoned then addPoison else id)
+                                             (Signal $ NoPoison ((pn*1000)+en))) $
+                      putStrLn $ testName ++ " wrong choice: " ++ " exp: " ++ show
+                        (pn+en)
                   return pn
              ) $ map snd eventCounts
            -- test the others are unchanged
@@ -695,7 +796,7 @@
                             case x of
                               Nothing -> return ()
                               Just _ -> putStrLn $ testName ++ " Unexpected win for process: " ++
-                                show n ++ " " ++ show x
+                                show n
                      | n <- [0 .. length offerSets - 1] \\ allFired]
            -- check events are blanked afterwards:
            sequence_ [ let e = events !! n
@@ -703,10 +804,12 @@
                              Left _ -> []
                              Right ns -> map (realOffers !!) ns in do
                          x <- atomically $ readTVar $ getEventTVar e
-                         when (x /= NoPoison (count, expVal)) $
-                           putStrLn $ testName ++ "Event " ++ show n ++
+                         case x of
+                           NoPoison (c, _, e') | c == count && e' == expVal -> return ()
+                           _ ->
+                             putStrLn $ testName ++ "Event " ++ show n ++
                              " not as expected after, exp: " ++ show (length expVal)
-                             ++ " act: " ++ (let NoPoison (_,act) = x in show (length act))
+                             ++ " act: " ++ (let NoPoison (_,_,act) = x in show (length act))
                      | (n,(NoPoison count, st)) <- zip [0..] eventCounts]
 
     showStuff = show . fmap (map (\(u,x) -> (hashUnique u, x)) . Map.toList)
diff --git a/Control/Concurrent/CHP/Guard.hs b/Control/Concurrent/CHP/Guard.hs
--- a/Control/Concurrent/CHP/Guard.hs
+++ b/Control/Concurrent/CHP/Guard.hs
@@ -31,30 +31,37 @@
 
 import Control.Concurrent.STM
 import Control.Monad.Trans
+import Data.Unique
 import System.IO
 
 import Control.Concurrent.CHP.Event
 import Control.Concurrent.CHP.Traces.Base
 
 -- Setup (giving transaction)
-data Guard = TimeoutGuard (IO (STM [Int]))
-             | SkipGuard [Int]
+data Guard = TimeoutGuard (IO (STM ()))
+             | SkipGuard
              | StopGuard
-             | BadGuard String
              -- The STM item is an action to take in the same transaction as
              -- completing the event (before it is completed).
-             | EventGuard [Int] [RecordedIndivEvent] (STM ()) [Event]
-             | NestedGuards [Guard]
+             | EventGuard ((Unique -> Integer) -> [RecordedIndivEvent Unique]) (STM ()) [Event]
 
 skipGuard :: Guard
-skipGuard = SkipGuard []
+skipGuard = SkipGuard
 
-badGuard :: String -> Guard
-badGuard = BadGuard
+isSkipGuard :: Guard -> Bool
+isSkipGuard SkipGuard = True
+isSkipGuard _ = False
 
+badGuard :: String -> Either String a
+badGuard = Left
+
 stopGuard :: Guard
 stopGuard = StopGuard
 
+isStopGuard :: Guard -> Bool
+isStopGuard StopGuard = True
+isStopGuard _ = False
+
 -- Microseconds
 guardWaitFor :: Int -> Guard
 guardWaitFor n
@@ -63,6 +70,6 @@
         return $ do b <- readTVar signalDone
                     if b == False
                       then retry
-                      else return []
+                      else return ()
 
 
diff --git a/Control/Concurrent/CHP/Monad.hs b/Control/Concurrent/CHP/Monad.hs
--- a/Control/Concurrent/CHP/Monad.hs
+++ b/Control/Concurrent/CHP/Monad.hs
@@ -32,6 +32,7 @@
   (
    -- * CHP Monad
   CHP, MonadCHP(..), runCHP, runCHP_,
+  embedCHP, embedCHP_, embedCHP1, embedCHP1_,
 
   onPoisonTrap, onPoisonRethrow, throwPoison, Poisonable(..), poisonAll,
 
@@ -43,9 +44,9 @@
    ) where
 
 import Control.Concurrent
-import Control.Monad.Error
 import Control.Monad.State
 import Control.Monad.Trans
+import Data.Unique
 
 -- This module primarily re-exports the public definitions from
 -- Control.Concurrent.CHP.{Base,CSP,Poison}:
@@ -59,12 +60,39 @@
 -- communicate between those processes using channels.  Instead, run this function
 -- once and use it to spawn off the parallel processes that you need.
 runCHP :: CHP a -> IO (Maybe a)
-runCHP = liftM fst . (runCHPAndTrace :: CHP a -> IO (Maybe a, TraceOff))
+runCHP = liftM fst . (runCHPAndTrace :: CHP a -> IO (Maybe a, TraceOff Unique))
 
 -- | Runs a CHP program.  Like 'runCHP' but discards the output.
 runCHP_ :: CHP a -> IO ()
 runCHP_ p = runCHP p >> return ()
 
+-- | Allows embedding of the CHP monad back into the IO monad.  The argument
+-- that this function takes is a CHP action (with arbitrary behaviour).  The
+-- function is monadic, and returns something of type: IO a.  This
+-- is an IO action that you can now use in the IO monad wherever you like.
+-- What it returns is the result of your original action.
+--
+-- This function is intended for use wherever you need to supply an IO callback
+-- (for example with the OpenGL libraries) that needs to perform CHP communications.
+--  It is the safe way to do things, rather than using runCHP twice (and also works
+-- with CSP and VCR traces -- but not structural traces!).
+embedCHP :: CHP a -> CHP (IO (Maybe a))
+embedCHP m = liftM ($ ()) $ embedCHP1 (\() -> m)
+
+-- | A convenient version of embedCHP that ignores the result
+embedCHP_ :: CHP a -> CHP (IO ())
+embedCHP_ = liftM (>> return ()) . embedCHP
+
+-- | A helper like embedCHP for callbacks that take an argument
+embedCHP1 :: (a -> CHP b) -> CHP (a -> IO (Maybe b))
+embedCHP1 f = do t <- liftPoison $ liftTrace get
+                 return $ liftM fst . runCHPProgramWith t (const ()) . f
+
+-- | A convenient version of embedCHP1 that ignores the result
+embedCHP1_ :: (a -> CHP b) -> CHP (a -> IO ())
+embedCHP1_ = liftM (\m x -> m x >> return ()) . embedCHP1
+
+
 -- | A monad transformer for easier looping.  This is independent of the
 -- CHP aspects, but has all the right type-classes defined for it to make
 -- it easy to use with the CHP library.
@@ -88,12 +116,6 @@
 instance MonadCHP m => MonadCHP (LoopWhileT m) where
   liftCHP = lift . liftCHP
 
-instance MonadError e m => MonadError e (LoopWhileT m) where
-  throwError e = lift $ throwError e
-  catchError m h = LWT $ catchError (getLoop m) (getLoop . h)
-
---TODO instances for all the other monad transformers
-
 -- | Runs the given action in a loop, executing it repeatedly until a 'while'
 -- statement inside it has a False condition.  If you use 'loop' without 'while',
 -- the effect is the same as 'forever'.
@@ -126,7 +148,7 @@
 -- /NOTE:/ If you wish to use this as part of a choice, you must use @-threaded@
 -- as a GHC compilation option (at least under 6.8.2).
 waitFor :: Int -> CHP ()
-waitFor n = liftPoison $ AltableT (guardWaitFor n, return ()) (liftIO $ threadDelay n)
+waitFor n = liftPoison $ AltableT (Right [(guardWaitFor n, return ())]) (liftIO $ threadDelay n)
 -- TODO maybe fix the above lack of guarantees by keeping timeout guards explicit.
 
 -- TODO add waitUntil
@@ -135,14 +157,14 @@
 --
 -- Suitable for use in an 'Control.Concurrent.CHP.Alt.alt'.
 skip :: CHP ()
-skip = liftPoison $ AltableT (skipGuard, return ()) (return ())
+skip = liftPoison $ AltableT (Right [(skipGuard, return ())]) (return ())
 
 -- | The stop guard.  Its main use is that it is never ready in a choice, so
 -- can be used to mask out guards.  If you actually execute 'stop', that process
 -- will do nothing more.  Any parent process waiting for it to complete will
 -- wait forever.
 stop :: CHP ()
-stop = liftPoison $ AltableT (stopGuard, liftIO hang) (liftIO hang)
+stop = liftPoison $ AltableT (Right [(stopGuard, liftIO hang)]) (liftIO hang)
   where
     -- Strangely, I can't work out a good way to actually implement stop.
     -- If you wait on a variable that will never be ready, GHC will wake
diff --git a/Control/Concurrent/CHP/Parallel.hs b/Control/Concurrent/CHP/Parallel.hs
--- a/Control/Concurrent/CHP/Parallel.hs
+++ b/Control/Concurrent/CHP/Parallel.hs
@@ -117,16 +117,16 @@
 runParallelPoison :: forall a. [CHP a] -> CHP [a]
 runParallelPoison processes
   = do c <- liftIO $ atomically $ newResultsVar
-       (_, trace) <- PoisonT $ lift $ liftTrace get
+       trace <- PoisonT $ lift $ liftTrace get
        blanks <- liftIO $ blankTraces trace (length processes)
        liftIO $ 
-         mapM_ forkIO [do y <- wrapProcess p $ flip runStateT ([], btr) . pullOutStandard
+         mapM_ forkIO [do y <- wrapProcess p $ flip runStateT btr . pullOutStandard
                           C.block $ atomically $
                             do ys <- readTVar c
                                writeTVar c $ (case y of
                                  Nothing -> (n, (Nothing, Nothing))
-                                 Just (Right (x,(_,t))) -> (n, (Just x, Just t))
-                                 Just (Left (_,t)) -> (n, (Nothing, Just t))
+                                 Just (Right (x,t)) -> (n, (Just x, Just t))
+                                 Just (Left t) -> (n, (Nothing, Just t))
                                  ) : ys
                       | (p, btr, n) <- zip3 processes blanks [0..]]
        results <- liftIO $ atomically $ do xs <- readTVar c
@@ -178,10 +178,10 @@
               liftIO $ atomically $ do
                 (pa, n) <- readTVar b
                 writeTVar b (pa, n + 1)
-              (_, trace) <- liftCHP $ PoisonT $ lift $ liftTrace get
+              trace <- liftCHP $ PoisonT $ lift $ liftTrace get
               [blank] <- liftIO $ blankTraces trace 1
               liftIO $ forkIO $ do
-                r <- wrapProcess p $ flip runStateT ([], blank) . pullOutStandard
+                r <- wrapProcess p $ flip runStateT blank . pullOutStandard
                 C.block $ atomically $ do
                   (poisonedAlready, n) <- readTVar b
                   writeTVar b $ (poisonedAlready || isNothing r, n - 1)
diff --git a/Control/Concurrent/CHP/Traces.hs b/Control/Concurrent/CHP/Traces.hs
--- a/Control/Concurrent/CHP/Traces.hs
+++ b/Control/Concurrent/CHP/Traces.hs
@@ -66,6 +66,8 @@
   ,ChannelLabels
   ,RecordedEventType(..)
   ,RecordedIndivEvent(..)
+  ,recordedIndivEventLabel
+  ,recordedIndivEventSeq
   ,Trace(..)
   ) where
 
diff --git a/Control/Concurrent/CHP/Traces/Base.hs b/Control/Concurrent/CHP/Traces/Base.hs
--- a/Control/Concurrent/CHP/Traces/Base.hs
+++ b/Control/Concurrent/CHP/Traces/Base.hs
@@ -45,7 +45,9 @@
 -- identifiers are per channel\/barrier, not per event.  Currently,
 -- channels and barriers can never have the same Unique as each other, but
 -- do not rely on this behaviour.
-type RecordedEvent = (RecordedEventType, Unique)
+--
+-- The type became parameterised in version 1.3.0.
+type RecordedEvent u = (RecordedEventType, u)
 
 -- | An individual record of an event, found in nested traces.  Either a
 -- channel write or read, or a barrier synchronisation, each with a unique
@@ -56,17 +58,41 @@
 -- never have the same Unique as each other, but do not rely on this
 -- behaviour.
 --
--- TimerSyncIndiv was added in version 1.2.0.
-data RecordedIndivEvent = 
-  ChannelWrite Unique
-  | ChannelRead Unique
-  | BarrierSyncIndiv Unique
-  | ClockSyncIndiv Unique String
-  deriving (Eq, Ord)
+-- ClockSyncIndiv was added in version 1.2.0.
+--
+-- The type became parameterised, and the Show and Read instances were added in version 1.3.0.
+data RecordedIndivEvent u = 
+  ChannelWrite u Integer
+  | ChannelRead u Integer
+  | BarrierSyncIndiv u Integer
+  | ClockSyncIndiv u Integer String
+  deriving (Eq, Ord, Read, Show)
 
-type RecEvents = ([RecordedEvent], [RecordedIndivEvent])
+-- | Added in version 1.3.0.
+recordedIndivEventLabel :: RecordedIndivEvent u -> u
+recordedIndivEventLabel (ChannelWrite x _) = x
+recordedIndivEventLabel (ChannelRead x _) = x
+recordedIndivEventLabel (BarrierSyncIndiv x _) = x
+recordedIndivEventLabel (ClockSyncIndiv x _ _) = x
 
-getName :: String -> Unique -> State (Map.Map Unique String) String
+-- | Added in version 1.3.0.
+recordedIndivEventSeq :: RecordedIndivEvent u -> Integer
+recordedIndivEventSeq (ChannelWrite _ n) = n
+recordedIndivEventSeq (ChannelRead _ n) = n
+recordedIndivEventSeq (BarrierSyncIndiv _ n) = n
+recordedIndivEventSeq (ClockSyncIndiv _ n _) = n
+
+indivRec :: (u -> Integer -> RecordedIndivEvent u)
+            -> u -> (u -> Integer) -> (RecordedIndivEvent u)
+indivRec r u f = r u (f u)
+
+indivRecJust :: (u -> Integer -> RecordedIndivEvent u)
+                -> u -> (u -> Integer) -> Maybe (RecordedIndivEvent u)
+indivRecJust r u f = Just $ indivRec r u f
+
+type RecEvents = ([RecordedEvent Unique], [RecordedIndivEvent Unique])
+
+getName :: Ord u => String -> u -> State (Map.Map u String) String
 getName prefix u
           = do m <- get
                case Map.lookup u m of
@@ -75,7 +101,7 @@
                             do put $ Map.insert u x m
                                return x
 
-nameEvent :: RecordedEvent -> State (Map.Map Unique String) String
+nameEvent :: Ord u => RecordedEvent u -> State (Map.Map u String) String
 nameEvent (t, c) = liftM (++ suffix) $ getName prefix c
   where
     (prefix, suffix) = case t of
@@ -83,39 +109,54 @@
       BarrierSync -> ("_b","")
       ClockSync st -> ("_t", ':' : st)
 
-nameIndivEvent :: RecordedIndivEvent -> State (Map.Map Unique String) String
-nameIndivEvent (ChannelWrite c) = do c' <- getName "_c" c
-                                     return $ c' ++ "!"
-nameIndivEvent (ChannelRead c) = do c' <- getName "_c" c
-                                    return $ c' ++ "?"
-nameIndivEvent (BarrierSyncIndiv c) = do c' <- getName "_b" c
-                                         return $ c' ++ "*"
-nameIndivEvent (ClockSyncIndiv c t) = do c' <- getName "_t" c
-                                         return $ c' ++ ":" ++ t
+nameEvent' :: Ord u => RecordedEvent u -> State (Map.Map u String) (RecordedEvent String)
+nameEvent' (t, c) = do c' <- getName prefix c
+                       return (t, c' ++ suffix)
+  where
+    (prefix, suffix) = case t of
+      ChannelComm -> ("_c","")
+      BarrierSync -> ("_b","")
+      ClockSync st -> ("_t", ':' : st)
 
 
-ensureAllNamed :: Map.Map Unique String -> [RecordedEvent] -> Map.Map Unique String
--- Quite hacky:
-ensureAllNamed m es = execState (mapM_ nameEvent es) m
+nameIndivEvent :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) String
+nameIndivEvent (ChannelWrite c n) = do c' <- getName "_c" c
+                                       return $ c' ++ "![" ++ show n ++ "]"
+nameIndivEvent (ChannelRead c n) = do c' <- getName "_c" c
+                                      return $ c' ++ "?[" ++ show n ++ "]"
+nameIndivEvent (BarrierSyncIndiv c n) = do c' <- getName "_b" c
+                                           return $ c' ++ "[" ++ show n ++ "]"
+nameIndivEvent (ClockSyncIndiv c n t) = do c' <- getName "_t" c
+                                           return $ c' ++ ":" ++ t
+                                             ++ "[" ++ show n ++ "]"
 
-ensureAllNamedIndiv :: Map.Map Unique String -> [RecordedIndivEvent] -> Map.Map Unique String
--- Quite hacky:
-ensureAllNamedIndiv m es = execState (mapM_ nameIndivEvent es) m
+nameIndivEvent' :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) (RecordedIndivEvent String)
+nameIndivEvent' (ChannelWrite c n) = do c' <- getName "_c" c
+                                        return $ ChannelWrite c' n
+nameIndivEvent' (ChannelRead c n) = do c' <- getName "_c" c
+                                       return $ ChannelRead c' n
+nameIndivEvent' (BarrierSyncIndiv c n) = do c' <- getName "_b" c
+                                            return $ BarrierSyncIndiv c' n
+nameIndivEvent' (ClockSyncIndiv c n t) = do c' <- getName "_t" c
+                                            return $ ClockSyncIndiv c' n t
 
 
--- The list of integers is for alting
-type TraceT = StateT ([Int], TraceStore)
+type TraceT = StateT TraceStore
 
 data TraceStore =
   NoTrace
-  | Trace (ProcessId, TVar ChannelLabels, SubTraceStore)
+  | Trace (ProcessId, TVar (ChannelLabels Unique), SubTraceStore)
 
-type ChannelLabels = Map.Map Unique String
+mapSubTrace :: (SubTraceStore -> SubTraceStore) -> TraceStore -> TraceStore
+mapSubTrace _ NoTrace = NoTrace
+mapSubTrace f (Trace (pid, tv, s)) = Trace (pid, tv, f s)
 
+type ChannelLabels u = Map.Map u String
+
 data SubTraceStore =
-  Hierarchy (Structured RecordedIndivEvent)
-  | CSPTraceRev (TVar [(Int, [RecordedEvent])])
-  | VCRTraceRev (TVar [Set.Set (Set.Set ProcessId, RecordedEvent)])
+  Hierarchy (Structured (RecordedIndivEvent Unique))
+  | CSPTraceRev (TVar [(Int, [RecordedEvent Unique])])
+  | VCRTraceRev (TVar [Set.Set (Set.Set ProcessId, RecordedEvent Unique)])
 
 data Ord a => Structured a =
   StrEvent a
@@ -124,7 +165,7 @@
   deriving (Eq, Ord)
 
 -- | Records an event where you were the last person to engage in the event
-recordEventLast :: [(RecordedEvent, Set.Set ProcessId)] -> TraceStore -> STM ()
+recordEventLast :: [(RecordedEvent Unique, Set.Set ProcessId)] -> TraceStore -> STM ()
 recordEventLast news y
            =    case y of
                   Trace (_,_,CSPTraceRev tv) ->
@@ -145,25 +186,17 @@
                   _ -> return ()
 
 -- | Records an event where you were one of the people involved
-recordEvent :: [RecordedIndivEvent] -> TraceT IO ()
-recordEvent e
-           = do (x,y) <- get
-                case (x, y) of
-                  (as, Trace (pid,tvls,Hierarchy es)) ->
-                       put (as, Trace (pid, tvls, Hierarchy (foldl (flip addSeqEventH) es e)))
-                  _ -> return ()
+recordEvent :: [RecordedIndivEvent Unique] -> TraceT IO ()
+recordEvent e = modify $ mapSubTrace $ \(Hierarchy es) ->
+                  Hierarchy (addParEventsH (map StrEvent e) es)
 
 mergeSubProcessTraces :: [TraceStore] -> TraceT IO ()
 mergeSubProcessTraces ts
-  = do s <- get
-       case s of
-         (as, Trace (pid, tvls, Hierarchy es)) ->
-           put (as, Trace (pid, tvls, Hierarchy $ addParEventsH ts' es))
-           where ts' = [t | Trace (_,_,Hierarchy t) <- ts]
-         _ -> return ()
-
+  = modify $ mapSubTrace $ \(Hierarchy es) -> Hierarchy (addParEventsH ts' es)
+  where
+    ts' = [t | Trace (_,_,Hierarchy t) <- ts]
 
-shouldMakeNewSetVCR :: Set.Set ProcessId -> Set.Set (Set.Set ProcessId, RecordedEvent)
+shouldMakeNewSetVCR :: Set.Set ProcessId -> Set.Set (Set.Set ProcessId, RecordedEvent Unique)
   -> Bool
 shouldMakeNewSetVCR newIds existingSet
   = exists existingSet $ \(bigP,_) -> exists bigP $ \p -> exists newIds $ \q ->
@@ -222,18 +255,18 @@
 addRLE x nes = (1,[x]):nes
 
 
-labelEvent :: Event -> String -> StateT (a, TraceStore) IO ()
+labelEvent :: Event -> String -> StateT TraceStore IO ()
 labelEvent e l
   = labelUnique (getEventUnique e) l
 
-labelUnique :: Unique -> String -> StateT (a, TraceStore) IO ()
+labelUnique :: Unique -> String -> StateT TraceStore IO ()
 labelUnique u l
-  = do (_,t) <- get
+  = do t <- get
        case t of
          NoTrace -> return ()
          Trace (_,tvls,_) -> add tvls
   where
-    add :: TVar (Map.Map Unique String) -> StateT (a, TraceStore) IO ()
+    add :: TVar (Map.Map Unique String) -> StateT TraceStore IO ()
     add tv = liftIO $ atomically $ do
       m <- readTVar tv
       writeTVar tv $ Map.insert u l m
diff --git a/Control/Concurrent/CHP/Traces/CSP.hs b/Control/Concurrent/CHP/Traces/CSP.hs
--- a/Control/Concurrent/CHP/Traces/CSP.hs
+++ b/Control/Concurrent/CHP/Traces/CSP.hs
@@ -34,6 +34,7 @@
 import Control.Concurrent.STM
 import Control.Monad.State
 import qualified Data.Map as Map
+import Data.Unique
 import Text.PrettyPrint.HughesPJ
 
 import Control.Concurrent.CHP.Base
@@ -41,9 +42,9 @@
 
 -- | A classic CSP trace.  It is simply the channel labels, and a list of recorded
 -- events in sequence -- the head of the list is the first (oldest) event.
-newtype CSPTrace = CSPTrace (ChannelLabels, [RecordedEvent])
+newtype CSPTrace u = CSPTrace (ChannelLabels u, [RecordedEvent u])
 
-instance Show CSPTrace where
+instance Ord u => Show (CSPTrace u) where
   show = renderStyle (Style OneLineMode 1 1) . prettyPrint
 
 instance Trace CSPTrace where
@@ -52,21 +53,18 @@
                         runCHPProgramWith' (CSPTraceRev tv) toPublic p
 
   prettyPrint (CSPTrace (labels, events))
-    = char '<' <+> (sep $ punctuate (char ',') $ map (text . nameCSP labels') events) <+> char '>'
-    where
-      labels' = ensureAllNamed labels events      
+    = char '<' <+> (sep $ punctuate (char ',') $ evalState (mapM (liftM text . nameEvent) events) labels) <+> char '>'
 
-toPublic :: ChannelLabels -> SubTraceStore -> IO CSPTrace
+  labelAll (CSPTrace (labels, events))
+    = CSPTrace (Map.empty, evalState (mapM nameEvent' events) labels)
+
+toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (CSPTrace Unique)
 toPublic l (CSPTraceRev tv)
   = do list <- atomically $ readTVar tv
        return $ CSPTrace (l, concatMap (\(n,es) -> concat $ replicate n $ reverse es) $ reverse list)
 toPublic _ _ = error "Error in CSP trace -- tracing type got switched"
 
-nameCSP :: ChannelLabels -> RecordedEvent -> String
-nameCSP m = flip evalState m . nameEvent
-
-
-runCHP_CSPTrace :: CHP a -> IO (Maybe a, CSPTrace)
+runCHP_CSPTrace :: CHP a -> IO (Maybe a, CSPTrace Unique)
 runCHP_CSPTrace = runCHPAndTrace
 
 runCHP_CSPTraceAndPrint :: CHP a -> IO ()
diff --git a/Control/Concurrent/CHP/Traces/Structural.hs b/Control/Concurrent/CHP/Traces/Structural.hs
--- a/Control/Concurrent/CHP/Traces/Structural.hs
+++ b/Control/Concurrent/CHP/Traces/Structural.hs
@@ -37,10 +37,14 @@
 module Control.Concurrent.CHP.Traces.Structural (StructuralTrace(..), EventHierarchy(..), runCHP_StructuralTrace, runCHP_StructuralTraceAndPrint,
   getAllEventsInHierarchy) where
 
+import Control.Applicative hiding (empty)
 import Control.Monad.State
+import qualified Data.Foldable as F
 import Data.List
 import qualified Data.Map as Map
 import Data.Maybe
+import qualified Data.Traversable as T
+import Data.Unique
 import Text.PrettyPrint.HughesPJ
 
 import Control.Concurrent.CHP.Base
@@ -48,16 +52,29 @@
 
 -- | A data type representing a hierarchy of events.  The count on the StructuralSequence
 -- count is a replicator count for that list of sequential items.
+--
+-- The Show, Read, Foldable and Traversable instances were added in version 1.3.0.
 data EventHierarchy a =
   SingleEvent a
   | StructuralSequence Int [EventHierarchy a]
   | StructuralParallel [EventHierarchy a]
+  deriving (Show, Read)
 
 instance Functor EventHierarchy where
   fmap f (SingleEvent x) = SingleEvent $ f x
   fmap f (StructuralSequence n es) = StructuralSequence n $ map (fmap f) es
   fmap f (StructuralParallel es) = StructuralParallel $ map (fmap f) es
 
+instance F.Foldable EventHierarchy where
+  foldr f y (SingleEvent x) = f x y
+  foldr f y (StructuralSequence _ es) = F.foldr (flip $ F.foldr f) y es
+  foldr f y (StructuralParallel es) = F.foldr (flip $ F.foldr f) y es
+
+instance T.Traversable EventHierarchy where
+  traverse f (SingleEvent x) = SingleEvent <$> f x
+  traverse f (StructuralSequence n es) = StructuralSequence n <$> T.traverse (T.traverse f) es
+  traverse f (StructuralParallel es) = StructuralParallel <$> T.traverse (T.traverse f) es
+
 -- | Flattens the events into a list.  The resulting list may contain duplicates, and it
 -- should not be assumed that the order relates in any way to the original
 -- hierarchy.
@@ -69,9 +86,9 @@
 
 -- | A nested (or hierarchical) trace.  The trace is an event hierarchy, wrapped
 -- in a Maybe type to allow for representation of the empty trace (Nothing).
-newtype StructuralTrace = StructuralTrace (ChannelLabels, Maybe (EventHierarchy RecordedIndivEvent))
+newtype StructuralTrace u = StructuralTrace (ChannelLabels u, Maybe (EventHierarchy (RecordedIndivEvent u)))
 
-instance Show StructuralTrace where
+instance Ord u => Show (StructuralTrace u) where
   show = renderStyle (Style OneLineMode 1 1) . prettyPrint
 
 instance Trace StructuralTrace where
@@ -80,11 +97,8 @@
 
   prettyPrint (StructuralTrace (_,Nothing)) = empty
   prettyPrint (StructuralTrace (labels, Just h))
-    = pp $ fmap (flip evalState labels' . nameIndivEvent) h
+    = pp $ evalState (T.mapM nameIndivEvent h) labels
     where
-      labels' = ensureAllNamedIndiv labels $
-        getAllEventsInHierarchy h
- 
       pp :: EventHierarchy String -> Doc
       pp (SingleEvent x) = text x
       pp (StructuralSequence 1 es)
@@ -95,7 +109,11 @@
       pp (StructuralParallel es)
         = parens $ sep $ intersperse (text "||") $ map pp es
 
-toPublic :: ChannelLabels -> SubTraceStore -> IO StructuralTrace
+  labelAll (StructuralTrace (_, Nothing)) = StructuralTrace (Map.empty, Nothing)
+  labelAll (StructuralTrace (labels, Just h))
+    = StructuralTrace (Map.empty, Just $ evalState (T.mapM nameIndivEvent' h) labels)
+
+toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (StructuralTrace Unique)
 toPublic l (Hierarchy h)
   = return $ StructuralTrace (l, conv h)
   where
@@ -119,7 +137,7 @@
           reverse s) rev
 toPublic _ _ = error "Error in Structural trace -- tracing type got switched"
 
-runCHP_StructuralTrace :: CHP a -> IO (Maybe a, StructuralTrace)
+runCHP_StructuralTrace :: CHP a -> IO (Maybe a, StructuralTrace Unique)
 runCHP_StructuralTrace = runCHPAndTrace
 
 runCHP_StructuralTraceAndPrint :: CHP a -> IO ()
diff --git a/Control/Concurrent/CHP/Traces/TraceOff.hs b/Control/Concurrent/CHP/Traces/TraceOff.hs
--- a/Control/Concurrent/CHP/Traces/TraceOff.hs
+++ b/Control/Concurrent/CHP/Traces/TraceOff.hs
@@ -38,14 +38,15 @@
 import Text.PrettyPrint.HughesPJ
 
 -- | A trace type that does not record anything.
-newtype TraceOff = TraceOff ()
+newtype TraceOff a = TraceOff ()
 
-instance Show TraceOff where
+instance Show (TraceOff a) where
   show = const ""
 
 instance Trace TraceOff where
   runCHPAndTrace = runCHPProgramWith NoTrace (const $ TraceOff ())
   emptyTrace = TraceOff ()
   prettyPrint = const empty
+  labelAll = const emptyTrace
 
 
diff --git a/Control/Concurrent/CHP/Traces/VCR.hs b/Control/Concurrent/CHP/Traces/VCR.hs
--- a/Control/Concurrent/CHP/Traces/VCR.hs
+++ b/Control/Concurrent/CHP/Traces/VCR.hs
@@ -37,6 +37,7 @@
 import Control.Monad.State
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Data.Unique
 import Text.PrettyPrint.HughesPJ
 
 import Control.Concurrent.CHP.Base
@@ -46,9 +47,11 @@
 -- accompanied by a sequential list of sets of recorded events.  Each of
 -- the sets is a set of independent events.  The set at the head of the
 -- list is the first-recorded (oldest).
-newtype VCRTrace = VCRTrace (ChannelLabels, [Set.Set RecordedEvent])
+--
+-- The type became parameterised in version 1.3.0
+newtype VCRTrace u = VCRTrace (ChannelLabels u, [Set.Set (RecordedEvent u)])
 
-instance Show VCRTrace where
+instance Ord u => Show (VCRTrace u) where
   show = renderStyle (Style OneLineMode 1 1) . prettyPrint
 
 instance Trace VCRTrace where
@@ -59,24 +62,28 @@
   prettyPrint (VCRTrace (labels, eventSets))
     = char '<' <+> (sep $ punctuate (char ',') $ map (braces . sep . punctuate (char ',')) ropes) <+> char '>'
     where
-      labels' = ensureAllNamed labels (concatMap Set.toList eventSets)
-      es = map (nameVCR labels') eventSets
+      es = evalState (mapM nameVCR eventSets) labels
 
       ropes :: [[Doc]]
       ropes = map (map text . Set.toList) es
 
+  labelAll (VCRTrace (labels, eventSets))
+    = VCRTrace (Map.empty, evalState (mapM nameVCR' eventSets) labels)
 
-toPublic :: ChannelLabels -> SubTraceStore -> IO VCRTrace
+toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (VCRTrace Unique)
 toPublic l (VCRTraceRev tv)
   = do setList <- atomically $ readTVar tv
        return $ VCRTrace (l, map (Set.map snd) $ reverse setList)
 toPublic _ _ = error "Error in VCR trace -- tracing type got switched"
 
-nameVCR :: ChannelLabels -> Set.Set RecordedEvent -> Set.Set String
-nameVCR m x = Set.fromList $ evalState (mapM nameEvent $ Set.toList x) m
+nameVCR :: Ord u => Set.Set (RecordedEvent u) -> State (ChannelLabels u) (Set.Set String)
+nameVCR = liftM Set.fromList . mapM nameEvent . Set.toList
 
+nameVCR' :: Ord u => Set.Set (RecordedEvent u) -> State (ChannelLabels u) (Set.Set (RecordedEvent String))
+nameVCR' = liftM Set.fromList . mapM nameEvent' . Set.toList
 
-runCHP_VCRTrace :: CHP a -> IO (Maybe a, VCRTrace)
+
+runCHP_VCRTrace :: CHP a -> IO (Maybe a, VCRTrace Unique)
 runCHP_VCRTrace = runCHPAndTrace
 
 runCHP_VCRTraceAndPrint :: CHP a -> IO ()
diff --git a/chp.cabal b/chp.cabal
--- a/chp.cabal
+++ b/chp.cabal
@@ -1,5 +1,5 @@
 Name:            chp
-Version:         1.2.0
+Version:         1.3.0
 Synopsis:        An implementation of concurrency ideas from Communicating Sequential Processes
 License:         BSD3
 License-file:    LICENSE
@@ -18,7 +18,7 @@
 Category:        Concurrency
 
 Build-Type:      Simple
-Build-Depends:   base, containers, mtl, parallel, pretty, stm
+Build-Depends:   base >= 3 && < 5, containers, mtl, parallel, pretty, stm
 
 Exposed-modules: Control.Concurrent.CHP
                  Control.Concurrent.CHP.Actions
@@ -51,7 +51,7 @@
                  Control.Concurrent.CHP.Traces.Base
 
 Extensions:      ScopedTypeVariables MultiParamTypeClasses
-                 FlexibleInstances UndecidableInstances
+                 FlexibleInstances
                  GeneralizedNewtypeDeriving CPP
 
 GHC-Options:     -Wall -threaded