diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,29 @@
+Copyright (c) 2010, Andreas Voellmy and Yale University
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+o Redistributions of source code must retain the above copyright
+  notice, this list of conditions and the following disclaimer.
+
+o Redistributions in binary form must reproduce the above copyright
+  notice, this list of conditions and the following disclaimer in the
+  documentation and/or other materials provided with the distribution.
+
+o Neither the name of the <ORGANIZATION> nor the names of its
+  contributors may be used to endorse or promote products derived from
+  this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/LICENSE-AFRP.txt b/LICENSE-AFRP.txt
new file mode 100644
--- /dev/null
+++ b/LICENSE-AFRP.txt
@@ -0,0 +1,29 @@
+Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+- Neither name of the copyright holders nor the names of its
+contributors may be used to endorse or promote products derived from
+this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
+OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -0,0 +1,10 @@
+nettle-frp is a Haskell library that contains an FRP-based framework for 
+controlling OpenFlow switches. 
+
+This library is under active development and should still be considered experimental.
+
+Examples can be found in src/Examples/AFRPControl/
+
+This library contains a copy of the afrp-0.4 code. A license file for that code
+is included in LICENSE-AFRP.txt.
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main = defaultMain
+
diff --git a/nettle-frp.cabal b/nettle-frp.cabal
new file mode 100644
--- /dev/null
+++ b/nettle-frp.cabal
@@ -0,0 +1,69 @@
+Name:           nettle-frp
+Version:        0.1
+Synopsis:       FRP for controlling networks of OpenFlow switches.
+Cabal-Version:  >=1.2
+Build-Type:     Simple
+Stability:      Experimental
+Category:       Network
+License: 	BSD3
+License-file:   LICENSE
+Author: 	Andreas Voellmy, Daniel Rozycki, Kwabene Antwi-Boasiako
+Maintainer: 	andreas.voellmy@yale.edu
+
+Description:
+  This module provides an FRP-based framework for controlling OpenFlow switches. 
+  The library is under active development and should still be considered experimental.
+
+extra-source-files: src/Examples/AFRPControl/LearningNetwork.hs
+		    src/Examples/AFRPControl/TrackSwitches.hs
+		    src/Examples/AFRPControl/TrackPorts.hs
+		    LICENSE-AFRP.txt
+		    README
+
+Library
+  hs-source-dirs: src
+  cpp-options: "-DOPENFLOW_VERSION=1"
+
+  exposed-modules:
+    Nettle.FRPControl.NettleSF
+    Nettle.FRPControl.PacketPredicate
+    Nettle.FRPControl.AFRPUtils
+    Nettle.FRPControl.NetInfo
+    Nettle.FRPControl.SwitchInterface
+    Nettle.FRPControl.TrafficGenerator
+    Nettle.FRPControl.AFRP 
+    Nettle.Discovery.Discovery
+    Nettle.Discovery.Topology
+
+  other-modules:
+    Nettle.FRPControl.AFRPEvent
+    Nettle.FRPControl.AFRPInternals
+    Nettle.FRPControl.AFRPUtilities
+    Nettle.FRPControl.AFRPAffineSpace
+    Nettle.FRPControl.AFRPMergeableRecord
+    Nettle.FRPControl.AFRPVector2
+    Nettle.FRPControl.AFRPDiagnostics
+    Nettle.FRPControl.AFRPMiscellany
+    Nettle.FRPControl.AFRPVector3
+    Nettle.FRPControl.AFRPPoint2
+    Nettle.FRPControl.AFRPVectorSpace
+    Nettle.FRPControl.AFRPForceable
+    Nettle.FRPControl.AFRPPoint3
+    Nettle.FRPControl.AFRPGeometry
+    Nettle.FRPControl.AFRPTask
+    Nettle.Discovery.Topology_Internal
+    Nettle.LLDP.LLDP
+
+
+  build-depends:
+    base >= 4 && < 5
+    , nettle-openflow
+    , mtl
+    , bytestring
+    , containers
+    , bimap
+    , binary
+    , time
+    , network
+    , haskell98
+    , network-data
diff --git a/src/Examples/AFRPControl/LearningNetwork.hs b/src/Examples/AFRPControl/LearningNetwork.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/AFRPControl/LearningNetwork.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE Arrows, TransformListComp, RecordWildCards #-}
+
+module Main where
+
+import Nettle.FRPControl.NettleSF
+import Nettle.FRPControl.NetInfo
+import Nettle.IPv4.IPPacket
+import Nettle.IPv4.IPAddress
+import Nettle.OpenFlow.Match
+import Nettle.OpenFlow.Packet
+import Nettle.OpenFlow.Action
+import Nettle.OpenFlow.Statistics
+import Nettle.OpenFlow.Switch
+import Nettle.Ethernet.EthernetFrame
+import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
+
+{- 
+A learning switch, which installs flow table entries at the switches to 
+to avoid switch-to-controller messages.
+-}
+
+-- Warning: Only works for loop-free networks; On loopy networks, a single packet will loop indefinitely 
+-- through the network.
+
+main :: IO ()
+main = simpleNettleDriver 2525 (controller)
+
+monitorPolicy = NetworkMonitorPolicy { switchFeaturesRefreshPeriod = 20, -- seconds
+                                       portStatisticsRefreshPeriod = 20   -- seconds
+                                     } 
+
+controller :: SF (Event (SwitchID, SwitchMessage)) (Event SwitchCommand, Event String)
+controller = proc i -> do 
+  netInfoCmdE <- networkInfoRequester monitorPolicy  -< i
+  initCmd <- switchInitializer' -< i
+  hostDirMap <- hostDirectionsSF -< i
+  let tableMods = mapFilterE (updateTableCommands hostDirMap) (packetInE i)
+  returnA -< (mergeEventsBy (<+>) [netInfoCmdE, initCmd, tableMods], noEvent)
+
+updateTableCommands hostDirMap (sw, pktInfo@PacketInfo {..}) = 
+  case packetInFrame pktInfo of 
+    Left msg       -> Nothing
+    Right ethFrame -> 
+      let pred = fromMatch (frameToExactMatch receivedOnPort ethFrame)
+          s    = sourceAddress ethFrame
+          r    = destAddress ethFrame
+          cmd = do ps <- Map.lookup (sw,s) hostDirMap
+                   pr <- Map.lookup (sw,r) hostDirMap             
+                   case bufferID of
+                     Nothing -> return (addFlowRule (((pred ==> sendOnPort pr) `expiringAfter` 240) `withPriority` 1) sw
+                                        <+> sendPacket sw (receivedPacketOut pktInfo flood)
+                                       )
+                     Just bufid -> return (addFlowRule' (((pred ==> sendOnPort pr) `expiringAfter` 240) `withPriority` 1) bufid sw)
+      in case cmd of 
+        Nothing -> Just (sendPacket sw (receivedPacketOut pktInfo flood))
+        Just cmd' -> Just cmd'
+                
+{-
+updateTableCommands hostDirMap (sw,pktInfo) =
+  case packetInFrame pktInfo of 
+    Left msg       -> Nothing
+    Right ethFrame -> 
+       let s = sourceAddress ethFrame
+           r = destAddress ethFrame
+       in do ps <- Map.lookup (sw,s) hostDirMap
+             pr <- Map.lookup (sw,r) hostDirMap             
+             return (deleteFlowRules (ethSourceDestAre s r <|> ethSourceDestAre r s) sw <+>
+                     addFlowRules [(1, flowFromTo s ps r pr `expiringAfter` 240) , 
+                                   (1, flowFromTo r pr s ps `expiringAfter` 240)] sw)
+    where flowFromTo s ps r pr = inPortIs ps <&> ethSourceDestAre s r ==> sendOnPort pr 
+-}
+switchInitializer' :: SF (Event (SwitchID, SwitchMessage)) (Event SwitchCommand)
+switchInitializer' = proc i -> do
+  returnA -< liftE (\(swid,_) -> clearTables swid <+> 
+                                 addFlowRule ((arp ==> flood) `withPriority` 1) swid) (arrivalE i)  
+
+packetSender :: SF (Event (SwitchID, SwitchMessage)) (Event SwitchCommand)
+packetSender = proc i -> do 
+  returnA -< liftE (\(switchID, pktIn) -> sendPacket switchID (receivedPacketOut pktIn flood)) (packetInE i)
+
diff --git a/src/Examples/AFRPControl/TrackPorts.hs b/src/Examples/AFRPControl/TrackPorts.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/AFRPControl/TrackPorts.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE Arrows #-}
+
+module Main where
+
+import Nettle.FRPControl.NettleSF
+import Nettle.FRPControl.NetInfo
+import Nettle.OpenFlow.Action
+import Nettle.OpenFlow.Packet
+import Nettle.OpenFlow.Switch
+
+-- A controller that broadcasts everything.
+-- Warning: Only works for loop-free networks; On loopy networks, a single packet will loop indefinitely 
+-- through the network.
+
+main = do simpleNettleDriver 2525 controller
+
+controller = proc msgE -> do 
+               netInfoCmdE <- networkInfoRequester defaultMonitorPolicy -< msgE               
+               clock    <- repeatedly 2 () -< ()
+               netInfo  <- switchInfo      -< msgE
+               let clearE  = liftE (\(dpid, _) -> clearTables dpid) (arrivalE msgE)
+               let floodE  = liftE (\(dpid, pktIn) -> sendPacket dpid (receivedPacketOut pktIn flood)) (packetInE msgE)
+               let stdOutE = liftE show (packetInE msgE) <+> tag clock (show (portQuery netInfo))
+               returnA -< (mergeEventsBy (<+>) [netInfoCmdE, clearE, floodE], stdOutE)
+                           
+               
+portQuery i = [ (dPID p, portID p) | p <- portTable i ]
+
diff --git a/src/Examples/AFRPControl/TrackSwitches.hs b/src/Examples/AFRPControl/TrackSwitches.hs
new file mode 100644
--- /dev/null
+++ b/src/Examples/AFRPControl/TrackSwitches.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE Arrows #-}
+
+module Main where
+
+import Nettle.FRPControl.NettleSF
+import Nettle.FRPControl.NetInfo
+import Nettle.OpenFlow.Switch
+
+main :: IO ()
+main = simpleNettleDriver 2525 controller
+
+-- A controller that periodically prints a list of switches connected to the controller.
+controller = proc msgE -> do 
+               netInfoCmdE <- networkInfoRequester defaultMonitorPolicy -< msgE  
+               clock   <- repeatedly 1 () -< ()
+               netInfo <- switchInfo -< msgE
+               returnA -< (netInfoCmdE, tag clock (show (switchTable netInfo)))
diff --git a/src/Nettle/Discovery/Discovery.hs b/src/Nettle/Discovery/Discovery.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/Discovery/Discovery.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE Arrows #-}
+
+-- | Experimental version of topology discovery algorithm.
+module Nettle.Discovery.Discovery (
+  topoTracker
+  
+  ) where
+
+import Nettle.FRPControl.NettleSF
+import Nettle.FRPControl.NetInfo
+import Nettle.Ethernet.EthernetFrame
+import Nettle.OpenFlow.Switch 
+import Nettle.OpenFlow.Packet 
+import qualified Nettle.OpenFlow.Port as Port 
+import Nettle.OpenFlow.Action
+import Nettle.Discovery.Topology
+import Nettle.LLDP.LLDP hiding (portID)
+import qualified Nettle.LLDP.LLDP as LLDP
+
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.Binary
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as B
+import Data.IP
+import Data.Header
+
+
+topologyController :: SF (Event (SwitchID, SwitchMessage)) (Event SwitchCommand, Event String)
+topologyController = proc msgE -> do 
+  (msgE', cmdE, topoE) <- topoTracker -< msgE
+  returnA -< (cmdE, liftE (line . show) topoE)
+  
+line :: String -> String  
+line s = s ++ "\n"
+  
+-- | A signal function tracking the topology of the network. The signal function sends LLDP-like
+-- packets from various points in the network and infers the topology based on packet-in events
+-- generated by those packets. In order to ensure that your controller does not interfere with the 
+-- operation of @topoTracker@, you should drive your controllers with the switch message stream output
+-- by the @topoTracker@ (the first output stream), which has the packet-in events generated by the LLDP-like packets filtered out.
+-- The second output stream is a stream of commands which must be merged into the overall output of your
+-- controller in order for the @topoTracker@ to inject its discovery packets into the network.
+topoTracker :: SF (Event (SwitchID, SwitchMessage)) (Event (SwitchID, SwitchMessage), Event SwitchCommand, Event Topology)
+topoTracker = proc evt -> do
+                netInfo <-  switchInfo   -< evt
+                pktInE  <- (arr (filteredPacketInE (ethFrameTypeIs ethTypeLLDP))) -< evt
+                let switchTuples = [ (dPID p, portAddr p, portID p) | p <- portTable netInfo ]
+                clock <- repeatedly 60 () -< ()
+                let swJoinLLDPCmdE = liftE (switchUpSendLLDPCommand (portTable netInfo)) (arrivalE evt)
+                let portUpdateCmdE = liftE (\(dpid, (_,portDesc)) -> sendPortLLDPCommand dpid portDesc) (portUpdateE evt)
+                let periodicCmdE = tag clock (sendLLDPCommand switchTuples)
+                let topoRemoveSwitch     = liftE (removeSwitch . fst) (departureE evt) 
+                    removePortE          = liftE (\(dpid, (_,portDesc)) -> removePortTopoUpdate dpid portDesc) (portUpdateE evt)
+                    lldpTopoUpdate       = mapFilterE readLLDPPacket pktInE
+                topologyE <- accum empty -< mergeEvents [topoRemoveSwitch, removePortE, lldpTopoUpdate]
+                returnA -< (removeLLDPPacketIns evt, 
+                            mergeEventsBy (<+>) [swJoinLLDPCmdE, portUpdateCmdE, periodicCmdE], 
+                            topologyE)
+
+-- .|. (linkDownListE =>> linkDownRemovePorts)                            
+--                    pktInLinkE           = pktInE =>> pktInGenerateLink
+--                 linkDownListE <- timerCollection 10 -< pktInLinkE
+
+
+linkDownRemovePorts :: [Link] -> Topology -> Topology
+linkDownRemovePorts lst t = foldr removeLink t lst
+
+{-
+pktInGenerateLink :: (SwitchID, PacketInfo) -> Link
+pktInGenerateLink (dpid, pktInfo) = 
+    let lldp = runGet getLLDPInEthernet (packetData pktInfo)
+        sourcePort = (chassisID lldp, LLDP.portID lldp)
+        destinationPort = (dpid, receivedOnPort pktInfo)
+    in link (sourcePort, destinationPort)
+-}
+
+removeLLDPPacketIns ::  Event (SwitchID, SwitchMessage) -> Event (SwitchID, SwitchMessage)
+removeLLDPPacketIns = mapFilterE f 
+  where f (sid, msg) = 
+          case msg of 
+            PacketIn pktInfo -> 
+              case packetInMatches pktInfo lldp of 
+                Left err -> Just (sid, PacketIn pktInfo)
+                Right b  -> if b then Nothing else Just (sid, PacketIn pktInfo)
+            _  -> Just (sid, msg)
+
+
+switchUpSendLLDPCommand :: PortTable -> (SwitchID, SwitchFeatures) -> SwitchCommand 
+switchUpSendLLDPCommand portTable (dpid,_) = sendLLDPCommand [(dpid, portAddr p, portID p) | p <- portTable, dPID p == dpid ]
+
+sendPortLLDPCommand :: SwitchID -> Port.Port -> SwitchCommand
+sendPortLLDPCommand dpid portDesc
+    | Port.portLinkDown portDesc == True = noOp
+    | otherwise                          = sendLLDPCommand [(dpid, Port.portAddress portDesc, Port.portID portDesc)]
+
+removePortTopoUpdate :: SwitchID -> Port.Port -> Topology -> Topology
+removePortTopoUpdate dpid portDesc
+    | Port.portLinkDown portDesc == True = removePort (dpid, Port.portID portDesc)
+    | otherwise                          = id
+
+readLLDPPacket :: (SwitchID, PacketInfo) -> Maybe (Topology -> Topology)
+readLLDPPacket (dpid, pktInRecord) =
+     case runGetE getLLDPInEthernet (packetData pktInRecord) of
+       Left _ -> Nothing
+       Right lldp -> let sourcePort      = (chassisID lldp, LLDP.portID lldp)
+                         destinationPort = (dpid, receivedOnPort pktInRecord)
+                     in Just (addLink sourcePort destinationPort)
+
+sendLLDPCommand :: [ (SwitchID, EthernetAddress, Port.PortID) ] -> SwitchCommand
+sendLLDPCommand = mconcat . map f  
+    where f switchInfo@(dpid, ethAddr, pid) = sendPacket dpid (unbufferedPacketOut (generateLLDPFrame switchInfo) Nothing (sendOnPort pid))
+
+
+generateLLDPFrame :: (SwitchID, EthernetAddress, Port.PortID) -> ByteString
+generateLLDPFrame (dpid, ethAddr, pid) = runPut frame
+    where packet = LLDPDU { chassisID   = dpid,
+                            LLDP.portID = pid,
+                            timeToLive  = 0     }
+
+          header = EthernetHeader { destMACAddress   = ethAddr,  
+                                    sourceMACAddress = ethAddr,
+                                    typeCode         = ethTypeLLDP }
+
+          frame  = do putEthHeader header
+                      put packet
+
diff --git a/src/Nettle/Discovery/Topology.hs b/src/Nettle/Discovery/Topology.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/Discovery/Topology.hs
@@ -0,0 +1,23 @@
+-- | Module defining an abstract data type describing the 
+-- connectivity among a collection of OpenFlow switches.
+module Nettle.Discovery.Topology 
+    (
+     Port
+    ,Link
+    ,Topology
+    ,unTopology
+    ,merge
+    ,empty
+    ,link
+    ,addLink
+    ,removeSwitch
+    ,combine
+    ,removeLink
+    ,removePort
+    ,subset
+    ,containsDataPathID
+    ,containsPort
+    )
+    where
+
+import Nettle.Discovery.Topology_Internal
diff --git a/src/Nettle/Discovery/Topology_Internal.hs b/src/Nettle/Discovery/Topology_Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/Discovery/Topology_Internal.hs
@@ -0,0 +1,74 @@
+{-# OPTIONS_HADDOCK hide #-}
+
+module Nettle.Discovery.Topology_Internal where
+
+import Nettle.OpenFlow.Switch (SwitchID)
+import Nettle.OpenFlow.Port hiding (Port)
+import qualified Data.Set as S
+
+-- |Port definition that references a specific port on a specific switch
+type Port = (SwitchID, PortID)
+
+-- |A set of two Ports (as defined above) that represents a connection from
+-- the PortID of a switch with a certain DataPathID to the PortID of another
+-- switch with a different DataPathID
+type Link = S.Set Port
+
+-- |Definition of Topology, that is, a set of two-member sets of ports
+-- It's constructors are not made available in other modules; Topologies
+-- can only be manipulated by the functions defined in this module. This is
+-- done so that certain properties can be assumed of any Topology, namely that
+-- all Links contain two members
+type Topology = S.Set Link
+--try newtype Link, type Topology, then you can use set operations on Topologies
+
+-- |Deconstructor for Topology constructor
+unTopology :: Topology -> S.Set Link
+unTopology topo = topo
+
+-- |Merge two topologies
+merge :: Topology -> Topology -> Topology
+merge t1 t2 = S.union t1 t2
+
+
+-- |Provides a Topology with no links
+empty :: Topology
+empty = S.empty
+
+-- | Construct a link
+link :: (Port, Port) -> Link
+link (p1,p2) = S.fromList [p1,p2]
+
+-- |Add a link into an existing topology. Use with empty to make a new Topology.
+addLink :: Port -> Port -> Topology -> Topology
+addLink p1 p2 = S.insert $ S.insert p1 $ S.insert p2 S.empty
+
+-- |Removes all links that include a certain switch's DataPathID
+-- from the Topology.
+removeSwitch :: SwitchID -> Topology -> Topology
+removeSwitch dpid = S.filter $ not . containsDataPathID dpid
+
+-- |Given two topologies, merge them into one
+combine :: Topology -> Topology -> Topology
+combine t1 t2 = S.union t1 t2
+
+removePort :: Port -> Topology -> Topology
+removePort pt = S.filter $ not . containsPort pt
+
+removeLink :: Link -> Topology -> Topology
+removeLink lk = removePort $ S.findMin lk
+
+
+
+-- |Find the subset of Links in a Topology that all
+-- include a certain switch's DataPathID
+subset :: SwitchID -> Topology -> Topology
+subset dpid = S.filter $ containsDataPathID dpid
+
+-- Predicate that returns true if the DataPathID provided matches
+-- the DataPathID in either of the two Ports in the Link.
+containsDataPathID :: SwitchID -> Link -> Bool
+containsDataPathID dpid lk = not $ S.null $ S.filter (\ (x, _) -> dpid == x) lk
+
+containsPort :: Port -> Link -> Bool
+containsPort pt lk = S.member pt lk
diff --git a/src/Nettle/FRPControl/AFRP.hs b/src/Nettle/FRPControl/AFRP.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRP.hs
@@ -0,0 +1,1529 @@
+{-
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:         AFRP                                                 *
+*       Purpose:        The AFRP core.					     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+
+Modified by Andreas Voellmy (andreas.voellmy@yale.edu) as follows:
+* Update some definitions (Arrow, Category, etc.) to fix compilation problems.
+* Added liftE as a synonym for fmap on Event.
+* Expose Event constructors
+* Add strictness annotations to integral to improve performance
+* Added evalSF and initDelay functions (see haddock comments).
+
+-}
+
+
+
+{-# LANGUAGE BangPatterns, RankNTypes #-}
+
+module Nettle.FRPControl.AFRP (
+-- Re-exported module, classes, and types
+    module Control.Arrow,
+    module Nettle.FRPControl.AFRPVectorSpace,
+    RandomGen(..),
+    Random(..),
+
+-- Reverse function composition and arrow plumbing aids
+    ( # ),		-- :: (a -> b) -> (b -> c) -> (a -> c),	infixl 9
+    dup,		-- :: a -> (a,a)
+    swap,		-- :: (a,b) -> (b,a)
+
+-- Main types
+    Time,	-- [s] Both for time w.r.t. some reference and intervals.
+    SF,		-- Signal Function.
+    Event(..),	-- Events; conceptually similar to Maybe (but abstract).
+
+-- Main instances
+    -- SF is an instance of Arrow and ArrowLoop. Method instances:
+    -- arr	:: (a -> b) -> SF a b
+    -- (>>>)	:: SF a b -> SF b c -> SF a c
+    -- (<<<)	:: SF b c -> SF a b -> SF a c
+    -- first	:: SF a b -> SF (a,c) (b,c)
+    -- second	:: SF a b -> SF (c,a) (c,b)
+    -- (***)	:: SF a b -> SF a' b' -> SF (a,a') (b,b')
+    -- (&&&)	:: SF a b -> SF a b' -> SF a (b,b')
+    -- returnA	:: SF a a
+    -- loop	:: SF (a,c) (b,c) -> SF a b
+
+    -- Event is an instance of Functor, Eq, and Ord. Some method instances:
+    -- fmap	:: (a -> b) -> Event a -> Event b
+    -- (==)     :: Event a -> Event a -> Bool
+    -- (<=)	:: Event a -> Event a -> Bool
+
+-- Basic signal functions
+    identity,		-- :: SF a a
+    constant,		-- :: b -> SF a b
+    localTime,		-- :: SF a Time
+    time,               -- :: SF a Time,	Other name for localTime.
+
+-- Initialization
+    (-->),		-- :: b -> SF a b -> SF a b,		infixr 0
+    (>--),		-- :: a -> SF a b -> SF a b,		infixr 0
+    (-=>),              -- :: (b -> b) -> SF a b -> SF a b      infixr 0
+    (>=-),              -- :: (a -> a) -> SF a b -> SF a b      infixr 0
+    initially,		-- :: a -> SF a a
+
+-- Basic event sources
+    never, 		-- :: SF a (Event b)
+    now,		-- :: b -> SF a (Event b)
+    after,		-- :: Time -> b -> SF a (Event b)
+    repeatedly,		-- :: Time -> b -> SF a (Event b)
+    afterEach,		-- :: [(Time,b)] -> SF a (Event b)
+    edge,		-- :: SF Bool (Event ())
+    iEdge,		-- :: Bool -> SF Bool (Event ())
+    edgeTag,		-- :: a -> SF Bool (Event a)
+    edgeJust,		-- :: SF (Maybe a) (Event a)
+    edgeBy,		-- :: (a -> a -> Maybe b) -> a -> SF a (Event b)
+
+-- Stateful event suppression
+    notYet,		-- :: SF (Event a) (Event a)
+    once,		-- :: SF (Event a) (Event a)
+    takeEvents,		-- :: Int -> SF (Event a) (Event a)
+    dropEvents,		-- :: Int -> SF (Event a) (Event a)
+
+-- Basic switchers
+    switch,  dSwitch,	-- :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
+    rSwitch, drSwitch,	-- :: SF a b -> SF (a,Event (SF a b)) b
+    kSwitch, dkSwitch,	-- :: SF a b
+			--    -> SF (a,b) (Event c)
+			--    -> (SF a b -> c -> SF a b)
+			--    -> SF a b
+
+-- Parallel composition and switching over collections with broadcasting
+    parB,		-- :: Functor col => col (SF a b) -> SF a (col b)
+    pSwitchB,dpSwitchB, -- :: Functor col =>
+			--        col (SF a b)
+			--	  -> SF (a, col b) (Event c)
+			--	  -> (col (SF a b) -> c -> SF a (col b))
+			--	  -> SF a (col b)
+    rpSwitchB,drpSwitchB,-- :: Functor col =>
+			--        col (SF a b)
+			--	  -> SF (a, Event (col (SF a b)->col (SF a b)))
+			--	        (col b)
+
+-- Parallel composition and switching over collections with general routing
+    par,		-- Functor col =>
+    			--     (forall sf . (a -> col sf -> col (b, sf)))
+    			--     -> col (SF b c)
+    			--     -> SF a (col c)
+    pSwitch, dpSwitch,  -- pSwitch :: Functor col =>
+			--     (forall sf . (a -> col sf -> col (b, sf)))
+			--     -> col (SF b c)
+			--     -> SF (a, col c) (Event d)
+			--     -> (col (SF b c) -> d -> SF a (col c))
+			--     -> SF a (col c)
+    rpSwitch,drpSwitch, -- Functor col =>
+			--    (forall sf . (a -> col sf -> col (b, sf)))
+    			--    -> col (SF b c)
+			--    -> SF (a, Event (col (SF b c) -> col (SF b c)))
+			--	    (col c)
+
+-- Wave-form generation
+    hold,		-- :: a -> SF (Event a) a
+    trackAndHold,	-- :: a -> SF (Maybe a) a
+
+-- Accumulators
+    accum,		-- :: a -> SF (Event (a -> a)) (Event a)
+    accumBy,		-- :: (b -> a -> b) -> b -> SF (Event a) (Event b)
+    accumFilter,	-- :: (c -> a -> (c, Maybe b)) -> c
+			--    -> SF (Event a) (Event b)
+
+-- Delays
+    pre,		-- :: SF a a
+    iPre,		-- :: a -> SF a a
+
+-- Integration and differentiation
+    integral,		-- :: VectorSpace a s => SF a a
+    derivative,		-- :: VectorSpace a s => SF a a		-- Crude!
+    imIntegral,		-- :: VectorSpace a s => a -> SF a a
+
+-- Loops with guaranteed well-defined feedback
+    loopPre, 		-- :: c -> SF (a,c) (b,c) -> SF a b
+    loopIntegral,	-- :: VectorSpace c s => SF (a,c) (b,c) -> SF a b
+
+-- Pointwise functions on events
+    noEvent,		-- :: Event a
+    noEventFst,		-- :: (Event a, b) -> (Event c, b)
+    noEventSnd,		-- :: (a, Event b) -> (a, Event c)
+    liftE,              -- :: (a -> b) -> Event a -> Event b    
+    event, 		-- :: a -> (b -> a) -> Event b -> a
+    fromEvent,		-- :: Monoid a => Event a -> a
+    isEvent,		-- :: Event a -> Bool
+    isNoEvent,		-- :: Event a -> Bool
+    tag, 		-- :: Event a -> b -> Event b,		infixl 8
+    attach,		-- :: Event a -> b -> Event (a, b),	infixl 8
+    lMerge, 		-- :: Event a -> Event a -> Event a,	infixl 6
+    rMerge,		-- :: Event a -> Event a -> Event a,	infixl 6
+    merge,		-- :: Event a -> Event a -> Event a,	infixl 6
+    mergeBy,		-- :: (a -> a -> a) -> Event a -> Event a -> Event a
+    mapMerge,           -- :: (a -> c) -> (b -> c) -> (a -> b -> c) 
+                        --    -> Event a -> Event b -> Event c
+    mergeEvents,        -- :: [Event a] -> Event a
+    mergeEventsBy,      -- :: (a -> a -> a) -> [Event a] -> Event a    
+    catEvents,		-- :: [Event a] -> Event [a]
+    joinE,		-- :: Event a -> Event b -> Event (a,b),infixl 7
+    splitE,		-- :: Event (a,b) -> (Event a, Event b)
+    filterE,	 	-- :: (a -> Bool) -> Event a -> Event a
+    mapFilterE,		-- :: (a -> Maybe b) -> Event a -> Event b
+    gate,		-- :: Event a -> Bool -> Event a,	infixl 8
+    maybeToEvent,       -- :: Maybe a -> Event a    
+
+-- Noise (random signal) sources and stochastic event sources
+    noise,		-- :: noise :: (RandomGen g, Random b) =>
+			--        g -> SF a b
+    noiseR,		-- :: noise :: (RandomGen g, Random b) =>
+			--        (b,b) -> g -> SF a b
+    occasionally,	-- :: RandomGen g => g -> Time -> b -> SF a (Event b)
+
+-- Reactimation
+    reactimate,		-- :: IO a
+	      		--    -> (Bool -> IO (DTime, Maybe a))
+	      		--    -> (Bool -> b -> IO Bool)
+              		--    -> SF a b
+	      		--    -> IO ()
+    ReactHandle,
+    reactInit,          --    IO a -- init
+                        --    -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate
+                        --    -> SF a b
+                        --    -> IO (ReactHandle a b)
+-- process a single input sample:
+    react,              --    ReactHandle a b
+                        --    -> (DTime,Maybe a)
+                        --    -> IO Bool
+
+-- Embedding (tentative: will be revisited)
+    DTime,		-- [s] Sampling interval, always > 0.
+    embed,		-- :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
+    embedSynch,		-- :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b
+    deltaEncode,	-- :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
+    deltaEncodeBy 	-- :: (a -> a -> Bool) -> DTime -> [a]
+			--    -> (a, [(DTime, Maybe a)])
+    , evalSF            -- :: evalSF :: SF a b -> (a, [(DTime,a)]) -> [(DTime,b)]
+    , initDelay         -- :: initDelay :: [a] -> SF a a 
+) where
+
+import Monad (unless)
+import Random (RandomGen(..), Random(..), randoms, randomRs)
+
+import Control.Category (Category)
+import qualified Control.Category as Cat
+import Control.Arrow hiding ((<+>))
+import Nettle.FRPControl.AFRPDiagnostics
+import Nettle.FRPControl.AFRPMiscellany (( # ), dup, swap)
+import Nettle.FRPControl.AFRPEvent
+import Nettle.FRPControl.AFRPVectorSpace
+
+import Data.IORef
+
+infixr 0 -->, >--, -=>, >=-
+
+------------------------------------------------------------------------------
+-- Basic type definitions with associated utilities
+------------------------------------------------------------------------------
+
+-- The time type is really a bit boguous, since, as time passes, the minimal
+-- interval between two consecutive floating-point-represented time points
+-- increases. A better approach is probably to pick a reasonable resolution
+-- and represent time and time intervals by Integer (giving the number of
+-- "ticks").
+
+-- Time is used both for time intervals (duration), and time w.r.t. some
+-- agreed reference point in time. Conceptually, Time = R, i.e. time can be 0
+-- or even negative.
+type Time = Double	-- [s]
+
+
+-- DTime is the time type for lengths of sample intervals. Conceptually,
+-- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the
+-- same representation.
+
+type DTime = Double	-- [s]
+
+
+-- Representation of signal function in initial state.
+-- (Naming: "TF" stands for Transition Function.)
+
+data SF a b = SF {sfTF :: a -> Transition a b}
+
+
+-- Representation of signal function in running state.
+-- It would have been nice to have a constructor SFId representing (arr id):
+--
+--     SFId {sfTF' :: DTime -> a -> Transition a b}
+--
+-- But it seems as if we need dependent types as soon as we try to exploit
+-- that constructor (note that the type above is too general!), and a
+-- work-around based on keeping around an extra function as a "proof" that we
+-- can do the required coersions, yields codde which is no more efficient
+-- than using SFArr in the first place.
+-- (Naming: "TIVar" stands for "time-input-variable".)
+
+data SF' a b 
+    = SFConst {sfTF' :: DTime -> a -> Transition a b, sfCVal :: b}
+    | SFArr   {sfTF' :: DTime -> a -> Transition a b, sfAFun :: a -> b}
+    | SFTIVar {sfTF' :: DTime -> a -> Transition a b}
+
+
+-- A transition is a pair of the next state (in the form of a signal
+-- function) and the output at the present time step.
+
+type Transition a b = (SF' a b, b)
+
+
+-- "Smart" constructors. The corresponding "raw" constructors should not
+-- be used directly for construction.
+
+sfConst :: b -> SF' a b
+sfConst b = sf
+    where
+	sf = SFConst {sfTF' = \_ _ -> (sf, b), sfCVal = b}
+
+
+sfNever :: SF' a (Event b)
+sfNever = sfConst NoEvent
+
+
+sfId :: SF' a a
+sfId = sf
+    where
+	sf = SFArr {sfTF' = \_ a -> (sf, a), sfAFun = id}
+
+
+sfArr :: (a -> b) -> SF' a b
+sfArr f = sf
+    where
+	sf = SFArr {sfTF' = \_ a -> (sf, f a), sfAFun = f}
+
+
+-- Freezes a "running" signal function, i.e., turns it into a continuation in
+-- the form of a plain signal function.
+freeze :: SF' a b -> DTime -> SF a b
+freeze sf dt = SF {sfTF = (sfTF' sf) dt}
+
+
+freezeCol :: Functor col => col (SF' a b) -> DTime -> col (SF a b)
+freezeCol sfs dt = fmap (flip freeze dt) sfs
+
+
+------------------------------------------------------------------------------
+-- Arrow instance and implementation
+------------------------------------------------------------------------------
+
+instance Category SF where
+    id = arrPrim id
+    f . g = g `compPrim` f
+
+instance Arrow SF where
+    arr    = arrPrim
+    first  = firstPrim
+    second = secondPrim
+    (***)  = parSplitPrim
+    (&&&)  = parFanOutPrim
+
+-- Lifting.
+arrPrim :: (a -> b) -> SF a b
+arrPrim f = SF {sfTF = \a -> (sfArr f, f a)}
+
+
+-- Composition.
+-- The definition exploits the following identities:
+--     sf         >>> constant c = constant c
+--     constant c >>> arr f      = constant (f c)
+--     arr f      >>> arr g      = arr (g . f)
+-- (It would have been nice to explit e.g. identity >>> sf = sf, but it would
+-- seem that we need dependent types for that.)
+compPrim :: SF a b -> SF b c -> SF a c
+compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
+    where
+	tf0 a0 = (cpAux sf1 sf2, c0)
+	    where
+		(sf1, b0) = tf10 a0
+		(sf2, c0) = tf20 b0
+
+	cpAux _ 	       sf2@(SFConst {}) = sfConst (sfCVal sf2)
+	cpAux sf1@(SFConst {}) sf2              = cpAuxC1 (sfCVal sf1) sf2
+	cpAux sf1@(SFArr {})   sf2              = cpAuxA1 (sfAFun sf1) sf2
+	cpAux sf1              sf2@(SFArr {})   = cpAuxA2 sf1 (sfAFun sf2)
+	cpAux sf1              sf2              = SFTIVar {sfTF' = tf}
+	    where
+	        tf dt a = (cpAux sf1' sf2', c)
+		    where
+		        (sf1', b) = (sfTF' sf1) dt a
+			(sf2', c) = (sfTF' sf2) dt b
+
+	cpAuxC1 _ (SFConst {sfCVal = c})   = sfConst c
+	cpAuxC1 b (SFArr   {sfAFun = f2})  = sfConst (f2 b)
+	cpAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
+	    where
+		tf dt _ = (cpAuxC1 b sf2', c)
+		    where
+			(sf2', c) = tf2 dt b
+
+	cpAuxA1 _  (SFConst {sfCVal = c})   = sfConst c
+	cpAuxA1 f1 (SFArr   {sfAFun = f2})  = sfArr (f2 . f1)
+	cpAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = (cpAuxA1 f1 sf2', c)
+		    where
+			(sf2', c) = tf2 dt (f1 a)
+
+	cpAuxA2 (SFConst {sfCVal = b})   f2 = sfConst (f2 b)
+	cpAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (f2 . f1)
+	cpAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = (cpAuxA2 sf1' f2, f2 b)
+		    where
+			(sf1', b) = tf1 dt a
+
+
+-- Widening.
+-- The definition exploits the following identities:
+--     first (constant b) = arr (\(_, c) -> (b, c))
+--     (first (arr f))    = arr (\(a, c) -> (f a, c))
+-- (It would have been nice to exploit first identity = identity, but it would
+-- seem that we need dependent types for that.)
+firstPrim :: SF a b -> SF (a,c) (b,c)
+firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
+    where
+        tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))
+	    where
+		(sf1, b0) = tf10 a0 
+
+	fpAux (SFConst {sfCVal = b}) = sfArr (\(~(_, c)) -> (b, c))
+	fpAux (SFArr   {sfAFun = f}) = sfArr (\(~(a, c)) -> (f a, c))
+	fpAux sf1                    = SFTIVar {sfTF' = tf}
+	    where
+	        tf dt ~(a, c) = (fpAux sf1', (b, c))
+		    where
+			(sf1', b) = (sfTF' sf1) dt a 
+
+
+-- Mirror image of first.
+secondPrim :: SF a b -> SF (c,a) (c,b)
+secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
+    where
+        tf0 ~(c0, a0) = (spAux sf1, (c0, b0))
+	    where
+		(sf1, b0) = tf10 a0 
+
+	spAux (SFConst {sfCVal = b}) = sfArr (\(~(c, _)) -> (c, b))
+	spAux (SFArr   {sfAFun = f}) = sfArr (\(~(c, a)) -> (c, f a))
+	spAux sf1                    = SFTIVar {sfTF' = tf}
+	    where
+	        tf dt ~(c, a) = (spAux sf1', (c, b))
+		    where
+			(sf1', b) = (sfTF' sf1) dt a 
+
+
+-- Parallel composition.
+-- The definition exploits the following identities (which hold for SF):
+--     constant b *** constant d = constant (b, d)
+--     constant b *** arr f2     = arr (\(_, c) -> (b, f2 c)
+--     arr f1     *** constant d = arr (\(a, _) -> (f1 a, d)
+--     arr f1     *** arr f2     = arr (\(a, b) -> (f1 a, f2 b)
+parSplitPrim :: SF a b -> SF c d  -> SF (a,c) (b,d)
+parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
+    where
+	tf0 ~(a0, c0) = (psAux sf1 sf2, (b0, d0))
+	    where
+		(sf1, b0) = tf10 a0 
+		(sf2, d0) = tf20 c0 
+
+	psAux sf1@(SFConst {}) sf2              = psAuxC1 (sfCVal sf1) sf2
+	psAux sf1              sf2@(SFConst {}) = psAuxC2 sf1 (sfCVal sf2)
+	psAux sf1@(SFArr {})   sf2              = psAuxA1 (sfAFun sf1) sf2
+	psAux sf1              sf2@(SFArr   {}) = psAuxA2 sf1 (sfAFun sf2)
+	psAux sf1	       sf2		= SFTIVar {sfTF' = tf}
+	    where
+		tf dt ~(a, c) = (psAux sf1' sf2', (b, d))
+		    where
+		        (sf1', b) = (sfTF' sf1) dt a
+			(sf2', d) = (sfTF' sf2) dt c
+
+	psAuxC1 b (SFConst {sfCVal = d})   = sfConst (b, d)
+	psAuxC1 b (SFArr   {sfAFun = f2})  = sfArr (\(~(_, c)) -> (b, f2 c))
+	psAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
+	    where
+		tf dt ~(_, c) = (psAuxC1 b sf2', (b, d))
+		    where
+			(sf2', d) = tf2 dt c
+
+	psAuxC2 (SFConst {sfCVal = b})   d = sfConst (b, d)
+	psAuxC2 (SFArr   {sfAFun = f1})  d = sfArr (\(~(a, _)) -> (f1 a, d))
+	psAuxC2 (SFTIVar {sfTF'  = tf1}) d = SFTIVar {sfTF' = tf}
+	    where
+		tf dt ~(a, _) = (psAuxC2 sf1' d, (b, d))
+		    where
+			(sf1', b) = tf1 dt a
+
+	psAuxA1 f1 (SFConst {sfCVal = d})   = sfArr (\(~(a,_)) -> (f1 a, d))
+	psAuxA1 f1 (SFArr   {sfAFun = f2})  = sfArr (\(~(a,c)) -> (f1 a, f2 c))
+	psAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
+	    where
+		tf dt ~(a, c) = (psAuxA1 f1 sf2', (f1 a, d))
+		    where
+			(sf2', d) = tf2 dt c
+
+	psAuxA2 (SFConst {sfCVal = b})   f2 = sfArr (\(~(_,c)) -> (b, f2 c))
+	psAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (\(~(a,c)) -> (f1 a, f2 c))
+	psAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}
+	    where
+		tf dt ~(a, c) = (psAuxA2 sf1' f2, (b, f2 c))
+		    where
+			(sf1', b) = tf1 dt a
+
+
+parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
+parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
+    where
+	tf0 a0 = (pfoAux sf1 sf2, (b0, c0))
+	    where
+		(sf1, b0) = tf10 a0 
+		(sf2, c0) = tf20 a0 
+
+	pfoAux sf1@(SFConst {}) sf2              = pfoAuxC1 (sfCVal sf1) sf2
+	pfoAux sf1              sf2@(SFConst {}) = pfoAuxC2 sf1 (sfCVal sf2)
+	pfoAux sf1@(SFArr {})   sf2              = pfoAuxA1 (sfAFun sf1) sf2
+	pfoAux sf1              sf2@(SFArr   {}) = pfoAuxA2 sf1 (sfAFun sf2)
+	pfoAux sf1	        sf2		 = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = (pfoAux sf1' sf2', (b, c))
+		    where
+		        (sf1', b) = (sfTF' sf1) dt a
+			(sf2', c) = (sfTF' sf2) dt a
+
+	pfoAuxC1 b (SFConst {sfCVal = c})   = sfConst (b, c)
+	pfoAuxC1 b (SFArr   {sfAFun = f2})  = sfArr (\a -> (b, f2 a))
+	pfoAuxC1 b (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = (pfoAuxC1 b sf2', (b, c))
+		    where
+			(sf2', c) = tf2 dt a
+
+	pfoAuxC2 (SFConst {sfCVal = b})   c = sfConst (b, c)
+	pfoAuxC2 (SFArr   {sfAFun = f1})  c = sfArr (\a -> (f1 a, c))
+	pfoAuxC2 (SFTIVar {sfTF'  = tf1}) c = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = (pfoAuxC2 sf1' c, (b, c))
+		    where
+			(sf1', b) = tf1 dt a
+
+	pfoAuxA1 f1 (SFConst {sfCVal = c})   = sfArr (\a -> (f1 a, c))
+	pfoAuxA1 f1 (SFArr   {sfAFun = f2})  = sfArr (\a -> (f1 a ,f2 a))
+	pfoAuxA1 f1 (SFTIVar {sfTF'  = tf2}) = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = (pfoAuxA1 f1 sf2', (f1 a, c))
+		    where
+			(sf2', c) = tf2 dt a
+
+	pfoAuxA2 (SFConst {sfCVal = b})   f2 = sfArr (\a -> (b, f2 a))
+	pfoAuxA2 (SFArr   {sfAFun = f1})  f2 = sfArr (\a -> (f1 a, f2 a))
+	pfoAuxA2 (SFTIVar {sfTF'  = tf1}) f2 = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = (pfoAuxA2 sf1' f2, (b, f2 a))
+		    where
+			(sf1', b) = tf1 dt a
+
+
+------------------------------------------------------------------------------
+-- ArrowLoop instance and implementation
+------------------------------------------------------------------------------
+
+instance ArrowLoop SF where
+    loop = loopPrim
+
+
+loopPrim :: SF (a,c) (b,c) -> SF a b
+loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
+    where
+	tf0 a0 = (loopAux sf1, b0)
+	    where
+	        (sf1, (b0, c0)) = tf10 (a0, c0)
+
+        loopAux (SFConst {sfCVal = (b, _)}) = sfConst b
+	loopAux (SFArr   {sfAFun = f1})     = sfArr (\a -> let (b,c) = f1 (a,c)
+                                                           in b)
+	loopAux sf1                         = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = (loopAux sf1', b)
+		    where
+		        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)
+
+
+------------------------------------------------------------------------------
+-- Basic signal functions
+------------------------------------------------------------------------------
+
+-- Identity: identity = arr id
+identity :: SF a a
+identity = SF {sfTF = \a -> (sfId, a)}
+
+
+-- Identity: constant b = arr (const b)
+constant :: b -> SF a b
+constant b = SF {sfTF = \_ -> (sfConst b, b)}
+
+
+-- Outputs the time passed since the signal function instance was started.
+localTime :: SF a Time
+localTime = constant 1.0 >>> integral
+
+
+-- Alternative name for localTime.
+time :: SF a Time
+time = localTime
+
+
+------------------------------------------------------------------------------
+-- Initialization
+------------------------------------------------------------------------------
+
+-- Initialization operator (cf. Lustre/Lucid Synchrone).
+(-->) :: b -> SF a b -> SF a b
+b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)}
+
+
+-- Input initialization operator.
+(>--) :: a -> SF a b -> SF a b
+a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0}
+
+
+-- Transform initial output value.
+(-=>) :: (b -> b) -> SF a b -> SF a b
+f -=> (SF {sfTF = tf10}) =
+    SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)}
+
+
+-- Transform initial input value.
+(>=-) :: (a -> a) -> SF a b -> SF a b
+f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)}
+
+
+-- Override initial value of input signal.
+initially :: a -> SF a a
+initially = (--> identity)
+
+
+------------------------------------------------------------------------------
+-- Basic event sources
+------------------------------------------------------------------------------
+
+-- Event source which never occurs.
+never :: SF a (Event b)
+never = SF {sfTF = \_ -> (sfNever, NoEvent)}
+
+
+-- Event source with a single occurrence at time 0. The value of the event
+-- is given by the function argument.
+now :: b -> SF a (Event b)
+now b0 = (Event b0 --> never)
+
+
+-- Event source with a single occurrence at or as soon after (local) time q
+-- as possible.
+after :: Time -> b -> SF a (Event b)
+after q x = afterEach [(q,x)]
+
+
+-- Event source with repeated occurrences with interval q.
+-- Note: If the interval is too short w.r.t. the sampling intervals,
+-- the result will be that events occur at every sample. However, no more
+-- than one event results from any sampling interval, thus avoiding an
+-- "event backlog" should sampling become more frequent at some later
+-- point in time.
+repeatedly :: Time -> b -> SF a (Event b)
+repeatedly q x | q > 0 = afterEach qxs
+               | otherwise = usrErr "AFRP" "repeatedly" "Non-positive period."
+    where
+        qxs = (q,x):qxs        
+
+
+-- Event source with consecutive occurrences at the given intervals.
+-- Should more than one event be scheduled to occur in any sampling interval,
+-- only the first will in fact occur to avoid an event backlog.
+-- Question: Should positive periods except for the first one be required?
+-- Note that periods of length 0 will always be skipped except for the first.
+-- Right now, periods of length 0 is allowed on the grounds that no attempt
+-- is made to forbid simultaneous events elsewhere.
+afterEach :: [(Time,b)] -> SF a (Event b)
+afterEach [] = never
+afterEach ((q,x):qxs)
+    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."
+    | otherwise = SF {sfTF = tf0}
+    where
+	tf0 _ = if q <= 0 then
+                    (scheduleNextEvent 0.0 qxs, Event x)
+                else
+		    (awaitNextEvent (-q) x qxs, NoEvent)
+
+	scheduleNextEvent t [] = sfNever
+        scheduleNextEvent t ((q,x):qxs)
+	    | q < 0     = usrErr "AFRP" "afterEach" "Negative period."
+	    | t' >= 0   = scheduleNextEvent t' qxs
+	    | otherwise = awaitNextEvent t' x qxs
+	    where
+	        t' = t - q
+	awaitNextEvent t x qxs = SFTIVar {sfTF' = tf}
+	    where
+		tf dt _ | t' >= 0   = (scheduleNextEvent t' qxs, Event x)
+		        | otherwise = (awaitNextEvent t' x qxs, NoEvent)
+		    where
+		        t' = t + dt
+
+
+-- A rising edge detector. Useful for things like detecting key presses.
+-- Note that we initialize the loop with state set to True so that there
+-- will not be an occurence at t0 in the logical time frame in which
+-- this is started.
+edge :: SF Bool (Event ())
+edge = iEdge True
+
+
+iEdge :: Bool -> SF Bool (Event ())
+iEdge i = edgeBy (isBoolRaisingEdge ()) i
+
+
+-- Like edge, but parameterized on the tag value.
+edgeTag :: a -> SF Bool (Event a)
+edgeTag a = edgeBy (isBoolRaisingEdge a) True
+
+
+-- Internal utility.
+isBoolRaisingEdge :: a -> Bool -> Bool -> Maybe a
+isBoolRaisingEdge _ False False = Nothing
+isBoolRaisingEdge a False True  = Just a
+isBoolRaisingEdge _ True  True  = Nothing
+isBoolRaisingEdge _ True  False = Nothing
+
+
+-- Detects an edge where a maybe signal is changing from nothing to something.
+edgeJust :: SF (Maybe a) (Event a)
+edgeJust = edgeBy isJustEdge (Just undefined)
+    where
+        isJustEdge Nothing  Nothing     = Nothing
+        isJustEdge Nothing  ma@(Just _) = ma
+        isJustEdge (Just _) (Just _)    = Nothing
+        isJustEdge (Just _) Nothing     = Nothing
+
+
+-- Edge detector parameterized on the edge detection function and initial
+-- state, i.e., the previous input sample. The first argument to the
+-- edge detection function is the previous sample, the second the current one.
+
+-- !!! Is this broken!?! Does not disallow an edge condition that persists
+-- !!! between consecutive samples. See discussion in ToDo list above.
+
+edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b)
+edgeBy isEdge a_init = SF {sfTF = tf0}
+    where
+	tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0))
+
+	ebAux a_prev = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = (ebAux a, maybeToEvent (isEdge a_prev a))
+
+
+------------------------------------------------------------------------------
+-- Stateful event suppression
+------------------------------------------------------------------------------
+
+-- Suppression of initial (at local time 0) event.
+notYet :: SF (Event a) (Event a)
+notYet = initially NoEvent
+
+
+-- Suppress all but first event.
+once :: SF (Event a) (Event a)
+once = takeEvents 1
+
+
+-- Suppress all but first n events.
+takeEvents :: Int -> SF (Event a) (Event a)
+takeEvents 0       = never
+takeEvents (n + 1) = dSwitch (arr dup) (const (NoEvent >-- takeEvents n))
+
+
+{-
+-- More complicated using "switch" that "dSwitch".
+takeEvents :: Int -> SF (Event a) (Event a)
+takeEvents 0       = never
+takeEvents (n + 1) = switch (never &&& identity) (takeEvents' n)
+    where
+        takeEvents' 0       a = now a
+        takeEvents' (n + 1) a = switch (now a &&& notYet) (takeEvents' n)
+-}
+
+
+-- Suppress first n events.
+-- Here dSwitch or switch does not really matter.
+dropEvents :: Int -> SF (Event a) (Event a)
+dropEvents 0       = identity
+dropEvents (n + 1) = dSwitch (never &&& identity)
+                             (const (NoEvent >-- dropEvents n))
+
+
+------------------------------------------------------------------------------
+-- Basic switchers
+------------------------------------------------------------------------------
+
+-- Basic switch.
+switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
+switch (SF {sfTF = tf10}) k = SF {sfTF = tf0}
+    where
+	tf0 a0 =
+	    case tf10 a0 of
+	    	(sf1, (b0, NoEvent))  -> (switchAux sf1, b0)
+		(_,   (_,  Event c0)) -> sfTF (k c0) a0
+
+	switchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b
+	switchAux (SFArr   {sfAFun = f1})           = switchAuxA1 f1
+	switchAux sf1                               = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a =
+		    case (sfTF' sf1) dt a of
+			(sf1', (b, NoEvent)) -> (switchAux sf1', b)
+			(_,    (_, Event c)) -> sfTF (k c) a
+
+	-- Note: While switch behaves as a stateless arrow at this point, that
+	-- could change after a switch. Hence, SFTIVar overall.
+	switchAuxA1 f1 = sf
+	    where
+		sf     = SFTIVar {sfTF' = tf}
+		tf _ a =
+		    case f1 a of
+			(b, NoEvent) -> (sf, b)
+			(_, Event c) -> sfTF (k c) a
+
+
+-- Switch with delayed observation.
+dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b
+dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}
+    where
+	tf0 a0 =
+	    let (sf1, (b0, ec0)) = tf10 a0
+            in (case ec0 of
+                    NoEvent  -> dSwitchAux sf1
+		    Event c0 -> fst (sfTF (k c0) a0),
+                b0)
+
+	dSwitchAux (SFConst {sfCVal = (b, NoEvent)}) = sfConst b
+	dSwitchAux (SFArr   {sfAFun = f1})           = dSwitchAuxA1 f1
+	dSwitchAux sf1                               = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a =
+		    let (sf1', (b, ec)) = (sfTF' sf1) dt a
+                    in (case ec of
+			    NoEvent -> dSwitchAux sf1'
+			    Event c -> fst (sfTF (k c) a),
+
+			b)
+
+	-- Note: While dSwitch behaves as a stateless arrow at this point, that
+	-- could change after a switch. Hence, SFTIVar overall.
+	dSwitchAuxA1 f1 = sf
+	    where
+		sf = SFTIVar {sfTF' = tf}
+		tf _ a =
+		    let (b, ec) = f1 a
+                    in (case ec of
+			    NoEvent -> sf
+			    Event c -> fst (sfTF (k c) a),
+
+			b)
+
+
+-- Recurring switch.
+rSwitch :: SF a b -> SF (a, Event (SF a b)) b
+rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch)
+
+{-
+-- Old version. New is more efficient. Which one is clearer?
+rSwitch :: SF a b -> SF (a, Event (SF a b)) b
+rSwitch sf = switch (first sf) rSwitch'
+    where
+        rSwitch' sf = switch (sf *** notYet) rSwitch'
+-}
+
+
+-- Recurring switch with delayed observation.
+drSwitch :: SF a b -> SF (a, Event (SF a b)) b
+drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch)
+
+{-
+-- Old version. New is more efficient. Which one is clearer?
+drSwitch :: SF a b -> SF (a, Event (SF a b)) b
+drSwitch sf = dSwitch (first sf) drSwitch'
+    where
+        drSwitch' sf = dSwitch (sf *** notYet) drSwitch'
+-}
+
+
+-- "Call-with-current-continuation" switch.
+kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
+kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
+    where
+        tf0 a0 =
+	    let (sf1, b0) = tf10 a0
+            in
+	        case tfe0 (a0, b0) of
+		    (sfe, NoEvent)  -> (kSwitchAux sf1 sfe, b0)
+		    (_,   Event c0) -> sfTF (k sf10 c0) a0
+
+        kSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1
+        kSwitchAux sf1 sfe                          = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a =
+		    let	(sf1', b) = (sfTF' sf1) dt a
+		    in
+		        case (sfTF' sfe) dt (a, b) of
+			    (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b)
+			    (_,    Event c) -> sfTF (k (freeze sf1 dt) c) a
+
+
+-- kSwitch with delayed observation.
+dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b
+dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0}
+    where
+        tf0 a0 =
+	    let (sf1, b0) = tf10 a0
+            in (case tfe0 (a0, b0) of
+		    (sfe, NoEvent)  -> dkSwitchAux sf1 sfe
+		    (_,   Event c0) -> fst (sfTF (k sf10 c0) a0),
+                b0)
+
+        dkSwitchAux sf1 (SFConst {sfCVal = NoEvent}) = sf1
+        dkSwitchAux sf1 sfe                          = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a =
+		    let	(sf1', b) = (sfTF' sf1) dt a
+		    in (case (sfTF' sfe) dt (a, b) of
+			    (sfe', NoEvent) -> dkSwitchAux sf1' sfe'
+			    (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a),
+		        b)
+
+
+------------------------------------------------------------------------------
+-- Parallel composition and switching over collections with broadcasting
+------------------------------------------------------------------------------
+
+broadcast :: Functor col => a -> col sf -> col (a, sf)
+broadcast a sfs = fmap (\sf -> (a, sf)) sfs
+
+
+-- Spatial parallel composition of a signal function collection.
+parB :: Functor col => col (SF a b) -> SF a (col b)
+parB = par broadcast
+
+
+-- Parallel switch (dynamic collection of signal functions spatially composed
+-- in parallel).
+pSwitchB :: Functor col =>
+    col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b))
+    -> SF a (col b)
+pSwitchB = pSwitch broadcast
+
+
+dpSwitchB :: Functor col =>
+    col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c->SF a (col b))
+    -> SF a (col b)
+dpSwitchB = dpSwitch broadcast
+
+
+rpSwitchB :: Functor col =>
+    col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)
+rpSwitchB = rpSwitch broadcast
+
+
+drpSwitchB :: Functor col =>
+    col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b)
+drpSwitchB = drpSwitch broadcast
+
+
+------------------------------------------------------------------------------
+-- Parallel composition and switching over collections with general routing
+------------------------------------------------------------------------------
+
+-- Spatial parallel composition of a signal function collection parameterized
+-- on the routing function.
+-- rf .........	Routing function: determines the input to each signal function
+--		in the collection. IMPORTANT! The routing function MUST
+--		preserve the structure of the signal function collection.
+-- sfs0 .......	Signal function collection.
+-- Returns the spatial parallel composition of the supplied signal functions.
+
+par :: Functor col =>
+    (forall sf . (a -> col sf -> col (b, sf)))
+    -> col (SF b c)
+    -> SF a (col c)
+par rf sfs0 = SF {sfTF = tf0}
+    where
+	tf0 a0 =
+	    let bsfs0 = rf a0 sfs0
+		sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
+		sfs   = fmap fst sfcs0
+		cs0   = fmap snd sfcs0
+	    in
+		(parAux rf sfs, cs0)
+
+
+-- Internal definition. Also used in parallel swithers.
+parAux :: Functor col =>
+    (forall sf . (a -> col sf -> col (b, sf)))
+    -> col (SF' b c)
+    -> SF' a (col c)
+parAux rf sfs = SFTIVar {sfTF' = tf}
+    where
+	tf dt a = 
+	    let bsfs  = rf a sfs
+		sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
+		sfs'  = fmap fst sfcs'
+		cs    = fmap snd sfcs'
+	    in
+	        (parAux rf sfs', cs)
+
+
+-- Parallel switch parameterized on the routing function. This is the most
+-- general switch from which all other (non-delayed) switches in principle
+-- can be derived. The signal function collection is spatially composed in
+-- parallel and run until the event signal function has an occurrence. Once
+-- the switching event occurs, all signal function are "frozen" and their
+-- continuations are passed to the continuation function, along with the
+-- event value.
+-- rf .........	Routing function: determines the input to each signal function
+--		in the collection. IMPORTANT! The routing function has an
+--		obligation to preserve the structure of the signal function
+--		collection.
+-- sfs0 .......	Signal function collection.
+-- sfe0 .......	Signal function generating the switching event.
+-- k .......... Continuation to be invoked once event occurs.
+-- Returns the resulting signal function.
+
+pSwitch :: Functor col =>
+    (forall sf . (a -> col sf -> col (b, sf)))
+    -> col (SF b c)
+    -> SF (a, col c) (Event d)
+    -> (col (SF b c) -> d -> SF a (col c))
+    -> SF a (col c)
+pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}
+    where
+	tf0 a0 =
+	    let bsfs0 = rf a0 sfs0
+		sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
+		sfs   = fmap fst sfcs0
+		cs0   = fmap snd sfcs0
+	    in
+		case (sfTF sfe0) (a0, cs0) of
+		    (sfe, NoEvent)  -> (pSwitchAux sfs sfe, cs0)
+		    (_,   Event d0) -> sfTF (k sfs0 d0) a0
+
+	pSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs
+	pSwitchAux sfs sfe = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a =
+		    let bsfs  = rf a sfs
+			sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
+			sfs'  = fmap fst sfcs'
+			cs    = fmap snd sfcs'
+		    in
+			case (sfTF' sfe) dt (a, cs) of
+			    (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs)
+			    (_,    Event d) -> sfTF (k (freezeCol sfs dt) d) a
+
+
+-- Parallel switch with delayed observation parameterized on the routing
+-- function.
+dpSwitch :: Functor col =>
+    (forall sf . (a -> col sf -> col (b, sf)))
+    -> col (SF b c)
+    -> SF (a, col c) (Event d)
+    -> (col (SF b c) -> d -> SF a (col c))
+    -> SF a (col c)
+dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0}
+    where
+	tf0 a0 =
+	    let bsfs0 = rf a0 sfs0
+		sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0
+		cs0   = fmap snd sfcs0
+	    in
+		(case (sfTF sfe0) (a0, cs0) of
+		     (sfe, NoEvent)  -> dpSwitchAux (fmap fst sfcs0) sfe
+		     (_,   Event d0) -> fst (sfTF (k sfs0 d0) a0),
+	         cs0)
+
+	dpSwitchAux sfs (SFConst {sfCVal = NoEvent}) = parAux rf sfs
+	dpSwitchAux sfs sfe = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a =
+		    let bsfs  = rf a sfs
+			sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs
+			cs    = fmap snd sfcs'
+		    in
+			(case (sfTF' sfe) dt (a, cs) of
+			     (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs')
+							    sfe'
+			     (_,    Event d) -> fst (sfTF (k (freezeCol sfs dt)
+							     d)
+							  a),
+                         cs)
+
+
+-- Recurring parallel switch parameterized on the routing function.
+-- rf .........	Routing function: determines the input to each signal function
+--		in the collection. IMPORTANT! The routing function has an
+--		obligation to preserve the structure of the signal function
+--		collection.
+-- sfs ........	Initial signal function collection.
+-- Returns the resulting signal function.
+
+rpSwitch :: Functor col =>
+    (forall sf . (a -> col sf -> col (b, sf)))
+    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)
+rpSwitch rf sfs =
+    pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->
+    noEventSnd >=- rpSwitch rf (f sfs')
+
+
+{-
+rpSwitch rf sfs = pSwitch (rf . fst) sfs (arr (snd . fst)) k
+    where
+	k sfs f = rpSwitch' (f sfs)
+	rpSwitch' sfs = pSwitch (rf . fst) sfs (NoEvent --> arr (snd . fst)) k
+-}
+
+-- Recurring parallel switch with delayed observation parameterized on the
+-- routing function.
+drpSwitch :: Functor col =>
+    (forall sf . (a -> col sf -> col (b, sf)))
+    -> col (SF b c) -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c)
+drpSwitch rf sfs =
+    dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f ->
+    noEventSnd >=- drpSwitch rf (f sfs')
+
+{-
+drpSwitch rf sfs = dpSwitch (rf . fst) sfs (arr (snd . fst)) k
+    where
+	k sfs f = drpSwitch' (f sfs)
+	drpSwitch' sfs = dpSwitch (rf . fst) sfs (NoEvent-->arr (snd . fst)) k
+-}
+
+------------------------------------------------------------------------------
+-- Wave-form generation
+------------------------------------------------------------------------------
+
+-- Zero-order hold.
+hold :: a -> SF (Event a) a
+hold a_init = switch (constant a_init &&& identity) ((NoEvent >--) . hold)
+
+
+-- Tracks input signal when available, holds last value when disappears.
+trackAndHold :: a -> SF (Maybe a) a
+trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init
+
+
+------------------------------------------------------------------------------
+-- Accumulators
+------------------------------------------------------------------------------
+
+accum :: a -> SF (Event (a -> a)) (Event a)
+accum = accumBy (flip ($))
+
+accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)
+accumBy f b_init = switch (never &&& identity) $ \a -> abAux (f b_init a)
+    where
+        abAux b = switch (now b &&& notYet) $ \a -> abAux (f b a)
+
+
+{-
+-- Identity: accumBy f = accumFilter (\b a -> let b' = f b a in (b',Just b'))
+accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b)
+accumBy f b_init = SF {sfTF = tf0}
+    where
+        tf0 NoEvent    = (abAux b_init, NoEvent) 
+        tf0 (Event a0) = let b' = f b_init a0
+		         in (abAux b', Event b')
+
+        abAux b = SFTIVar {sfTF' = tf}
+	    where
+		tf _ NoEvent   = (abAux b, NoEvent)
+		tf _ (Event a) = let b' = f b a
+			         in (abAux b', Event b')
+-}
+
+{-
+accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)
+accumFilter f c_init = SF {sfTF = tf0}
+    where
+        tf0 NoEvent    = (afAux c_init, NoEvent) 
+        tf0 (Event a0) = case f c_init a0 of
+		             (c', Nothing) -> (afAux c', NoEvent)
+			     (c', Just b0) -> (afAux c', Event b0)
+
+        afAux c = SFTIVar {sfTF' = tf}
+	    where
+		tf _ NoEvent   = (afAux c, NoEvent)
+		tf _ (Event a) = case f c a of
+			             (c', Nothing) -> (afAux c', NoEvent)
+				     (c', Just b)  -> (afAux c', Event b)
+-}
+
+
+accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)
+accumFilter f c_init = switch (never &&& identity) $ \a -> afAux (f c_init a)
+    where
+        afAux (c, Nothing) = switch (never &&& notYet) $ \a -> afAux (f c a)
+        afAux (c, Just b)  = switch (now b &&& notYet) $ \a -> afAux (f c a)
+
+
+------------------------------------------------------------------------------
+-- Delays
+------------------------------------------------------------------------------
+
+-- Uninitialized delay operator.
+-- !!! The seq helps in the dynamic delay line example. But is it a good
+-- !!! idea in general? Are there other accumulators which should be seq'ed
+-- !!! as well? E.g. accum? Switch? Anywhere else? What's the underlying
+-- !!! design principle? What can the user assume?
+pre = SF {sfTF = tf0}
+    where
+        tf0 a0 = (preAux a0, usrErr "AFRP" "pre" "Uninitialized pre operator.")
+
+	preAux a_prev = SFTIVar {sfTF' = tf}
+	    where
+		tf dt a = {- a_prev `seq` -} (preAux a, a_prev)
+
+
+-- Initialized delay operator.
+iPre :: a -> SF a a
+iPre = (--> pre)
+
+
+------------------------------------------------------------------------------
+-- Integraltion and differentiation
+------------------------------------------------------------------------------
+
+-- Integration using the rectangle rule.
+integral :: VectorSpace a s => SF a a
+integral = SF {sfTF = tf0}
+    where
+        igrl0  = zeroVector
+
+	tf0 a0 = (integralAux igrl0 a0, igrl0)
+
+	integralAux !igrl !a_prev = SFTIVar {sfTF' = tf}
+	    where
+	        tf dt a = (integralAux igrl' a, igrl')
+		    where
+		       igrl' = igrl ^+^ realToFrac dt *^ a_prev
+
+
+
+-- "immediate" integration (using the function's value at the current time)
+imIntegral :: VectorSpace a s => a -> SF a a
+imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`)
+
+iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b
+f `iterFrom` b = SF (iterAux b) where
+  iterAux b a = (SFTIVar (\ dt a' -> iterAux (f a a' dt b) a'), b)
+
+{-
+integral :: Fractional a => SF a a
+integral = SF {sfTF = tf0}
+    where
+        igrl0  = 0.0
+
+	tf0 a0 = (integralAux igrl0 a0, igrl0)
+
+	integralAux igrl a_prev = SFTIVar {sfTF' = tf}
+	    where
+	        tf dt a = (integralAux igrl' a, igrl')
+		    where
+		       igrl' = igrl + a_prev * realToFrac dt
+-}
+
+-- This is extremely crude. Use at your own risk.
+derivative :: VectorSpace a s => SF a a
+derivative = SF {sfTF = tf0}
+    where
+	tf0 a0 = (derivativeAux a0, zeroVector)
+
+	derivativeAux a_prev = SFTIVar {sfTF' = tf}
+	    where
+	        tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt)
+
+
+------------------------------------------------------------------------------
+-- Loops with guaranteed well-defined feedback
+------------------------------------------------------------------------------
+
+loopPre :: c -> SF (a,c) (b,c) -> SF a b
+loopPre c_init sf = loop (second (iPre c_init) >>> sf)
+
+
+
+loopIntegral :: VectorSpace c s => SF (a,c) (b,c) -> SF a b
+loopIntegral sf = loop (second integral >>> sf)
+
+
+------------------------------------------------------------------------------
+-- Noise (i.e. random signal generators) and stochastic processes
+------------------------------------------------------------------------------
+
+-- Noise (random signal) with default range for type in question;
+-- based on "randoms".
+noise :: (RandomGen g, Random b) => g -> SF a b
+noise g0 = streamToSF (randoms g0)
+
+
+-- Noise (random signal) with specified range; based on "randomRs".
+noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b
+noiseR range g0 = streamToSF (randomRs range g0)
+
+
+-- Internal. Not very useful for other purposes since we do not have any
+-- control over the intervals between each "sample". Or? A version with
+-- time-stamped samples would be similar to embedSynch (applied to identity).
+-- The list argument must be a stream (infinite list) at present.
+
+streamToSF :: [b] -> SF a b
+streamToSF []     = intErr "AFRP" "streamToSF" "Empty list!"
+streamToSF (b:bs) = SF {sfTF = tf0}
+    where
+        tf0 _ = (stsfAux bs, b)
+
+        stsfAux []     = intErr "AFRP" "streamToSF" "Empty list!"
+        stsfAux (b:bs) = SFTIVar {sfTF' = tf}
+	    where
+		tf _ _ = (stsfAux bs, b)
+
+
+-- Stochastic event source with events occurring on average once every t_avg
+-- seconds. However, no more than one event results from any one sampling
+-- interval in the case of relatively sparse sampling, thus avoiding an
+-- "event backlog" should sampling become more frequent at some later
+-- point in time.
+-- !!! Maybe it would better to give a frequency? But like this to make
+-- !!! consitent with "repeatedly".
+occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b)
+occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0}
+                       | otherwise = usrErr "AFRP" "occasionally"
+				            "Non-positive average interval."
+    where
+	-- Generally, if events occur with an average frequency of f, the
+	-- probability of at least one event occurring in an interval of t
+        -- is given by (1 - exp (-f*t)). The goal in the following is to
+	-- decide whether at least one event occurred in the interval of size
+	-- dt preceding the current sample point. For the first point,
+	-- we can think of the preceding interval as being 0, implying
+	-- no probability of an event occurring.
+
+	tf0 _ = (occAux ((randoms g) :: [Double]), NoEvent)
+
+	occAux (r:rs) = SFTIVar {sfTF' = tf}
+	    where
+		tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at
+			  in				-- least one event.
+			      (occAux rs, if r < p then Event x else NoEvent)
+
+
+------------------------------------------------------------------------------
+-- Reactimation
+------------------------------------------------------------------------------
+
+-- Reactimation of a signal function.
+-- init .......	IO action for initialization. Will only be invoked once,
+--		at (logical) time 0, before first call to "sense".
+--		Expected to return the value of input at time 0.
+-- sense ......	IO action for sensing of system input.
+--	arg. #1 .......	True: action may block, waiting for an OS event.
+--			False: action must not block.
+--	res. #1 .......	Time interval since previous invocation of the sensing
+--			action (or, the first time round, the init action),
+--			returned. The interval must be _strictly_ greater
+--			than 0. Thus even a non-blocking invocation must
+--			ensure that time progresses.
+--	res. #2 .......	Nothing: input is unchanged w.r.t. the previously
+--			returned input sample.
+--			Just i: the input is currently i.
+--			It is OK to always return "Just", even if input is
+--			unchanged.
+-- actuate ....	IO action for outputting the system output.
+--	arg. #1 .......	True: output may have changed from previous output
+--			sample.
+--			False: output is definitely unchanged from previous
+--			output sample.
+--			It is OK to ignore argument #1 and assume that the
+--			the output has always changed.
+--	arg. #2 .......	Current output sample.
+--	result .......	Termination flag. Once True, reactimate will exit
+--			the reactimation loop and return to its caller.
+-- sf .........	Signal function to reactimate.
+
+reactimate :: IO a
+	      -> (Bool -> IO (DTime, Maybe a))
+	      -> (Bool -> b -> IO Bool)
+              -> SF a b
+	      -> IO ()
+reactimate init sense actuate (SF {sfTF = tf0}) =
+    do
+        a0 <- init
+        let (sf, b0) = tf0 a0
+        loop sf a0 b0
+    where
+        loop sf a b = do
+	    done <- actuate True b
+            unless (a `seq` b `seq` done) $ do
+	        (dt, ma') <- sense False
+		let a' = maybe a id ma'
+                    (sf', b') = (sfTF' sf) dt a'
+		loop sf' a' b'
+
+-- An API for animating a signal function when some other library
+-- needs to own the top-level control flow:
+
+-- reactimate's state, maintained across samples:
+data ReactState a b = ReactState {
+    rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool,
+    rsSF :: SF' a b,
+    rsA :: a,
+    rsB :: b
+  }	      
+
+type ReactHandle a b = IORef (ReactState a b)
+
+-- initialize top-level reaction handle
+reactInit :: IO a -- init
+             -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate
+             -> SF a b
+             -> IO (ReactHandle a b)
+reactInit init actuate (SF {sfTF = tf0}) = 
+  do a0 <- init
+     let (sf,b0) = tf0 a0
+     -- TODO: really need to fix this interface, since right now we
+     -- just ignore termination at time 0:
+     r <- newIORef (ReactState {rsActuate = actuate, rsSF = sf,
+				rsA = a0, rsB = b0 })
+     done <- actuate r True b0
+     return r
+
+-- process a single input sample:
+react :: ReactHandle a b
+      -> (DTime,Maybe a)
+      -> IO Bool
+react rh (dt,ma') = 
+  do rs@(ReactState {rsActuate = actuate,
+	             rsSF = sf,
+		     rsA = a,
+		     rsB = b }) <- readIORef rh
+     let a' = maybe a id ma'
+         (sf',b') = (sfTF' sf) dt a'
+     writeIORef rh (rs {rsSF = sf',rsA = a',rsB = b'})
+     done <- actuate rh True b'
+     return done     
+
+
+------------------------------------------------------------------------------
+-- Embedding
+------------------------------------------------------------------------------
+
+-- New embed interface. We will probably have to revisit this. To run an
+-- embedded signal function while retaining full control (e.g. start and
+-- stop at will), one would probably need a continuation based interface
+-- (as well as a continuation based underlying implementation).
+--
+-- E.g. here are interesting alternative (or maybe complementary)
+-- signatures:
+--
+--    sample :: SF a b -> SF (Event a) (Event b)
+--    sample' :: SF a b -> SF (Event (DTime, a)) (Event b)
+
+embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b]
+embed sf0 (a0, dtas) = b0 : loop a0 sf dtas
+    where
+	(sf, b0) = (sfTF sf0) a0
+
+        loop a_prev sf [] = []
+	loop a_prev sf ((dt, ma) : dtas) =
+	    b : (a `seq` b `seq` (loop a sf' dtas))
+	    where
+		a        = maybe a_prev id ma
+	        (sf', b) = (sfTF' sf) dt a
+
+
+-- Synchronous embedding. The embedded signal function is run on the supplied
+-- input and time stream at a given (but variable) ratio >= 0 to the outer
+-- time flow. When the ratio is 0, the embedded signal function is paused.
+
+-- !!! Should "dropped frames" be forced to avoid space leaks?
+-- !!! It's kind of hard to se why, but "frame dropping" was a problem
+-- !!! in the old robot simulator. Try to find an example!
+
+embedSynch :: SF a b -> (a, [(DTime, Maybe a)]) -> SF Double b
+embedSynch sf0 (a0, dtas) = SF {sfTF = tf0}
+    where
+        tts       = scanl (\t (dt, _) -> t + dt) 0 dtas
+	bbs@(b:_) = embed sf0 (a0, dtas)
+
+	tf0 r = (esAux 0 (zip tts bbs), b)
+
+	esAux _       []    = intErr "AFRP" "embedSynch" "Empty list!"
+	esAux tp_prev tbtbs = SFTIVar {sfTF' = tf}
+	    where
+		tf dt r | r < 0     = usrErr "AFRP" "embedSynch"
+					     "Negative ratio."
+			| otherwise = let tp = tp_prev + dt * r
+					  (b, tbtbs') = advance tp tbtbs
+				      in
+					  (esAux tp tbtbs', b)
+
+		-- Advance the time stamped stream to the perceived time tp.
+		-- Under the assumption that the perceived time never goes
+		-- backwards (non-negative ratio), advance maintains the
+		-- invariant that the perceived time is always >= the first
+		-- time stamp.
+		advance tp tbtbs@[(t, b)] = (b, tbtbs)
+		advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _))
+		    | tp <  t' = (b, tbtbtbs)
+		    | t' <= tp = advance tp tbtbs
+
+
+deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)])
+deltaEncode _  []        = usrErr "AFRP" "deltaEncode" "Empty input list."
+deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas
+
+
+deltaEncodeBy :: (a -> a -> Bool) -> DTime -> [a] -> (a, [(DTime, Maybe a)])
+deltaEncodeBy _  _  []      = usrErr "AFRP" "deltaEncodeBy" "Empty input list."
+deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as))
+    where
+	debAux a_prev []                     = []
+	debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as
+                             | otherwise     = Just a  : debAux a as 
+
+-- | Evaluate the signal function.
+evalSF :: SF a b               -- ^ Signal function to evaluate
+          -> (a, [(DTime,a)])  -- ^ Initial value and sample times, with inputs
+          -> [(DTime,b)]
+evalSF sf0 (a0, tas) = (0, b0) : evalSF' sf' tas
+    where (sf', b0) = sfTF sf0 a0
+          evalSF' sf [] = []
+          evalSF' sf ((dt,a):tas) = (dt,b) : evalSF' sf' tas
+              where (sf', b) = sfTF' sf dt a
+
+-- | Delay the input by the number of samples in the given list. The first samples
+-- will be from the list, while the next samples will be from the input. Warning: this
+-- operation only makes sense in the case when the sampling interval is constant, in which
+-- case it implements a delay of @length xs * dt@ time units, where @dt@ is the sampling 
+-- interval and @xs@ is the input list.
+initDelay :: [a] -> SF a a 
+initDelay [] = identity
+initDelay (a:as) = SF sf0
+    where sf0 a'       = (sfAux (as ++ [a']), a)
+          sfAux (a:as) = SFTIVar (\_ a' -> (sfAux (as ++ [a']), a))
+
diff --git a/src/Nettle/FRPControl/AFRPAffineSpace.hs b/src/Nettle/FRPControl/AFRPAffineSpace.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPAffineSpace.hs
@@ -0,0 +1,41 @@
+{- \$Id: AFRPAffineSpace.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:		AFRPAffineSpace					     *
+*       Purpose:	Affine space type relation.			     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
+module Nettle.FRPControl.AFRPAffineSpace where
+
+import Nettle.FRPControl.AFRPVectorSpace
+
+------------------------------------------------------------------------------
+-- Affine Space type relation
+------------------------------------------------------------------------------
+
+infix 6 .+^, .-^, .-.
+
+-- Maybe origin should not be a class method, even though an origin
+-- can be assocoated with any affine space.
+-- Maybe distance should not be a class method, in which case the constraint
+-- on the coefficient space (a) could be Fractional (i.e., a Field), which
+-- seems closer to the mathematical definition of affine space, provided
+-- the constraint on the coefficient space for VectorSpace is also Fractional.
+
+-- Minimal instance: origin, .+^, .^.
+class (Floating a, VectorSpace v a) => AffineSpace p v a | p -> v, v -> a where
+    origin   :: p
+    (.+^)    :: p -> v -> p
+    (.-^)    :: p -> v -> p
+    (.-.)    :: p -> p -> v
+    distance :: p -> p -> a
+
+    p .-^ v = p .+^ (negateVector v)
+
+    distance p1 p2 = norm (p1 .-. p2)
diff --git a/src/Nettle/FRPControl/AFRPDiagnostics.hs b/src/Nettle/FRPControl/AFRPDiagnostics.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPDiagnostics.hs
@@ -0,0 +1,19 @@
+{- \$Id: AFRPDiagnostics.hs,v 1.3 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:         AFRPDiagnostics                                      *
+*       Purpose:        Standardized error-reporting for AFRP                *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+module Nettle.FRPControl.AFRPDiagnostics where
+
+usrErr mn fn msg = error (mn ++ "." ++ fn ++ ": " ++ msg)
+
+intErr mn fn msg = error ("[internal error] " ++ mn ++ "." ++ fn ++ ": "
+                          ++ msg)
diff --git a/src/Nettle/FRPControl/AFRPEvent.hs b/src/Nettle/FRPControl/AFRPEvent.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPEvent.hs
@@ -0,0 +1,317 @@
+{-# LANGUAGE 
+  MultiParamTypeClasses, 
+  FlexibleInstances
+ #-}
+
+
+{- \$Id: AFRPEvent.hs,v 1.17 2003/12/19 15:31:50 henrik Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:         AFRPEvent                                            *
+*       Purpose:        Definition of AFRP Event type.			     *
+*	Authors:	Antony Courtney and Henrik Nilsson		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+-- Note on naming conventions used in this module.
+--
+-- Names here might have to be rethought. It's really a bit messy.
+-- In general, the aim has been short and convenient names (like "tag",
+-- "attach", "lMerge") and thus we have tried to stay away from suffixing/
+-- prefixing conventions. E.g. "Event" as a common suffix would be very
+-- verbose.
+--
+-- However, part of the names come from a desire to stay close to similar
+-- functions for the Maybe type. e.g. "event", "fromEvent", "isEvent".
+-- In many cases, this use of "Event" can could understood to refer to the
+-- \*constructor* "Event", not to the type name "Event". Thus this use of
+-- event should not be seen as a suffixing-with-type-name convention. But
+-- that is obviously not easy to see, and, more over, interpreting "Event"
+-- as the name of the type might make equally good or better sense. E.g.
+-- "fromEvent" can also be seen as a function taking an event signal,
+-- which is a *partial* function on time, to a normal signal. The latter is
+-- then undefined when the source event function is undefined.
+--
+-- In other cases, it has been necessary to somehow stay out of the way of
+-- names used by the prelude or other commonly imported modules/modules
+-- which could be expected to be used heavily in AFRP code. In those cases
+-- a suffix "E" have been added. Examples are "filterE" (exists in Prelude)
+-- and "joinE" (exists in Monad). Maybe the suffix isn't necessary in the
+-- last case.
+--
+-- Some functions (actually only one currently, mapFilterE") have got an "E"
+-- suffix just because they're closely related (by name or semantics) to one
+-- which already has an "E" suffix. Another candidate would be "splitE" to
+-- complement "joinE". But events carrying pairs could obviously have other
+-- sources than a "joinE", so currently it is called "split".
+--
+-- 2003-05-19: Actually, have now changed to "splitE" to avoid a clash
+-- with the method "split" in the class RandomGen.
+--
+-- 2003-05-19: What about "gate"? Stands out compared to e.g. "filterE".
+--
+-- Currently the "E" suffix is considered an exception. Maybe we should use
+-- completely different names to avoid the "E" suffix. If the functions
+-- are not used that often, "Event" might be approriate. Alternatively the
+-- suffix "E" should be adopted globaly (except if the name already contains
+-- "event" in some form?).
+--
+-- Arguably, having both a type "Event" and a constructor "Event" is confusing
+-- since there are more than one constructor. But the name "Event" for the
+-- constructor is quite apt. It's really the type name that is wrong. But
+-- no one has found a better name, and changing it would be a really major
+-- undertaking. Yes, the constructor "Event" is not exported, but we still
+-- need to talk conceptually about them. On the other hand, if we consider
+-- Event-signals as partial functions on time, maybe it isn't so confusing:
+-- they just don't have a value between events, so "NoEvent" does not really
+-- exist conceptually.
+--
+-- ToDo:
+-- - Either: reveal NoEvent and Event
+--   or:     introcuce "event = Event", call what's now "event" "fromEvent",
+--           and call what's now called "fromEvent" something else, like
+--           "unsafeFromEvent"??? Better, dump it! After all, using current
+--	     names, "fromEvent = event undefined"!
+
+module Nettle.FRPControl.AFRPEvent where
+
+import Nettle.FRPControl.AFRPDiagnostics
+import Nettle.FRPControl.AFRPForceable
+import Data.Monoid
+
+infixl 8 `tag`, `attach`, `gate`
+infixl 7 `joinE`
+infixl 6 `lMerge`, `rMerge`, `merge`
+
+{-
+class Eventful t e where
+    null :: t
+    prjE :: t -> Maybe e
+    injE :: e -> t
+
+{- Any type of this class must satisfy: 
+prjE null   = Nothing
+prjE . injE = Just
+-}
+
+instance Eventful (Event a) a where
+    null = NoEvent
+    prjE = eventToMaybe
+    injE = Event
+-}
+------------------------------------------------------------------------------
+-- The Event type
+------------------------------------------------------------------------------
+
+-- The type Event represents a single possible event occurrence.
+-- It is isomorphic to Maybe, but its constructors are not exposed outside
+-- the AFRP implementation.
+-- There could possibly be further constructors, but note that the NeverEvent-
+-- idea does not work, at least not in the current AFRP implementation.
+-- Also note that it unfortunately is possible to partially break the
+-- abstractions through judicious use of e.g. snap and switching.
+
+data Event a = NoEvent
+	     | Event a
+               deriving (Read,Show)
+
+
+-- Make the NoEvent constructor available. Useful e.g. for initialization,
+-- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []).
+noEvent :: Event a
+noEvent = NoEvent
+
+
+-- Suppress any event in the first component of a pair.
+noEventFst :: (Event a, b) -> (Event c, b)
+noEventFst (_, b) = (NoEvent, b)
+
+
+-- Suppress any event in the second component of a pair.
+noEventSnd :: (a, Event b) -> (a, Event c)
+noEventSnd (a, _) = (a, NoEvent)
+
+
+------------------------------------------------------------------------------
+-- Eq instance
+------------------------------------------------------------------------------
+
+-- Right now, we could derive this instance. But that could possibly change.
+
+instance Eq a => Eq (Event a) where
+    NoEvent   == NoEvent   = True
+    (Event x) == (Event y) = x == y
+    _         == _         = False
+
+
+------------------------------------------------------------------------------
+-- Ord instance
+------------------------------------------------------------------------------
+
+instance Ord a => Ord (Event a) where
+    compare NoEvent   NoEvent   = EQ
+    compare NoEvent   (Event _) = LT
+    compare (Event _) NoEvent   = GT
+    compare (Event x) (Event y) = compare x y
+
+
+------------------------------------------------------------------------------
+-- Functor instance
+------------------------------------------------------------------------------
+
+instance Functor Event where
+    fmap f NoEvent   = NoEvent
+    fmap f (Event a) = Event (f a)
+
+liftE :: (a -> b) -> Event a -> Event b
+liftE f = fmap f
+
+------------------------------------------------------------------------------
+-- Forceable instance
+------------------------------------------------------------------------------
+
+instance Forceable a => Forceable (Event a) where
+    force ea@NoEvent   = ea
+    force ea@(Event a) = force a `seq` ea
+
+
+------------------------------------------------------------------------------
+-- Internal utilities for event construction
+------------------------------------------------------------------------------
+
+-- These utilities are to be considered strictly internal to AFRP for the
+-- time being.
+
+maybeToEvent :: Maybe a -> Event a
+maybeToEvent Nothing  = NoEvent
+maybeToEvent (Just a) = Event a
+
+eventToMaybe :: Event a -> Maybe a
+eventToMaybe NoEvent = Nothing
+eventToMaybe (Event a) = Just a
+------------------------------------------------------------------------------
+-- Utility functions similar to those available for Maybe
+------------------------------------------------------------------------------
+
+-- An event-based version of the maybe function.
+event :: a -> (b -> a) -> Event b -> a
+event a _ NoEvent   = a
+event _ f (Event b) = f b
+
+-- | Useful function for projecting a monoidal value out of an Event value.
+fromEvent :: Monoid a => Event a -> a
+fromEvent e = event mempty id e
+
+isEvent :: Event a -> Bool
+isEvent NoEvent   = False
+isEvent (Event _) = True
+
+isNoEvent :: Event a -> Bool
+isNoEvent = not . isEvent
+
+
+------------------------------------------------------------------------------
+-- Event tagging
+------------------------------------------------------------------------------
+
+-- Tags an (occurring) event with a value ("replacing" the old value).
+tag :: Event a -> b -> Event b
+e `tag` b = fmap (const b) e
+
+
+-- Attaches an extra value to the value of an occurring event.
+attach :: Event a -> b -> Event (a, b)
+e `attach` b = fmap (\a -> (a, b)) e
+
+
+------------------------------------------------------------------------------
+-- Event merging (disjunction) and joining (conjunction)
+------------------------------------------------------------------------------
+
+-- Left-biased event merge.
+lMerge :: Event a -> Event a -> Event a
+le `lMerge` re = event re Event le
+
+
+-- Right-biased event merge.
+rMerge :: Event a -> Event a -> Event a
+le `rMerge` re = event le Event re
+
+
+-- Unbiased event merge: simultaneous occurrence is an error.
+merge :: Event a -> Event a -> Event a
+merge = mergeBy (usrErr "AFRP" "merge" "Simultaneous event occurrence.")
+
+
+-- Event merge paramterezied on the conflict resolution function.
+mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a
+mergeBy _       NoEvent      NoEvent      = NoEvent
+mergeBy _       le@(Event _) NoEvent      = le
+mergeBy _       NoEvent      re@(Event _) = re
+mergeBy resolve (Event l)    (Event r)    = Event (resolve l r)
+
+
+-- A generic event merge utility:
+mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c) 
+	    -> Event a -> Event b -> Event c
+mapMerge _  _  _   NoEvent   NoEvent = NoEvent
+mapMerge lf _  _   (Event l) NoEvent = Event (lf l)
+mapMerge _  rf _   NoEvent  (Event r) = Event (rf r)
+mapMerge _  _  lrf (Event l) (Event r) = Event (lrf l r)
+
+-- Merging of a list of events; foremost event has priority.
+mergeEvents :: [Event a] -> Event a
+mergeEvents = foldr lMerge NoEvent
+
+-- Merging of a list of events, parameterized on the 
+-- conflict resolution function.
+mergeEventsBy :: (a -> a -> a) -> [Event a] -> Event a
+mergeEventsBy f = foldr (mergeBy f) NoEvent
+
+
+-- Collects simultaneous event occurrences; no event if none.
+catEvents :: [Event a] -> Event [a]
+catEvents eas = case [ a | Event a <- eas ] of
+		    [] -> NoEvent
+		    as -> Event as
+
+
+-- Join (conjucntion) of two events.
+joinE :: Event a -> Event b -> Event (a,b)
+joinE NoEvent   _         = NoEvent
+joinE _         NoEvent   = NoEvent
+joinE (Event l) (Event r) = Event (l,r)
+
+
+-- Split event carrying pairs into two events.
+splitE :: Event (a,b) -> (Event a, Event b)
+splitE NoEvent       = (NoEvent, NoEvent)
+splitE (Event (a,b)) = (Event a, Event b)
+
+
+------------------------------------------------------------------------------
+-- Event filtering
+------------------------------------------------------------------------------
+
+-- Filter out events that don't satisfy some predicate.
+filterE :: (a -> Bool) -> Event a -> Event a
+filterE p e@(Event a) = if (p a) then e else NoEvent
+filterE _ NoEvent     = NoEvent
+
+
+-- Combined event mapping and filtering.
+mapFilterE :: (a -> Maybe b) -> Event a -> Event b
+mapFilterE _ NoEvent   = NoEvent
+mapFilterE f (Event a) = case f a of
+			    Nothing -> NoEvent
+			    Just b  -> Event b
+
+
+-- Enable/disable event occurences based on an external condition.
+gate :: Event a -> Bool -> Event a
+_ `gate` False = NoEvent
+e `gate` True  = e
diff --git a/src/Nettle/FRPControl/AFRPForceable.hs b/src/Nettle/FRPControl/AFRPForceable.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPForceable.hs
@@ -0,0 +1,76 @@
+{- \$Id: AFRPForceable.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:         AFRPForceable                                        *
+*       Purpose:        Hyperstrict evaluation.				     *
+*	Author:		Zhanyong Wan					     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+module Nettle.FRPControl.AFRPForceable where
+
+
+class Forceable a where
+    force :: a -> a
+
+
+instance Forceable Int where
+  force = id
+
+
+instance Forceable Integer where
+  force = id
+
+
+instance Forceable Double where
+  force = id
+
+
+instance Forceable Float where
+  force = id
+
+
+instance Forceable Bool where
+  force = id
+
+
+instance Forceable () where
+  force = id
+
+
+instance Forceable Char where
+  force = id
+
+
+instance (Forceable a, Forceable b) => Forceable (a, b) where
+  force p@(a, b) = force a `seq` force b `seq` p
+
+
+instance (Forceable a, Forceable b, Forceable c) => Forceable (a, b, c) where
+  force p@(a, b, c) = force a `seq` force b `seq` force c `seq` p
+
+
+instance (Forceable a, Forceable b, Forceable c, Forceable d) =>
+         Forceable (a, b, c, d) where
+  force p@(a, b, c, d) =
+      force a `seq` force b `seq` force c `seq` force d `seq` p
+
+
+instance (Forceable a, Forceable b, Forceable c, Forceable d, Forceable e) =>
+         Forceable (a, b, c, d, e) where
+  force p@(a, b, c, d, e) =
+      force a `seq` force b `seq` force c `seq` force d `seq` force e `seq` p
+
+
+instance (Forceable a) => Forceable [a] where
+  force nil@[] = nil
+  force xs@(x:xs') = force x `seq` force xs' `seq` xs
+
+
+instance (Forceable a) => Forceable (Maybe a) where
+  force mx@Nothing  = mx
+  force mx@(Just x) = force x `seq` mx
diff --git a/src/Nettle/FRPControl/AFRPGeometry.hs b/src/Nettle/FRPControl/AFRPGeometry.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPGeometry.hs
@@ -0,0 +1,30 @@
+{- \$Id: AFRPGeometry.hs,v 1.3 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:		AFRPGeometry					     *
+*       Purpose:	Basic geometrical abstractions.			     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+module Nettle.FRPControl.AFRPGeometry (
+    module Nettle.FRPControl.AFRPVectorSpace,
+    module Nettle.FRPControl.AFRPAffineSpace,
+    module Nettle.FRPControl.AFRPVector2,
+    module Nettle.FRPControl.AFRPVector3,
+    module Nettle.FRPControl.AFRPPoint2,
+    module Nettle.FRPControl.AFRPPoint3
+) where
+
+import Nettle.FRPControl.AFRPVectorSpace
+import Nettle.FRPControl.AFRPAffineSpace
+import Nettle.FRPControl.AFRPVector2
+import Nettle.FRPControl.AFRPVector3
+import Nettle.FRPControl.AFRPPoint2
+import Nettle.FRPControl.AFRPPoint3
+
+
diff --git a/src/Nettle/FRPControl/AFRPInternals.hs b/src/Nettle/FRPControl/AFRPInternals.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPInternals.hs
@@ -0,0 +1,38 @@
+{- \$Id: AFRPInternals.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:         AFRPInternals                                        *
+*       Purpose:        An interface giving access to some of the internal   *
+*			details of the AFRP implementation.		     *
+*	Authors:	Antony Courtney and Henrik Nilsson		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+-- This interface is indended to be used when the need arises to break
+-- abstraction barriers, e.g. for interfacing AFRP to the real world, for
+-- debugging purposes, or the like. Be aware that the internal details
+-- may change. Relying on this interface means that your code is not
+-- insulated against such changes.
+
+module Nettle.FRPControl.AFRPInternals (
+    Event(..)		-- The event type, its constructors, and instances.
+) where
+
+import Nettle.FRPControl.AFRPEvent
+
+
+------------------------------------------------------------------------------
+-- Extra Event instances
+------------------------------------------------------------------------------
+{-
+instance Show a => Show (Event a) where
+    showsPrec d NoEvent   = showString "NoEvent"
+    showsPrec d (Event a) = showParen (d >= 10)
+				      (showString "Event " . showsPrec 10 a)
+
+
+-}
diff --git a/src/Nettle/FRPControl/AFRPMergeableRecord.hs b/src/Nettle/FRPControl/AFRPMergeableRecord.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPMergeableRecord.hs
@@ -0,0 +1,81 @@
+{- \$Id: AFRPMergeableRecord.hs,v 1.4 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:         AFRPMergeableRecord                                  *
+*       Purpose:        Framework for record merging.			     *
+*	Authors:	Antony Courtney and Henrik Nilsson		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+-- Idea:
+-- MergeableRecord is intended to be a super class for classes providing
+-- update operations on records. The ADT induced by such a set of operations
+-- can be considered a "mergeable record", which can be merged into larger
+-- mergeable records essentially by function composition. Finalization turns
+-- a mergeable record into a record.
+--
+-- Typical use:
+-- Given
+--
+--   data Foo = Foo {l1 :: T1, l2 :: T2}
+--
+-- one define a mergeable record type (MR Foo) by the following instance:
+--
+--   instance MergeableRecord Foo where
+--       mrDefault = Foo {l1 = v1_dflt, l2 = v2_dflt}
+--
+-- Typically, one would also provide definitions for setting the fields,
+-- possibly (but not necessarily) overloaded:
+--
+--   instance HasL1 Foo where
+--       setL1 v = mrMake (\foo -> foo {l1 = v})
+--
+-- Now Foo records can be created as follows:
+--
+--   let foo1 = setL1 v1
+--   ...
+--   let foo2 = setL2 v2 ~+~ foo1
+--   ...
+--   let foo<N> = setL1 vN ~+~ foo<N-1>
+--   let fooFinal = mrFinalize foo<N>
+
+module Nettle.FRPControl.AFRPMergeableRecord (
+    MergeableRecord(..),
+    MR,			-- Abstract
+    mrMake,
+    (~+~),
+    mrMerge,
+    mrFinalize
+) where
+
+import Control.Category ((>>>))
+
+class MergeableRecord a where
+    mrDefault :: a
+
+
+-- Type constructor for mergeable records.
+newtype MergeableRecord a => MR a = MR (a -> a)
+
+
+-- Construction of a mergeable record.
+mrMake :: MergeableRecord a => (a -> a) -> MR a
+mrMake f = (MR f)
+
+infixl 9 ~+~
+
+-- Merge two mergeable records. Left "overrides" in case of conflict.
+(~+~) :: MergeableRecord a => MR a -> MR a -> MR a
+(MR f1) ~+~ (MR f2) = MR (f1 >>> f2)
+
+mrMerge :: MergeableRecord a => MR a -> MR a -> MR a
+mrMerge = (~+~)
+
+
+-- Finalization: turn a mergeable record into a record.
+mrFinalize :: MergeableRecord a => MR a -> a
+mrFinalize (MR f) = f mrDefault
diff --git a/src/Nettle/FRPControl/AFRPMiscellany.hs b/src/Nettle/FRPControl/AFRPMiscellany.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPMiscellany.hs
@@ -0,0 +1,121 @@
+{- \$Id: AFRPMiscellany.hs,v 1.4 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:         AFRPMiscellany					     *
+*       Purpose:        Collection of entities that really should be part    *
+*			of the Haskell 98 prelude or simply have no better   *
+*			home.						     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+module Nettle.FRPControl.AFRPMiscellany (
+-- Reverse function composition
+    ( # ),	-- :: (a -> b) -> (b -> c) -> (a -> c),	infixl 9
+
+-- Arrow plumbing aids
+    dup,	-- :: a -> (a,a)
+    swap,	-- :: (a,b) -> (b,a)
+
+-- Maps over lists of pairs
+    mapFst,	-- :: (a -> b) -> [(a,c)] -> [(b,c)]
+    mapSnd,	-- :: (a -> b) -> [(c,a)] -> [(c,b)]
+
+-- Generalized tuple selectors
+    sel3_1, sel3_2, sel3_3,
+    sel4_1, sel4_2, sel4_3, sel4_4,
+    sel5_1, sel5_2, sel5_3, sel5_4, sel5_5,
+
+-- Floating point utilities
+    fDiv,	-- :: (RealFrac a, Integral b) => a -> a -> b
+    fMod,	-- :: RealFrac a => a -> a -> a
+    fDivMod	-- :: (RealFrac a, Integral b) => a -> a -> (b, a)
+) where
+
+infixl 9 #
+infixl 7 `fDiv`, `fMod`
+
+
+------------------------------------------------------------------------------
+-- Reverse function composition
+------------------------------------------------------------------------------
+
+( # ) :: (a -> b) -> (b -> c) -> (a -> c)
+f # g = g . f
+
+
+------------------------------------------------------------------------------
+-- Arrow plumbing aids
+------------------------------------------------------------------------------
+
+dup :: a -> (a,a)
+dup x = (x,x)
+
+swap :: (a,b) -> (b,a)
+swap ~(x,y) = (y,x)
+
+
+------------------------------------------------------------------------------
+-- Maps over lists of pairs
+------------------------------------------------------------------------------
+
+mapFst :: (a -> b) -> [(a,c)] -> [(b,c)]
+mapFst f []             = []
+mapFst f ((x, y) : xys) = (f x, y) : mapFst f xys
+
+mapSnd :: (a -> b) -> [(c,a)] -> [(c,b)]
+mapSnd f []             = []
+mapSnd f ((x, y) : xys) = (x, f y) : mapSnd f xys
+
+
+------------------------------------------------------------------------------
+-- Generalized tuple selectors
+------------------------------------------------------------------------------
+
+-- Triples
+
+sel3_1 (x,_,_) = x
+sel3_2 (_,x,_) = x
+sel3_3 (_,_,x) = x
+
+
+-- 4-tuples
+
+sel4_1 (x,_,_,_) = x
+sel4_2 (_,x,_,_) = x
+sel4_3 (_,_,x,_) = x
+sel4_4 (_,_,_,x) = x
+
+
+-- 5-tuples
+
+sel5_1 (x,_,_,_,_) = x
+sel5_2 (_,x,_,_,_) = x
+sel5_3 (_,_,x,_,_) = x
+sel5_4 (_,_,_,x,_) = x
+sel5_5 (_,_,_,_,x) = x
+
+
+------------------------------------------------------------------------------
+-- Floating point utilities
+------------------------------------------------------------------------------
+
+-- Floating-point div and modulo operators.
+
+fDiv :: (RealFrac a, Integral b) => a -> a -> b
+fDiv x y = fst (fDivMod x y)
+
+
+fMod :: RealFrac a => a -> a -> a
+fMod x y = snd (fDivMod x y)
+
+
+fDivMod :: (RealFrac a, Integral b) => a -> a -> (b, a)
+fDivMod x y = (q, r)
+    where
+        q = (floor (x/y))
+        r = x - fromIntegral q * y
diff --git a/src/Nettle/FRPControl/AFRPPoint2.hs b/src/Nettle/FRPControl/AFRPPoint2.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPPoint2.hs
@@ -0,0 +1,60 @@
+{- \$Id: AFRPPoint2.hs,v 1.3 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:		AFRPPoint2					     *
+*       Purpose:	2D point abstraction (R^2).			     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+module Nettle.FRPControl.AFRPPoint2 (
+    module Nettle.FRPControl.AFRPVectorSpace,
+    module Nettle.FRPControl.AFRPAffineSpace,
+    module Nettle.FRPControl.AFRPVector2,
+    Point2(..),	-- Non-abstract, instance of AffineSpace
+    point2X,	-- :: RealFloat a => Point2 a -> a
+    point2Y	-- :: RealFloat a => Point2 a -> a
+) where
+
+import Nettle.FRPControl.AFRPVectorSpace
+import Nettle.FRPControl.AFRPAffineSpace
+import Nettle.FRPControl.AFRPVector2 hiding ((*^), (^/), dot, (^+^), (^-^), zeroVector, negateVector, norm, normalize, VectorSpace)
+import Nettle.FRPControl.AFRPForceable
+
+------------------------------------------------------------------------------
+-- 2D point, constructors and selectors.
+------------------------------------------------------------------------------
+
+data RealFloat a => Point2 a = Point2 !a !a deriving Eq
+
+point2X :: RealFloat a => Point2 a -> a
+point2X (Point2 x _) = x
+
+point2Y :: RealFloat a => Point2 a -> a
+point2Y (Point2 _ y) = y
+
+
+------------------------------------------------------------------------------
+-- Affine space instance
+------------------------------------------------------------------------------
+
+instance RealFloat a => AffineSpace (Point2 a) (Vector2 a) a where
+    origin = Point2 0 0
+
+    (Point2 x y) .+^ v = Point2 (x + vector2X v) (y + vector2Y v)
+
+    (Point2 x y) .-^ v = Point2 (x - vector2X v) (y - vector2Y v)
+
+    (Point2 x1 y1) .-. (Point2 x2 y2) = vector2 (x1 - x2) (y1 - y2)
+
+
+------------------------------------------------------------------------------
+-- Forceable instance
+------------------------------------------------------------------------------
+
+instance RealFloat a => Forceable (Point2 a) where
+     force = id
diff --git a/src/Nettle/FRPControl/AFRPPoint3.hs b/src/Nettle/FRPControl/AFRPPoint3.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPPoint3.hs
@@ -0,0 +1,67 @@
+{- \$Id: AFRPPoint3.hs,v 1.3 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:		AFRPPoint3					     *
+*       Purpose:	3D point abstraction (R^3).			     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+module Nettle.FRPControl.AFRPPoint3 (
+    module Nettle.FRPControl.AFRPVectorSpace,
+    module Nettle.FRPControl.AFRPAffineSpace,
+    module Nettle.FRPControl.AFRPVector3,
+    Point3(..),	-- Non-abstract, instance of AffineSpace
+    point3X,	-- :: RealFloat a => Point3 a -> a
+    point3Y,	-- :: RealFloat a => Point3 a -> a
+    point3Z	-- :: RealFloat a => Point3 a -> a
+) where
+
+import Nettle.FRPControl.AFRPVectorSpace
+import Nettle.FRPControl.AFRPAffineSpace
+import Nettle.FRPControl.AFRPVector3
+import Nettle.FRPControl.AFRPForceable
+
+------------------------------------------------------------------------------
+-- 3D point, constructors and selectors.
+------------------------------------------------------------------------------
+
+data RealFloat a => Point3 a = Point3 !a !a !a deriving Eq
+
+point3X :: RealFloat a => Point3 a -> a
+point3X (Point3 x _ _) = x
+
+point3Y :: RealFloat a => Point3 a -> a
+point3Y (Point3 _ y _) = y
+
+point3Z :: RealFloat a => Point3 a -> a
+point3Z (Point3 _ _ z) = z
+
+
+------------------------------------------------------------------------------
+-- Affine space instance
+------------------------------------------------------------------------------
+
+instance RealFloat a => AffineSpace (Point3 a) (Vector3 a) a where
+    origin = Point3 0 0 0
+
+    (Point3 x y z) .+^ v =
+	Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v)
+
+    (Point3 x y z) .-^ v =
+	Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v)
+
+    (Point3 x1 y1 z1) .-. (Point3 x2 y2 z2) =
+	vector3 (x1 - x2) (y1 - y2) (z1 - z2)
+
+
+------------------------------------------------------------------------------
+-- Forceable instance
+------------------------------------------------------------------------------
+
+instance RealFloat a => Forceable (Point3 a) where
+     force = id
diff --git a/src/Nettle/FRPControl/AFRPTask.hs b/src/Nettle/FRPControl/AFRPTask.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPTask.hs
@@ -0,0 +1,221 @@
+{- \$Id: AFRPTask.hs,v 1.6 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:         AFRPTask                                             *
+*       Purpose:        Task abstraction on top of signal transformers.      *
+*	Authors:	Antony Courtney and Henrik Nilsson		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+{-# LANGUAGE RankNTypes #-}
+
+module Nettle.FRPControl.AFRPTask (
+    Task,
+    mkTask,	-- :: SF a (b, Event c) -> Task a b c
+    runTask,	-- :: Task a b c -> SF a (Either b c)	-- Might change.
+    runTask_,	-- :: Task a b c -> SF a b
+    taskToSF,	-- :: Task a b c -> SF a (b, Event c)	-- Might change.
+    constT,	-- :: b -> Task a b c
+    sleepT, 	-- :: Time -> b -> Task a b ()
+    snapT, 	-- :: Task a b a
+    timeOut, 	-- :: Task a b c -> Time -> Task a b (Maybe c)
+    abortWhen, 	-- :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
+    repeatUntil,-- :: Monad m => m a -> (a -> Bool) -> m a
+    for, 	-- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()
+    forAll, 	-- :: Monad m => [a] -> (a -> m b) -> m ()
+    forEver 	-- :: Monad m => m a -> m b
+) where
+
+import Nettle.FRPControl.AFRP
+import Nettle.FRPControl.AFRPUtilities (snap)
+import Nettle.FRPControl.AFRPDiagnostics
+
+infixl 0 `timeOut`, `abortWhen`, `repeatUntil`
+
+
+------------------------------------------------------------------------------
+-- The Task type
+------------------------------------------------------------------------------
+
+-- CPS-based representation allowing a termination to be detected.
+-- (Note the rank 2 polymorphic type!)
+-- The representation can be changed if necessary, but the Monad laws
+-- follow trivially in this case.
+newtype Task a b c =
+    Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d))
+
+
+unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d))
+unTask (Task f) = f
+
+
+mkTask :: SF a (b, Event c) -> Task a b c
+mkTask st = Task (switch (st >>> first (arr Left)))
+
+
+-- "Runs" a task (unusually bad name?). The output from the resulting
+-- signal transformer is tagged with Left while the underlying task is
+-- running. Once the task has terminated, the output goes constant with
+-- the value Right x, where x is the value of the terminating event.
+runTask :: Task a b c -> SF a (Either b c)
+runTask tk = (unTask tk) (\c -> constant (Right c))
+
+
+-- Runs a task. The output becomes undefined once the underlying task has
+-- terminated. Convenient e.g. for tasks which are known not to terminate.
+runTask_ :: Task a b c -> SF a b
+runTask_ tk = runTask tk
+              >>> arr (either id (usrErr "AFRPTask" "runTask_"
+                                         "Task terminated!"))
+
+
+-- Seems as if the following is convenient after all. Suitable name???
+-- Maybe that implies a representation change for Tasks?
+-- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.)
+taskToSF :: Task a b c -> SF a (b, Event c)
+taskToSF tk = runTask tk
+	      >>> (arr (either id ((usrErr "AFRPTask" "runTask_"
+                                           "Task terminated!")))
+		   &&& edgeBy isEdge (Left undefined))
+    where
+        isEdge (Left _)  (Left _)  = Nothing
+	isEdge (Left _)  (Right c) = Just c
+	isEdge (Right _) (Right _) = Nothing
+	isEdge (Right _) (Left _)  = Nothing
+
+
+------------------------------------------------------------------------------
+-- Monad instance
+------------------------------------------------------------------------------
+
+instance Monad (Task a b) where
+    tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k))
+    return x = Task (\k -> k x)
+
+{-
+Let's check the monad laws:
+
+    t >>= return
+    = \k -> t (\c -> return c k)
+    = \k -> t (\c -> (\x -> \k -> k x) c k)
+    = \k -> t (\c -> (\x -> \k' -> k' x) c k)
+    = \k -> t (\c -> k c)
+    = \k -> t k
+    = t
+    QED
+
+    return x >>= f
+    = \k -> (return x) (\c -> f c k)
+    = \k -> (\k -> k x) (\c -> f c k)
+    = \k -> (\k' -> k' x) (\c -> f c k)
+    = \k -> (\c -> f c k) x
+    = \k -> f x k
+    = f x
+    QED
+
+    (t >>= f) >>= g
+    = \k -> (t >>= f) (\c -> g c k)
+    = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k)
+    = \k -> t (\c' -> f c' (\c -> g c k))
+    = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k)
+    = \k -> t (\c' -> (\x -> f x >>= g) c' k)
+    = t >>= (\x -> f x >>= g)
+    QED
+
+No surprises (obviously, since this is essentially just the CPS monad).
+-}
+
+
+------------------------------------------------------------------------------
+-- Basic tasks
+------------------------------------------------------------------------------
+
+-- Non-terminating task with constant output b.
+constT :: b -> Task a b c
+constT b = mkTask (constant b &&& never)
+
+
+-- "Sleeps" for t seconds with constant output b.
+sleepT :: Time -> b -> Task a b ()
+sleepT t b = mkTask (constant b &&& after t ())
+
+
+-- Takes a "snapshot" of the input and terminates immediately with the input
+-- value as the result. No time passes; law:
+--
+--    snapT >> snapT = snapT
+--
+snapT :: Task a b a
+snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap)
+
+
+------------------------------------------------------------------------------
+-- Basic tasks combinators
+------------------------------------------------------------------------------
+
+-- Impose a time out on a task.
+timeOut :: Task a b c -> Time -> Task a b (Maybe c)
+tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)
+    where
+        aux ((b, ec), et) = (b, (lMerge (fmap Just ec)
+					(fmap (const Nothing) et)))
+
+
+-- Run a "guarding" event source (SF a (Event b)) in parallel with a
+-- (possibly non-terminating) task. The task will be aborted at the
+-- first occurrence of the event source (if it has not terminated itself
+-- before that). Useful for separating sequencing and termination concerns.
+-- E.g. we can do something "useful", but in parallel watch for a (exceptional)
+-- condition which should terminate that activity, whithout having to check
+-- for that condition explicitly during each and every phase of the activity.
+-- Example: tsk `abortWhen` lbp
+abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
+tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux)
+    where
+        aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed)))
+
+
+------------------------------------------------------------------------------
+-- Loops
+------------------------------------------------------------------------------
+
+-- These are general monadic combinators. Maybe they don't really belong here.
+
+-- Repeat m until result satisfies the predicate p
+repeatUntil :: Monad m => m a -> (a -> Bool) -> m a
+m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x
+
+
+-- C-style for-loop.
+-- Example: for 0 (+1) (>=10) ...
+for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()
+for i f p m = if p i then m >> for (f i) f p m else return ()
+
+
+-- Perform the monadic operation for each element in the list.
+forAll :: Monad m => [a] -> (a -> m b) -> m ()
+forAll = flip mapM_
+
+
+-- Repeat m for ever.
+forEver :: Monad m => m a -> m b
+forEver m = m >> forEver m
+
+
+-- Alternatives/other potentially useful signatures:
+-- until :: a -> (a -> M a) -> (a -> Bool) -> M a
+-- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b
+-- while??? It could be:
+-- while :: a -> (a -> Bool) -> (a -> M a) -> M a
+
+
+------------------------------------------------------------------------------
+-- Monad transformers?
+------------------------------------------------------------------------------
+
+-- What about monad transformers if we want to compose this monad with
+-- other capabilities???
diff --git a/src/Nettle/FRPControl/AFRPUtilities.hs b/src/Nettle/FRPControl/AFRPUtilities.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPUtilities.hs
@@ -0,0 +1,304 @@
+{- \$Id: AFRPUtilities.hs,v 1.8 2003/12/19 15:31:50 henrik Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:         AFRPUtilities                                        *
+*       Purpose:        Derived utility definitions.			     *
+*	Authors:	Antony Courtney and Henrik Nilsson		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+-- ToDo:
+-- \* Possibly add
+--       impulse :: VectorSpace a k => a -> Event a
+--   But to do that, we need access to Event, which we currently do not have.
+-- \* The general arrow utilities should be moved to a module
+--   AFRPArrowUtilities.
+-- \* I'm not sure structuring the AFRP "core" according to what is
+--   core functionality and what's not is all that useful. There are
+--   many cases where we want to implement combinators that fairly
+--   easily could be implemented in terms of others as primitives simply
+--   because we expect that that implementation is going to be much more
+--   efficient, and that the combinators are used sufficiently often to
+--   warrant doing this. E.g. "switch" should be a primitive, even though
+--   it could be derived from "pSwitch".
+-- \* Reconsider "recur". If an event source has an immediate occurrence,
+--   we'll get into a loop. For example: recur now. Maybe suppress
+--   initial occurrences? Initial occurrences are rather pointless in this
+--   case anyway.
+
+{-# LANGUAGE RankNTypes #-}
+module Nettle.FRPControl.AFRPUtilities (
+-- General arrow utilities
+    (^>>),		-- :: Arrow a => (b -> c) -> a c d -> a b d
+    (>>^),		-- :: Arrow a => a b c -> (c -> d) -> a b d
+    (^<<),		-- :: Arrow a => (c -> d) -> a b c -> a b d 
+    (<<^),		-- :: Arrow a => a c d -> (b -> c) -> a b d
+
+-- Liftings
+    arr2,		-- :: Arrow a => (b->c->d) -> a (b,c) d
+    arr3,		-- :: Arrow a => (b->c->d->e) -> a (b,c,d) e
+    arr4,		-- :: Arrow a => (b->c->d->e->f) -> a (b,c,d,e) f
+    arr5,		-- :: Arrow a => (b->c->d->e->f->g) -> a (b,c,d,e,f) g
+    lift0,		-- :: Arrow a => c -> a b c
+    lift1,		-- :: Arrow a => (c->d) -> (a b c->a b d)
+    lift2,		-- :: Arrow a => (c->d->e) -> (a b c->a b d->a b e)
+    lift3,		-- :: Arrow a => (c->d->e->f) -> (a b c-> ... ->a b f)
+    lift4,		-- :: Arrow a => (c->d->e->f->g) -> (a b c->...->a b g)
+    lift5,		-- :: Arrow a => (c->d->e->f->g->h)->(a b c->...a b h)
+
+-- Event sources
+    snap,		-- :: SF a (Event a)
+    snapAfter,		-- :: Time -> SF a (Event a)
+    sample,		-- :: Time -> SF a (Event a)
+    recur,		-- :: SF a (Event b) -> SF a (Event b)
+
+-- Parallel composition/switchers with "zip" routing
+    parZ,		-- [SF a b] -> SF [a] [b]
+    pSwitchZ,		-- [SF a b] -> SF ([a],[b]) (Event c)
+			-- -> ([SF a b] -> c -> SF [a] [b]) -> SF [a] [b]
+    dpSwitchZ,		-- [SF a b] -> SF ([a],[b]) (Event c)
+			-- -> ([SF a b] -> c ->SF [a] [b]) -> SF [a] [b]
+    rpSwitchZ,		-- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]
+    drpSwitchZ,		-- [SF a b] -> SF ([a], Event ([SF a b]->[SF a b])) [b]
+
+-- Guards and automata-oriented combinators
+    provided,		-- :: (a -> Bool) -> SF a b -> SF a b -> SF a b
+
+-- Wave-form generation
+    dHold,		-- :: a -> SF (Event a) a
+    dTrackAndHold,	-- :: a -> SF (Maybe a) a
+
+-- Accumulators
+    accumHold,		-- :: a -> SF (Event (a -> a)) a
+    dAccumHold,		-- :: a -> SF (Event (a -> a)) a
+    accumHoldBy,	-- :: (b -> a -> b) -> b -> SF (Event a) b
+    dAccumHoldBy,	-- :: (b -> a -> b) -> b -> SF (Event a) b
+    count,		-- :: Integral b => SF (Event a) (Event b)
+
+-- Delays
+    fby,		-- :: b -> SF a b -> SF a b,	infixr 0
+
+-- Integrals
+    impulseIntegral	-- :: VectorSpace a k => SF (a, Event a) a
+) where
+
+import Nettle.FRPControl.AFRPDiagnostics
+import Nettle.FRPControl.AFRP hiding ((>>^), (^>>), (^<<), (<<^))
+
+
+infixr 1 ^<<, ^>>
+infixl 1 <<^, >>^
+infixr 0 `fby`
+
+
+------------------------------------------------------------------------------
+-- General arrow utilities
+------------------------------------------------------------------------------
+
+(^>>) :: Arrow a => (b -> c) -> a c d -> a b d
+f ^>> a = arr f >>> a
+
+(>>^) :: Arrow a => a b c -> (c -> d) -> a b d
+a >>^ f = a >>> arr f
+
+
+(^<<) :: Arrow a => (c -> d) -> a b c -> a b d 
+f ^<< a = arr f <<< a
+
+
+(<<^) :: Arrow a => a c d -> (b -> c) -> a b d
+a <<^ f = a <<< arr f
+
+
+------------------------------------------------------------------------------
+-- Liftings
+------------------------------------------------------------------------------
+
+arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d
+arr2 = arr . uncurry
+
+
+arr3 :: Arrow a => (b -> c -> d -> e) -> a (b, c, d) e
+arr3 = arr . \h (b, c, d) -> h b c d
+
+
+arr4 :: Arrow a => (b -> c -> d -> e -> f) -> a (b, c, d, e) f
+arr4 = arr . \h (b, c, d, e) -> h b c d e
+
+
+arr5 :: Arrow a => (b -> c -> d -> e -> f -> g) -> a (b, c, d, e, f) g
+arr5 = arr . \h (b, c, d, e, f) -> h b c d e f
+
+
+lift0 :: Arrow a => c -> a b c
+lift0 c = arr (const c)
+
+
+lift1 :: Arrow a => (c -> d) -> (a b c -> a b d)
+lift1 f = \a -> a >>> arr f
+
+
+lift2 :: Arrow a => (c -> d -> e) -> (a b c -> a b d -> a b e)
+lift2 f = \a1 a2 -> a1 &&& a2 >>> arr2 f
+
+
+lift3 :: Arrow a => (c -> d -> e -> f) -> (a b c -> a b d -> a b e -> a b f)
+lift3 f = \a1 a2 a3 -> (lift2 f) a1 a2 &&& a3 >>> arr2 ($)
+
+
+lift4 :: Arrow a => (c->d->e->f->g) -> (a b c->a b d->a b e->a b f->a b g)
+lift4 f = \a1 a2 a3 a4 -> (lift3 f) a1 a2 a3 &&& a4 >>> arr2 ($)
+
+
+lift5 :: Arrow a =>
+    (c->d->e->f->g->h) -> (a b c->a b d->a b e->a b f->a b g->a b h)
+lift5 f = \a1 a2 a3 a4 a5 ->(lift4 f) a1 a2 a3 a4 &&& a5 >>> arr2 ($)
+
+
+------------------------------------------------------------------------------
+-- Event sources
+------------------------------------------------------------------------------
+
+-- Event source with a single occurrence at time 0. The value of the event
+-- is obtained by sampling the input at that time.
+snap :: SF a (Event a)
+snap = switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now
+
+
+-- Event source with a single occurrence at or as soon after (local) time t_ev
+-- as possible. The value of the event is obtained by sampling the input a
+-- that time.
+snapAfter :: Time -> SF a (Event a)
+snapAfter t_ev = switch (never
+			 &&& (identity
+			      &&& after t_ev () >>^ \(a, e) -> e `tag` a))
+			now
+
+
+-- Sample a signal at regular intervals.
+sample :: Time -> SF a (Event a)
+sample p_ev = identity &&& repeatedly p_ev () >>^ \(a, e) -> e `tag` a
+
+
+-- Makes an event source recurring by restarting it as soon as it has an
+-- occurrence.
+recur :: SF a (Event b) -> SF a (Event b)
+recur sfe = switch (never &&& sfe) recurAux
+    where
+	recurAux b = switch (now b &&& sfe) recurAux
+
+
+------------------------------------------------------------------------------
+-- Parallel composition/switchers with "zip" routing
+------------------------------------------------------------------------------
+
+safeZip :: String -> [a] -> [b] -> [(a,b)]
+safeZip fn as bs = safeZip' as bs
+    where
+	safeZip' as []     = []
+	safeZip' as (b:bs) = (head' as, b) : safeZip' (tail' as) bs
+
+	head' []    = err
+	head' (a:_) = a
+
+	tail' []     = err
+	tail' (_:as) = as
+
+	err = usrErr "AFRPUtilities" fn "Input list too short."
+
+
+parZ :: [SF a b] -> SF [a] [b]
+parZ = par (safeZip "parZ")
+
+
+pSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c -> SF [a] [b])
+            -> SF [a] [b]
+pSwitchZ = pSwitch (safeZip "pSwitchZ")
+
+
+dpSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c ->SF [a] [b])
+             -> SF [a] [b]
+dpSwitchZ = dpSwitch (safeZip "dpSwitchZ")
+
+
+rpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]
+rpSwitchZ = rpSwitch (safeZip "rpSwitchZ")
+
+
+drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b]
+drpSwitchZ = drpSwitch (safeZip "drpSwitchZ")
+
+
+------------------------------------------------------------------------------
+-- Guards and automata-oriented combinators
+------------------------------------------------------------------------------
+
+-- Runs sft only when the predicate p is satisfied, otherwise runs sff.
+provided :: (a -> Bool) -> SF a b -> SF a b -> SF a b
+provided p sft sff =
+    switch (constant undefined &&& snap) $ \a0 ->
+    if p a0 then stt else stf
+    where
+	stt = switch (sft &&& (not . p ^>> edge)) (const stf)
+        stf = switch (sff &&& (p ^>> edge)) (const stt)
+
+
+------------------------------------------------------------------------------
+-- Wave-form generation
+------------------------------------------------------------------------------
+
+-- Zero-order hold with delay.
+-- Identity: dHold a0 = hold a0 >>> iPre a0).
+dHold :: a -> SF (Event a) a
+dHold a0 = dSwitch (constant a0 &&& identity) dHold'
+    where
+	dHold' a = dSwitch (constant a &&& notYet) dHold'
+
+
+dTrackAndHold :: a -> SF (Maybe a) a
+dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init
+
+
+------------------------------------------------------------------------------
+-- Accumulators
+------------------------------------------------------------------------------
+
+accumHold :: a -> SF (Event (a -> a)) a
+accumHold a_init = accum a_init >>> hold a_init
+
+
+dAccumHold :: a -> SF (Event (a -> a)) a
+dAccumHold a_init = accum a_init >>> dHold a_init
+
+
+accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b
+accumHoldBy f b_init = accumBy f b_init >>> hold b_init
+
+
+dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b
+dAccumHoldBy f b_init = accumBy f b_init >>> dHold b_init
+
+
+count :: Integral b => SF (Event a) (Event b)
+count = accumBy (\n _ -> n + 1) 0
+
+
+------------------------------------------------------------------------------
+-- Delays
+------------------------------------------------------------------------------
+
+-- Lucid-Synchrone-like initialized delay (read "followed by").
+fby :: b -> SF a b -> SF a b
+b0 `fby` sf = b0 --> sf >>> pre
+
+
+------------------------------------------------------------------------------
+-- Integrals
+------------------------------------------------------------------------------
+
+impulseIntegral :: VectorSpace a k => SF (a, Event a) a
+impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^)
diff --git a/src/Nettle/FRPControl/AFRPUtils.hs b/src/Nettle/FRPControl/AFRPUtils.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPUtils.hs
@@ -0,0 +1,171 @@
+{-# LANGUAGE 
+  GADTs, 
+  EmptyDataDecls,
+  TypeFamilies, 
+  TypeOperators
+  #-}
+
+-- | This module provides some utilities for writing drivers of
+-- signal functions. 
+module Nettle.FRPControl.AFRPUtils
+    (
+     -- * Type-level lists
+     Nil, 
+     (:::), 
+
+     -- * Value-level representation of type-level lists
+     Rep (..), 
+
+     -- * Event-source vector
+     SFInput(..), 
+
+     -- * List of sensor channels
+     SensorChans,
+
+     -- * Output vector
+     SFOutput(..), 
+
+     -- * List of actuator actions
+     Actuators,
+
+     -- * Driver
+     sfDriver
+
+    ) where
+
+import Control.Concurrent
+import Data.Time.Clock (getCurrentTime, diffUTCTime)
+import Control.Monad
+import Nettle.FRPControl.AFRP 
+import Data.Monoid hiding (All)
+
+-- Heterogeneous lists of types
+
+-- | Empty list.
+data Nil 
+
+-- | Cons list
+data (:::) x xs = (:::) (x, xs)
+
+-- | Infix operator; synonymous with TCons.
+infixr 5 :::
+
+-- | Value level representation of type level lists.
+data Rep a where
+    RNil  :: Rep Nil
+    RCons :: Rep b -> Rep (a ::: b)
+
+-- |Input types for each heterogeneous type list.
+type family SFInput t
+type instance SFInput Nil          = () 
+type instance SFInput ((:::) x xs) = (Maybe x, SFInput xs) 
+
+-- | Injects the missing value into an SFInput type.
+missing :: Rep a -> SFInput a 
+missing RNil       = ()
+missing (RCons rb) = (Nothing, missing rb)
+
+-- | Vector of Sensor channels of the right types
+type family SensorChans t
+type instance SensorChans Nil = ()
+type instance SensorChans (a ::: bs) = (Chan a, SensorChans bs)
+
+-- | Make a sensor for SFInput s values, given a collection of SensorChans.
+mkSensor :: Rep s -> SensorChans s -> IO (Chan (SFInput s))
+mkSensor RNil ()                = newChan
+mkSensor (RCons rb) (aCh, bChs) = 
+    do bCh <- mkSensor rb bChs 
+       multiplexChanPair rb aCh bCh
+
+-- Helper function, used in mkSensor above.
+multiplexChanPair :: Rep b -> 
+                     Chan a -> 
+                     Chan (SFInput b) -> 
+                     IO (Chan (SFInput (a ::: b))) 
+multiplexChanPair RNil aCh _ = do                       
+  abCh <- newChan
+  forkIO $ forever (readChan aCh >>= writeChan abCh . (\a -> (Just a, ())))
+  return abCh
+multiplexChanPair rb aCh bCh = do 
+  abCh <- newChan
+  forkIO $ readWriter aCh (\a -> (Just a, missing rb)) abCh
+  forkIO $ readWriter bCh (\b -> (Nothing, b)) abCh
+  return abCh
+      where readWriter srcCh f destCh = 
+                forever (readChan srcCh >>= writeChan destCh . f)
+
+
+-- |Output type for each heterogeneous list 
+type family SFOutput t 
+type instance SFOutput Nil        = ()
+type instance SFOutput (a ::: bs) = (a, SFOutput bs)
+
+-- Vector of Actuator actions of the right types
+type family Actuators t
+type instance Actuators Nil       = ()
+type instance Actuators (a ::: bs) = (a -> IO (), Actuators bs)
+
+-- Make an actuator given a representation of type s, and 
+-- an actuator list of shape s.
+actuateVector :: Rep s -> Actuators s -> SFOutput s -> IO ()
+actuateVector RNil () ()
+    = return ()
+actuateVector (RCons rb) (actA, actsB) (a, b)
+    = actA a >> actuateVector rb actsB b
+
+
+-- | Drives signal functions with the given collection of sensor channels
+-- and actuator actions. It multiplexes the sensors into a single channel of events.
+sfDriver :: Rep s                            -- ^ Representation of the shape of the @SensorChans@ argument
+            -> SensorChans s                 -- ^ Sensor channels
+            -> Rep t                         -- ^ Representation of the shape of the actuator argument
+            -> Actuators t                   -- ^ Actuators
+            -> SF (SFInput s) (SFOutput t)   -- ^ Signal function to drive
+            -> IO ()                         
+sfDriver repS chS repT chT sf = 
+  do 
+    sensorCh      <- mkSensor repS chS
+    let actuator  = actuateVector repT chT
+    let sense     = readChan sensorCh
+    let a0        = missing repS
+    let aMissing  = Just (missing repS)
+    sfDriverAux a0 sense aMissing actuator sf
+
+
+------------- INTERNAL ----------------
+
+sfDriverAux :: a -> IO a -> Maybe a -> (b -> IO ()) -> SF a b -> IO ()
+sfDriverAux a0 sensor clockInput actuator sf = do 
+
+  lastSenseTimeVar <- newEmptyMVar
+  inCh             <- newChan :: IO (Chan (Maybe a))
+  let initiator = initReact lastSenseTimeVar
+  let sensor''  = sensor' inCh lastSenseTimeVar
+  forkIO $ genClockSignal inCh
+  forkIO $ genNormalSignal inCh
+  reactimate initiator sensor'' actuator' sf
+
+    where 
+
+      initReact lastSenseTimeVar = 
+          do
+            t <- getCurrentTime
+            putMVar lastSenseTimeVar t
+            return a0
+  
+      sensor' ch lastSenseTimeVar _ = 
+          do 
+            ma <- readChan ch
+            t' <- getCurrentTime
+            t  <- swapMVar lastSenseTimeVar t'
+            let delta = fromRational (toRational (diffUTCTime t' t))
+            return (delta, ma)
+
+      actuator' changed b = actuator b >> return False
+
+      genClockSignal ch  = 
+          forever (threadDelay clockCycle >> writeChan ch clockInput)
+          where clockCycle = 1000
+
+      genNormalSignal ch = forever (sensor >>= writeChan ch . Just)
+
diff --git a/src/Nettle/FRPControl/AFRPVector2.hs b/src/Nettle/FRPControl/AFRPVector2.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPVector2.hs
@@ -0,0 +1,100 @@
+{- \$Id: AFRPVector2.hs,v 1.5 2004/03/22 19:46:40 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:		AFRPVector2					     *
+*       Purpose:	2D vector abstraction (R^2).			     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+module Nettle.FRPControl.AFRPVector2 (
+    module Nettle.FRPControl.AFRPVectorSpace,
+    Vector2,		-- Abstract, instance of VectorSpace
+    vector2,		-- :: RealFloat a => a -> a -> Vector2 a
+    vector2X,		-- :: RealFloat a => Vector2 a -> a
+    vector2Y,		-- :: RealFloat a => Vector2 a -> a
+    vector2XY,		-- :: RealFloat a => Vector2 a -> (a, a)
+    vector2Polar,	-- :: RealFloat a => a -> a -> Vector2 a
+    vector2Rho,		-- :: RealFloat a => Vector2 a -> a
+    vector2Theta,	-- :: RealFloat a => Vector2 a -> a
+    vector2RhoTheta,	-- :: RealFloat a => Vector2 a -> (a, a)
+    vector2Rotate 	-- :: RealFloat a => a -> Vector2 a -> Vector2 a
+) where
+
+import Nettle.FRPControl.AFRPVectorSpace
+import Nettle.FRPControl.AFRPForceable
+
+
+------------------------------------------------------------------------------
+-- 2D vector, constructors and selectors.
+------------------------------------------------------------------------------
+
+-- Restrict coefficient space to RealFloat (rather than Floating) for now.
+-- While unclear if a complex coefficient space would be useful (and if the
+-- result really would be a 2d vector), the only thing causing trouble is the
+-- use of atan2 in vector2Theta. Maybe atan2 can be generalized?
+
+data RealFloat a => Vector2 a = Vector2 !a !a deriving (Eq,Show)
+
+vector2 :: RealFloat a => a -> a -> Vector2 a
+vector2 x y = Vector2 x y
+
+vector2X :: RealFloat a => Vector2 a -> a
+vector2X (Vector2 x _) = x
+
+vector2Y :: RealFloat a => Vector2 a -> a
+vector2Y (Vector2 _ y) = y
+
+vector2XY :: RealFloat a => Vector2 a -> (a, a)
+vector2XY (Vector2 x y) = (x, y)
+
+vector2Polar :: RealFloat a => a -> a -> Vector2 a
+vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta) 
+
+vector2Rho :: RealFloat a => Vector2 a -> a
+vector2Rho (Vector2 x y) = sqrt (x * x + y * y)
+
+vector2Theta :: RealFloat a => Vector2 a -> a
+vector2Theta (Vector2 x y) = atan2 y x
+
+vector2RhoTheta :: RealFloat a => Vector2 a -> (a, a)
+vector2RhoTheta v = (vector2Rho v, vector2Theta v)
+
+------------------------------------------------------------------------------
+-- Vector space instance
+------------------------------------------------------------------------------
+
+instance RealFloat a => VectorSpace (Vector2 a) a where
+    zeroVector = Vector2 0 0
+
+    a *^ (Vector2 x y) = Vector2 (a * x) (a * y)
+
+    (Vector2 x y) ^/ a = Vector2 (x / a) (y / a)
+
+    negateVector (Vector2 x y) = (Vector2 (-x) (-y))
+
+    (Vector2 x1 y1) ^+^ (Vector2 x2 y2) = Vector2 (x1 + x2) (y1 + y2)
+
+    (Vector2 x1 y1) ^-^ (Vector2 x2 y2) = Vector2 (x1 - x2) (y1 - y2)
+
+    (Vector2 x1 y1) `dot` (Vector2 x2 y2) = x1 * x2 + y1 * y2
+
+
+------------------------------------------------------------------------------
+-- Additional operations
+------------------------------------------------------------------------------
+
+vector2Rotate :: RealFloat a => a -> Vector2 a -> Vector2 a
+vector2Rotate theta' v = vector2Polar (vector2Rho v) (vector2Theta v + theta')
+
+
+------------------------------------------------------------------------------
+-- Forceable instance
+------------------------------------------------------------------------------
+
+instance RealFloat a => Forceable (Vector2 a) where
+     force = id
diff --git a/src/Nettle/FRPControl/AFRPVector3.hs b/src/Nettle/FRPControl/AFRPVector3.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPVector3.hs
@@ -0,0 +1,118 @@
+{- \$Id: AFRPVector3.hs,v 1.3 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:		AFRPVector3					     *
+*       Purpose:	3D vector abstraction (R^3).			     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+module Nettle.FRPControl.AFRPVector3 (
+    module Nettle.FRPControl.AFRPVectorSpace,
+    Vector3,		-- Abstract, instance of VectorSpace
+    vector3,		-- :: RealFloat a => a -> a -> a -> Vector3 a
+    vector3X,		-- :: RealFloat a => Vector3 a -> a
+    vector3Y,		-- :: RealFloat a => Vector3 a -> a
+    vector3Z,		-- :: RealFloat a => Vector3 a -> a
+    vector3XYZ,		-- :: RealFloat a => Vector3 a -> (a, a, a)
+    vector3Spherical,	-- :: RealFloat a => a -> a -> a -> Vector3 a
+    vector3Rho,		-- :: RealFloat a => Vector3 a -> a
+    vector3Theta,	-- :: RealFloat a => Vector3 a -> a
+    vector3Phi,		-- :: RealFloat a => Vector3 a -> a
+    vector3RhoThetaPhi,	-- :: RealFloat a => Vector3 a -> (a, a, a)
+    vector3Rotate 	-- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a
+) where
+
+import Nettle.FRPControl.AFRPVectorSpace
+import Nettle.FRPControl.AFRPForceable
+
+------------------------------------------------------------------------------
+-- 3D vector, constructors and selectors.
+------------------------------------------------------------------------------
+
+-- Restrict coefficient space to RealFloat (rather than Floating) for now.
+-- While unclear if a complex coefficient space would be useful (and if the
+-- result really would be a 3d vector), the only thing causing trouble is the
+-- use of atan2 in vector3Theta and vector3Phi. Maybe atan2 can be generalized?
+
+data RealFloat a => Vector3 a = Vector3 !a !a !a deriving Eq
+
+vector3 :: RealFloat a => a -> a -> a -> Vector3 a
+vector3 x y z = Vector3 x y z
+
+vector3X :: RealFloat a => Vector3 a -> a
+vector3X (Vector3 x _ _) = x
+
+vector3Y :: RealFloat a => Vector3 a -> a
+vector3Y (Vector3 _ y _) = y
+
+vector3Z :: RealFloat a => Vector3 a -> a
+vector3Z (Vector3 _ _ z) = z
+
+vector3XYZ :: RealFloat a => Vector3 a -> (a, a, a)
+vector3XYZ (Vector3 x y z) = (x, y, z)
+
+vector3Spherical :: RealFloat a => a -> a -> a -> Vector3 a
+vector3Spherical rho theta phi =
+    Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi)
+    where
+	rhoSinPhi = rho * sin phi
+
+vector3Rho :: RealFloat a => Vector3 a -> a
+vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z)
+
+vector3Theta :: RealFloat a => Vector3 a -> a
+vector3Theta (Vector3 x y _) = atan2 y x
+
+vector3Phi :: RealFloat a => Vector3 a -> a
+vector3Phi v@(Vector3 x y z) = acos (z / vector3Rho v)
+
+vector3RhoThetaPhi :: RealFloat a => Vector3 a -> (a, a, a)
+vector3RhoThetaPhi (Vector3 x y z) = (rho, theta, phi)
+    where
+        rho   = sqrt (x * x + y * y + z * z)
+        theta = atan2 y x
+	phi   = acos (z / rho)
+
+
+------------------------------------------------------------------------------
+-- Vector space instance
+------------------------------------------------------------------------------
+
+instance RealFloat a => VectorSpace (Vector3 a) a where
+    zeroVector = Vector3 0 0 0
+
+    a *^ (Vector3 x y z) = Vector3 (a * x) (a * y) (a * z)
+
+    (Vector3 x y z) ^/ a = Vector3 (x / a) (y / a) (z / a)
+
+    negateVector (Vector3 x y z) = (Vector3 (-x) (-y) (-z))
+
+    (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2)
+
+    (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2)
+
+    (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2
+
+
+------------------------------------------------------------------------------
+-- Additional operations
+------------------------------------------------------------------------------
+
+vector3Rotate :: RealFloat a => a -> a -> Vector3 a -> Vector3 a
+vector3Rotate theta' phi' v =
+    vector3Spherical (vector3Rho v)
+		     (vector3Theta v + theta')
+		     (vector3Phi v + phi')
+
+
+------------------------------------------------------------------------------
+-- Forceable instance
+------------------------------------------------------------------------------
+
+instance RealFloat a => Forceable (Vector3 a) where
+     force = id
diff --git a/src/Nettle/FRPControl/AFRPVectorSpace.hs b/src/Nettle/FRPControl/AFRPVectorSpace.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/AFRPVectorSpace.hs
@@ -0,0 +1,160 @@
+{- \$Id: AFRPVectorSpace.hs,v 1.2 2003/11/10 21:28:58 antony Exp $
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:		AFRPVectorSpace					     *
+*       Purpose:	Vector space type relation and basic instances.	     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
+
+module Nettle.FRPControl.AFRPVectorSpace where
+
+------------------------------------------------------------------------------
+-- Vector space type relation
+------------------------------------------------------------------------------
+
+infixr *^
+infixl ^/
+infix 7 `dot`
+infixl 6 ^+^, ^-^
+
+-- Maybe norm and normalize should not be class methods, in which case
+-- the constraint on the coefficient space (a) should (or, at least, could)
+-- be Fractional (roughly a Field) rather than Floating.
+
+-- Minimal instance: zeroVector, (*^), (^+^), dot
+class Floating a => VectorSpace v a | v -> a where
+    zeroVector   :: v
+    (*^)         :: a -> v -> v
+    (^/)         :: v -> a -> v
+    negateVector :: v -> v
+    (^+^)        :: v -> v -> v
+    (^-^)        :: v -> v -> v
+    dot          :: v -> v -> a
+    norm	 :: v -> a
+    normalize	 :: v -> v
+
+    v ^/ a = (1/a) *^ v
+
+    negateVector v = (-1) *^ v
+
+    v1 ^-^ v2 = v1 ^+^ v1 -- (negateVector v2)
+
+    norm v = sqrt (v `dot` v)
+
+    normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector"
+        where
+	    nv = norm v
+
+------------------------------------------------------------------------------
+-- Vector space instances for Float and Double
+------------------------------------------------------------------------------
+
+instance VectorSpace Float Float where
+    zeroVector = 0
+
+    a *^ x = a * x
+
+    x ^/ a = x / a
+
+    negateVector x = (-x)
+
+    x1 ^+^ x2 = x1 + x2
+
+    x1 ^-^ x2 = x1 - x2
+
+    x1 `dot` x2 = x1 * x2
+
+
+instance VectorSpace Double Double where
+    zeroVector = 0
+
+    a *^ x = a * x
+
+    x ^/ a = x / a
+
+    negateVector x = (-x)
+
+    x1 ^+^ x2 = x1 + x2
+
+    x1 ^-^ x2 = x1 - x2
+
+    x1 `dot` x2 = x1 * x2
+
+
+------------------------------------------------------------------------------
+-- Vector space instances for small tuples of Floating
+------------------------------------------------------------------------------
+
+instance Floating a => VectorSpace (a,a) a where
+    zeroVector = (0,0)
+
+    a *^ (x,y) = (a * x, a * y)
+
+    (x,y) ^/ a = (x / a, y / a)
+
+    negateVector (x,y) = (-x, -y)
+
+    (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2)
+
+    (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2)
+
+    (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2
+
+
+instance Floating a => VectorSpace (a,a,a) a where
+    zeroVector = (0,0,0)
+
+    a *^ (x,y,z) = (a * x, a * y, a * z)
+
+    (x,y,z) ^/ a = (x / a, y / a, z / a)
+
+    negateVector (x,y,z) = (-x, -y, -z)
+
+    (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2)
+
+    (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2)
+
+    (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2
+
+
+instance Floating a => VectorSpace (a,a,a,a) a where
+    zeroVector = (0,0,0,0)
+
+    a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u)
+
+    (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a)
+
+    negateVector (x,y,z,u) = (-x, -y, -z, -u)
+
+    (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2)
+
+    (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2)
+
+    (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2
+
+
+instance Floating a => VectorSpace (a,a,a,a,a) a where
+    zeroVector = (0,0,0,0,0)
+
+    a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v)
+
+    (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a)
+
+    negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v)
+
+    (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2)
+
+    (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2)
+
+    (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) =
+        x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2
+
+
+
diff --git a/src/Nettle/FRPControl/NetInfo.hs b/src/Nettle/FRPControl/NetInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/NetInfo.hs
@@ -0,0 +1,360 @@
+{-# LANGUAGE Arrows, DisambiguateRecordFields, RecordWildCards, TypeSynonymInstances, CPP #-}
+
+-- | This module defines a relational view of the network
+-- state and configuration, and provides signal functions
+-- that dynamically maintain this view.
+module Nettle.FRPControl.NetInfo
+    (
+    -- * Switch and port information
+    SwitchTable,
+    SwitchRecord(..),
+    PortTable,
+    PortRecord(..),
+    HasDataPathID(..),
+    NetInfo, 
+    portTable, 
+    switchTable,
+    NetworkMonitorPolicy(..),
+    defaultMonitorPolicy,
+    networkInfoRequester,
+    switchInfo,
+    
+    -- * Host information
+    HostDirectionMap,
+    hostDirectionsSF,
+    hostDirectionsChangeSF,
+    HostLocationMap,
+    hostLocationSF,
+
+    -- * Port Statistics
+    withPortStats,
+    portRatesMapSF,
+    nAveragePortRateMap    
+    ) where
+
+import Nettle.OpenFlow.Messages hiding (Features)
+import Nettle.OpenFlow.Switch hiding (SwitchFeatures(..))
+import qualified Nettle.OpenFlow.Switch as M
+import qualified Nettle.OpenFlow.Port as P
+import Nettle.OpenFlow.Port hiding (Port,portID)
+import Nettle.OpenFlow.Action
+import Nettle.OpenFlow.Packet 
+import Nettle.OpenFlow.Statistics hiding (StatsReply(..))
+import Nettle.Ethernet.EthernetAddress
+import Nettle.IPv4.IPPacket
+import Nettle.FRPControl.NettleSF 
+import Nettle.Discovery.Topology 
+import Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Monoid 
+  
+
+-- | A @SwitchTable@ is a list of @SwitchRecord@s
+type SwitchTable  = [ SwitchRecord ]
+data SwitchRecord 
+    = SwitchRecord 
+      { switchID           :: SwitchID           -- ^ switch identifier
+      , packetBufferSize   :: Integer            -- ^ maximum number of packets buffered at the switch
+      , numberFlowTables   :: Integer            -- ^ number of flow tables
+      , capabilities       :: [SwitchCapability] -- ^ switch's capabilities
+      , supportedActions   :: [ActionType]       -- ^ actions supported by the switch
+      } deriving (Show,Eq,Ord)
+
+-- | A list of @PortRecord@s; @PortRecords@ should be uniquely identifiable by their @SwitchID@ and @PortID@.
+type PortTable    = [ PortRecord ]
+
+data PortRecord = 
+  PortRecord { portSwitch           :: SwitchID              -- ^ Switch the port belongs to
+             , portID               :: PortID                -- ^ Port ID of the port
+             , portAddr             :: EthernetAddress       -- ^ Hardware (Ethernet) address of the port.
+             , spanningTreeState    :: SpanningTreePortState -- ^ Spanning tree protocol state for this port
+             , isPortDown           :: Bool                  
+             , isLinkDown           :: Bool 
+             , isUsedForFlooding    :: Bool
+             } deriving (Show, Eq)
+
+
+
+-- | Type class for records having datapath-id fields. Having records
+-- implement this class allows the client to use uniform syntax for fields
+-- of different records.
+class HasDataPathID a where
+    dPID :: a -> SwitchID
+
+instance HasDataPathID SwitchID where
+    dPID = id
+
+instance HasDataPathID PortRecord where
+    dPID = portSwitch
+
+
+-- | The NetInfo datatype carries network information in a form that
+-- is easily retrieved from switches. 
+newtype NetInfo = NetInfo (Map SwitchID M.SwitchFeatures) deriving Show
+
+-- | Project the current @SwitchTable@ value from a @NetInfo@ value.
+switchTable :: NetInfo -> SwitchTable
+switchTable (NetInfo smap) = 
+    [ SwitchRecord { switchID = id, 
+                     packetBufferSize = packetBufferSize,
+                     numberFlowTables = numberFlowTables, 
+                     capabilities     = capabilities,
+                     supportedActions = supportedActions
+                   }
+      | (id, M.SwitchFeatures {..}) <- Map.assocs smap ]
+
+-- | Project the current @PortTable@ value from a @NetInfo@ value.
+portTable :: NetInfo -> PortTable
+portTable (NetInfo smap)
+                  = concat $ 
+                    Map.elems $ 
+                    Map.map f smap
+    where f sfr = [ PortRecord { portSwitch           = M.switchID sfr, 
+                                 portID               = portNumber, 
+                                 portAddr             = portAddr, 
+                                 spanningTreeState    = portState, 
+                                 isPortDown           = PortDown `elem` portConfig, 
+                                 isLinkDown           = linkDown,
+                                 isUsedForFlooding    = not (NoFlooding `elem` portConfig)
+                               }
+                    | P.Port portNumber portName portAddr portConfig linkDown portState _ _ _ _ <- M.ports sfr, 
+                      portNumber <= maxNumberPorts
+                  ]
+
+
+-- | Map giving the next hop @PortID@ (if it is known) to a host from
+-- a given switch.
+type HostDirectionMap = Map (SwitchID, EthernetAddress) PortID
+
+-- | Current @HostDirectionMap@
+hostDirectionsSF :: SF (Event (SwitchID, SwitchMessage)) HostDirectionMap
+hostDirectionsSF = hostDirectionsChangeSF >>> arr (liftE snd) >>> hold Map.empty
+
+-- | Outputs an event whenever the host direction information changes. 
+-- Outputs both the previous and the updated host direction map.
+hostDirectionsChangeSF :: SF (Event (SwitchID, SwitchMessage)) (Event (HostDirectionMap, HostDirectionMap))
+hostDirectionsChangeSF = arr packetInE >>> accumFilter learn Map.empty
+    where learn dict (sid, pktRecord) = 
+            case packetInFrame pktRecord of 
+              Left msg    -> (dict, Nothing)
+              Right frame -> 
+                let src   = sourceAddress frame
+                    port' = receivedOnPort pktRecord
+                    dict' = Map.insert (sid,src) port' dict
+                in case Map.lookup (sid, src) dict of 
+                  Nothing   -> (dict', Just (dict, dict'))
+                  Just port -> if port == port' 
+                               then (dict, Nothing) 
+                               else (dict', Just (dict,dict'))
+
+
+type HostLocationMap = Map EthernetAddress (SwitchID, PortID)
+
+hostLocationSF :: SF (Event (SwitchID, SwitchMessage), Topology) HostLocationMap
+hostLocationSF = proc (i, topology) -> do 
+  hold Map.empty <<< accumBy learn Map.empty -< packetInE i `attach` topology
+    where learn hlMap ((dpid, pktInfo), topology) = 
+            if (dpid, inPort) `portInTopology` topology
+            then hlMap
+            else case packetInFrame pktInfo of 
+              Left str -> hlMap
+              Right frame -> Map.insert (sourceAddress frame) (dpid, inPort) hlMap
+            where inPort = receivedOnPort pktInfo
+                        
+
+
+portInTopology :: Port -> Topology -> Bool
+portInTopology port = not . Set.null . Set.filter (port `Set.member`) 
+
+
+
+                                                   
+data NetworkMonitorPolicy 
+    = NetworkMonitorPolicy { switchFeaturesRefreshPeriod :: Time -- ^ Amount of time (in seconds) between switch feature queries
+                           , portStatisticsRefreshPeriod :: Time -- ^ Amount of time (in seconds) between port statistics queries
+                           } deriving (Show,Eq)
+
+
+defaultMonitorPolicy :: NetworkMonitorPolicy
+defaultMonitorPolicy = 
+  NetworkMonitorPolicy { switchFeaturesRefreshPeriod = 10  -- seconds
+                       , portStatisticsRefreshPeriod = 5   -- seconds
+                       } 
+
+-- | Issues switch queries according to the given @NetworkMonitorPolicy@.
+networkInfoRequester :: NetworkMonitorPolicy -> 
+                        SF (Event (SwitchID, SwitchMessage)) (Event SwitchCommand)
+networkInfoRequester policy = 
+    proc i -> do 
+      dpids <- activeSwitches -< i 
+      cmdE <- switchFeatureMonitor (switchFeaturesRefreshPeriod policy) -< (i, dpids)
+      cmdE' <- requestPortFlows (portStatisticsRefreshPeriod policy) -< (i, dpids)
+      returnA -< mergeBy (<+>) cmdE cmdE'
+
+switchFeatureMonitor :: Time -> SF (i, Set SwitchID) (Event SwitchCommand)
+switchFeatureMonitor refreshPeriod = 
+    proc (evt,dpids) -> do
+      timeOut <- repeatedly refreshPeriod () -< ()
+      returnA -< tag timeOut (mconcat [ requestFeatures swid | swid <- Set.toList dpids ])
+
+activeSwitches :: SF (Event (SwitchID, SwitchMessage)) (Set SwitchID)
+activeSwitches = proc i -> do 
+  hold Set.empty <<< accum Set.empty -< (liftE (\(dpid,_) -> Set.insert dpid) (arrivalE i) `lMerge`
+                                         liftE (Set.delete . fst) (departureE i)
+                                        )
+
+switchInfo :: SF (Event (SwitchID, SwitchMessage)) NetInfo
+switchInfo = proc i -> do 
+  let update = liftE (\(sw, sfr) -> Map.insert sw sfr) (arrivalE i) `lMerge`
+               liftE (\(sw, _)   -> Map.delete sw) (departureE i) `lMerge`
+               liftE (\(sw, sfr) -> Map.insert sw sfr) (featureUpdateE i)
+  arr NetInfo <<< hold Map.empty <<< accum Map.empty -< update
+
+requestPortFlows :: Time -> SF (Event (SwitchID, SwitchMessage), Set SwitchID) (Event SwitchCommand)
+#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
+requestPortFlows refreshPeriod = 
+    proc (i, dpids) -> do 
+      clock <- repeatedly refreshPeriod () -< ()
+      let periodicQuery = tag clock ( mconcat [requestStats dpid PortStatsRequest | dpid <- Set.toList dpids])
+      let joinQuery     = liftE (\(dpid,_) -> requestStats dpid PortStatsRequest) (arrivalE i)
+      writeToSwitch -< mergeBy (<+>) joinQuery periodicQuery
+#endif
+#if OPENFLOW_VERSION==1
+requestPortFlows refreshPeriod = 
+    proc (i, dpids) -> do 
+      clock <- repeatedly refreshPeriod () -< ()
+      let periodicQuery = tag clock ( mconcat [requestStats dpid (PortStatsRequest AllPorts) | dpid <- Set.toList dpids])
+      let joinQuery     = liftE (\(dpid,_) -> requestStats dpid (PortStatsRequest AllPorts)) (arrivalE i)
+      returnA -< mergeBy (<+>) joinQuery periodicQuery
+#endif
+
+
+-- | Applies the given signal function to each switch-port pair in the network.
+withPortStats :: SF (Event PortStats) a -> SF (Event (SwitchID, SwitchMessage)) (Map (SwitchID, PortID) a)
+withPortStats sf = proc i -> do 
+  let inserts = liftE (\(swid,sfr) -> Map.union (newMap swid sfr)) (arrivalE i)
+  let deletes = liftE (\(swid,_)   -> Map.filterWithKey (\(swid',_) _ -> swid /= swid')) (departureE i)
+  rpSwitchB Map.empty -< (i, inserts `lMerge` deletes)
+  where newMap swid sfr = Map.fromList [ ((swid, pid), statsForPort swid pid >>> sf)
+                                         | p <- M.ports sfr, let pid = P.portID p, pid <= maxNumberPorts ]
+
+
+statsForPort :: SwitchID -> PortID -> SF (Event (SwitchID, SwitchMessage)) (Event PortStats) 
+statsForPort dpid pid = 
+    proc i -> do 
+      returnA -< mapFilterE f (portStatReplyE i)
+      where f (swid, ports) 
+              | swid /= dpid = Nothing
+              | swid == dpid = lookup pid ports
+
+
+-- | Computes the rate of change of the port statistics vector by 
+-- calculating - for each component of the vector - the difference between the last two samples
+-- and dividing by the time difference. This measurements are then held until the next
+-- sample is observed. 
+portRatesMapSF :: SF (Event (SwitchID, SwitchMessage)) (Map (SwitchID, PortID) PortStats)
+portRatesMapSF = withPortStats (oneStepDifferenceSF >>> hold nullPortStats)
+
+averageRateMap :: Int -> SF (Event (SwitchID, SwitchMessage)) (Map (SwitchID, PortID) PortStats)
+averageRateMap n = withPortStats (averageRateN n >>> hold nullPortStats)
+
+-- | Tracks the average rate of change of the port statistics using a moving average
+-- of the last @n@ port statistics updates, where @n@ is the first argument to 
+-- the function.
+averageRateN :: Int -> SF (Event PortStats) (Event PortStats)
+averageRateN n = 
+    proc aEvent -> do 
+      t <- time -< ()
+      accumFilter f [] -< aEvent `attach` t
+
+    where f xs (a,t) = (xs', y)
+              where y = if length xs' == n 
+                        then Just (liftIntoPortStats1 (/dt) vdiff)
+                        else Nothing
+                    xs' = (a,t) : take (n-1) xs
+                    vdiff = liftIntoPortStats2 (-) vmax vmin
+                    (vmax,tmax) = head xs'
+                    (vmin,tmin) = last xs'
+                    dt = tmax - tmin
+                    
+nEvents :: Int -> SF (Event a) (Event [(Time,a)])
+nEvents n = proc e -> do 
+              t <- time -< ()
+              accum [] -< liftE (\a -> take n . ((t,a):)) e
+
+nAverage :: Int -> SF (Event PortStats) (Event PortStats)
+nAverage n = proc e -> do
+               arr (mapFilterE average) <<< nEvents n -< e
+    where average [] = Nothing
+          average ((t1,v1):tvs) 
+              | null tvs  = Nothing
+              | otherwise = let (tn,vn) = last tvs
+                                dt      = t1 - tn
+                                vdiff   = liftIntoPortStats2 (-) v1 vn
+                                slope   = liftIntoPortStats1 (/dt) vdiff
+                            in Just slope
+
+-- | Tracks the average rate of change of the port statistics using a moving average
+-- of the last @n@ port statistics updates, where @n@ is the first argument to 
+-- the function.
+nAveragePortRateMap :: Int -> SF (Event (SwitchID, SwitchMessage)) (Map (SwitchID, PortID) PortStats)
+nAveragePortRateMap n = withPortStats (nAverage n >>> hold zeroPortStats)
+
+smoothPortRateMap ::SF (Event (SwitchID, SwitchMessage)) (Map (SwitchID, PortID) PortStats)
+smoothPortRateMap = withPortStats portRatesSmooth
+
+portRatesSmooth :: SF (Event PortStats) PortStats
+portRatesSmooth = oneStepDifferenceSF >>> oneStepDifferenceSF >>> hold zeroPortStats >>> integralPortStats
+
+integralPortStats :: SF PortStats PortStats
+integralPortStats = proc v -> do 
+                      receivedPackets' <- integral -< maybe 0 id (portStatsReceivedPackets v)
+                      sentPackets'     <- integral -< maybe 0 id (portStatsSentPackets v)
+                      receivedBytes'   <- integral -< maybe 0 id (portStatsReceivedBytes v)
+                      sentBytes'       <- integral -< maybe 0 id (portStatsSentBytes v)
+                      receiverDropped' <- integral -< maybe 0 id (portStatsReceiverDropped v)
+                      senderDropped'   <- integral -< maybe 0 id (portStatsSenderDropped v)
+                      receiveErrors'   <- integral -< maybe 0 id (portStatsReceiveErrors v)
+                      transmitErrors'  <- integral -< maybe 0 id (portStatsTransmitError v)
+                      receivedFrameErrors'  <- integral -< maybe 0 id (portStatsReceivedFrameErrors v)
+                      receiverOverrunError' <- integral -< maybe 0 id (portStatsReceiverOverrunError v)
+                      receiverCRCError'     <- integral -< maybe 0 id (portStatsReceiverCRCError v)
+                      collisions'           <- integral -< maybe 0 id (portStatsCollisions v)
+                      let v' = PortStats { portStatsReceivedPackets      = Just receivedPackets', 
+                                           portStatsSentPackets          = Just sentPackets', 
+                                           portStatsReceivedBytes        = Just receivedBytes', 
+                                           portStatsSentBytes            = Just sentBytes', 
+                                           portStatsReceiverDropped      = Just receiverDropped', 
+                                           portStatsSenderDropped        = Just senderDropped', 
+                                           portStatsReceiveErrors        = Just receiveErrors', 
+                                           portStatsTransmitError        = Just transmitErrors', 
+                                           portStatsReceivedFrameErrors  = Just receivedFrameErrors', 
+                                           portStatsReceiverOverrunError = Just receiverOverrunError', 
+                                           portStatsReceiverCRCError     = Just receiverCRCError', 
+                                           portStatsCollisions           = Just collisions'
+                                         }
+                      returnA -< v'
+
+
+oneStepDifferenceSF :: SF (Event PortStats) (Event PortStats)
+oneStepDifferenceSF = 
+    proc statEvent -> do 
+      statPair <- consecutiveEvents -< statEvent 
+      returnA -< liftE slope statPair
+    where slope ((pr1, t1), (pr2, t2)) = 
+              liftIntoPortStats2 (\a1 a2 -> (a2 - a1) / (t2 - t1)) pr1 pr2
+
+
+
+consecutiveEvents :: SF (Event a) (Event ((a,Time),(a,Time)))
+consecutiveEvents = proc aEvent -> do 
+                      t <- time -< ()
+                      accumFilter f Nothing -< aEvent `attach` t
+    where f ma' (a,t) = (Just (a,t), mb) 
+              where mb = case ma' of
+                           Just (a',t') -> Just ((a',t'),(a,t))
+                           Nothing      -> Nothing
+
diff --git a/src/Nettle/FRPControl/NettleSF.hs b/src/Nettle/FRPControl/NettleSF.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/NettleSF.hs
@@ -0,0 +1,465 @@
+{-# LANGUAGE Arrows, GeneralizedNewtypeDeriving, TypeOperators, CPP, DisambiguateRecordFields, RecordWildCards #-}
+
+-- | Nettle signal functions and drivers. These drivers take care
+-- of low level details, such as message numbering, correlation of stats
+-- requests and replies, translation of higher level flow rules expressed
+-- using packet predicates to low level flow rules expressed in terms of
+-- matches.
+module Nettle.FRPControl.NettleSF
+    (
+      
+      -- * Nettle Signal Functions
+    runNettleSF
+     , simpleNettleDriver
+    
+      
+     -- * Switch event sources
+     , SwitchMessage(..) 
+     , arrivalE  
+     , departureE
+     , featureUpdateE
+     , portUpdateE
+     , switchErrorE
+     , packetInE
+     , filteredPacketInE
+     , flowRemovedE
+     , portStatReplyE
+     , flowStatReplyE       
+     
+     -- * Switch commands
+     , SwitchCommand
+     , sendPacket
+     , modifyFlowTable
+     , deleteFlowRules
+     , clearTables
+     , configurePort
+     , requestStats
+     , requestFeatures
+     , FlowRule
+     , PrioritizedFlowRule
+     , addFlowRule
+     , addFlowRule'
+     , addFlowRules
+
+     , (<+>)
+     , noOp
+     , (==>)
+     , expiringAfter
+     , expiringAfterInactive
+     , withPriority
+
+
+     , module Nettle.FRPControl.AFRP
+     , module Nettle.FRPControl.PacketPredicate
+     , module Nettle.Ethernet.EthernetAddress
+     , module Data.Monoid
+
+    ) where
+
+import Nettle.FRPControl.AFRP
+import Nettle.FRPControl.AFRPEvent
+
+import Nettle.FRPControl.SwitchInterface ((<+>), noOp)
+import qualified Nettle.FRPControl.SwitchInterface as SI
+import Nettle.FRPControl.PacketPredicate
+import Nettle.FRPControl.AFRPUtils
+
+import Nettle.Ethernet.EthernetAddress
+import Nettle.Ethernet.EthernetFrame
+
+import Nettle.Servers.TCPServer (SockAddr)
+import Nettle.Servers.MultiplexedTCPServer (TCPMessage(..))
+import Nettle.OpenFlow.Messages hiding (SCMessage(..), CSMessage(..))
+import qualified Nettle.OpenFlow.Messages as M
+import Nettle.OpenFlow.Switch
+import Nettle.OpenFlow.Match
+import qualified Nettle.OpenFlow.FlowTable as FlowTable
+import Nettle.OpenFlow.Statistics hiding (StatsReply(..))
+import qualified Nettle.OpenFlow.Statistics as M
+import Nettle.OpenFlow.Port
+import Nettle.OpenFlow.Error
+import Nettle.OpenFlow.Packet
+import Nettle.OpenFlow.Action
+import Data.Monoid
+import Data.Bimap (Bimap)
+import qualified Data.Bimap as Bimap
+import qualified Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.ByteString.Lazy (ByteString)
+import Data.Word
+import Control.Exception
+import qualified Control.Category as Category
+import Control.Monad.State hiding (lift)
+import Data.Maybe (mapMaybe)
+import System.IO
+import Control.Concurrent
+import Nettle.Servers.TCPServer (ServerPortNumber, SockAddr)
+
+data SwitchMessage = Arrival SwitchFeatures
+                   | Departure IOException
+                   | FeatureUpdate SwitchFeatures
+                   | PortUpdate PortStatus
+                   | SwitchError SwitchError
+                   | PacketIn PacketInfo
+                   | FlowRemoved FlowTable.FlowRemoved
+                   | PortStatsUpdate [(PortID, PortStats)]
+                   | FlowStatsUpdate [FlowStats]
+                   deriving (Show,Eq)
+
+
+-- | Outputs an event whenever a switch connects with the controller.
+-- The event carries the @SwitchID@ of the switch.
+arrivalE :: Event (SwitchID, SwitchMessage) -> Event (SwitchID, SwitchFeatures)
+arrivalE = mapFilterE f 
+  where f (sid, Arrival sfr) = Just (sid, sfr)
+        f _ = Nothing
+
+-- | Outputs an event whenever the switch disconnects from the controller. 
+-- The event carries the @SwitchID@ of the switch and  
+-- an @IOException@ value indicating the reason for the disconnection.
+departureE ::  Event (SwitchID, SwitchMessage) -> Event (SwitchID, IOException)
+departureE = mapFilterE f
+  where f (sid, Departure e) = Just (sid, e)
+        f _ = Nothing
+
+-- | Outputs an event whenever a switch sends a switch features update.
+-- The event carries the @SwitchID@ of the sending switch and the @SwitchFeatures@ data.
+featureUpdateE :: Event (SwitchID, SwitchMessage) -> Event (SwitchID, SwitchFeatures)
+featureUpdateE = mapFilterE f
+  where f (sid, FeatureUpdate sfr) = Just (sid, sfr)
+        f _ = Nothing
+
+-- | Outputs an event whenever a switch sends a port status update.
+-- The event carries the @SwitchID@ of the sending switch and the @PortStatus@.
+portUpdateE :: Event (SwitchID, SwitchMessage) -> Event (SwitchID, PortStatus)
+portUpdateE = mapFilterE f
+  where f (sid, PortUpdate e) = Just (sid, e)
+        f _ = Nothing
+
+-- | Outputs an event whenever a switch sends an error message.
+-- The event carries the @SwitchID@ of the sending switch and the @SwitchError@.
+switchErrorE :: Event (SwitchID, SwitchMessage) -> Event (SwitchID, SwitchError)
+switchErrorE = mapFilterE f
+  where f (sid, SwitchError e) = Just (sid, e)
+        f _ = Nothing
+
+-- | Outputs an event whenever a switch sends a packet in message.
+-- The event carries the @SwitchID@ of the sending switch and the @PacketInfo@.
+packetInE :: Event (SwitchID, SwitchMessage) -> Event (SwitchID, PacketInfo)
+packetInE = mapFilterE f
+  where f (sid, PacketIn e) = Just (sid, e)
+        f _ = Nothing
+
+
+-- | Packet-in events, filtered by a packet predicate applied to the 
+-- packet carried by the packet-in event. The output stream will only include 
+-- Packet-in messages that satisfy the filter criteria.
+filteredPacketInE :: PacketPredicate 
+                       -> Event (SwitchID, SwitchMessage) 
+                       -> Event (SwitchID, PacketInfo)
+filteredPacketInE p = packetInE >>> filterE (f . snd)
+  where f pktIn = either (const False) id (packetInMatches pktIn p)
+
+-- | Outputs an event whenever a switch notifies the controller of a flow removal.
+flowRemovedE :: Event (SwitchID, SwitchMessage) -> Event (SwitchID, FlowTable.FlowRemoved)
+flowRemovedE = mapFilterE f
+  where f (sid, FlowRemoved e) = Just (sid, e)
+        f _ = Nothing
+
+-- | Outputs an event whenever a switch sends a port statistics information to the controller. 
+-- This information may be communicated with several messages; the statistics from several messages  
+-- related to the same statistics request are aggregated and output in one event from this signal function. 
+portStatReplyE :: Event (SwitchID, SwitchMessage) -> Event (SwitchID, [(PortID, PortStats)])
+portStatReplyE = mapFilterE f
+  where f (sid, PortStatsUpdate e) = Just (sid, e)
+        f _ = Nothing
+
+-- | Outputs an event whenever a switch sends a flow statistics information to the controller. 
+-- This information may be communicated with several messages; the statistics from several messages  
+-- related to the same statistics request are aggregated and output in one event from this signal function. 
+flowStatReplyE :: Event (SwitchID, SwitchMessage) -> Event (SwitchID, [FlowStats])
+flowStatReplyE = mapFilterE f
+  where f (sid, FlowStatsUpdate e) = Just (sid, e)
+        f _ = Nothing
+  
+-- | Type of switch commands
+newtype SwitchCommand = SwitchCommand [(SwitchID, M.CSMessage)] deriving (Monoid, Show, Eq)
+
+-- | Send a packet
+sendPacket :: SwitchID -> PacketOut -> SwitchCommand
+sendPacket switchID packet = SwitchCommand [ (switchID, M.PacketOut packet) ]
+{-
+sendPacketIn :: (SwitchID, PacketIn) -> ActionSequence -> SwitchCommand
+floodPacketIn :: (SwitchID, PacketIn) -> SwitchCommand
+
+emptyAddFlow = AddFlow { match    = undefined
+                       , priority = 1
+                       , actions  = drop
+                       , cookie   = 0
+                       , idleTimeOut = Permanent
+                       , hardTimeOut = Permanent
+                       , notifyWhenRemoved = True
+                       , applyToPacket = Nothing
+                       , overlapAllowed = True 
+                       } 
+                                    
+-}
+
+-- | Modify a flow table
+modifyFlowTable :: SwitchID -> FlowTable.FlowMod -> SwitchCommand
+modifyFlowTable switchID mod = SwitchCommand [ (switchID, M.FlowMod mod) ]
+  
+-- | Delete all flow entries whose match conditions fall inside a given packet predicate.
+deleteFlowRules :: SwitchID -> PacketPredicate -> SwitchCommand
+deleteFlowRules dpid pred = 
+  case toMatches pred of
+    Just ms -> mconcat [ modifyFlowTable dpid (FlowTable.DeleteFlows { match = m, outPort = Nothing }) | m <- ms ]
+    Nothing -> error ("Attempted to delete flow rules with an unrealizable predicate: " ++ show pred)
+
+-- | Clear the flow table of a switch. @clearTables switch = deleteFlowRules switch anyPacket@.
+clearTables :: SwitchID -> SwitchCommand
+clearTables dpid = deleteFlowRules dpid anyPacket
+
+-- | Configure a port
+configurePort :: SwitchID -> PortMod -> SwitchCommand
+configurePort switchID mod = SwitchCommand [ (switchID, M.PortMod mod) ]
+
+-- | Request statistics
+requestStats :: SwitchID -> StatsRequest -> SwitchCommand
+requestStats switchID request = SwitchCommand [ (switchID, M.StatsRequest request) ]
+
+-- | Request switch features
+requestFeatures :: SwitchID -> SwitchCommand
+requestFeatures switchID = SwitchCommand [ (switchID, M.FeaturesRequest) ]
+
+type PrioritizedFlowRule = (FlowTable.Priority, FlowRule)
+type FlowRule = (PacketPredicate, ActionSequence, FlowTable.TimeOut, FlowTable.TimeOut)
+
+-- | A synonym for the tupling operator, specialized to packet predicates. 
+-- Provides suggestive infix syntax useful in writing addFlowRule commands.
+(==>) :: PacketPredicate -> ActionSequence -> FlowRule
+a ==> b = (a, b, FlowTable.Permanent, FlowTable.Permanent)
+
+infix 4 ==>
+
+expiringAfter :: FlowRule -> Word16 -> FlowRule
+(a,b,c,d) `expiringAfter` to = (a,b,FlowTable.ExpireAfter to,d)
+
+expiringAfterInactive :: FlowRule -> Word16 -> FlowRule
+(a,b,c,d) `expiringAfterInactive` to = (a,b,c,FlowTable.ExpireAfter to)
+
+withPriority ::  FlowRule -> FlowTable.Priority -> PrioritizedFlowRule
+withPriority r p = (p,r)
+
+addFlowRule :: PrioritizedFlowRule -> SwitchID -> SwitchCommand
+addFlowRule (priority, (pred, acts, idleTimeout, hardTimeout)) dpid 
+  = SwitchCommand [(dpid, msg) | msg <- compileFlowRule priority (pred, acts) idleTimeout hardTimeout ] 
+
+compileFlowRule :: FlowTable.Priority -> 
+                   (PacketPredicate, [Action]) -> 
+                   FlowTable.TimeOut -> 
+                   FlowTable.TimeOut -> 
+                   [M.CSMessage]
+compileFlowRule priority (pred,ports) idleTimeOut hardTimeOut  
+    = case toMatches pred of 
+        Just ms -> flowMods ms 
+        Nothing -> error ("Attempted to add a flow rule with an unrealizable predicate: " ++ show pred)
+      where flowMods ms = [ M.FlowMod $ FlowTable.AddFlow { 
+                               match             = m, 
+                               actions           = ports, 
+                               priority          = priority, 
+                               idleTimeOut       = idleTimeOut, 
+                               hardTimeOut       = hardTimeOut, 
+                               applyToPacket     = Nothing 
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1                                                    
+                             , overlapAllowed    = True
+                             , notifyWhenRemoved = True
+#endif
+#if OPENFLOW_VERSION==1                                                    
+                             , cookie            = 0 
+#endif                                                                        
+                             } 
+                          | m <- ms ]
+
+addFlowRule' :: PrioritizedFlowRule -> BufferID -> SwitchID -> SwitchCommand
+addFlowRule' (priority, (pred, acts, idleTimeout, hardTimeout)) bufid dpid 
+  = SwitchCommand [(dpid, msg) | msg <- compileFlowRule' priority (pred, acts) idleTimeout hardTimeout bufid ] 
+
+compileFlowRule' :: FlowTable.Priority -> 
+                    (PacketPredicate, [Action]) -> 
+                    FlowTable.TimeOut -> 
+                    FlowTable.TimeOut -> 
+                    BufferID -> 
+                    [M.CSMessage]
+compileFlowRule' priority (pred,ports) idleTimeOut hardTimeOut bufid  
+    = case toMatches pred of 
+        Just ms -> flowMods ms 
+        Nothing -> error ("Attempted to add an flow rule with an unrealizable predicate: " ++ show pred)
+      where flowMods ms = [ M.FlowMod $ FlowTable.AddFlow { 
+                               match             = m, 
+                               actions           = ports, 
+                               priority          = priority, 
+                               idleTimeOut       = idleTimeOut, 
+                               hardTimeOut       = hardTimeOut, 
+                               applyToPacket     = Just bufid 
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1                                                    
+                             , overlapAllowed    = True
+                             , notifyWhenRemoved = True
+#endif
+#if OPENFLOW_VERSION==1                                                    
+                             , cookie            = 0 
+#endif                                                                        
+                             } 
+                          | m <- ms ]
+-- | Add a collection of flow rules to a switch.
+addFlowRules 
+    :: [(FlowTable.Priority, (PacketPredicate, ActionSequence, FlowTable.TimeOut, FlowTable.TimeOut))] -> 
+       SwitchID -> 
+       SwitchCommand
+addFlowRules rs sw = 
+    mconcat [ addFlowRule (priority, (pred, acts, idleTimeout, hardTimeout)) sw | (priority, (pred, acts, idleTimeout, hardTimeout)) <- rs ]
+
+-- | Runs a signal function carrying messages and commands as defined in this module,
+-- converting it into a signal function in terms of basic switch messages and switch output, 
+-- which can be run using the switch driver provided in @SwitchInterface@.
+runNettleSF :: SF (Event (SwitchID, SwitchMessage), i) (Event SwitchCommand, o) 
+               -> SF (Event SI.SwitchMessage, i) (SI.SwitchOutput, o)
+runNettleSF sf = proc (smsgE, i) -> do 
+  let helloReplyE = liftE (\(addr, msgID) -> [(addr, (msgID, M.CSHello))]) (SI.switchHelloE smsgE) 
+  let echoReplyE  = liftE (\(addr, xid, bytes) -> [(addr, (xid, M.CSEchoReply bytes))]) (SI.switchEchoRequestE smsgE)
+  (bindings, bindingChange)  <- switchSockAddressBindingSF -< smsgE
+  msgsE <- messageConverter -< (smsgE, bindings, bindingChange)
+  (cmdsE, sfo) <- sf -< (msgsE, i)
+  let cmdsE' = liftE (\(SwitchCommand cmds) -> mapMaybe (translateAddress bindings) cmds) cmdsE
+  switchOutput <- xidTagger -< mergeBy (<+>) (liftE (\(addr,_) ->  [(addr, M.FeaturesRequest)]) (SI.switchHelloE smsgE)) cmdsE' 
+  returnA -< (fromEvent (mergeEventsBy (<+>) [ helloReplyE, echoReplyE, switchOutput ]), sfo)
+
+messageConverter :: SF (Event SI.SwitchMessage, Bimap SockAddr SwitchID, Event BindingChange) (Event (SwitchID, SwitchMessage))
+messageConverter = proc (smsgE, bindings, bindingChange) -> do
+  let arrivalsDeparts = liftE bindingChangeToMessage bindingChange
+  let nonStatMessage  = mapFilterE (msgToNonStatMessage bindings) smsgE
+  portStatReplies <- portStatRepliesSF' -< (smsgE, bindings)
+  flowStatReplies <- flowStatRepliesSF' -< (smsgE, bindings)  
+  returnA -< mergeEvents [arrivalsDeparts, nonStatMessage, portStatReplies, flowStatReplies]
+  
+portStatRepliesSF' :: SF (Event SI.SwitchMessage, Bimap SockAddr SwitchID) (Event (SwitchID, SwitchMessage))
+portStatRepliesSF' = proc (sMsgE, bindings) -> do
+  x <- accumFilter f Map.empty -< SI.portStatsReplyE sMsgE
+  returnA -< mapFilterE (g bindings) x
+  where f x2sMap (addr, xid, moreComing, stats) 
+          | moreComing = (Map.insertWith (++) xid stats x2sMap, Nothing)
+          | otherwise  = let stats' = Map.lookup xid x2sMap
+                         in (Map.delete xid x2sMap, Just (addr, PortStatsUpdate (stats ++ maybe [] id stats')))
+        g bindings (addr, msg) = 
+          case Bimap.lookup addr bindings of 
+            Nothing -> Nothing
+            Just sid -> Just (sid, msg)
+
+flowStatRepliesSF' :: SF (Event SI.SwitchMessage, Bimap SockAddr SwitchID) (Event (SwitchID, SwitchMessage))
+flowStatRepliesSF' = proc (sMsgE, bindings) -> do
+  x <- accumFilter f Map.empty -< SI.flowStatsReplyE sMsgE  
+  returnA -< mapFilterE (g bindings) x
+  where f x2sMap (addr, xid, moreComing, stats) 
+          | moreComing = (Map.insertWith (++) xid stats x2sMap, Nothing)
+          | otherwise  = let stats' = Map.lookup xid x2sMap
+                         in (Map.delete xid x2sMap, Just (addr, FlowStatsUpdate (stats ++ maybe [] id stats')))
+        g bindings (addr, msg) = 
+          case Bimap.lookup addr bindings of 
+            Nothing -> Nothing
+            Just sid -> Just (sid, msg)
+
+
+bindingChangeToMessage :: BindingChange -> (SwitchID, SwitchMessage)  
+bindingChangeToMessage (AddSwitch sid sfr)   = (sid, Arrival sfr)
+bindingChangeToMessage (SwitchRemoved sid e) = (sid, Departure e)
+
+msgToNonStatMessage :: Bimap SockAddr SwitchID -> SI.SwitchMessage -> Maybe (SwitchID, SwitchMessage)
+msgToNonStatMessage _ (ConnectionEstablished _) = Nothing
+msgToNonStatMessage _ (ConnectionTerminated _ _) = Nothing
+msgToNonStatMessage binding (PeerMessage addr (xid, msg)) = 
+  case Bimap.lookup addr binding of 
+    Nothing -> Nothing
+    Just sid -> 
+      case msg of 
+        M.SCHello          -> Nothing
+        M.SCEchoRequest _  -> Nothing
+        M.SCEchoReply _    -> Nothing
+        M.Features sfr     -> Just (sid, FeatureUpdate sfr)
+        M.PacketIn pktInfo -> Just (sid, PacketIn pktInfo)
+        M.PortStatus ps    -> Just (sid, PortUpdate ps)
+        M.FlowRemoved fr   -> Just (sid, FlowRemoved fr)
+        M.StatsReply sr    -> Nothing
+        M.Error se         -> Just (sid, SwitchError se)
+        M.BarrierReply     -> Nothing
+
+
+translateAddress :: (Ord k, Ord k') => Bimap k' k -> (k, a) -> Maybe (k', a)
+translateAddress bimap (k,a) = Bimap.lookupR k bimap >>= \k' -> return (k',a)
+
+xidTagger :: SF (Event [(SockAddr, M.CSMessage)]) (Event SI.SwitchOutput)
+xidTagger = proc cmdE -> do 
+  let lenE = liftE (fromIntegral . length) cmdE
+  xid <- hold 0 <<< accum 0 -< liftE (+) lenE
+  returnA -< liftE (\(len, cmds) -> zipWith (\x (a,c) -> (a, (x,c))) [xid-len..] cmds) (joinE lenE cmdE)
+
+-- | @switchSockAddressBindingSF@ is a signal function that maintains a binding of 
+-- socket address to switch ID for every switch. It also outputs an event whenever
+-- a switch binding is added or deleted.
+switchSockAddressBindingSF :: SF (Event SI.SwitchMessage) (Bimap SockAddr SwitchID, Event BindingChange)
+switchSockAddressBindingSF = proc i -> do
+  let switchLeave = SI.switchLeaveE i
+  let switchFeature = SI.switchFeaturesE i
+  a <- accumFilter f Bimap.empty -< (liftE Left switchFeature `lMerge` liftE Right switchLeave)
+  bimap <- hold Bimap.empty -< (liftE fst a)
+  returnA -<  (bimap, liftE snd a)
+    where f bimap e = 
+              case e of 
+                Left (addr, _, sfr) ->
+                    case Bimap.lookup addr bimap of
+                      Just dpid -> (bimap, Nothing)
+                      Nothing   -> let dpid = switchID sfr
+                                       bimap' = Bimap.insert addr dpid bimap 
+                                   in (bimap', Just (bimap', AddSwitch dpid sfr))
+                Right (addr, exc) -> 
+                    case Bimap.lookup addr bimap of 
+                      Just dpid -> let bimap' = Bimap.delete addr bimap
+                                   in (bimap', Just (bimap', SwitchRemoved dpid exc))
+                      Nothing   -> (bimap, Nothing)
+
+data BindingChange = AddSwitch SwitchID SwitchFeatures
+                   | SwitchRemoved SwitchID IOException
+                     deriving (Show,Eq)
+
+
+type StandardInput       = SFInput StandardInputVector
+type StandardInputVector = SI.SwitchMessage ::: Nil
+
+inputRep :: Rep (SI.SwitchMessage ::: Nil)
+inputRep = RCons RNil
+
+type StandardOutput = SFOutput OutputVector
+type OutputVector   = SI.SwitchOutput ::: String ::: Nil 
+
+outputRep :: Rep (SI.SwitchOutput ::: String ::: Nil)
+outputRep = RCons (RCons RNil)
+
+-- | Runs a signal function with a single input stream of switch messages
+-- and two output streams, one for switch commands and one for messages to the
+-- standard output device; starts a switch server at the specified port.
+simpleNettleDriver :: ServerPortNumber 
+                      -> SF (Event (SwitchID, SwitchMessage)) (Event SwitchCommand, Event String) 
+                      -> IO ()
+simpleNettleDriver pstring sf = do 
+  (switchSensor, switchActuator) <- SI.switchInterfaceDriver pstring
+  switchSensorCh <- newChan
+  forkIO $ forever (switchSensor >>= writeChan switchSensorCh)
+  let senseChans = (switchSensorCh,())
+  hdl <- openFile "foo.out" ReadWriteMode 
+  let consoleActuator msg = when (not (null msg)) (putStrLn msg >> hPutStrLn hdl msg)
+  let actuators = (switchActuator, (consoleActuator, ()))
+  let sf'       = arr (\(mx,_) -> (maybeToEvent mx, ())) >>> 
+                  runNettleSF (arr (\(msg,()) -> msg) >>> sf) >>> 
+                  arr (\(swOut, msgE) -> (swOut, (fromEvent msgE, ())))
+  finally (sfDriver inputRep senseChans outputRep actuators sf') (hClose hdl)
+
diff --git a/src/Nettle/FRPControl/PacketPredicate.hs b/src/Nettle/FRPControl/PacketPredicate.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/PacketPredicate.hs
@@ -0,0 +1,445 @@
+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, DisambiguateRecordFields , RecordWildCards , NamedFieldPuns #-}
+
+module Nettle.FRPControl.PacketPredicate 
+    (
+     -- * Packet predicates and match semantics
+     Logic(..), 
+     (|-), 
+     PacketPredicate(..), Clause, Literal,
+     (<&>), 
+     (<|>), 
+     anyPacket, 
+     inPortIs,
+     ethSourceIs, 
+     ethDestIs, 
+     vLANIDIs,
+     vlanPriority,
+     ethFrameTypeIs, 
+     ipTypeOfService,
+     transportProtocolIs, 
+     ipSourceIn,
+     ipDestIn,
+     senderTransportIs, 
+     receiverTransportIs, 
+     receiverTransportIn,
+     ands, 
+     ors,
+     satisfies, 
+     clauses, 
+     literals, 
+     overlaps,
+
+     -- * Commonly occurring packet predicates.
+     dhcp, dns, arp, lldp, ip, udp, ethSourceDestAre,
+
+     -- * Packet predicates and matches for this version
+     fromMatch,
+     toMatches,
+     realizable,
+     packetInFrame, 
+     exactPredicate, 
+     packetInMatches
+
+    )
+    where
+
+import Nettle.OpenFlow.Messages  
+import Nettle.OpenFlow.Port
+import Nettle.OpenFlow.Match hiding (ipTypeOfService)
+import qualified Nettle.OpenFlow.Match as Match
+import Nettle.OpenFlow.Packet
+import Nettle.Ethernet.EthernetFrame
+import Nettle.Ethernet.EthernetAddress
+import Nettle.IPv4.IPAddress
+import Nettle.IPv4.IPPacket
+import Data.Word
+import qualified Data.List as List
+import Data.Maybe
+import Data.Binary.Get
+import Control.Monad.Error
+
+-- | Type class for pairs of types where one type is a set of "structures", and the other is
+-- a set of predicates over these structures, and for which there exists a relations of
+-- satisfaction.
+class Logic m p where
+    holds :: m -> p -> Bool
+
+-- | A synonym for holds
+(|-) :: Logic m p => m -> p -> Bool
+(|-) = holds
+
+infix 5 |-
+
+-- | Packet Predicates
+-- Note that values of this data type should NOT be constructed using the constructors of this data type, 
+-- but rather through the functions defined below. The functions below maintain this data type's invariants, 
+-- whereas these constructors do not. 
+data PacketPredicate 
+    = AndPP PacketPredicate PacketPredicate
+    | OrPP PacketPredicate PacketPredicate
+    | TruePP
+    | FalsePP
+    | InPortIs PortID
+    | MacSourceIs EthernetAddress
+    | MacDestIs EthernetAddress
+    | VLANIDIs VLANID
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1    
+    | VLANPriority VLANPriority
+#endif
+    | MacFrameTypeIs EthernetTypeCode
+#if OPENFLOW_VERSION==1      
+    | IPTypeOfService IPTypeOfService      
+#endif
+    | IPProtocolIs IPProtocol
+    | IPSourceIn IPAddressPrefix
+    | IPDestIn IPAddressPrefix
+    | SenderTransportPortIs Word16
+    | ReceiverTransportPortIs Word16
+      deriving (Show,Read,Eq)
+ 
+anyPacket              = TruePP
+inPortIs p             = InPortIs p
+ethSourceIs a          = MacSourceIs a
+ethDestIs a            = MacDestIs a
+vLANIDIs x             = VLANIDIs x
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1    
+vlanPriority x         = VLANPriority x
+#endif
+ethFrameTypeIs t       = MacFrameTypeIs t
+#if OPENFLOW_VERSION==1      
+ipTypeOfService x      = IPTypeOfService x
+#endif
+transportProtocolIs x  = IPProtocolIs x
+ipSourceIn x           = IPSourceIn x
+ipDestIn x             = IPDestIn x
+senderTransportIs x    = SenderTransportPortIs x
+receiverTransportIs x  = ReceiverTransportPortIs x
+receiverTransportIn xs = ors [receiverTransportIs x | x <- xs]
+
+infixl 8 <|>, <&>
+
+(<|>), (<&>) :: PacketPredicate -> PacketPredicate -> PacketPredicate
+f <|> g = f `OrPP` g
+f <&> g = f `andPP` g
+
+andPP TruePP p1 = p1
+andPP FalsePP p1 = FalsePP
+andPP p1 TruePP = p1
+andPP p1 FalsePP = FalsePP
+
+andPP (InPortIs p1) (InPortIs p2) = 
+    if p1 /= p2 then FalsePP else InPortIs p1
+
+andPP (MacSourceIs x1) (MacSourceIs x2) = 
+    if x1 /= x2 then FalsePP else MacSourceIs x1
+
+andPP (MacDestIs x1) (MacDestIs x2) = 
+    if x1 /= x2 then FalsePP else MacDestIs x1
+
+andPP (VLANIDIs x1) (VLANIDIs x2) = 
+    if x1 /= x2 then FalsePP else VLANIDIs x1
+
+andPP (MacFrameTypeIs x1) (MacFrameTypeIs x2) = 
+    if x1 /= x2 then FalsePP else MacFrameTypeIs x1
+
+andPP (IPProtocolIs x1) (IPProtocolIs x2) = 
+    if x1 /= x2 then FalsePP else IPProtocolIs x1
+
+andPP (SenderTransportPortIs x1) (SenderTransportPortIs x2) = 
+    if x1 == x2 then SenderTransportPortIs x1 else SenderTransportPortIs x1 `AndPP` SenderTransportPortIs x2
+
+andPP (ReceiverTransportPortIs x1) (ReceiverTransportPortIs x2) = 
+    if x1 == x2 then ReceiverTransportPortIs x1 else ReceiverTransportPortIs x1 `AndPP` ReceiverTransportPortIs x2
+
+andPP (p1 `OrPP` p2) p3 = andPP p1 p3 `OrPP` andPP p2 p3
+andPP p1 (p2 `OrPP` p3) = andPP p1 p2 `OrPP` andPP p1 p3
+
+andPP p1 p2 = p1 `AndPP` p2
+
+ands, ors :: [PacketPredicate] -> PacketPredicate
+ors  = foldl (<|>) FalsePP
+ands = foldl (<&>) TruePP
+
+-- | This function defines when an incoming packet (as received by a switch)
+-- satisfies a given packet predicate.
+satisfies :: (PortID, EthernetFrame) -> PacketPredicate -> Bool
+satisfies _ TruePP  = True
+satisfies _ FalsePP = False
+satisfies (portid',_) (InPortIs portid) = portid==portid'
+satisfies (_, frame) (MacSourceIs a) = a == sourceAddress frame
+satisfies (_, frame) (MacDestIs a)   = a == destAddress frame
+satisfies (_, EthernetFrame hdr _) (VLANIDIs a) = 
+    case hdr of 
+      EthernetHeader {}    -> True
+      (Ethernet8021Q {..}) -> a == vlanId
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1    
+satisfies (_, EthernetFrame hdr _) (VLANPriority p) = 
+    case hdr of 
+      EthernetHeader {}    -> True
+      (Ethernet8021Q {..}) -> p == priorityCodePoint
+#endif      
+satisfies (_, EthernetFrame hdr _) (MacFrameTypeIs a) = a == typeCode hdr
+#if OPENFLOW_VERSION==1    
+satisfies (_, EthernetFrame hdr body) (IPTypeOfService tos) =
+  case body of 
+    IPInEthernet (IPPacket (IPHeader {..}) ipBody) -> tos == dscp
+    _ -> True
+#endif    
+satisfies (_, EthernetFrame _ body) (IPProtocolIs a) = 
+    case body of 
+      IPInEthernet (IPPacket (IPHeader {..}) ipbody) -> ipProtocol == a
+      _ -> True
+satisfies (_, EthernetFrame _ body) (IPSourceIn prefix) = 
+    case body of 
+      IPInEthernet ipPkt -> sourceAddress ipPkt `elemOfPrefix` prefix
+      _                  -> True
+satisfies (_, EthernetFrame _ body) (IPDestIn prefix) = 
+    case body of 
+      IPInEthernet ipPkt -> destAddress ipPkt `elemOfPrefix` prefix
+      _                  -> True
+satisfies (_, EthernetFrame _ body) (SenderTransportPortIs a) = 
+    case body of 
+      IPInEthernet (IPPacket iphdr ipbody) -> 
+          case ipbody of 
+            TCPInIP (srcp,_) -> srcp == a
+            UDPInIP (srcp,_) -> srcp == a
+      _ -> True
+satisfies (_, EthernetFrame _ body) (ReceiverTransportPortIs a) = 
+    case body of 
+      IPInEthernet (IPPacket iphdr ipbody) -> 
+          case ipbody of 
+            TCPInIP (_,destp) -> destp == a
+            UDPInIP (_,destp) -> destp == a
+      _ -> True
+satisfies x (p1 `AndPP` p2) = satisfies x p1 && satisfies x p2
+satisfies x (p1 `OrPP` p2)  = satisfies x p1 || satisfies x p2
+
+instance Logic (PortID, EthernetFrame) PacketPredicate where
+    holds = satisfies
+
+
+-- | A literal is any packet predicate except those formed using conjunction or disjunction.
+--   The type synonym does not enforce this constraint - we just use it as a reminder of the 
+--   intent.
+type Literal = PacketPredicate
+
+-- | A clause is a list of literals. A packet satisfies a clause if it satisfies
+-- all the literals in the clause. From this, it follows that any packet satisfies an 
+-- empty clause; i.e. the empty clause is equivalent to True.
+type Clause = [Literal]
+
+-- | Computes the clauses for a packet predicate; assumes the data type invariants hold. 
+-- A packet satisfies a list of clauses if it satisfies some clause in the list. From this
+-- it follows that no packet satisfies the empty list of clauses. I.e. the empty list
+-- of clauses is equivalent to False.
+clauses :: PacketPredicate -> [Clause]
+clauses (p1 `OrPP` p2) = clauses p1 ++ clauses p2
+clauses p1 = let c = normalizeClause (literals p1)
+             in if c == [FalsePP] then [] else [c]
+
+-- Helper function to normalize a clause:
+-- It does the following: 
+-- (1) removes duplicate literals
+-- (2) identifies unsatisfiable clauses
+-- (3) ensures clauses equivalent to TruePP are represented by [TruePP]
+-- Note that distinct "normal" forms may be logically equivalent, and logically equivalent 
+-- clauses may be reduced to distinct "normal" forms by this procedure. This is due to the 
+-- semantics of literals such as senderTransportIs, IPSourceIn, etc, which are really 
+-- implications. 
+normalizeClause :: Clause -> Clause
+normalizeClause = 
+    convertToTrue . conflictToFalse . remdups . normalizeSourceIPAddressConditions . normalizeDestIPAddressConditions
+    where remdups = List.nub
+          conflictToFalse ls = if (length inPortLits > 1 
+                                   || length macSourceLits > 1 
+                                   || length macDestLits > 1 
+                                   || length macFrameTypeLits > 1 
+                                   || (MacFrameTypeIs ethTypeVLAN `elem` ls && length vlanLits > 1)              
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1                                       
+                                   || (MacFrameTypeIs ethTypeVLAN `elem` ls && length vlanPriorityLits > 1)      
+#endif                                   
+                                   || (MacFrameTypeIs ethTypeIP `elem` ls   && length ipProtocolLits > 1)        
+#if OPENFLOW_VERSION==1                                   
+                                   || (MacFrameTypeIs ethTypeIP `elem` ls   && length dscpLits > 1)
+#endif                                   
+                                   || (MacFrameTypeIs ethTypeIP `elem` ls   && length senderTransportLits > 1)   
+                                   || (MacFrameTypeIs ethTypeIP `elem` ls   && length receiverTransportLits > 1) 
+                                   || elem FalsePP ls)
+                               then [FalsePP]
+                               else ls
+              where inPortLits            = [ x | InPortIs x <- ls ]
+                    macSourceLits         = [ x | MacSourceIs x <- ls]
+                    macDestLits           = [ a | MacDestIs a <- ls ]
+                    vlanLits              = [ x | VLANIDIs x <- ls]
+                    vlanPriorityLits      = [ x | VLANPriority x <- ls ]
+                    macFrameTypeLits      = [ x | MacFrameTypeIs x <- ls ]
+#if OPENFLOW_VERSION==1                                   
+                    dscpLits              = [ x | IPTypeOfService x <- ls]
+#endif                                            
+                    ipProtocolLits        = [ x | IPProtocolIs x <- ls ]
+                    senderTransportLits   = [ x | SenderTransportPortIs x <- ls ]
+                    receiverTransportLits = [ x | ReceiverTransportPortIs x <- ls ]
+                    ipSourcePrefixes      = [ x | IPSourceIn x <- ls ]
+
+          convertToTrue ls = let ls' = filter (/=TruePP) ls
+                             in if null ls' then [TruePP] else ls'
+
+          removeTrues ls   = filter (/=TruePP) ls
+
+          normalizeSourceIPAddressConditions ls = 
+              case intersects [ x | IPSourceIn x <- ls ] of 
+                Nothing -> if MacFrameTypeIs ethTypeIP `elem` ls 
+                           then [FalsePP]
+                           else ls
+                Just x  -> IPSourceIn x : filter (not . isIPSourcePred) ls
+
+          normalizeDestIPAddressConditions ls = 
+              case intersects [ x | IPDestIn x <- ls ] of 
+                Nothing -> if MacFrameTypeIs ethTypeIP `elem` ls 
+                           then [FalsePP]
+                           else ls
+                Just x  -> IPDestIn x : filter (not . isIPDestPred) ls
+
+
+isIPSourcePred :: PacketPredicate -> Bool
+isIPSourcePred (IPSourceIn _) = True
+isIPSourcePred _              = False
+
+isIPDestPred :: PacketPredicate -> Bool
+isIPDestPred (IPDestIn _) = True
+isIPDestPred _            = False
+
+-- Finds the literals in a clause; note: it is not defined for disjunctions.
+literals :: PacketPredicate -> [Literal]
+literals (p1 `AndPP` p2) = literals p1 ++ literals p2
+literals p = [p]
+
+-- | With the above, we can now calculate whether two packet predicates
+--   overlap, that is, when their intersection is non-empty.
+overlaps :: PacketPredicate -> PacketPredicate -> Bool
+p1 `overlaps` p2 = clauses (p1 <&> p2) /= []
+
+-- | Commonly occurring packet predicates.
+dhcp, dns, arp, ip, udp :: PacketPredicate
+dhcp     = ip <&> udp <&> (senderTransportIs dhcpPort <|> receiverTransportIs dhcpPort)
+dns      = ip <&> udp <&> (senderTransportIs dnsPort  <|> receiverTransportIs dnsPort)
+arp      = ethFrameTypeIs ethTypeARP
+lldp     = ethFrameTypeIs ethTypeLLDP
+ip       = ethFrameTypeIs ethTypeIP
+udp      = transportProtocolIs udpCode
+
+udpCode  = 17
+dhcpPort = 67
+dnsPort  = 53
+
+ethSourceDestAre :: EthernetAddress -> EthernetAddress -> PacketPredicate
+ethSourceDestAre s d = ethSourceIs s <&> ethDestIs d
+
+-- | The disjunction of (toMatches pred) matches the same set of 
+--   packets as the packet predicate pred does.
+toMatches :: PacketPredicate -> Maybe [Match]
+toMatches p = if all realizableClause cs
+              then Just [ fromJust mm | c <- clauses p, let mm = clauseToMatch c, isJust mm ]
+              else Nothing
+    where cs = clauses p
+
+realizable :: PacketPredicate -> Bool
+realizable = all realizableClause . clauses
+
+realizableClause :: Clause -> Bool
+realizableClause lits 
+    | FalsePP `elem` lits = False
+    | conflictExists      = False
+    | otherwise           = True
+    where conflictExists = length vlanLits > 1            
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1              
+                           || length vlanPriorityLits > 1    
+#endif                           
+                           || length ipProtocolLits > 1      
+#if OPENFLOW_VERSION==1                           
+                           || length dscpLits > 1
+#endif                           
+                           || length ipSourcePrefixes > 1    
+                           || length ipDestPrefixes > 1      
+                           || length senderTransportLits > 1 
+                           || length receiverTransportLits > 1 
+          vlanLits              = [ x | VLANIDIs x <- lits                ]
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1              
+          vlanPriorityLits      = [ x | VLANPriority x <- lits            ]
+#endif          
+          ipProtocolLits        = [ x | IPProtocolIs x <- lits            ]
+#if OPENFLOW_VERSION==1                                   
+          dscpLits              = [ x | IPTypeOfService x <- lits         ]
+#endif                                            
+          senderTransportLits   = [ x | SenderTransportPortIs x <- lits   ]
+          receiverTransportLits = [ x | ReceiverTransportPortIs x <- lits ]
+          ipSourcePrefixes      = [ x | IPSourceIn x <- lits              ]
+          ipDestPrefixes        = [ x | IPDestIn x <- lits                ]
+
+-- Converts a single clause to maybe a match; If the clause is unsatisfiable,
+-- then it is converted to Nothing.
+clauseToMatch :: Clause -> Maybe Match
+clauseToMatch [] = Just matchAny 
+clauseToMatch (p:ps) = toMatchAux (p:ps) (Just matchAny)
+
+toMatchAux :: Clause -> Maybe Match -> Maybe Match
+toMatchAux [] m = m
+toMatchAux (p:ps) mm = do m <- mm 
+                          toMatchAux ps (literalToMatchUpdate p m)
+
+literalToMatchUpdate :: Literal -> Match -> Maybe Match
+literalToMatchUpdate TruePP m                      = Just matchAny
+literalToMatchUpdate FalsePP m                     = undefined
+literalToMatchUpdate (InPortIs p)    (Match {..})  = Just $ Match { inPort = Just p, .. } 
+literalToMatchUpdate (MacSourceIs a) m             = Just $ m { srcEthAddress    = Just a }
+literalToMatchUpdate (MacDestIs a)   m             = Just $ m { dstEthAddress    = Just a } 
+literalToMatchUpdate (VLANIDIs  a)   m             = Just $ m { vLANID           = Just a }
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1    
+literalToMatchUpdate (VLANPriority a)   m          = Just $ m { vLANPriority     = Just a }
+#endif
+literalToMatchUpdate (MacFrameTypeIs a) m          = Just $ m { ethFrameType     = Just a } 
+literalToMatchUpdate (IPProtocolIs a) m            = Just $ m { Match.ipProtocol = Just a }
+#if OPENFLOW_VERSION==1    
+literalToMatchUpdate (IPTypeOfService a) m         = Just $ m { Match.ipTypeOfService = Just a }
+#endif
+literalToMatchUpdate (IPSourceIn prefix) m         = Just $ m { srcIPAddress     = prefix }
+literalToMatchUpdate (IPDestIn prefix) m           = Just $ m { dstIPAddress     = prefix }
+literalToMatchUpdate (SenderTransportPortIs  a)  m = Just $ m { srcTransportPort = Just a } 
+literalToMatchUpdate (ReceiverTransportPortIs a) m = Just $ m { dstTransportPort = Just a } 
+
+-- | Calculates a packet predicate that matches the same in-packets as the given match.
+fromMatch :: Match -> PacketPredicate
+fromMatch (Match {Match.ipTypeOfService=ipTypeOfService',..}) = 
+  ands [ maybe TruePP inPortIs inPort, 
+         maybe TruePP ethSourceIs srcEthAddress,
+         maybe TruePP ethDestIs dstEthAddress,
+         maybe TruePP vLANIDIs vLANID,
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1             
+         maybe TruePP VLANPriority vLANPriority,
+#endif         
+         maybe TruePP ethFrameTypeIs ethFrameType,
+         maybe TruePP transportProtocolIs ipProtocol,
+#if OPENFLOW_VERSION==1             
+         maybe TruePP ipTypeOfService ipTypeOfService',
+#endif
+         if srcIPAddress == defaultIPPrefix then TruePP else ipSourceIn srcIPAddress,
+         if dstIPAddress == defaultIPPrefix then TruePP else ipDestIn dstIPAddress,
+         maybe TruePP senderTransportIs srcTransportPort,
+         maybe TruePP receiverTransportIs dstTransportPort
+       ]
+
+packetInMatches :: PacketInfo -> PacketPredicate -> Either ErrorMessage Bool
+packetInMatches pktIn pred = 
+  do ethFrame <- runGet (runErrorT getEthernetFrame) (packetData pktIn)
+     return ((receivedOnPort pktIn, ethFrame) |- pred)
+
+packetInFrame :: PacketInfo -> Either ErrorMessage EthernetFrame
+packetInFrame = runGet (runErrorT getEthernetFrame) . packetData 
+
+exactPredicate :: PacketInfo -> Either ErrorMessage PacketPredicate
+exactPredicate pktIn = 
+  do match <- runGet (runErrorT (getExactMatch inPort)) pktData 
+     return $ fromMatch match
+    where inPort  = receivedOnPort pktIn
+          pktData = packetData pktIn
+
diff --git a/src/Nettle/FRPControl/SwitchInterface.hs b/src/Nettle/FRPControl/SwitchInterface.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/SwitchInterface.hs
@@ -0,0 +1,233 @@
+{-# LANGUAGE Arrows, CPP #-}
+
+-- | This module defines type classes for input types carrying
+-- switch messages and output types carrying switch commands. It defines
+-- a few basic instances of these classes. In addition it defines
+-- some signal functions that implement the most basic functionality to maintain  
+-- switch-controller connections.
+module Nettle.FRPControl.SwitchInterface
+    (
+     -- * Switch input 
+     SwitchMessage 
+     , SockAddr
+     , switchJoinE
+     , switchLeaveE
+     , switchHelloE            
+     , switchEchoRequestE
+     , switchEchoReplyE
+     , packetInE 
+     , switchFeaturesE
+     , portUpdateE      
+     , switchErrorE
+     , flowRemovalE
+     , statsReplyE
+     , portStatsReplyE
+     , flowStatsReplyE
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
+     , barrierReplyE
+#endif
+     , filterPacketIns
+
+     -- * Switch output
+     , SwitchOutput
+     , switchCommand
+     , noOp
+     , (<+>)
+
+     -- * Driver
+     , switchInterfaceDriver
+
+     -- * Basic OpenFlow controller
+     , openFlowController
+    ) where
+
+import Nettle.Ethernet.EthernetAddress
+import Nettle.OpenFlow.Messages as M
+import Nettle.OpenFlow.Switch
+import Nettle.OpenFlow.Port
+import Nettle.OpenFlow.Action
+import Nettle.OpenFlow.Match
+import Nettle.OpenFlow.FlowTable
+import Nettle.OpenFlow.Statistics
+import Nettle.OpenFlow.Error
+import Nettle.OpenFlow.Packet
+import Nettle.OpenFlow.MessagesBinary as M
+import Nettle.Servers.TCPServer
+import Nettle.Servers.MultiplexedTCPServer 
+import Nettle.FRPControl.AFRP 
+import Data.Word
+import Data.Monoid 
+import Control.Exception 
+
+-- | A switch message is a TCP message where normal messages
+-- contain a @TransactionID@ and an @SCMessage@
+type SwitchMessage = TCPMessage (TransactionID, SCMessage)
+
+-- | Projects out the @SockAddr@ associated with the switch from a @ConnectionEstablished@ @TCPMessage@.
+switchJoinE :: Event SwitchMessage -> Event SockAddr
+switchJoinE = mapFilterE f 
+    where f (ConnectionEstablished addr) = Just addr
+          f _ = Nothing
+
+-- | Outputs an event whenever the switch disconnects from the controller. 
+-- The event carries the @SockAddr@ used to communicate with the switch and 
+-- an @IOException@ value indicating the reason for the disconnection.
+switchLeaveE :: Event SwitchMessage -> Event (SockAddr, IOException)
+switchLeaveE = mapFilterE f
+    where f (ConnectionTerminated addr e) = Just (addr, e)
+          f _ = Nothing
+
+-- | Outputs an event whenever a switch sends a hello message.
+switchHelloE :: Event SwitchMessage -> Event (SockAddr, TransactionID)
+switchHelloE = mapFilterE f 
+    where f (PeerMessage sw (msgID, SCHello)) = Just (sw, msgID)
+          f _             = Nothing
+
+-- | Outputs an event whenever a switch sends an echo request; carries 
+-- the @SockAddr@ of the switch, the @TransactionID@ of the echo request, 
+-- and the data included in the echo request.
+switchEchoRequestE :: Event SwitchMessage -> Event (SockAddr, TransactionID, [Word8])
+switchEchoRequestE = mapFilterE f
+    where f (PeerMessage sw (msgID, SCEchoRequest bytes)) = Just (sw, msgID, bytes)
+          f _                                                = Nothing
+
+-- | Outputs an event whenever a switch sends an echo reply; carries 
+-- the @SockAddr@ of the switch, the @TransactionID@ of the echo reply, 
+-- and the data included in the echo reply.
+switchEchoReplyE :: Event SwitchMessage -> Event (SockAddr, TransactionID, [Word8])
+switchEchoReplyE = mapFilterE f
+    where f (PeerMessage sw (msgID, SCEchoReply bytes)) = Just (sw, msgID, bytes)
+          f _                                              = Nothing
+
+-- | Outputs an event whenever a switch sends a packet in message.
+-- The event carries the @SockAddr@ of the switch, the @TransactionID@ of the
+-- message, and the @PacketInfo@ message itself.
+packetInE ::  Event SwitchMessage -> Event (SockAddr, TransactionID, PacketInfo)
+packetInE = mapFilterE f
+    where f (PeerMessage sw (msgID, PacketIn pktRecord)) = Just (sw, msgID, pktRecord)
+          f _ = Nothing
+
+-- | Outputs an event whenever a switch sends a switch features message.
+-- The event carries the @SockAddr@ of the switch, the @TransactionID@ of the
+-- message, and the @SwitchFeatures@ message itself.
+switchFeaturesE :: Event SwitchMessage -> Event (SockAddr, TransactionID, SwitchFeatures)
+switchFeaturesE = mapFilterE f 
+    where f (PeerMessage sw (msgID, Features x)) = Just (sw, msgID, x)
+          f _ = Nothing
+
+-- | Outputs an event whenever a switch sends a port update message.
+-- The event carries the @SockAddr@ of the switch, the @TransactionID@ of the
+-- message, and the @PortStatus@ message itself.
+portUpdateE :: Event SwitchMessage -> Event (SockAddr, TransactionID, PortStatus)
+portUpdateE = mapFilterE f
+    where f (PeerMessage sw (msgID, M.PortStatus x)) = Just (sw, msgID, x)
+          f _ = Nothing
+
+-- | Outputs an event whenever a switch sends an error message.
+-- The event carries the @SockAddr@ of the switch, the @TransactionID@ of the
+-- message, and the @SwitchError@ message itself.
+switchErrorE :: Event SwitchMessage -> Event (SockAddr, TransactionID, SwitchError)
+switchErrorE = mapFilterE f
+    where f (PeerMessage sw (msgID, Error x)) = Just (sw, msgID, x)
+          f _ = Nothing
+
+-- | Outputs an event whenever a switch sends an flow removed message.
+-- The event carries the @SockAddr@ of the switch, the @TransactionID@ of the
+-- message, and the @FlowRemoved@ message itself.
+flowRemovalE :: Event SwitchMessage -> Event (SockAddr, TransactionID, FlowRemoved)
+flowRemovalE = mapFilterE f
+    where f (PeerMessage sw (msgID, M.FlowRemoved x)) = Just (sw, msgID, x)
+          f _ = Nothing
+
+#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
+-- | Outputs an event whenever a switch sends a barrier reply.
+-- The event carries the @SockAddr@ of the switch and the @TransactionID@ of the
+-- message.
+barrierReplyE :: Event SwitchMessage -> Event (SockAddr, TransactionID)
+barrierReplyE = mapFilterE f
+    where f (PeerMessage sw (msgID, BarrierReply)) = Just (sw, msgID)
+          f _                      = Nothing
+#endif
+
+-- | Outputs an event whenever a switch sends statistics reply.
+-- The event carries the @SockAddr@ of the switch, the @TransactionID@ of the
+-- message, and the @StatsReply@ message itself.
+statsReplyE ::Event SwitchMessage -> Event (SockAddr, TransactionID, StatsReply)
+statsReplyE = mapFilterE f
+    where f (PeerMessage sw (msgID, StatsReply reply)) = Just (sw, msgID, reply)
+          f _ = Nothing
+
+-- | Outputs an event whenever a switch sends port statistics reply.
+-- The event carries the @SockAddr@ of the switch, the @TransactionID@ of the
+-- message, a flag indicating whether more statistics for this reply will follow 
+-- in a separate message and the port statistics included in this message itself.
+portStatsReplyE :: Event SwitchMessage -> Event (SockAddr, TransactionID, MoreToFollowFlag, [(PortID, PortStats)])
+portStatsReplyE = statsReplyE >>> arr (mapFilterE f)
+  where f (addr, xid, PortStatsReply moreComing ports) = Just (addr, xid, moreComing, ports)
+        f _ = Nothing
+
+-- | Outputs an event whenever a switch sends flow statistics reply.
+-- The event carries the @SockAddr@ of the switch, the @TransactionID@ of the
+-- message, a flag indicating whether more statistics for this reply will follow 
+-- in a separate message and the flow statistics included in this message itself.
+flowStatsReplyE :: Event SwitchMessage -> Event (SockAddr, TransactionID, MoreToFollowFlag, [FlowStats])
+flowStatsReplyE = statsReplyE >>> arr (mapFilterE f)
+  where f (addr, xid, FlowStatsReply moreComing stats) = Just (addr, xid, moreComing, stats)
+        f _ = Nothing
+
+-- | Remove packet in messages not satisfying the given predicate.
+filterPacketIns :: (PacketInfo -> Bool) -> Event SwitchMessage -> Event SwitchMessage
+filterPacketIns p = mapFilterE p'
+  where p' m = case m of 
+          PeerMessage switch (xid, PacketIn pktIn) -> if p pktIn then Just m else Nothing
+          _ -> Just m
+
+-----------------------------------------------------
+-- Switch output commands
+-----------------------------------------------------
+-- An implementation of HasSwitchCommands
+type SwitchOutput       = [(SockAddr, (TransactionID, CSMessage))]
+                          
+switchCommand :: SockAddr -> TransactionID -> CSMessage -> SwitchOutput 
+switchCommand addr xid msg = [(addr, (xid, msg))]
+
+-- | Another name for the unit element of a Monoid, specialized to the HasSwitchCommands class.
+noOp :: Monoid o => o
+noOp = mempty
+
+-- | Infix binary operator for mappend.
+(<+>) :: Monoid o => o -> o -> o 
+(<+>) = mappend
+
+-- | Monoid instance for a Monoid embedded inside an Event.
+instance Monoid a => Monoid (Event a) where
+    mempty  = NoEvent
+    mappend = mergeBy mappend
+
+-------------------------------------
+
+-- | Runs an OpenFlow server at the specified port number, and return the driver IO actions.
+switchInterfaceDriver :: ServerPortNumber -> IO (IO SwitchMessage, SwitchOutput -> IO ())
+switchInterfaceDriver portNumber = 
+    do process <- openFlowServer portNumber
+       let actuator csMsgs = writeAll process csMsgs
+       return (readP process, actuator)
+
+-- | @openFlowController@ implements the basic aspects of the OpenFlow
+-- protocol, such as the initial version negotiation and responding to 
+-- echo requests.
+openFlowController :: SF (Event SwitchMessage) (Event SwitchOutput)
+openFlowController = 
+    proc i -> do 
+      o1E <- greeter     -< i
+      o2E <- echoHandler -< i
+      returnA -< mergeBy (<+>) o1E o2E
+
+echoHandler :: SF (Event SwitchMessage) (Event SwitchOutput)
+echoHandler = arr (fmap (\(addr, xid, bytes) -> switchCommand addr xid (CSEchoReply bytes)) . switchEchoRequestE)
+
+greeter :: SF (Event SwitchMessage) (Event SwitchOutput)
+greeter = 
+    proc i -> do
+      returnA -< liftE (\(addr, msgID) -> switchCommand addr msgID CSHello) (switchHelloE i)
+
diff --git a/src/Nettle/FRPControl/TrafficGenerator.hs b/src/Nettle/FRPControl/TrafficGenerator.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/FRPControl/TrafficGenerator.hs
@@ -0,0 +1,130 @@
+{-# LANGUAGE Arrows, TypeOperators #-}
+
+-- | Module that can be used to generate UDP traffic using a signal 
+-- function that outputs packets and displays information on the local
+-- console.
+module Nettle.FRPControl.TrafficGenerator 
+    (
+     TrafficGenerator
+    , PacketSendCommand
+    , ConsoleMessage
+    , UDPPort
+    , driveTrafficGenerator
+
+    ) where 
+
+import Network.Socket
+import Data.Word
+import Data.Bits
+import Control.Exception
+import Nettle.IPv4.IPAddress
+import Nettle.FRPControl.AFRP
+import Control.Concurrent.MVar
+import Control.Concurrent
+import Data.Time.Clock (getCurrentTime, diffUTCTime)
+import Control.Monad
+
+-- |The type of signal function that can be used to generate UDP traffic.
+type TrafficGenerator    = SF () (Event PacketSendCommand) 
+
+-- |A console message is simply a string.
+type ConsoleMessage = String
+
+-- |A packet send command is a list of triples including the destination address, 
+-- the UDP port, and the payload (as a String).
+type PacketSendCommand   = [(IPAddress, UDPPort, String)]
+
+-- |A UDP port is a 16 bit number.
+type UDPPort = Word16
+
+
+-- |Drive (i.e. run) a traffic generator.
+driveTrafficGenerator :: SF () (Event PacketSendCommand, Event ConsoleMessage) -> IO ()
+driveTrafficGenerator sf = do 
+
+  cntVar           <- newMVar 0
+  lastSenseTimeVar <- newEmptyMVar
+  inCh             <- newChan 
+
+  let initiator = do forkIO $ genClockSignal inCh
+                     t <- getCurrentTime
+                     putMVar lastSenseTimeVar t
+                     return ()
+
+  let sensor _ = do ma <- readChan inCh
+                    t' <- getCurrentTime
+                    t  <- swapMVar lastSenseTimeVar t'
+                    let delta = fromRational (toRational (diffUTCTime t' t))
+                    return (delta, ma)
+
+  let actuator sock _ (e1,e2) = 
+          do event (return ()) (mapM_ send) e1
+             event (return ()) putStr e2
+             return False
+          where send (addr,port,msg) = let ipAddr     = toHostAddress addr 
+                                           udpPortNum = PortNum (flipBytes port) 
+                                           dest       = SockAddrInet udpPortNum ipAddr
+                                       in do sendTo sock msg dest
+                                             modifyMVar_ cntVar (return . (+1)) 
+                                             return ()
+  sock   <- socket AF_INET Datagram defaultProtocol
+  finally (reactimate initiator sensor (actuator sock) sf)
+          (do sClose sock
+              cnt <- readMVar cntVar
+              putStrLn ("Number of packets sent: " ++ show cnt)
+          )
+
+    where 
+
+      genClockSignal ch  = 
+          forever (threadDelay clockCycle >> writeChan ch Nothing)
+          where clockCycle = 1000
+
+flipBytes :: Word16 -> Word16
+flipBytes word = shiftL lbyte 8 + hbyte
+    where hbyte = shiftR word 8 .&. (2^8 - 1)
+          lbyte = word .&. (2^8 - 1)
+
+toHostAddress :: IPAddress -> HostAddress
+toHostAddress addr = shiftL (fromIntegral b4) 24 + 
+                     shiftL (fromIntegral b3) 16 + 
+                     shiftL (fromIntegral b2) 8 + 
+                     fromIntegral b1
+    where (b1,b2,b3,b4) = addressToOctets addr
+
+
+  
+{-
+-- |This function can be used to run a traffic generator.
+driveTrafficGenerator :: TrafficGenerator -> IO ()
+driveTrafficGenerator sf = do 
+  cntVar <- newMVar 0
+  let senseChans = ()
+  sock <- socket AF_INET Datagram defaultProtocol
+  let send (addr,port,msg) = let ipAddr     = toHostAddress addr 
+                                 udpPortNum = PortNum (flipBytes port) 
+                                 dest       = SockAddrInet udpPortNum ipAddr
+                             in do sendTo sock msg dest
+                                   modifyMVar_ cntVar (return . (+1)) 
+                                   return ()
+  let packetActuator e = case e of 
+                           Event cs -> mapM_ send cs
+                           NoEvent  -> return ()
+  let actuators = (packetActuator, ())
+  let sf' = arr (const ()) >>> sf >>> arr (\e -> OutCons (e, (OutNil ())))
+  finally (sfDriver inputRep senseChans outputRep actuators sf') (sClose sock >> readMVar cntVar >>= \cnt -> putStrLn ("Number sent: " ++ show cnt))
+
+
+
+type InputVector     = TNil
+type ControllerInput = SFInput InputVector -- ESumNil () 
+inputRep :: Rep InputVector
+inputRep = RepNil
+
+type OutputVector      = Event PacketSendCommand ::: TNil
+type ControllerOutput  = SFOutput OutputVector -- == OutCons (Event PacketSendCommand) (OutNil ())
+
+outputRep :: Rep OutputVector
+outputRep = RepCons RepNil
+-}
+
diff --git a/src/Nettle/LLDP/LLDP.hs b/src/Nettle/LLDP/LLDP.hs
new file mode 100644
--- /dev/null
+++ b/src/Nettle/LLDP/LLDP.hs
@@ -0,0 +1,75 @@
+module Nettle.LLDP.LLDP (
+
+             LLDPDU ( .. ), 
+             getLLDPInEthernet
+
+                        ) where
+
+import Data.Binary
+import Data.Binary.Get (skip)
+import Nettle.Ethernet.EthernetAddress
+import Nettle.Ethernet.EthernetFrame
+import Control.Monad.Error
+
+data LLDPDU = LLDPDU {
+      
+      chassisID  :: Word64,
+      -- make PortID of type PortID (=Word16) when that definition is refactored
+      -- from Nettle.OpenFlow.Messages0x98 to Nettle.OpenFlow.Base
+      portID     :: Word16,
+      timeToLive :: Word16
+
+    } deriving (Eq, Show)
+
+
+instance Binary LLDPDU where
+    get = do
+
+      skip $ headerLength + subtypeLength
+      address <- get
+
+      skip $ headerLength + subtypeLength
+      portNumber <- get
+
+      skip $ headerLength
+      timeUntilExpiration <- get
+      
+      skip headerLength
+
+      return LLDPDU { 
+                   chassisID=address, 
+                   portID=portNumber, 
+                   timeToLive=timeUntilExpiration 
+                 }
+
+
+    put LLDPDU { chassisID=cid, portID=pid, timeToLive=ttl } = do
+                         
+                         put chassisIDHeader
+                         put chassisIDSubtype
+                         put cid
+
+                         put portIDHeader
+                         put portIDSubtype
+                         put pid
+
+                         put timeToLiveHeader
+                         put ttl
+
+                         put endOfLLDPDUTLV
+
+chassisIDHeader = 521 :: Word16
+chassisIDSubtype = 4 :: Word8
+portIDHeader = 1027 :: Word16
+portIDSubtype = 2 :: Word8
+timeToLiveHeader = 1538 :: Word16
+endOfLLDPDUTLV = 0 :: Word16
+
+headerLength = 2
+subtypeLength = 1
+
+getLLDPInEthernet :: GetE LLDPDU
+getLLDPInEthernet = 
+    do ethHeader <- getEthHeader
+       lldpdu    <- lift get
+       return lldpdu