packages feed

nettle-frp (empty) → 0.1

raw patch · 34 files changed

+5652/−0 lines, 34 filesdep +basedep +bimapdep +binarysetup-changed

Dependencies added: base, bimap, binary, bytestring, containers, haskell98, mtl, nettle-openflow, network, network-data, time

Files

+ LICENSE view
@@ -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.
+ LICENSE-AFRP.txt view
@@ -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.
+ README view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main = defaultMain+
+ nettle-frp.cabal view
@@ -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
+ src/Examples/AFRPControl/LearningNetwork.hs view
@@ -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)+
+ src/Examples/AFRPControl/TrackPorts.hs view
@@ -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 ]+
+ src/Examples/AFRPControl/TrackSwitches.hs view
@@ -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)))
+ src/Nettle/Discovery/Discovery.hs view
@@ -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+
+ src/Nettle/Discovery/Topology.hs view
@@ -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
+ src/Nettle/Discovery/Topology_Internal.hs view
@@ -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
+ src/Nettle/FRPControl/AFRP.hs view
@@ -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))+
+ src/Nettle/FRPControl/AFRPAffineSpace.hs view
@@ -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)
+ src/Nettle/FRPControl/AFRPDiagnostics.hs view
@@ -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)
+ src/Nettle/FRPControl/AFRPEvent.hs view
@@ -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
+ src/Nettle/FRPControl/AFRPForceable.hs view
@@ -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
+ src/Nettle/FRPControl/AFRPGeometry.hs view
@@ -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++
+ src/Nettle/FRPControl/AFRPInternals.hs view
@@ -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)+++-}
+ src/Nettle/FRPControl/AFRPMergeableRecord.hs view
@@ -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
+ src/Nettle/FRPControl/AFRPMiscellany.hs view
@@ -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
+ src/Nettle/FRPControl/AFRPPoint2.hs view
@@ -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
+ src/Nettle/FRPControl/AFRPPoint3.hs view
@@ -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
+ src/Nettle/FRPControl/AFRPTask.hs view
@@ -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???
+ src/Nettle/FRPControl/AFRPUtilities.hs view
@@ -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 (^+^)
+ src/Nettle/FRPControl/AFRPUtils.hs view
@@ -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)+
+ src/Nettle/FRPControl/AFRPVector2.hs view
@@ -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
+ src/Nettle/FRPControl/AFRPVector3.hs view
@@ -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
+ src/Nettle/FRPControl/AFRPVectorSpace.hs view
@@ -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+++
+ src/Nettle/FRPControl/NetInfo.hs view
@@ -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+
+ src/Nettle/FRPControl/NettleSF.hs view
@@ -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)+
+ src/Nettle/FRPControl/PacketPredicate.hs view
@@ -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+
+ src/Nettle/FRPControl/SwitchInterface.hs view
@@ -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)+
+ src/Nettle/FRPControl/TrafficGenerator.hs view
@@ -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+-}+
+ src/Nettle/LLDP/LLDP.hs view
@@ -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