AERN-Net (empty) → 0.2.0
raw patch · 25 files changed
+4529/−0 lines, 25 filesdep +AERN-Realdep +AERN-RnToRmdep +basesetup-changed
Dependencies added: AERN-Real, AERN-RnToRm, base, binary, containers, html, stm, time
Files
- AERN-Net.cabal +73/−0
- ChangeLog +4/−0
- LICENCE +30/−0
- Setup.lhs +3/−0
- src/Control/ERNet/Blocks/Basic.hs +409/−0
- src/Control/ERNet/Blocks/Control/Basic.hs +494/−0
- src/Control/ERNet/Blocks/Real/Basic.hs +109/−0
- src/Control/ERNet/Blocks/Real/Protocols.hs +137/−0
- src/Control/ERNet/Blocks/RnToRm/Basic.hs +762/−0
- src/Control/ERNet/Blocks/RnToRm/Protocols.hs +233/−0
- src/Control/ERNet/Deployment/Local/Channel.hs +478/−0
- src/Control/ERNet/Deployment/Local/Logger.hs +57/−0
- src/Control/ERNet/Deployment/Local/Manager.hs +165/−0
- src/Control/ERNet/Foundations/Channel.hs +177/−0
- src/Control/ERNet/Foundations/Event.hs +75/−0
- src/Control/ERNet/Foundations/Event/JavaScript.hs +108/−0
- src/Control/ERNet/Foundations/Event/Logger.hs +31/−0
- src/Control/ERNet/Foundations/Manager.hs +140/−0
- src/Control/ERNet/Foundations/Process.hs +101/−0
- src/Control/ERNet/Foundations/Protocol.hs +154/−0
- src/Control/ERNet/Foundations/Protocol/StandardCombinators.hs +371/−0
- src/ernet-trace.html +69/−0
- tests/DemoMax.hs +133/−0
- tests/DemoSqrt.hs +147/−0
- tests/ernet-trace.html +69/−0
+ AERN-Net.cabal view
@@ -0,0 +1,73 @@+Name: AERN-Net+Version: 0.2.0+Cabal-Version: >= 1.2+Build-Type: Simple+License: BSD3+License-File: LICENCE+Author: Michal Konecny (Aston University)+Copyright: (c) 2007-2008 Michal Konecny+Maintainer: mik@konecny.aow.cz+Stability: experimental+Category: Math, Distributed Computing+Synopsis: Compositional lazy dataflow networks for exact real number computation+Tested-with: GHC ==6.8.3+Description:+ AERN-Net provides+ datatypes and abstractions for defining and executing+ networks of communicating processes. These networks have a fixed+ topology, which can be infinite via recursion.+ The communication on each channel is driven by+ some query-response protocol. Basic protocols+ for communicating approximations of real numbers and+ functions are provided together with protocol combinators+ eg for communicating value pairs or lists+ and communicating with additional query parameters+ or with optimised repetitions.+ .+ An class-based abstraction is provided to make it possible+ to execute networks on various distributed backends without modification.+ At the moment there is only one backend, which is not distributed.+ It is envisaged that truly distributed backends will be added soon,+ eg based on plain TCP, MPI or REST/SOAP Web services.+ .+ A mathematical foundation of these networks is described+ in the draft+ paper <http://www-users.aston.ac.uk/~konecnym/papers/ernets08-draft.html>.+ .+ Simple examples of usage can be found in modules @DemoMax@ and @DemoSqrt@ + in folder @tests@.+Extra-source-files:+ tests/DemoMax.hs tests/DemoSqrt.hs tests/ernet-trace.html src/ernet-trace.html+Data-files:+ ChangeLog++Flag containers-in-base+ Default: False++Library+ hs-source-dirs: src+ if flag(containers-in-base)+ Build-Depends:+ base < 3, binary >= 0.4, html, time, stm, AERN-Real >= 0.9.8, AERN-RnToRm >= 0.4.2+ else+ Build-Depends:+ base >= 3, containers, binary >= 0.4, html, time, stm, AERN-Real >= 0.9.8, AERN-RnToRm >= 0.4.2+ Exposed-modules:+ Control.ERNet.Blocks.Basic+ Control.ERNet.Blocks.Control.Basic+ Control.ERNet.Blocks.Real.Basic+ Control.ERNet.Blocks.Real.Protocols+ Control.ERNet.Blocks.RnToRm.Basic+ Control.ERNet.Blocks.RnToRm.Protocols+ Control.ERNet.Foundations.Event.Logger+ Control.ERNet.Foundations.Event.JavaScript+ Control.ERNet.Foundations.Channel+ Control.ERNet.Foundations.Protocol.StandardCombinators+ Control.ERNet.Foundations.Manager+ Control.ERNet.Foundations.Process+ Control.ERNet.Foundations.Event+ Control.ERNet.Foundations.Protocol+ Control.ERNet.Deployment.Local.Channel+ Control.ERNet.Deployment.Local.Manager+ Control.ERNet.Deployment.Local.Logger+
+ ChangeLog view
@@ -0,0 +1,4 @@+0.2.0: ?? November 2008+ * initial public release of AERN-Net after two years of work and many internal experiments+ and refactorings+
+ LICENCE view
@@ -0,0 +1,30 @@+Copyright (c) 2007-2008 Michal Konecny, Amin Farjudian, Jan Duracz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY 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 AUTHORS 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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Control/ERNet/Blocks/Basic.hs view
@@ -0,0 +1,409 @@+{-|+ Module : Control.ERNet.Blocks.Basic+ Description : generic processes and process templates+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ Definitions of a few universaly useful simple network processes + and process templates. +-}+module Control.ERNet.Blocks.Basic+(+ constantProcess,+ constantChangedProcess,+ constantStatefulProcess,+ passThroughProcess,+ maybePassThroughProcess,+ passThroughStatefulProcess,+ passThroughBinaryStatefulProcess,+ passThroughBinaryProcess,+ rateProcess,+ precProcess+) +where++import Control.ERNet.Foundations.Protocol +import Control.ERNet.Foundations.Protocol.StandardCombinators+import qualified Control.ERNet.Foundations.Event.Logger as LG +import qualified Control.ERNet.Foundations.Channel as CH +import Control.ERNet.Foundations.Process ++import Data.Number.ER.BasicTypes++import Data.Maybe+import Data.Typeable+import qualified Data.Map as Map++import Control.Concurrent as Concurrent+import Control.Concurrent.STM as STM+import Data.Number.ER.MiscSTM++{-|+ A generic stateless process with no inputs.+-}+constantProcess ::+ (QAProtocol q a, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcessName {-^ process identifier (string) -} ->+ (q -> a) {- ^ function to answer queries -} ->+ ChannelType {- ^ result channel type -} ->+ ERProcess sInAnyProt sOutAnyProt+constantProcess defName responderFn =+ constantStatefulProcess defName responderTransferFn ()+ where+ responderTransferFn _ (_, q) = + (responderFn q, Nothing)+ +{-|+ A generic process with no inputs that answers using a ChTChanges protocol.+-}+constantChangedProcess ::+ (QAProtocol q a, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcessName {-^ process identifier (string) -} ->+ (q -> a) {- ^ function to answer queries (without the ChTChanges wrapper) -} ->+ ChannelType {- ^ result channel type -} ->+ ERProcess sInAnyProt sOutAnyProt+constantChangedProcess defName responderFn chtp =+ constantProcess defName responderNoChangesFn chtp+ where+ responderNoChangesFn (QAChangesQ q) = + (QAChangesANew (responderFn q))+ responderNoChangesFn (QAChangesQIfNew _ _) =+ QAChangesASame+ responderNoChangesFn (QAChangesQWhenNew _ _) =+ QAChangesAGivenUp+ +{-|+ A generic stateful process with no inputs.+-}+constantStatefulProcess ::+ (QAProtocol q a, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcessName {-^ process identifier (string) -} ->+ (s -> (QueryId, q) -> (a, Maybe s)) {- ^ function to answer queries and transform state -} ->+ s {-^ initial state -} ->+ ChannelType {- ^ result channel type -} ->+ ERProcess sInAnyProt sOutAnyProt+constantStatefulProcess defName responderTransferFn initState chtp =+ ERProcess defName deploy [] [chtp]+ where+ deploy _ [] [resCHA] _ = + do+ stateTV <- newTVarIO initState+ dispatcher stateTV+ where+ resCH = + CH.castOut + "ERNet.Blocks.Basic: constantStatefulProcess: resCH: "+ resCHA+ dispatcher stateTV = + do+ qryData <- CH.waitForQuery resCH+-- putStrLn $ name ++ ": got query"+ forkIO $ responder stateTV qryData+ dispatcher stateTV+ responder stateTV (qryId, qry) =+ do+ ans <- atomically updateState+ CH.answerQuery True resCH (qryId, ans)+-- putStrLn $ name ++ ": answered query+ where+ updateState =+ do+ state <- readTVar stateTV+ case responderTransferFn state (qryId, qry) of+ (ans, Nothing) -> return ans+ (ans, Just newState) ->+ do+ writeTVar stateTV newState+ return ans++{-|+ A process that passes on a translated version of each query+ to another process. When the other other answers, it analyses+ the answer and decides whether to send another query or+ answer its original query.+ + Several simpler processes are defined as specialisations of this one.+-} +passThroughStatefulProcess ::+ (QAProtocol q1 a1, QAProtocol q2 a2, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ Bool {-^ should use channel cache? -} ->+ ERProcessName ->+ (s -> (QueryId, q1) -> (Either q2 a1, Maybe s)) {-^ what to do with a query + forward or reply -} ->+ (s -> (QueryId, q1) -> a2 -> (Either q2 a1, Maybe s)) {-^ what to do with an answer - another query or reply -} ->+ s {-^ initial state -} -> + ChannelType {-^ argument channel type -} ->+ ChannelType {-^ result channel type -} ->+ ERProcess sInAnyProt sOutAnyProt++passThroughStatefulProcess useCache defName qryStFn ansStFn initState chtpIn chtpRes =+ ERProcess defName deploy [chtpIn] [chtpRes]+ where+ deploy deployName [argCHA] [resCHA] _ =+ do+ stateTV <- newTVarIO initState+ dispatcher stateTV+ where+ resCH = + CH.castOut "ERNet.Blocks.Basic: passThroughStatefulProcess: resCH: "+ resCHA+ argCH = + CH.castIn "ERNet.Blocks.Basic: passThroughStatefulProcess: argCH: " + argCHA + + dispatcher stateTV =+ do+ qryData <- CH.waitForQuery resCH+ forkIO $ responder stateTV qryData+ dispatcher stateTV+ responder stateTV qryData@(resQryId, qry) =+ do+ qry2OrAns <- atomically $ processQuery stateTV qryData+ proceed stateTV qryData qry2OrAns+ proceed stateTV qryData@(resQryId, qry) (Left qry2) =+ do+ argQryId <- CH.makeQuery resCH resQryId argCH qry2+ ans2 <- CH.waitForAnswer resCH resQryId argCH argQryId+ qry2OrAns <- atomically $ processAnswer stateTV qryData ans2+ proceed stateTV qryData qry2OrAns+ proceed stateTV qryData@(resQryId, qry) (Right ans) = + CH.answerQuery useCache resCH (resQryId, ans)+ processQuery stateTV qryData =+ do+ state <- readTVar stateTV+ let (qry2OrAns, maybeNewState) = qryStFn state qryData+ maybeWriteTVar stateTV maybeNewState+ return qry2OrAns+ processAnswer stateTV qryData ans2 =+ do+ state <- readTVar stateTV+ let (qry2OrAns, maybeNewState) = ansStFn state qryData ans2+ maybeWriteTVar stateTV maybeNewState+ return qry2OrAns+ maybeWriteTVar stateTV maybeNewState =+ case maybeNewState of+ Just newState -> writeTVar stateTV newState+ Nothing -> return () +++{-|+ A simple process that passes on a translated version of each query+ to another process and translates the answers before passing them back.+-} +passThroughProcess :: + (QAProtocol q1 a1, QAProtocol q2 a2, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ Bool {-^ should use channel cache? -} ->+ ERProcessName ->+ (q1 -> q2) {-^ query translator -} ->+ (q1 -> a2 -> a1) {-^ answer translator -} ->+ ChannelType {-^ argument channel type -} ->+ ChannelType {-^ result channel type -} ->+ ERProcess sInAnyProt sOutAnyProt+passThroughProcess useCache defName preFn postFn =+ passThroughStatefulProcess useCache defName preStFn postStFn ()+ where+ preStFn _ (_, q) = (Left (preFn q), Nothing) + postStFn _ (_, q) a = (Right (postFn q a), Nothing) ++{-|+ A simple process that either responds with no further queries + or passes on a translated version of the query to another process, + and then passing back a translated version of the answer received.+-} +maybePassThroughProcess :: + (QAProtocol q1 a1, QAProtocol q2 a2, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ Bool {-^ should use channel cache? -} ->+ ERProcessName ->+ (q1 -> Bool) + {-^ if True, query should NOT be passed on -} ->+ (q1 -> a1) + {-^ responder to use if not passing queries on -} ->+ (q1 -> q2) + {-^ translator for queries to pass on -} ->+ (q1 -> a2 -> a1) + {-^ translator for passed answers -} ->+ ChannelType {-^ input channel type -} ->+ ChannelType {-^ output channel type -} ->+ ERProcess sInAnyProt sOutAnyProt+maybePassThroughProcess useCache defName noPass noPassResponder preFn postFn =+ passThroughStatefulProcess useCache defName qryStFn ansStFn ()+ where+ qryStFn _ (_, q) + | noPass q =+ (Right (noPassResponder q), Nothing) -- answer+ | otherwise = + (Left (preFn q), Nothing) -- pass on translated query+ ansStFn _ (_, q) a = + (Right (postFn q a), Nothing) -- reply translated answer++{-|+ A process passing on information without modification, except for improving the+ convergence rate in successive queries.+ + Each query may refer to a previous query. When it does,+ the query will not be answered until either:+ + * the answer has improved sufficiently since last time one was given + + * the number of queries made in response to this query has reached the given limit+ + Currently supports only single-threaded querying.+-}+rateProcess ::+ (QAProtocol q a, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcessName {-^ process identifier (string) -} ->+ (a -> a -> Bool) {-^ function to judge whether the improvement is good enough -} -> + Int {-^ maximum number of attempts to reach desired improvement -} ->+ ChannelType {-^ number channel type -} ->+ ERProcess sInAnyProt sOutAnyProt+rateProcess defName goodEnough maxAttepts chtp =+ passThroughStatefulProcess False defName qryStFn ansStFn initState chtp chtp+ where+ initState = (Nothing, 0) -- no previous answer yet+ qryStFn _ qryData@(_, qry) =+ (Left qry, Nothing)+ ansStFn (Nothing, _) qryData ans =+ (Right ans, Just (Just ans, 0)) -- remember answer for comparing with future answers+ ansStFn (Just prevAns, prevAttemptNo) qryData@(_, qry) ans+ | goodEnough prevAns ans || prevAttemptNo >= maxAttepts - 1 =+ (Right ans, Just (Just ans, 0)) -- reset attempt counter+ | otherwise =+ (Left qry, Just (Just prevAns, prevAttemptNo + 1)) -- increase attempt counter+ +{-|+ A trivial passthrough process that only:+ + * reduces prec by 1 in all queries+ + * ensures that the granularity of all answers is raised to prec+-}+precProcess :: + (QAProtocol q a, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ Bool {-^ should use channel cache? -} ->+ ERProcessName ->+ ChannelType {-^ in, out channel type -} ->+ a {-^ sample answer (without QAIxA) to identify protocol type -} -> + ERProcess sInAnyProt sOutAnyProt+precProcess useCache name chtp sampleA =+ passThroughProcess useCache name lowerIx setMinGranAux chtp chtp+ where+ lowerIx (QAIxQ ix q) =+ (QAIxQ (ix - 1) q)+ setMinGranAux (QAIxQ ix q) a =+ qaaSetMinGran g a+ where+ g = effIx2gran ix+ _ = qaMatch q sampleA -- force type unification+ ++{-|+ A process that passes on a translated version of each query+ to one or both of another 2 channels. When the other channel(s) answer, + it analyses the answer(s) and decides whether to send other queries or+ answer its original query.+-} +passThroughBinaryStatefulProcess ::+ (QAProtocol q1 a1, QAProtocol q2 a2, QAProtocol q a, + CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ Bool {-^ should use channel cache? -} ->+ ERProcessName ->+ (s -> (QueryId, q) -> (Either (Maybe q1, Maybe q2) a, Maybe s)) + {-^ what to do with a query + forward or reply -} ->+ (s -> (QueryId, q) -> (Maybe a1, Maybe a2) -> (Either (Maybe q1, Maybe q2) a, Maybe s)) + {-^ what to do with an answer - another query or reply -} ->+ s {-^ initial state -} -> + (ChannelType, ChannelType) {-^ argument channels types -} ->+ ChannelType {-^ result channel type -} ->+ ERProcess sInAnyProt sOutAnyProt++passThroughBinaryStatefulProcess useCache defName qryStFn ansStFn initState (chtpIn1, chtpIn2) chtpRes =+ ERProcess defName deploy [chtpIn1, chtpIn2] [chtpRes]+ where+ deploy deployName [arg1CHA, arg2CHA] [resCHA] _ =+ do+ stateTV <- newTVarIO initState+ dispatcher stateTV+ where+ resCH = + CH.castOut "ERNet.Blocks.Basic: passThroughBinaryStatefulProcess: resCH: "+ resCHA+ arg1CH = + CH.castIn "ERNet.Blocks.Basic: passThroughBinaryStatefulProcess: arg1CH: "+ arg1CHA+ arg2CH = + CH.castIn "ERNet.Blocks.Basic: passThroughBinaryStatefulProcess: arg2CH: "+ arg2CHA+ + dispatcher stateTV =+ do+ qryData <- CH.waitForQuery resCH+ forkIO $ responder stateTV qryData+ dispatcher stateTV+ + responder stateTV qryData@(resQryId, qry) =+ do+ qry12OrAns <- atomically $ processQuery stateTV qryData+ proceed stateTV qryData qry12OrAns+ + proceed stateTV qryData@(resQryId, qry) (Left (mqry1, mqry2)) =+ do+ mans1 <- maybeQuerySync arg1CH mqry1+ mans2 <- maybeQuerySync arg2CH mqry2+ qry12OrAns <- atomically $ processAnswer stateTV qryData (mans1, mans2)+ proceed stateTV qryData qry12OrAns+ where+ maybeQuerySync argCH Nothing = return Nothing+ maybeQuerySync argCH (Just qry) =+ do+ argQryId <- CH.makeQuery resCH resQryId argCH qry+ ans <- CH.waitForAnswer resCH resQryId argCH argQryId+ return $ Just ans+ + proceed stateTV qryData@(resQryId, qry) (Right ans) = + CH.answerQuery useCache resCH (resQryId, ans)+ + processQuery stateTV qryData =+ do+ state <- readTVar stateTV+ let (qry12OrAns, maybeNewState) = qryStFn state qryData+ maybeWriteTVar stateTV maybeNewState+ return qry12OrAns+ + processAnswer stateTV qryData (mans1, mans2) =+ do+ state <- readTVar stateTV+ let (qry12OrAns, maybeNewState) = ansStFn state qryData (mans1, mans2)+ maybeWriteTVar stateTV maybeNewState+ return qry12OrAns+ + maybeWriteTVar stateTV maybeNewState =+ case maybeNewState of+ Just newState -> writeTVar stateTV newState+ Nothing -> return () ++{-|+ A simple process that passes on a translated version of each query+ to another process and translates the answers before passing them back.+-} +passThroughBinaryProcess :: + (QAProtocol q1 a1, QAProtocol q2 a2, QAProtocol q a, + CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ Bool {-^ should use channel cache? -} ->+ ERProcessName ->+ (q -> (q1,q2)) {-^ query translator -} ->+ (q -> (a1,a2) -> a) {-^ answer translator -} ->+ (ChannelType, ChannelType) {-^ argument channels types -} ->+ ChannelType {-^ result channel type -} ->+ ERProcess sInAnyProt sOutAnyProt++passThroughBinaryProcess useCache defName preFn postFn =+ passThroughBinaryStatefulProcess useCache defName preStFn postStFn ()+ where+ preStFn _ (_, q) = (Left (Just q1, Just q2), Nothing)+ where+ (q1, q2) = preFn q + postStFn _ (_, q) (Just a1, Just a2) = (Right (postFn q (a1, a2)), Nothing) +
+ src/Control/ERNet/Blocks/Control/Basic.hs view
@@ -0,0 +1,494 @@+{-|+ Module : Control.ERNet.Blocks.Control.Basic+ Description : processes with purely synchronisation effects + Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ A collection of processes whose main purpose is + to synchronise other processes and have little+ semantical value.+-}+module Control.ERNet.Blocks.Control.Basic +(+ joinStepValProcess,+ splitSyncProcess,+ biasedSplitSyncProcess,+ switchMultiProcess,+ improverIxSimpleProcess,+ improverNoIxSimpleProcess+)+where++import Control.ERNet.Foundations.Protocol +import Control.ERNet.Foundations.Protocol.StandardCombinators+import qualified Control.ERNet.Foundations.Event.Logger as LG +import qualified Control.ERNet.Foundations.Channel as CH +import Control.ERNet.Foundations.Process ++import Control.Concurrent as Concurrent+import Control.Concurrent.STM as STM+import Data.Number.ER.MiscSTM++import Data.Typeable++{-|+ This process joins information from two channels ("step", "val") + in such a way that it acts as a splitter of responsibilities + for its multi-threaded failure-enabled result channel as follows:+ + * The "step" channel provides the timing and effort information for responses.+ + * The "val" channel provides values without significant blocking.+ + While the process is waiting for a response from the step channel,+ any queries are put on hold until the response comes.+ + * If the step channel responds with indication of failure, then+ all pending queries are answered as failed.+ + * If the step channel responds with ok, then all the pending queries+ are forwarded to the value channel and answered asap.+ No new queries are accepted during such forwarding stage.+ +-}+joinStepValProcess ::+ (QAProtocol q a, Show q, Show a, + CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcessName {-^ process identifier (string) -} ->+ ChannelType {-^ value input channel type -} ->+ a {-^ example answer on value channel to help compiler work out the protocol -} ->+ ERProcess sInAnyProt sOutAnyProt+joinStepValProcess defName chtp sampleAnswer =+ ERProcess defName deploy [chTChanges (chTIx chTUnit), chtp] [chTChanges (chTIx chtp)]+ where+ deploy deployName [stepCHA, valCHA] [resCHA] _ =+ do+ stateTV <- newTVarIO [] -- list of pending queries+ forkIO $ forwarder stateTV+ accumulator stateTV+ where+ resCH = + CH.castOut "ERNet.Blocks.Control.Basic: joinStepValProcess: resCH: " + resCHA+ stepCH =+ CH.castIn "ERNet.Blocks.Control.Basic: joinStepValProcess: stepCH: " + stepCHA+ valCH =+ CH.castIn "ERNet.Blocks.Control.Basic: joinStepValProcess: valCH: " + valCHA+ + accumulator stateTV =+ do+ qryData@(resQryId, qry) <- CH.waitForQuery resCH+ -- explore the kind of query:+ case qry of+ QAChangesQWhenNew _ _ ->+ -- add this query to the pending list:+ atomically $ modifyTVar stateTV $ (:) qryData+ QAChangesQ (QAIxQ ix q) ->+ do+ -- forward and answer this immediately:+ valQryId <- CH.makeQuery resCH resQryId valCH q+ a <- CH.waitForAnswer resCH resQryId valCH valQryId+ let _ = [a, sampleAnswer] -- indicate the protocol on valCH+ CH.answerQuery False resCH (resQryId, QAChangesANew $ QAIxA a)+ accumulator stateTV+ + forwarder stateTV =+ do+ -- wait until pending list non-empty:+ (qryId, qry) <- atomically $ + do+ pendingList <- readTVar stateTV+ case pendingList of+ [] -> retry+ (qryData : _) -> return qryData+ -- explore the query:+ stepQryId <- case qry of+ QAChangesQWhenNew _ (QAIxQ ix q) ->+ -- make a query to the step channel:+ CH.makeQuery resCH qryId stepCH $ QAChangesQWhenNew 0 (QAIxQ ix QAUnitQ)+ -- wait for step answer signalling that value is ready:+ ans <- CH.waitForAnswer resCH qryId stepCH stepQryId+ -- obtain the current list of pending queries and empty the shared list:+ pendingList <- atomically $ modifyTVarGetOldVal stateTV (const [])+ -- investigate whether to indicate failure:+ case ans of+ QAChangesAGivenUp -> + answerAllGivenUp pendingList+ _ ->+ forwardAll pendingList+ -- go back to the beginning:+ forwarder stateTV+ + answerAllGivenUp pendingList =+ do+ mapM_ (\ (qryId, _) -> CH.answerQuery False resCH (qryId, QAChangesAGivenUp)) + pendingList+ + forwardAll pendingList =+ do+ -- forward all pending queries:+ valQryIds <-+ mapM (\ (qryId, (QAChangesQWhenNew _ (QAIxQ ix q))) -> CH.makeQuery resCH qryId valCH q)+ pendingList+ -- wait for all answers in turn:+ fwdAnswers <-+ mapM (\ (valQryId, (qryId, _)) -> CH.waitForAnswer resCH qryId valCH valQryId) + (zip valQryIds pendingList)+ -- forward all these answers:+ mapM_ (\ (ans, (qryId, _)) -> CH.answerQuery False resCH (qryId, QAChangesANew $ QAIxA $ ans)) + (zip fwdAnswers pendingList)++{-|+ This process provides two channels (primary, secondary) + split off from one source channel. The primary channel+ is a clean forward of the source channel. The secondary+ channel can use a slightly different protocol than the primary channel.+ + Any query on the secondary channel will be blocked until a matching+ query is received and processed on the primary channel. (The user must+ supply a function that decides whether or not the queries are matching.)+ + Whenever a query is being answered on the primary channel, + all queries pending on the secondary channel that are+ matching this one will be replied at the same time + using the an answer derived from the answer on the primary channel.+-}+biasedSplitSyncProcess ::+ (QAProtocol q1 a1, QAProtocol q2 a2, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcessName {-^ process identifier (string) -} ->+ ChannelType {-^ primary and input channel type -} ->+ ChannelType {-^ secondary channel type -} ->+-- a1 {-^ example answer on value channel to help compiler work out the protocol -} ->+ (q2 -> q1 -> Bool) {-^ decision whether a secondary query matches a primary query -} ->+ (q2 -> a1 -> a2) {-^ translation of primary answer to a secondary answer -} ->+ ERProcess sInAnyProt sOutAnyProt+biasedSplitSyncProcess defName chtp1 chtp2 qry2MatchQry1 getAns2 =+ ERProcess defName deploy [chtp1] [chtp1, chtp2]+ where+ deploy deployName [inCHA] [primCHA, secCHA] _ =+ do+ stateTV <- newTVarIO [] -- list of pending queries on secondary channel+ forkIO $ accumulator stateTV+ forwarder stateTV+ where+ inCH =+ CH.castIn "ERNet.Blocks.Control.Basic: joinStepValProcess: inCH: " + inCHA+ primCH = + CH.castOut "ERNet.Blocks.Control.Basic: biasedSplitSyncProcess: primCH: " + primCHA+ secCH = + CH.castOut "ERNet.Blocks.Control.Basic: biasedSplitSyncProcess: secCH: " + secCHA+ +-- _ = CH.answerQuery False inCH (0, sampleAnswer)+ + accumulator stateTV =+ do+ qryData@(secQryId, qry) <- CH.waitForQuery secCH+ -- add this query to the pending list:+ atomically $ modifyTVar stateTV $ (:) qryData+ -- and so on:+ accumulator stateTV+ + forwarder stateTV =+ do+ qryData@(primQryId, qry) <- CH.waitForQuery primCH+ -- forward:+ inQryId <- CH.makeQuery primCH primQryId inCH qry+ ans <- CH.waitForAnswer primCH primQryId inCH inQryId + -- answer on primary channel:+ CH.answerQuery False primCH (primQryId, ans)+ -- extract all matching queries on secondary channel:+ secQrys <- atomically $ + do+ pendingList <- readTVar stateTV+ let (matchingQrys, prunedPendingList) = analyseList qry pendingList+ writeTVar stateTV prunedPendingList+ return matchingQrys+ -- answer all these queries:+ mapM (answerSecQry ans) secQrys+ -- go back to the beginning:+ forwarder stateTV+ where+ analyseList qry1 =+ analyseListAUX [] []+ where+ analyseListAUX prevMatching prevPruned [] = (prevMatching, prevPruned)+ analyseListAUX prevMatching prevPruned (qry2Data@(qry2Id, qry2) : others)+ | qry2MatchQry1 qry2 qry1 =+ analyseListAUX (qry2Data : prevMatching) prevPruned others+ | otherwise =+ analyseListAUX prevMatching (qry2Data : prevPruned) others + answerSecQry ans1 (qry2Id, qry2) =+ do+ CH.answerQuery False secCH (qry2Id, getAns2 qry2 ans1)++{-|+ This process provides multiple copies of one single-threaded channel. + + merges splits a channel into two channels + - primary channel and secondary channel. The primary channel+ is a clean forward of the original channel. The secondary+ channel can use a slightly different protocol than the primary channel.+ + Any query on the secondary channel will be blocked until a matching+ query is received and processed on the primary channel. (The user must+ supply a function that decides whether or not the queries are matching.)+ + Whenever a query is being answered on the primary channel, + all queries pending on the secondary channel that are+ matching this one will be replied at the same time + using the an answer derived from the answer on the primary channel.+-}+splitSyncProcess ::+ (QAProtocol q a, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcessName {-^ process identifier (string) -} ->+ ChannelType {-^ type of all channels -} ->+ Int {-^ number of channels to serve -} ->+ a {-^ example answer on value channel to help compiler work out the protocol -} ->+ ERProcess sInAnyProt sOutAnyProt+splitSyncProcess defName chtp n sampleAnswer =+ ERProcess defName deploy [chtp] (replicate n chtp)+ where+ deploy deployName [inCHA] outCHAs _ =+ do+ stateTV <- newTVarIO [] -- list of pending queries while another one is being processed+ forkIO $ accumulator stateTV+ forwarder stateTV+ where+ inCH = + CH.castIn "ERNet.Blocks.Control.Basic: splitSyncProcess: inCH: " + inCHA + outCHs = + map (\(chA, chN) -> + CH.castOut ("ERNet.Blocks.Control.Basic: splitSyncProcess: outCH" ++ show chN ++ ": ") chA) $ + zip outCHAs [0..]+ + accumulator stateTV =+ do+ (chN, (qryId, QueryAnyProt qry_)) <- CH.waitForQueryMulti outCHAs+ let (Just qry) = cast qry_ + -- add this query to the pending list:+ atomically $ modifyTVar stateTV $ (:) $ (chN, (qryId, qry))+ -- and so on:+ accumulator stateTV+ + forwarder stateTV =+ do+ -- wait till list is not empty and extract first pending query:+ (chN, (qryId, qry)) <- atomically $+ do+ pendingList <- readTVar stateTV+ case pendingList of+ [] -> retry+ (qryData : _) -> return qryData+ let outCH = outCHs !! chN+ -- forward the query:+ inQryId <- CH.makeQuery outCH qryId inCH qry+ ans <- CH.waitForAnswer outCH qryId inCH inQryId+ let _ = [ans, sampleAnswer] -- indicate the protocol on inCH + -- extract all matching queries:+ qrys <- atomically $ + do+ pendingList <- readTVar stateTV+ let (matchingQrys, prunedPendingList) = analyseList qry pendingList+ writeTVar stateTV prunedPendingList+ return matchingQrys+ -- answer all these queries:+ mapM (answerQry ans) qrys+ -- go back to the beginning:+ forwarder stateTV+ where+ analyseList qry1 =+ analyseListAUX [] []+ where+ analyseListAUX prevMatching prevPruned [] = (prevMatching, prevPruned)+ analyseListAUX prevMatching prevPruned (qry2Data@(_, (_, qry2)) : others)+ | qry2 == qry1 =+ analyseListAUX (qry2Data : prevMatching) prevPruned others+ | otherwise =+ analyseListAUX prevMatching (qry2Data : prevPruned) others + answerQry ans1 (chN, (qry2Id, qry2)) =+ do+ CH.answerQuery False (outCHs !! chN) (qry2Id, ans1) -- getAns2 qry2 ans1)++{-|+ This process acts as a "switch" for a group of channels, forwarding information+ from one of two groups of source channels. The special "switch" channel+ indicates whether to use one or the other. +-}+switchMultiProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ Bool {-^ should use channel cache? -} ->+ ERProcessName {-^ process identifier (string) -} ->+ [ChannelType] {-^ switched output channel types -} ->+ ERProcess sInAnyProt sOutAnyProt+switchMultiProcess useCache defName chTypes =+ ERProcess defName deploy (chTBool : (chTypes ++ chTypes)) (chTypes)+ where+ deploy deployName (switchCHA : inCHAs) resCHAs _ =+ dispatcher+ where+ (in1CHAs, in2CHAs) = + splitAt (length resCHAs) inCHAs+ switchCH =+ CH.castIn "ERNet.Blocks.Control.Basic: switchMultiProcess: switchCH: " switchCHA + + dispatcher =+ do + (chN, qryData) <- CH.waitForQueryMulti resCHAs+ forkIO $ responder chN qryData+ dispatcher+ + responder chN (resQryId, qry) =+ do+ case chtp of+ ChannelType _ sampleAnswer ->+ do+ resCH <- + CH.castOutIO + ("ERNet.Blocks.Control.Basic: switchMultiProcess: resCHAs !! " ++ show chN ++ ": ") + resCHA+ let _ = CH.answerQuery False resCH (0, sampleAnswer)+ -- find out whether to switch to secondary source:+ switchQryId <- CH.makeQuery resCH resQryId switchCH QABoolQ+ shouldSwitch <- CH.waitForAnswer resCH resQryId switchCH switchQryId+ case () of + _ -> -- ... persuaded Haskell parser that it is ok to have "where" inside a "do"+ do+ -- obtain the answer from either source:+ qryId <- + CH.makeQueryAnyProt "ERNet.Blocks.Control.Basic: switchMultiProcess: making query on inCHA: " + resCHA resQryId inCHA qry+ (_, ans) <- + CH.waitForAnswerMulti resCHA resQryId [(inCHA, qryId)]+ -- pass it back:+ CH.answerQueryAnyProt "ERNet.Blocks.Control.Basic: switchMultiProcess: answering query on resCHA: "+ useCache resCHA (resQryId, ans)+ where+ inCHA = inCHAs !! chN+ inCHAs = if shouldSwitch then in2CHAs else in1CHAs+ where+ chtp = chTypes !! chN+ resCHA = resCHAs !! chN+ +{-|+ This process acts as a simple pass-through + + it decreases the effort index of each query+ except for a query with effort index zero+ it asks a special value provider.+ It can cope with several queries in parallel.+-}+improverIxSimpleProcess ::+ (QAProtocol q a, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcessName {-^ process identifier (string) -} ->+ ChannelType {-^ type shared by all channels -} ->+ a {-^ sample answer to help the type checker -} ->+ ERProcess sInAnyProt sOutAnyProt+improverIxSimpleProcess defName chType sampleAns =+ ERProcess defName deploy [chType, chType] [chType]+ where+ deploy _ [initCHA, inCHA] [resCHA] _ =+ do+ dispatcher+ where+ initCH =+ CH.castIn "ERNet.Blocks.Control.Basic: improverNoIxSimpleProcess: initCH: "+ initCHA+ inCH =+ CH.castIn "ERNet.Blocks.Control.Basic: improverNoIxSimpleProcess: inCH: "+ inCHA+ resCH =+ CH.castOut "ERNet.Blocks.Control.Basic: improverNoIxSimpleProcess: resCH: "+ resCHA+ _ = [inCH, initCH]+ _ = CH.answerQuery False resCH (0, QAIxA sampleAns)++ dispatcher =+ do+ qryData <- CH.waitForQuery resCH+ forkIO $ responder qryData+ dispatcher+ + responder (resQryId, QAIxQ ix sqry) =+ do + ans <- + case ix == 0 of+ True -> enquire initCH resQryId (QAIxQ ix sqry)+ False -> enquire inCH resQryId (QAIxQ (ix - 1) sqry)+ CH.answerQuery True resCH (resQryId, ans)+ + enquire ch resQryId qry =+ do+ fwdQryId <- CH.makeQuery resCH resQryId ch qry+ CH.waitForAnswer resCH resQryId ch fwdQryId++{-|+ This process acts as a simple pass-through + it + remembers its last answer and provides it on another channel.+ It initialises its memory from a special value provider. +-}+improverNoIxSimpleProcess ::+ (QAProtocol q a, CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcessName {-^ process identifier (string) -} ->+ ChannelType {-^ type shared by all channels -} ->+ a {-^ sample answer to help the type checker -} ->+ ERProcess sInAnyProt sOutAnyProt+improverNoIxSimpleProcess defName chType sampleAns =+ ERProcess defName deploy [chType, chType] [chType, chType]+ where+ deploy _ [initCHA, inCHA] [resCHA, resCurrCHA] _ =+ do+ stateTV <- newTVarIO Nothing + forkIO $ currentValServer stateTV+ responder stateTV+ where+ initCH =+ CH.castIn "ERNet.Blocks.Control.Basic: improverNoIxSimpleProcess: initCH: "+ initCHA+ inCH =+ CH.castIn "ERNet.Blocks.Control.Basic: improverNoIxSimpleProcess: inCH: "+ inCHA+ resCH =+ CH.castOut "ERNet.Blocks.Control.Basic: improverNoIxSimpleProcess: resCH: "+ resCHA+ resCurrCH =+ CH.castOut "ERNet.Blocks.Control.Basic: improverNoIxSimpleProcess: resCurrCH: "+ resCurrCHA+ _ = [resCH, resCurrCH]+ _ = [inCH, initCH]+ _ = CH.answerQuery False resCH (0, sampleAns)+ + currentValServer stateTV =+ do+ (qryId, qry) <- CH.waitForQuery resCurrCH+ mans <- atomically $ readTVar stateTV+ ans <- case mans of+ Nothing -> + do+ initQryId <- CH.makeQuery resCurrCH qryId initCH qry+ ans <- CH.waitForAnswer resCurrCH qryId initCH initQryId+ atomically $ writeTVar stateTV $ Just ans+ return ans+ Just ans ->+ return ans + CH.answerQuery False resCurrCH (qryId, ans)+ currentValServer stateTV+ + responder stateTV =+ do + (resQryId, qry) <- CH.waitForQuery resCH+ fwdQryId <- CH.makeQuery resCH resQryId inCH qry+ ans <- CH.waitForAnswer resCH resQryId inCH fwdQryId+ CH.answerQuery False resCH (resQryId, ans)+ atomically $ writeTVar stateTV $ Just ans+ responder stateTV+ +
+ src/Control/ERNet/Blocks/Real/Basic.hs view
@@ -0,0 +1,109 @@+{-|+ Module : Control.ERNet.Blocks.Real.Basic+ Description : basic processes for processing reals via intervals + Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable+-}+module Control.ERNet.Blocks.Real.Basic+(+ rateRProcess,+ rateRsProcess+) +where++import Control.ERNet.Foundations.Protocol+import Control.ERNet.Foundations.Protocol.StandardCombinators+import qualified Control.ERNet.Foundations.Channel as CH+import Control.ERNet.Foundations.Process++import Control.ERNet.Blocks.Basic++import Control.ERNet.Blocks.Real.Protocols+import qualified Data.Number.ER.Real.Approx as RA+import qualified Data.Number.ER.Real.Approx.Elementary as RAEL++import Data.Typeable++{-|+ A process passing on information about a real number, trying to improve the+ convergence rate in successive queries.+ + Each query may refer to a previous query. When it does,+ the query will not be answered until either:+ + * the information about the number has improved by the desired amount since last time + + * the number of queries made in response to this query has reached the given limit+-}+rateRProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ RAEL.ERApproxElementary ra, Typeable ra) =>+ ERProcessName {-^ process identifier (string) -} ->+ Rational {-^ desired ratio of improvement -} ->+ Int {-^ maximum number of attempts to reach desired improvement -} ->+ ra {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+rateRProcess defName desiredImpr maxAttepts sampleRA = + rateProcess defName goodEnough maxAttepts chtpRC+ where+ chtpRC = chTChanges $ chTIx $ chtpRNoIx + chtpRNoIx = chTReal sampleRA+ + goodEnough _ QAChangesAGivenUp = True+ goodEnough QAChangesAGivenUp _ = True+ goodEnough+ (QAChangesANew (QAIxA (QARealA prevRA))) + (QAChangesANew (QAIxA (QARealA newRA))) =+ case RA.compareReals (impr) (fromRational desiredImpr) of+ Just LT -> False + _ -> True+ where+ (_, impr) = RA.intersectMeasureImprovement 20 prevRA newRA+ _ = prevRA == sampleRA+ +{-|+ A process passing on information about a list of real numbers, trying to improve the+ convergence rate in successive queries.+ + Each query may refer to a previous query. When it does,+ the query will not be answered until either:+ + * the information about the tuple has improved by the desired amount since last time + + * the number of queries made in response to this query has reached the given limit+-}+rateRsProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ RAEL.ERApproxElementary ra, Typeable ra) =>+ ERProcessName {-^ process identifier (string) -} ->+ Rational {-^ desired ratio of improvement -} ->+ Int {-^ maximum number of attempts to reach desired improvement -} ->+ ra {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+rateRsProcess defName desiredImpr maxAttepts sampleRA =+ rateProcess defName goodEnough maxAttepts chtpRsC+ where+ chtpRsC = chTChanges $ chTIx $ chTList chtpRNoIx + chtpRNoIx = chTReal sampleRA+ +-- Just (QAChangesANew (QAIxA (QAListASingle (QARealA sampleRA)))) = cast a+ goodEnough _ QAChangesAGivenUp = True+ goodEnough QAChangesAGivenUp _ = True+ goodEnough+ (QAChangesANew (QAIxA (QAListA prevAs))) + (QAChangesANew (QAIxA (QAListA newAs))) =+ case RA.compareReals (impr) (fromRational desiredImpr) of+ Just LT -> False + _ -> True+ where+ impr = foldl max 1 $ zipWith getImprAs prevAs newAs+ getImprAs (QARealA prevRA) (QARealA newRA) =+ snd $ RA.intersectMeasureImprovement 20 prevRA newRA+ where+ _ = prevRA == sampleRA+ +
+ src/Control/ERNet/Blocks/Real/Protocols.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-|+ Module : Control.ERNet.Blocks.Real.Protocols+ Description : protocols for communicating a real number+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ Basic protocols for transferring approximations of a single real number. ++-}+module Control.ERNet.Blocks.Real.Protocols where++import Control.ERNet.Foundations.Protocol+import Control.ERNet.Foundations.Protocol.StandardCombinators+import qualified Control.ERNet.Foundations.Channel as CH++import qualified Data.Number.ER.Real.Approx as RA+import qualified Data.Number.ER.Real.Approx.Elementary as RAEL++import Data.Number.ER.BasicTypes++import Data.Number.ER.ShowHTML+import qualified Text.Html as H++import Data.Typeable++{- protocol for real numbers -}++instance (RAEL.ERApproxElementary ira, Typeable ira) => + (QAProtocol QARealQ (QARealA ira))+ where+ qaMatch _ _ = Nothing -- always matching++data QARealQ+ = QARealQ+ deriving (Eq, Ord, Show, Typeable)++data QARealA ra+ = QARealA ra+ deriving (Eq, Ord, Show, Typeable)++chTReal :: + (RAEL.ERApproxElementary ira, Typeable ira) =>+ ira -> ChannelType+chTReal sampleRA = ChannelType QARealQ (QARealA sampleRA)++instance H.HTML QARealQ + where+ toHtml = toHtmlDefault+ +instance (Show ra) => H.HTML (QARealA ra)+ where+ toHtml = toHtmlDefault ++{-| + Construct an answer to a query for a real number+ using the default real number protocol with an effort index.+-}+makeAnswerR ::+ (RAEL.ERApproxElementary ra) =>+ (EffortIndex -> ra) ->+ (QAIxQ (QARealQ)) ->+ (QAIxA (QARealA ra))+makeAnswerR val (QAIxQ ix q) =+ QAIxA $ makeAnswerRNoIx (val ix) q++{-| + Construct an answer to a query for a real number+ using the default real number protocol without any effort index.+-}+makeAnswerRNoIx ::+ (RAEL.ERApproxElementary ra) =>+ (ra) ->+ (QARealQ) ->+ (QARealA ra)+makeAnswerRNoIx val QARealQ =+ QARealA val++{-| + Construct an answer to a query for a list a real numbers+ using the list protocol with an effort index.+-}+makeAnswerRs ::+ (RAEL.ERApproxElementary ra) =>+ (EffortIndex -> [ra]) ->+ (QAIxQ (QAListQ QARealQ)) ->+ (QAIxA (QAListA (QARealA ra)))+makeAnswerRs vals (QAIxQ ix q) =+ QAIxA $ makeAnswerRsNoIx (vals ix) q++{-| + Construct an answer to a query for a list a real numbers+ using the list protocol without any effort index.+-}+makeAnswerRsNoIx ::+ (RAEL.ERApproxElementary ra) =>+ ([ra]) ->+ (QAListQ QARealQ) ->+ (QAListA (QARealA ra))+makeAnswerRsNoIx vals qry =+ case qry of+ (QAListQAllHomog (QARealQ)) ->+ QAListA $ map QARealA vals+ (QAListQPrefix qs) ->+ QAListA $ map QARealA $ take (length qs) vals+ (QAListQSingle n qs) ->+ QAListASingle $ QARealA $ vals !! n+ (QAListQLength) ->+ QAListALength $ length vals++{-|+ Make a query and wait for answer + on a real number input socket with the standard+ (index -> approx) protocol.+-}+querySyncR ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt, + RAEL.ERApproxElementary ira, Typeable ira) =>+ sOut q2 a2 {-^ initiator query channel -} ->+ QueryId ->+ (sIn (QAIxQ QARealQ) (QAIxA (QARealA ira))) ->+ EffortIndex ->+ IO (ira)+querySyncR callingCH callingQryId channel ix =+ do+ qryId <- CH.makeQuery callingCH callingQryId channel (QAIxQ ix QARealQ)+ (QAIxA (QARealA ansRA)) <- + CH.waitForAnswer callingCH callingQryId channel qryId+ return ansRA+
+ src/Control/ERNet/Blocks/RnToRm/Basic.hs view
@@ -0,0 +1,762 @@+{-|+ Module : Control.ERNet.Blocks.RnToRm.Basic+ Description : basic processes for function enclosures+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ A few processes universally useful when representing (1st-order) real functions+ as single data entities via 'FA.ERFnDomApprox'. +-}+module Control.ERNet.Blocks.RnToRm.Basic +(+ boundingProcess,+ integrateFAProcess,+ integrateIsectMeasureFAProcess,+ applyFieldProcess,+ joinFADomProcess,+ splitFADomProcess,+ rateFnProcess,+ getEndpointValsProcess,+ maxOverDomProcess+)+where++import Control.ERNet.Foundations.Protocol+import Control.ERNet.Foundations.Protocol.StandardCombinators+import qualified Control.ERNet.Foundations.Channel as CH+import Control.ERNet.Foundations.Process++import Control.ERNet.Blocks.Basic++import Control.ERNet.Blocks.RnToRm.Protocols+import Control.ERNet.Blocks.Real.Protocols+import qualified Data.Number.ER.RnToRm.Approx as FA+import qualified Data.Number.ER.Real.Approx as RA+import qualified Data.Number.ER.Real.Approx.Elementary as RAEL+import qualified Data.Number.ER.Real.DomainBox as DBox+import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox)+import Data.Number.ER.BasicTypes+-- import Misc++import qualified Data.Number.ER.RnToRm.BisectionTree as BISTR++import qualified Text.Html as H++import Data.Typeable+import Data.Maybe++import qualified Data.Map as Map++import Control.Concurrent as Concurrent+import Control.Concurrent.STM as STM+import Data.Number.ER.MiscSTM+++{-|+ A pass-through process for first order real functions with effort index + that is almost equal to the identity.+ + It restricts the function's graph at certain given intervals+ to the given boxes.+-}+boundingProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ FA.ERFnDomApprox box varid domra ranra fa,+ Typeable box, Typeable fa, Show box, H.HTML fa,+ RAEL.ERApproxElementary domra, RAEL.ERApproxElementary ranra,+ Typeable domra, Typeable ranra) =>+ Bool {-^ should use channel cache? -} ->+ ERProcessName -> + ChannelType->+ fa {-^ sample approximation to aid typechecking -} ->+ EffortIndex + {- ^ below this threshold precision do not pass the query through + if it can be answered via the bounds -} ->+ [(domra, ranra)]+ {- ^ one bounding box for each order of derivative -} ->+ ERProcess sInAnyProt sOutAnyProt+boundingProcess useCache name chtp sampleFA thrsIx bounds =+ maybePassThroughProcess useCache name noPass makeAnswer id adjustAnswer chtp chtp+ where+ noPass (QAIxQ ix qry) =+ (ix < thrsIx) && (qryInBounds qry)+ boundsExt = + bounds ++ (repeat (RA.bottomApprox, RA.bottomApprox))+ qryInBounds qry =+ and $+ (map (\(r,b) -> r `RA.refines` b) $ zip regions $ map fst boundsExt)+ where+ regions = + case qry of + (QAFn1QPt xB) -> DBox.elems xB+ (QAFn1QDom dB) -> DBox.elems dB+ (QAFn1QAll) -> [RA.bottomApprox]+ makeAnswer (QAIxQ ix qry) =+ QAIxA $ case qry of+ (_) | False -> QAFn1A sampleFA -- never happens, only here to unify "fa" types + (QAFn1QPt xB) -> QAFn1APt $ [bound0]+ (QAFn1QDom dB) -> QAFn1A $ boundFA+ (QAFn1QAll) -> QAFn1A $ boundFA+ where+ (dom0, bound0) = head boundsExt+ boundFA = + FA.partialIntersect+ ix + (DBox.unary dom0) (FA.const DBox.noinfo [bound0])+ (FA.const DBox.noinfo [RA.bottomApprox]) + adjustAnswer qry ans = ans+{- + adjustAnswer qry ans =+ case (chqryType qry,ans) of+ (ChQryDeriv n, ChAnsDeriv ra) ->+ ChAnsDeriv $ bound (boundsExt !! n, ra)+ (ChQryDerivsUpTo n, ChAnsDerivs ras) ->+ ChAnsDerivs $ map bound $ zip boundsExt ras+ _ -> error "type mismatch in boundingProcess query"+ where+ [region] = chqryArgNums qry+ bound ((domRA, imgRA), ra)+ | region `RA.refines` domRA = ra /\ imgRA+ | otherwise = ra+-}+++{-|+ A simple integrator process for first-order linear domain functions + with effort index using the default integration + of the 'FA.ERFnDomApprox' instance.+-}+integrateFAProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ FA.ERFnDomApprox box varid domra ranra fa,+ Typeable box, Typeable fa, Show box, H.HTML fa,+ RAEL.ERApproxElementary domra, RAEL.ERApproxElementary ranra,+ Typeable domra, Typeable ranra) =>+ ERProcessName {-^ process identifier (string) -} ->+ ChannelType {-^ result channel type -} ->+ fa {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+integrateFAProcess defName chtpFn sampleFA =+ ERProcess defName deploy [chtpFn, chtpFn] [chtpFn]+ where+ deploy deployName [valueAtOriginCHA, derivCHA] [resCHA] _ =+ dispatcher+ where+ derivCH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: integrateFAProcess: derivCH:"+ derivCHA + valueAtOriginCH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: integrateFAProcess: valueAtOriginCH:"+ valueAtOriginCHA + resCH = + CH.castOut "ERNet.Blocks.RnToRm.Basic: integrateFAProcess: resCH:" + resCHA + + -- determine channel protocol types:+ _ = [derivCH, valueAtOriginCH]+ _ = CH.answerQuery False resCH (0, QAIxA $ QAFn1A sampleFA)+ + dispatcher = -- standard code+ do+ qryData <- CH.waitForQuery resCH+ forkIO $ responder qryData+ dispatcher+ responder (resQryId, (QAIxQ ix qry)) =+ do+ derivQryId <- + CH.makeQuery resCH resQryId derivCH + (QAIxQ ix $ QAFn1QDom (DBox.unary dom))+ valQryId <- + CH.makeQuery resCH resQryId valueAtOriginCH + (QAIxQ ix $ QAFn1QPt (DBox.unary origin))+ (QAIxA (QAFn1APt [val])) <- + CH.waitForAnswer resCH resQryId valueAtOriginCH valQryId+ (QAIxA (QAFn1A deriv)) <- + CH.waitForAnswer resCH resQryId derivCH derivQryId+ CH.answerQuery False resCH+ (resQryId, QAIxA $ getAns val deriv)+ where+ origin = 0+ dom = + case qry of+ (QAFn1QDom domB) -> + (dom RA.\/ origin)+ where+ dom = case DBox.elems domB of [dom] -> dom+ (QAFn1QAll) -> (RA.bottomApprox)+ (QAFn1QPt xB) -> (x RA.\/ origin)+ where+ x = case DBox.elems xB of [x] -> x+ getAns valRA derivFA =+ case qry of+ (QAFn1QPt xB) -> QAFn1APt $ FA.eval xB resFA+ _ -> QAFn1A resFA + where+ resFA = FA.integrateUnary ix derivFA dom origin [valRA] + ++{-|+ An intersecting and improvement measuring stateful integrator process using + default intersecting & measuring integration of the + 'FA.ERFnDomApprox' instance.+-}+integrateIsectMeasureFAProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ FA.ERFnDomApprox box varid domra ranra fa,+ Typeable box, Typeable fa, Show box, H.HTML fa,+ RAEL.ERApproxElementary domra, RAEL.ERApproxElementary ranra,+ Typeable domra, Typeable ranra) =>+ ERProcessName {-^ process identifier (string) -} ->+ fa {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+integrateIsectMeasureFAProcess defName sampleFA =+ ERProcess defName deploy [chtpFn, chtpFnNoIx, chtpRNoIxC] [chtpFnFn]+ where+ chtpFn = chTIx chtpFnNoIx+ chtpFnFn = chTIx $ chTProd chtpFnNoIx chtpFnNoIx+ chtpFnNoIx = chTFn1 sampleFA+ chtpRNoIxC = chTChanges (chTReal sampleRanRA)+ sampleDomRA = 0+ sampleRanRA = head $ FA.eval (DBox.unary sampleDomRA) sampleFA+ deploy deployName [derivCHA, initFnCHA, origCHA] [resCHA] _ =+ do+ dispatcher Nothing Nothing+ where+ derivCH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: integrateIsectMeasureFAProcess: derivCH:"+ derivCHA + initFnCH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: integrateIsectMeasureFAProcess: initFnCH:"+ initFnCHA + origCH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: integrateIsectMeasureFAProcess: origCH:"+ origCHA + resCH = + CH.castOut "ERNet.Blocks.RnToRm.Basic: integrateIsectMeasureFAProcess: resCH:"+ resCHA++ -- determine channel protocol types:+ _ = CH.answerQuery False resCH (0, QAIxA $ QAProdABoth (QAFn1A sampleFA) (QAFn1A sampleFA))+-- _ = CH.answerQuery False resCH (0, QAIxA $ QAProdABoth (QAFn1APt [sampleRanRA]) (QAFn1APt [sampleRanRA]))+-- _ = do+-- (QAIxA (QAFn1A derivFA)) <- CH.waitForAnswer resCH 0 derivCH 0+-- (QAIxA (QAFn1APt [derivRA])) <- CH.waitForAnswer resCH 0 derivCH 0+-- (QAFn1A initFnFA) <- CH.waitForAnswer resCH 0 initFnCH 0+-- (QAFn1APt [initFnRA]) <- CH.waitForAnswer resCH 0 initFnCH 0+-- (QAChangesANew (QARealA origRA)) <- CH.waitForAnswer resCH 0 origCH 0+-- let _ = [sampleFA, derivFA, initFnFA]+-- let _ = [sampleRanRA, derivRA, initFnRA]+-- let _ = [sampleDomRA, origRA]+-- return ()+ + -- the remaining protocols are determined from the following code+ + dispatcher maybePrevFA maybeOriginData = -- standard code+ do+ qryData <- CH.waitForQuery resCH+ originData <- case maybeOriginData of+ Nothing -> getFirstOriginData qryData+ Just originData -> return originData+ (newFA, newOriginData) <- responder maybePrevFA originData qryData+ dispatcher (Just newFA) (Just newOriginData)+ + getFirstOriginData (resQryId, _) =+ do+ originQryId <- + CH.makeQuery resCH resQryId origCH (QAChangesQ QARealQ)+ (QAChangesANew (QARealA originRA)) <-+ CH.waitForAnswer resCH resQryId origCH originQryId+ return (originQryId, originRA)+ + responder maybePrevFA (originQryId, originRA) (resQryId, (QAIxQ ix (QAProdQBoth fnQ imprQ))) =+ do+ -- enquire derivative first because it is likely to take the longest:+ derivQryId <- + CH.makeQuery resCH resQryId derivCH (QAIxQ ix fnQ)+ -- now inspect the origin to establish whether it has changed:+ testOriginQryId <-+ CH.makeQuery resCH resQryId origCH (QAChangesQIfNew originQryId QARealQ)+ testOriginAns <-+ CH.waitForAnswer resCH resQryId origCH testOriginQryId+ (updatedOrigin, updatedFA) <- case (testOriginAns, maybePrevFA) of+ (QAChangesASame, Just prevFA) -> + return (originRA, prevFA) -- no changes+ (QAChangesANew (QARealA updatedOriginRA), Just prevFA) -> -- origin changed+ do+ -- need to obtain new approximation to solution (new origin -> new initial values) + initFnQryId <-+ CH.makeQuery resCH resQryId initFnCH QAFn1QAll+ (QAFn1A updatedFA) <-+ CH.waitForAnswer resCH resQryId initFnCH initFnQryId+ return (updatedOriginRA, updatedFA)+ (_, Nothing) -> -- no previous function+ do+ -- need to obtain initial approximation to solution: + initFnQryId <-+ CH.makeQuery resCH resQryId initFnCH QAFn1QAll + (QAFn1A initialFA) <-+ CH.waitForAnswer resCH resQryId initFnCH initFnQryId+ return (originRA, initialFA)+ -- get an approximation of the derivative: + (QAIxA (QAFn1A derivFA)) <-+ CH.waitForAnswer resCH resQryId derivCH derivQryId+ -- do the integration:+ let [dom] = DBox.elems (FA.dom derivFA)+ (resFA, imprFA) = + FA.integrateMeasureImprovementUnary + ix derivFA dom updatedOrigin updatedFA+ CH.answerQuery False resCH+ (resQryId, QAIxA $ QAProdABoth (QAFn1A resFA) (QAFn1A imprFA))+ return (resFA, (originQryId, updatedOrigin))++ +{-|+ Apply a function transformer ((R^m->R^n) -> (R^m->R^n)) to a function (R^m->R^n).+-}+applyFieldProcess :: + (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ FA.ERFnDomApprox box varid domra ranra fa,+ Typeable box, Typeable fa, Show box, H.HTML fa,+ RAEL.ERApproxElementary domra, RAEL.ERApproxElementary ranra,+ Typeable domra, Typeable ranra) =>+ ERProcessName {-^ process identifier (string) -} ->+ fa {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+applyFieldProcess defName sampleFA =+ ERProcess defName deploy [chtpFld, chtpFnNoIx] [chtpFn]+ where+ chtpFn = chTIx chtpFnNoIx + chtpFnNoIx = chTFn1 sampleFA+ chtpFld = chTFn2 sampleFA+ deploy deployName [fieldCHA, fnCHA] [resCHA] _ =+ dispatcher+ where+ fieldCH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: applyFieldProcess: fieldCH:"+ fieldCHA + fnCH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: applyFieldProcess: fnCH:"+ fnCHA+ resCH = + CH.castOut "ERNet.Blocks.RnToRm.Basic: applyFieldProcess: resCH:"+ resCHA+ + dispatcher = -- standard code+ do+ qryData <- CH.waitForQuery resCH+ forkIO $ responder qryData+ dispatcher+ + responder (resQryId, (QAIxQ ix qry)) =+ do+ fnQryId <- CH.makeQuery resCH resQryId fnCH qry+ (QAFn1A argFA) <-+ CH.waitForAnswer resCH resQryId fnCH fnQryId+ return $ [sampleFA, argFA] -- unify "fa" from chtpFn and from actual channels+ fieldQryId <- + CH.makeQuery resCH resQryId fieldCH (QAIxQ ix (QAFn2QPt argFA))+ (QAIxA (QAFn2APt resFA)) <- + CH.waitForAnswer resCH resQryId fieldCH fieldQryId+ CH.answerQuery False resCH (resQryId, QAIxA $ QAFn1A resFA)+ ++{-|+ A process joining two functions for adjacent domains + to one function on the joint domain.+ + Each query is split accordingly to two queries on the+ two halves of the bisected domain, respectively.+-}+joinFADomProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ FA.ERFnDomApprox box varid domra ranra fa,+ Typeable box, Typeable fa, Show box, H.HTML fa,+ RAEL.ERApproxElementary domra, RAEL.ERApproxElementary ranra,+ Typeable domra, Typeable ranra) =>+ ERProcessName {-^ process identifier (string) -} ->+ fa {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+joinFADomProcess defName sampleFA =+ ERProcess defName deploy [chtpFnC, chtpFnC] [chtpFnC]+ where+ chtpFnC = chTChanges chtpFn+ chtpFn = chTIx chtpFnNoIx+ chtpFnNoIx = chTFn1 sampleFA+ deploy deployName [fn1CHA, fn2CHA] [resCHA] _ =+ dispatcher+ where+ fn1CH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: joinFADomProcess: fn1CH:"+ fn1CHA+ fn2CH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: joinFADomProcess: fn2CH:"+ fn2CHA+ resCH = + CH.castOut "ERNet.Blocks.RnToRm.Basic: joinFADomProcess: resCH:"+ resCHA+ + _ = CH.answerQuery False resCH (0, QAChangesANew $ QAIxA $ QAFn1A sampleFA)+ + dispatcher = -- standard code+ do+ qryData <- CH.waitForQuery resCH+ forkIO $ responder qryData+ dispatcher+ + responder (resQryId, (QAChangesQWhenNew _ (QAIxQ ix qry))) =+ do+ fnQryId1 <- CH.makeQuery resCH resQryId fn1CH (QAChangesQWhenNew 0 $ QAIxQ ix qry1)+ fnQryId2 <- CH.makeQuery resCH resQryId fn2CH (QAChangesQWhenNew 0 $ QAIxQ ix qry2)+ ans1 <-+ CH.waitForAnswer resCH resQryId fn1CH fnQryId1+ ans2 <- + CH.waitForAnswer resCH resQryId fn2CH fnQryId2+ case (ans1, ans2) of+ (QAChangesANew (QAIxA (QAFn1A fa1)), + QAChangesANew (QAIxA (QAFn1A fa2))) -> + CH.answerQuery False resCH + (resQryId, + QAChangesANew $ QAIxA $ QAFn1A $ FA.unBisect defaultVar (fa1,fa2))+ _ -> CH.answerQuery False resCH (resQryId, QAChangesAGivenUp)+ where+ (qry1, qry2) =+ case qry of+ QAFn1QAll -> + (QAFn1QAll, QAFn1QAll)+ QAFn1QDom domB -> + (QAFn1QDom (DBox.unary dom1), QAFn1QDom (DBox.unary dom2))+ where+ (dom1, dom2) = RA.bisectDomain Nothing dom+ [dom] = DBox.elems domB++{-|+ A process splitting a function into two based on a bisection of the domain.+ + A query for either half of the function results in a query for the whole.+ The whole function is then cached to answer an analogous query for the second half.+ Only one such result is cached (always the last one). +-}+splitFADomProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ FA.ERFnDomApprox box varid domra ranra fa,+ Typeable box, Typeable fa, Show box, H.HTML fa,+ RAEL.ERApproxElementary domra, RAEL.ERApproxElementary ranra,+ Typeable domra, Typeable ranra) =>+ ERProcessName {-^ process identifier (string) -} ->+ fa {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+splitFADomProcess defName sampleFA =+ ERProcess defName deploy [chtpFnNoIx] [chtpFnNoIx, chtpFnNoIx]+ where+ chtpFnNoIx = chTFn1 sampleFA+ deploy deployName [fnCHA] [res1CHA, res2CHA] _ =+ dispatcher Nothing+ where+ fnCH = + CH.castIn "ERNet.Blocks.RnToRm.Basic: splitFADomProcess: fnCH:"+ fnCHA+ res1CH = + CH.castOut "ERNet.Blocks.RnToRm.Basic: splitFADomProcess: res1CH:"+ res1CHA+ res2CH = + CH.castOut "ERNet.Blocks.RnToRm.Basic: splitFADomProcess: res2CH:"+ res2CHA+ + _ = do+ (QAFn1A fnFA) <- CH.waitForAnswer res1CH 0 fnCH 0+ let _ = [sampleFA, fnFA]+ return ()+ + dispatcher maybeFnSideQry =+ do+ (chN, (resQryId, QueryAnyProt qry)) <- CH.waitForQueryMulti [res1CHA, res2CHA]+ -- explore the history and see whether the answer is already known+ (maybeAnsFA, updatedMaybeFnSideQry) <- case (maybeFnSideQry, cast qry) of+ (Just (fnFA, prevN, prevQry), Just newQry)+ | chN /= prevN && prevQry == newQry -> -- got it!+ return (Just $ getHalfFA chN fnFA, Nothing)+ (_, Just qry) -> -- nope, need to get the function again+ do+ fnQryId <- CH.makeQuery (resCH chN) resQryId fnCH qry -- assuming QAFn1QAll+ ans <- CH.waitForAnswer (resCH chN) resQryId fnCH fnQryId+ return $+ case ans of+ (QAFn1A fullFA) ->+-- QAChangesAGivenUp -> +-- (Nothing, Nothing)+-- QAChangesANew (QAIxA (QAFn1A fullFA)) ->+ (Just $ getHalfFA chN fullFA, Just (fullFA, chN, qry))+ -- answer original query+ CH.answerQuery False (resCH chN) (resQryId, makeAns maybeAnsFA)+ dispatcher updatedMaybeFnSideQry+ where+ resCH chN = [res1CH, res2CH] !! chN+ +-- makeAns Nothing = QAChangesAGivenUp+ makeAns (Just resFA) =+-- QAChangesANew (QAIxA (QAFn1A resFA))+ QAFn1A resFA+ getHalfFA chN fullFA =+ ([fst, snd] !! chN) $ FA.bisect defaultVar Nothing fullFA++ +{-|+ A process passing on information about a real function, trying to improve the+ convergence rate in successive queries.+ + Each query may refer to a previous query. When it does,+ the query will not be answered until either:+ + * the information about the function has improved by the desired amount since last time + + * the number of queries made in response to this query has reached the given limit+-}+rateFnProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ FA.ERFnDomApprox box varid domra ranra fa,+ Typeable box, Typeable fa, Show box, H.HTML fa,+ RAEL.ERApproxElementary domra, RAEL.ERApproxElementary ranra,+ Typeable domra, Typeable ranra) =>+ ERProcessName {-^ process identifier (string) -} ->+ Rational {-^ desired ratio of improvement -} ->+ Int {-^ maximum number of attempts to reach desired improvement -} ->+ fa {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+rateFnProcess defName desiredImpr maxAttepts sampleFA =+ rateProcess defName goodEnough maxAttepts chtpFnC+ where+ chtpFnC = chTChanges chtpFn+ chtpFn = chTIx chtpFnNoIx+ chtpFnNoIx = chTFn1 sampleFA+ goodEnough _ QAChangesAGivenUp = True+ goodEnough QAChangesAGivenUp _ = True+ goodEnough+ (QAChangesANew (QAIxA (QAFn1A prevFA))) + (QAChangesANew (QAIxA (QAFn1A newFA))) =+ case RA.compareReals (impr) (fromRational desiredImpr) of+ Just LT -> False + _ -> True+ where+ (_, impr) = FA.intersectMeasureImprovement 20 prevFA newFA+ _ = prevFA == sampleFA++ +{-|+ A process passing on information about the values of a real function + at its domain endpoints. + + Protocols are wrapped in 'ChannelComm.ChTChanges' + in order to be able to communicate failure.+-}+getEndpointValsProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ FA.ERFnDomApprox box varid domra ranra fa,+ Typeable box, Typeable fa, Show box, H.HTML fa,+ RAEL.ERApproxElementary domra, RAEL.ERApproxElementary ranra,+ Typeable domra, Typeable ranra) =>+ ERProcessName {-^ process identifier (string) -} ->+ fa {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+getEndpointValsProcess defName sampleFA =+ ERProcess defName deploy [chtpFnC, chtpFnNoIx] [chtpRsC, chtpRsC]+ where+ chtpFnC = chTChanges chtpFn+ chtpFn = chTIx chtpFnNoIx+ chtpFnNoIx = chTFn1 sampleFA+ chtpRNoIxC = chTChanges (chTReal sampleRanRA)+ sampleDomRA = 0+ sampleRanRA = head $ FA.eval (DBox.unary sampleDomRA) sampleFA+ chtpRsC = chTChanges $ chTIx $ chTList $ chTReal sampleRanRA+ deploy _ [fnCHA, fastFnCHA] [res1CHA, res2CHA] _ =+ do+ dispatcher Nothing+ where+ fnCH =+ CH.castIn "ERNet.Blocks.RnToRm.Basic: getEndpointValsProcess: fnCH:"+ fnCHA+ fastFnCH =+ CH.castIn "ERNet.Blocks.RnToRm.Basic: getEndpointValsProcess: fastFnCH:"+ fastFnCHA+ res1CH = + CH.castOut "ERNet.Blocks.RnToRm.Basic: getEndpointValsProcess: res1CH:"+ res1CHA+ res2CH = + CH.castOut "ERNet.Blocks.RnToRm.Basic: getEndpointValsProcess: res2CH:"+ res2CHA+ _ = do+ (QAChangesANew (QAIxA (QAFn1A fnFA))) <- CH.waitForAnswer res1CH 0 fnCH 0+ (QAFn1A fastFnFA) <- CH.waitForAnswer res1CH 0 fastFnCH 0+ let _ = [sampleFA, fnFA, fastFnFA]+ return ()++ dispatcher maybeEndpoints =+ do+ (chN, qryData) <- CH.waitForQueryMulti [res1CHA, res2CHA]+ endPoints <- case maybeEndpoints of+ Just endPoints -> return endPoints+ Nothing -> obtainEndpoints qryData ([res1CH, res2CH] !! chN)+ case chN of+ 0 -> forkIO $ responder qryData (fst endPoints) res1CH+ 1 -> forkIO $ responder qryData (snd endPoints) res2CH+ dispatcher (Just endPoints)+ + obtainEndpoints qryData@(resQryId, _) resCH =+ do+ fnQryId <- CH.makeQuery resCH resQryId fastFnCH QAFn1QAll+ (QAFn1A fa) <- CH.waitForAnswer resCH resQryId fastFnCH fnQryId+ let [dom] = DBox.elems $ FA.dom fa+ return $ RA.bounds dom+ + responder (resQryId, (QueryAnyProt qry)) endPoint resCH =+ do+ fnQryId <- CH.makeQuery resCH resQryId fnCH fnQry+ fnAns <- CH.waitForAnswer resCH resQryId fnCH fnQryId+ let ans = case fnAns of+ QAChangesAGivenUp -> + QAChangesAGivenUp+ QAChangesANew (QAIxA (QAFn1APt vals)) -> + QAChangesANew $ QAIxA $ QAListA $ map QARealA vals+ CH.answerQuery False resCH (resQryId, ans)+ where+ Just (QAChangesQWhenNew _ (QAIxQ ix (QAListQAllHomog (QARealQ)))) = cast qry+ fnQry = + QAChangesQWhenNew 0 $ + QAIxQ ix $ QAFn1QPt (DBox.unary endPoint)+ ++{-|+ A process passing on information about the values of a real function + over a fixed domain.+ + Protocols are wrapped in 'ChannelComm.ChTChanges' + in order to be able to communicate failure.+-}+maxOverDomProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,+ FA.ERFnDomApprox box varid domra ranra fa,+ Typeable box, Typeable fa, Show box, H.HTML fa,+ RAEL.ERApproxElementary domra, RAEL.ERApproxElementary ranra,+ Typeable domra, Typeable ranra) =>+ ERProcessName {-^ process identifier (string) -} ->+ box {-^ domain over which to search for maximum -} ->+ fa {-^ sample approximation to aid typechecking -} ->+ ERProcess sInAnyProt sOutAnyProt+maxOverDomProcess defName dom sampleFA =+ ERProcess defName deploy [chtpFnNoIx] [chtpRNoIx]+ where+ chtpFnNoIx = chTFn1 sampleFA+ chtpRNoIx = chTReal sampleRanRA+ sampleDomRA = 0+ sampleRanRA = head $ FA.eval (DBox.unary sampleDomRA) sampleFA+ deploy _ [fnCHA] [resCHA] _ =+ do+-- activePartitionTV <-+-- atomically $ newTVar $ +-- (False, BISTR.const domC (Just RA.bottomApprox))+-- dispatcher activePartitionTV+ dispatcher (RA.bottomApprox, BISTR.const dom (Just RA.bottomApprox))+ where+ fnCH =+ CH.castIn "ERNet.Blocks.RnToRm.Basic: maxOverDomProcess: fnCH:"+ fnCHA+ resCH = + CH.castOut "ERNet.Blocks.RnToRm.Basic: maxOverDomProcess: resCH:"+ resCHA++-- _ = CH.answerQuery False fnCH (0, QAIxA $ QAFn1A sampleFA)+ _ = CH.answerQuery False resCH (0, QARealA sampleRanRA)+ _ = do+ (QAFn1A fnFA) <- CH.waitForAnswer resCH 0 fnCH 0+ let _ = [sampleFA, fnFA]+ return ()+ + dispatcher (prevResult, prevBistr) =+ do+ qryData <- CH.waitForQuery resCH+-- forkIO $ responder activePartitionTV qryData+ (newResult, newBistr) <- responder (prevResult, prevBistr) qryData+ dispatcher (newResult, newBistr)+ + responder (prevResult, prevBistr) qryData@(qryId, qry) =+ do+-- atomically $ getLock activePartitionTV+-- (_, oldBistr) <- atomically $ readTVar activePartitionTV+ splitBistr <- BISTR.doMapLeaves (processLeaf qryId) Nothing prevBistr+ let (newBistr, newResult) = normalisePartition prevResult splitBistr+ CH.answerQuery False resCH (qryId, QARealA newResult) + return (newResult, newBistr) +-- atomically $ writeTVar activePartitionTV (True, newBistr) +-- atomically $ releaseLock activePartitionTV+ + -- ignore a segment that we have marked as ruled out: + processLeaf _ bistr@(BISTR.Leaf _ _ Nothing) = + return bistr + -- split a segment that we have not yet ruled out: + processLeaf resQryId bistr@(BISTR.Leaf depth dom (Just b)) =+ do+ domLOQryId <- + CH.makeQuery resCH resQryId fnCH $ + QAFn1QPt domLO + domHIQryId <- + CH.makeQuery resCH resQryId fnCH $ + QAFn1QPt domHI+ (QAFn1APt [boundLO]) <-+ CH.waitForAnswer resCH resQryId fnCH domLOQryId+ (QAFn1APt [boundHI]) <-+ CH.waitForAnswer resCH resQryId fnCH domHIQryId+ return $+ BISTR.Node depth dom var pt + (bistrLO { BISTR.bistrVal = Just boundLO }) + (bistrHI { BISTR.bistrVal = Just boundHI })+ where+ (var, pt) = DBox.bestSplit dom+ (domLO, domHI) = DBox.split dom var pt+ BISTR.Node _ _ _ _ bistrLO bistrHI =+ BISTR.split undefined 0 var pt dom bistr++ -- mark all segments that cannot contain maximum+ -- and recompute the current best knowledge about the maximum from the partition: + normalisePartition prevQryBound bistr =+ (normalisedBistr, resBound RA./\ prevQryBound)+ where+ resBound = resBoundLO RA.\/ resBoundHI+ (resBoundLO, resBoundHI) = + foldl addBound (-1/0, -1/0) $ BISTR.collectValues bistr+ where+ addBound prevBounds Nothing = prevBounds + addBound (prevBoundLO, prevBoundHI) (Just newBound) =+ (max newBoundLO prevBoundLO, max newBoundHI prevBoundHI)+ where+ (newBoundLO, newBoundHI) = RA.bounds newBound + normalisedBistr = + BISTR.mapWithDom removeIrrelevantBound bistr+ where+ removeIrrelevantBound dom Nothing = Nothing+ removeIrrelevantBound dom (Just bound)+ | boundHI `RA.ltSingletons` resBoundLO = Nothing+ -- ie this box has to be strictly below the maximum+ | boundHI `RA.eqSingletons` resBoundLO && boundHI `RA.ltSingletons` resBoundHI = Nothing+ -- ie the function could potentially reach its maximum in this box + -- but such maximum would be also have to be reached in another box+ -- (although it is much more likely that the function + -- does not reach its maximum in this box) + | otherwise = Just bound+ where+ (_, boundHI) = RA.bounds bound+ +-- getLock activePartitionTV =+-- do+-- (locked, partition) <- readTVar activePartitionTV+-- case locked of+-- True -> retry+-- False -> +-- writeTVar activePartitionTV (True, partition) +-- releaseLock activePartitionTV =+-- do+-- (_, partition) <- readTVar activePartitionTV+-- writeTVar activePartitionTV (False, partition)+--
+ src/Control/ERNet/Blocks/RnToRm/Protocols.hs view
@@ -0,0 +1,233 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-|+ Module : Control.ERNet.Blocks.Real.Protocols+ Description : protocols for communicating real functions+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ Basic protocols for transferring approximations of real functions. ++-}++module Control.ERNet.Blocks.RnToRm.Protocols where++import Control.ERNet.Foundations.Protocol+import Control.ERNet.Foundations.Protocol.StandardCombinators++import qualified Data.Number.ER.RnToRm.Approx as FA+import qualified Data.Number.ER.Real.Approx as RA+import qualified Data.Number.ER.Real.Approx.Elementary as RAEL++import qualified Data.Number.ER.Real.DomainBox as DBox+import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox)++import Data.Number.ER.Misc+import Data.Number.ER.BasicTypes++import Data.Number.ER.ShowHTML+import qualified Text.Html as H++import Data.Typeable+++{- protocol for first-order functions -}++instance+ (FA.ERFnApprox box varid domra ranra fa,+ RAEL.ERApproxElementary domra, + RAEL.ERApproxElementary ranra,+ Typeable box, Show box,+ Typeable domra, Typeable ranra, Typeable fa,+ H.HTML fa) =>+ (QAProtocol (QAFn1Q box) (QAFn1A ranra fa))+ where+ qaMatch (QAFn1QAll) (QAFn1A _) = Nothing+ qaMatch (QAFn1QDom _) (QAFn1A _) = Nothing+ qaMatch (QAFn1QPt _) (QAFn1APt _) = Nothing+ qaMatch q a = + Just $ "function " ++ (qaMatchDefaultMessage q a)++data QAFn1Q box+ = QAFn1QAll+ | QAFn1QDom box+ | QAFn1QPt box+ deriving (Show, Typeable)+ +data QAFn1A ranra fa+ = QAFn1A fa+ | QAFn1APt [ranra]+ deriving (Show, Typeable)++chTFn1 :: + (FA.ERFnApprox box varid domra ranra fa,+ RAEL.ERApproxElementary domra, + RAEL.ERApproxElementary ranra,+ Typeable box, Show box,+ Typeable domra, Typeable ranra, Typeable fa,+ H.HTML fa) =>+ fa -> ChannelType+chTFn1 sampleFA = ChannelType QAFn1QAll (QAFn1A sampleFA)+ +instance (DomainBox box varid domra, RA.ERApprox domra) => Eq (QAFn1Q box)+ where+ (QAFn1QAll) == (QAFn1QAll) = True+ (QAFn1QDom dom1) == (QAFn1QDom dom2) =+ (and $ map snd $ DBox.zipWithDefault RA.bottomApprox RA.equalApprox dom1 dom2)+ (QAFn1QPt x1) == (QAFn1QPt x2) =+ (and $ map snd $ DBox.zipWithDefault RA.bottomApprox RA.equalApprox x1 x2)+ _ == _ = False++instance (DomainBox box varid domra, RA.ERApprox domra) => Ord (QAFn1Q box)+ where+ compare (QAFn1QAll) (QAFn1QAll) = EQ+ compare (QAFn1QDom dom1) (QAFn1QDom dom2) =+ compareComposeMany $ map snd $ + DBox.zipWithDefault RA.bottomApprox RA.compareApprox dom1 dom2 + compare (QAFn1QPt pt1) (QAFn1QPt pt2) =+ compareComposeMany $ map snd $ + DBox.zipWithDefault RA.bottomApprox RA.compareApprox pt1 pt2 + compare (QAFn1QAll) (QAFn1QDom _) = LT+ compare (QAFn1QDom _) (QAFn1QAll) = GT+ compare (QAFn1QAll) (QAFn1QPt _) = LT+ compare (QAFn1QPt _) (QAFn1QAll) = GT+ compare (QAFn1QDom _) (QAFn1QPt _) = LT+ compare (QAFn1QPt _) (QAFn1QDom _) = GT++instance (FA.ERFnApprox box varid domra ranra fa) => Eq (QAFn1A ranra fa)+ where+ (QAFn1A fa1) == (QAFn1A fa2) = RA.equalApprox fa1 fa2+ (QAFn1APt vals1) == (QAFn1APt vals2) =+ (and $ zipWith RA.equalApprox vals1 vals2)+ _ == _ = False++++instance (Show box) => H.HTML (QAFn1Q box) where+ toHtml = toHtmlDefault+instance (Show ranra, H.HTML fa) => H.HTML (QAFn1A ranra fa)+ where+ toHtml (QAFn1APt doms) = + H.toHtml $ "QAFn1APt " ++ " " ++ show doms+ toHtml (QAFn1A fa) =+ H.toHtml $ + abovesTable [H.border 2]+ [+ H.toHtml "QAFn1A"+ ,+ H.toHtml fa+ ] +{-|+ Construct an answer about a function, assuming+ they will not ask about a subdomain.+-}+makeAnswerFn1NoIx ::+ (FA.ERFnApprox box varid domra ranra fa) =>+ fa ->+ (QAFn1Q box) ->+ (QAFn1A ranra fa)+makeAnswerFn1NoIx fa qry =+ case qry of+ QAFn1QAll -> QAFn1A fa+ QAFn1QDom doms -> QAFn1A fa+ QAFn1QPt vals ->+ QAFn1APt $ FA.eval vals fa++{-|+ Construct an answer about a function, given+ as a Haskell real -> real function.+-}+makeAnswerFn1ByBoxesNoIx ::+ (FA.ERFnDomApprox box varid domra ranra fa) =>+ (box -> [ranra]) ->+ (QAFn1Q box) ->+ (QAFn1A ranra fa)+makeAnswerFn1ByBoxesNoIx computeBounds qry =+ case qry of+ (QAFn1QPt domB) ->+ QAFn1APt $ computeBounds domB+ (QAFn1QDom domB) ->+ QAFn1A $ FA.const domB $ computeBounds domB+++ +{- protocol for functions (R^m -> R^n) -> (R^m -> R^n) -}++instance (FA.ERFnApprox box varid domra ranra fa, Typeable fa, H.HTML fa) =>+ (QAProtocol (QAFn2Q fa) (QAFn2A fa))+ where+ qaMatch _ _ = Nothing++data QAFn2Q fa+ = QAFn2QPt fa+ deriving (Show, Typeable)+ +data QAFn2A fa+ = QAFn2APt fa+ deriving (Show, Typeable)++chTFn2 :: + (FA.ERFnApprox box varid domra ranra fa,+ RAEL.ERApproxElementary domra, + RAEL.ERApproxElementary ranra,+ Typeable box, Show box,+ Typeable domra, Typeable ranra, Typeable fa,+ H.HTML fa) =>+ fa -> ChannelType+chTFn2 sampleFA = ChannelType (QAFn2QPt sampleFA) (QAFn2APt sampleFA)++instance (FA.ERFnApprox box varid domra ranra fa) => Eq (QAFn2Q fa)+ where+ (QAFn2QPt fn1) == (QAFn2QPt fn2) = + RA.equalApprox fn1 fn2++instance (FA.ERFnApprox box varid domra ranra fa) => Eq (QAFn2A fa)+ where+ (QAFn2APt fn1) == (QAFn2APt fn2) = + RA.equalApprox fn1 fn2++instance (FA.ERFnApprox box varid domra ranra fa) => Ord (QAFn2Q fa)+ where+ compare (QAFn2QPt fn1) (QAFn2QPt fn2) =+ RA.compareApprox fn1 fn2 ++instance (H.HTML fa) => H.HTML (QAFn2Q fa)+ where+ toHtml (QAFn2QPt fa) =+ H.toHtml $+ abovesTable [H.border 2]+ [+ H.toHtml "QAFn2QPt "+ ,+ H.toHtml fa+ ] ++instance (H.HTML fa) => H.HTML (QAFn2A fa)+ where+ toHtml (QAFn2APt fa) = + H.toHtml $+ abovesTable [H.border 2]+ [+ H.toHtml "QAFn2APt "+ ,+ H.toHtml fa+ ]+ ++-- TODO: rename the following reply... functions to makeAnswer... +-- and unify them with existing makeAnswer... functions +replyFn f (QAIxQ ix QAFn1QAll) =+ QAIxA $ QAFn1A (f ix)+ +replyFnNoIx f QAFn1QAll =+ QAFn1A f+ +replyFn2Fn f2f (QAIxQ ix (QAFn2QPt argFA)) =+ QAIxA $ QAFn2APt (f2f ix argFA)+
+ src/Control/ERNet/Deployment/Local/Channel.hs view
@@ -0,0 +1,478 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-|+ Module : Control.ERNet.Deployment.Local.Channel+ Description : channel implementation using STM+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ A simple channel implementation using STM protected variables.+-}+module Control.ERNet.Deployment.Local.Channel +(+ ChannelLocal,+ ChannelLocalAnyProt+)+where++import Control.ERNet.Deployment.Local.Logger++import Control.ERNet.Foundations.Protocol+import Control.ERNet.Foundations.Event+import qualified Control.ERNet.Foundations.Event.Logger as LG+import qualified Control.ERNet.Foundations.Channel as CH++import Control.Concurrent as Concurrent+import Control.Concurrent.STM+import Data.Number.ER.MiscSTM++--import System.Time+import Data.Time.Clock++import qualified Data.Map as Map+import Data.Maybe+import Data.Typeable++instance CH.Channel ChannelLocal ChannelLocal ChannelLocalAnyProt ChannelLocalAnyProt+ where+ castIn = castChannel+ castOut = castChannel+ castInIO = castChannelIO+ castOutIO = castChannelIO+ makeQuery = makeQuery+ makeQueryAnyProt = makeQueryAnyProt+ waitForQuery = waitForQuery+ waitForQueryMulti = waitForQueryMulti+ answerQuery = answerQuery+ answerQueryAnyProt = answerQueryAnyProt+ waitForAnswer = waitForAnswer+ waitForAnswerMulti = waitForAnswerMulti+ +instance CH.ChannelForScheduler LoggerLocal ChannelLocal ChannelLocal ChannelLocalAnyProt ChannelLocalAnyProt+ where+ new = newChannel ++{-|+ Union of channel types over instances of the 'ChannelComm.QERrotocol' class.+ + (existential type) +-}+data ChannelLocalAnyProt =+ forall q a. (QAProtocol q a, Show q, Show a) =>+ ChannelLocalAnyProt+ {+ chanyCH :: (ChannelLocal q a)+ ,+ chanyChT :: ChannelType+ }++data ChannelLocal q a =+ ChannelLocal+ {+-- chExampleQA :: (q,a),+ chTV :: TVar (ChannelState q a),+ chLogger :: LoggerLocal,+ chDestination :: String,+ chID :: Int -- ^ rank within its answering process (0..)+ }+ deriving (Typeable)+ +instance (Eq (ChannelLocal q a)) where+ ch1 == ch2 = (chID ch1) == (chID ch2)+instance (Ord (ChannelLocal q a)) where+ compare ch1 ch2 = compare (chID ch1) (chID ch2)+instance (Show (ChannelLocal q a)) where+ show ch = "CH" ++ show (chID ch)++type ChannelName = String++makeChName ::+ ChannelLocal q a ->+ ChannelName+makeChName channel+ | cId == 0 = procName+ | otherwise = procName ++ show (cId)+ where+ procName = chDestination channel+ cId = chID channel ++data ChannelState q a =+ ChannelState+ {+ chStNextId :: QueryId,+ -- ^ unique query Id to use for the next query+ chStQueriesNew :: [(QueryId, q)],+ -- ^ queries that have not been picked up yet+ chStQueriesCache :: Map.Map QueryId (QAState q),+ -- ^ queries that are being served or whose answers have been cached+ chStQueriesIndex :: Map.Map q QueryId,+ -- ^ index to queries that are being served or whose answers have been cached+ chStAnswers :: Map.Map QueryId (a, Bool)+ -- ^ answers that have not been picked up yet or have been cached + indicator whether to cache+ }++initialChState = + ChannelState 1 [] Map.empty Map.empty Map.empty++data QAState q =+ QAState+ {+ qaStQry :: q,+ qaStWaiting :: Int+ {-^ + This number indicates how many times this query has been made + and answers not picked up yet.+ + When 0, this QAstate and the corresponding answer + can be removed from the channel state unless the answer is cached. + -} + } + +initialQAState qry = QAState qry 1++newChannel ::+ LoggerLocal {-^ for logging events -} ->+ String {-^ name of channel responder process -} ->+ Int {-^ channel id -} ->+ ChannelType {-^ used to determine the embedded instance of QAProtocol -} ->+ IO (ChannelLocalAnyProt, ChannelLocalAnyProt)+newChannel logger procName cID chType =+ do+ cha <- auxNewCHA chType + return (cha, cha)+ where+ auxNewCHA chType@(ChannelType (q :: q) (a :: a)) =+ do+ cTV <- newTVarIO initialChState + return $ + ChannelLocalAnyProt + ((chan cTV) :: ChannelLocal q a) + chType+ chan cTV =+ ChannelLocal+ {+ chID = cID,+ chTV = cTV,+ chLogger = logger,+ chDestination = procName+ }+++castChannel ::+ (QAProtocol q a) =>+ String {-^ place where function used; for error messages -} ->+ ChannelLocalAnyProt ->+ (ChannelLocal q a)+castChannel locationDescr chA =+ case chA of+ ChannelLocalAnyProt ch chtp ->+ case cast ch of+ Just ch -> ch+ Nothing -> + channelCastError locationDescr (makeChName ch) chtp+castChannelIO ::+ (QAProtocol q a) =>+ String {-^ place where function used; for error messages -} ->+ ChannelLocalAnyProt ->+ IO (ChannelLocal q a)+castChannelIO locationDescr chA =+ do+ (chA_, _) <- newChannel undefined "" 0 chtp + case (chA, chA_) of+ (ChannelLocalAnyProt ch _, ChannelLocalAnyProt ch_ _) -> + case [cast ch, cast ch_] of+ [Just ch, Just _] ->+ return ch+ _ -> + channelCastError locationDescr (makeChName ch) chtp+ where+ chtp = chanyChT chA++channelCastError ::+ String ->+ ChannelName ->+ ChannelType ->+ a+channelCastError locationDescr chnm chtp =+ error $ + locationDescr + ++ " failed casting channel " ++ chnm+ ++ " to " ++ show chtp + + +makeQuery callingCh callingQryId channel qry =+ do+ qryId <- atomically updateChSt+ timeNow <- getCurrentTime+ LG.addEvent (chLogger channel)+ ERNetEvQryMade+ {+ ernetevTime = timeNow,+ ernetevQryId = qryId,+ ernetevFromId = makeChName callingCh,+ ernetevFromQryId = callingQryId,+ ernetevToId = makeChName channel,+ ernetevQry = qry+ }+ return qryId+ where+ updateChSt =+ do+ chSt <- readTVar cTV+ case (Map.lookup qry (chStQueriesIndex chSt)) of+ (Nothing) -> + do+ writeTVar cTV (updateNew chSt)+ return $ chStNextId chSt+ (Just qryId) ->+ do+ writeTVar cTV (updateOld chSt qryId)+ return qryId+ where+ cTV = chTV channel+ updateNew chSt =+ chSt+ {+ chStNextId = qryId + 1,+ chStQueriesNew = + (chStQueriesNew chSt) ++ [(qryId, qry)],+ chStQueriesCache =+ Map.insert qryId (initialQAState qry) (chStQueriesCache chSt),+ -- remember the query so that answer can be logged with+ -- the query included+ chStQueriesIndex =+ Map.insert qry qryId (chStQueriesIndex chSt)+ -- index the query so that we can recognise it when it comes again+ }+ where+ qryId = chStNextId chSt+ updateOld chSt qryId =+ chSt+ {+ chStQueriesCache =+ Map.adjust cacheIncCount qryId (chStQueriesCache chSt)+ }+ where+ cacheIncCount qaSt@(QAState _ count) =+ qaSt { qaStWaiting = count + 1 }++makeQueryAnyProt locationDescr callingCHA callingQryId chA qry =+ case (callingCHA, qry) of+ (ChannelLocalAnyProt callingCH _, QueryAnyProt q) ->+ do+ ch <- castChannelIO locationDescr chA+ makeQuery callingCH callingQryId ch q+ +waitForQuery channel =+ do+ (qryId, qry) <- atomically waitUpdateChSt+-- timeNow <- getCurrentTime+-- addEvent (chLogTV channel)+-- ERNetEvQryReceived+-- {+-- ernetevTime = timeNow,+-- ernetevQryId = qryId,+-- ernetevToId = makeChName channel,+-- ernetevQry = qry+-- }+ return (qryId, qry)+ where+ waitUpdateChSt =+ do+ chSt <- readTVar cTV+ exploreState chSt+ where+ cTV = chTV channel+ exploreState chSt =+ case chStQueriesNew chSt of+ [] -> + retry -- no queries on this channel, wait+ (qryData : otherQueries) -> -- a new query found on channel number chN+ do+ writeTVar cTV chSt' -- remove it from the queue+ return qryData+ where+ chSt' = + chSt+ {+ chStQueriesNew = otherQueries+ }+ +waitForQueryMulti channels =+ do+ (chN, qryData) <- atomically waitUpdateChSt+-- timeNow <- getClockTime+-- addEvent (chLogTV channel)+-- ERNetEvQryReceived+-- {+-- ernetevTime = timeNow,+-- ernetevQryId = qryId,+-- ernetevToId = case channels !! chN of Just channel -> makeChName channel+-- ernetevQry = qry+-- }+ return (chN, qryData)+ where+ waitUpdateChSt =+ do+ exploreChannels $ zip [0..] channels+ where+ exploreChannels [] = retry -- no new queries, keep waiting+ exploreChannels ((chN, ChannelLocalAnyProt ch _) : otherChannels) =+ do+ res <- exploreState $ chTV ch + case res of+ Nothing -> exploreChannels otherChannels+ Just qryData -> return (chN, qryData) + exploreState cTV =+ do+ chSt <- readTVar cTV+ case chStQueriesNew chSt of+ [] -> + return Nothing -- no queries on this channel, try another one+ ((qryId, qry) : otherQueries) -> -- a new query found on channel number chN+ do+ writeTVar cTV chSt' -- remove it from the queue+ return $ Just (qryId, QueryAnyProt qry)+ where+ chSt' = + chSt+ {+ chStQueriesNew = otherQueries+ }++answerQuery useCache channel (qryId, ans) =+ do+ atomically updateChSt+-- timeNow <- getClockTime+-- addEvent (chLogTV channel)+-- ERNetEvAnsMade+-- {+-- ernetevTime = timeNow,+-- ernetevQryId = qryId,+-- ernetevToId = makeChName channel,+-- ernetevAns = ans+-- }++-- putStrLn $ "answerQuery: " ++ answeringProcess ++ " inserted answer for qryId=" ++ show qryId+ return ()+ where+ updateChSt =+ do+ modifyTVar cTV update+ where+ cTV = chTV channel+ update chSt =+ chSt+ {+ chStAnswers =+ Map.insert qryId (ans, useCache) (chStAnswers chSt)+ }++answerQueryAnyProt locationDescr useCache chA (qryId, ans) =+ case ans of + AnswerAnyProt a ->+ answerQuery useCache (castChannel locationDescr chA) (qryId, a)+ +waitForAnswer waitingCh waitingQryId channel qryId =+ do+-- putStrLn $ "waitForAnswer: " ++ waitingProcess ++ " waiting for answer to qryId=" ++ show qryId+ (qry, ans) <- atomically waitUpdateChSt+ timeNow <- getCurrentTime+ LG.addEvent (chLogger channel)+ ERNetEvAnsReceived+ {+ ernetevTime = timeNow,+ ernetevQryId = qryId,+ ernetevFromId = makeChName waitingCh,+ ernetevFromQryId = waitingQryId,+ ernetevToId = makeChName channel,+ ernetevAns = ans,+ ernetevQry = qry+ }+ return ans+ where+ waitUpdateChSt =+ do+ chSt <- readTVar cTV+ case Map.lookup qryId (chStAnswers chSt) of+ Nothing -> retry+ Just (ans, isCached) ->+ do+ writeTVar cTV chSt'+ return (qry, ans)+ where+ (chSt', qry) = + waitForAnswerAUX qryId chSt isCached+ cTV = chTV channel++waitForAnswerAUX qryId chSt isCached =+ (chSt', qry)+ where + (Just (QAState qry count)) = + qryId `Map.lookup` (chStQueriesCache chSt)+ chSt' + | count > 1 || isCached = + chSt+ {+ chStQueriesCache =+ Map.insert qryId (QAState qry (count - 1)) + (chStQueriesCache chSt)+ }+ | otherwise = + -- delete all references to this query: + chSt+ {+ chStQueriesCache =+ Map.delete qryId (chStQueriesCache chSt),+ chStQueriesIndex =+ Map.delete qry (chStQueriesIndex chSt),+ chStAnswers =+ Map.delete qryId (chStAnswers chSt)+ } ++waitForAnswerMulti waitingCHA waitingQryId channelIds =+ do+ (chN, chn, qryId, qry, ans) <- atomically $ waitUpdateChSt $ zip [0..] channelIds+ timeNow <- getCurrentTime+ case (waitingCHA, chn, qry, ans) of+ (ChannelLocalAnyProt waitingCH _, + ChannelLocalAnyProt ch _, + QueryAnyProt q, AnswerAnyProt a) -> + LG.addEvent (chLogger ch)+ ERNetEvAnsReceived+ {+ ernetevTime = timeNow,+ ernetevQryId = qryId,+ ernetevFromId = makeChName waitingCH,+ ernetevFromQryId = waitingQryId,+ ernetevToId = makeChName ch,+ ernetevAns = a,+ ernetevQry = fromJust $ cast q+ }+ return (chN, ans)+ where+ waitUpdateChSt [] = retry+ waitUpdateChSt ((chN, (channel, qryId)) : otherQueryInfos) =+ case channel of+ (ChannelLocalAnyProt ch chtp) ->+ do+ chSt <- readTVar cTV+ case Map.lookup qryId (chStAnswers chSt) of+ Nothing -> waitUpdateChSt otherQueryInfos+ Just (ans, isCached) ->+ do+ writeTVar cTV chSt'+ return (chN, ChannelLocalAnyProt ch chtp, qryId, QueryAnyProt qry, AnswerAnyProt ans)+ where+ (chSt', qry) = + waitForAnswerAUX qryId chSt isCached+ where+ cTV = chTV ch+
+ src/Control/ERNet/Deployment/Local/Logger.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleInstances #-}+{-|+ Module : Control.ERNet.Deployment.Local.Logger+ Description : logger implementation using an STM channel+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ A simple logger implementation using an STM channel.+-}+module Control.ERNet.Deployment.Local.Logger +(+ LoggerLocal()+)+where++import Control.ERNet.Foundations.Event+import qualified Control.ERNet.Foundations.Event.Logger as LG++--import Control.Concurrent as Concurrent+import Control.Concurrent.STM as STM++newtype LoggerLocal = LoggerLocal (TChan ERNetEvent)++instance LG.Logger LoggerLocal where+ new = + do+ logTV <- newTChanIO+ return $ LoggerLocal logTV+ addEvent (LoggerLocal logTV) event = + atomically $+ writeTChan logTV event+ emptyAndDo (LoggerLocal logTV) processEvent =+ keepProcessing+ where+ keepProcessing =+ do+ event <- atomically $ readTChan logTV+ processEvent event+ keepProcessing+ emptyAndGetEvents (LoggerLocal logTV) =+ keepProcessing+ where+ keepProcessing =+ do+ empty <- atomically $ isEmptyTChan logTV+ if empty + then return []+ else+ do+ event <- atomically $ readTChan logTV+ rest <- keepProcessing+ return $ event : rest+
+ src/Control/ERNet/Deployment/Local/Manager.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-|+ Module : Control.ERNet.Deployment.Local.Manager+ Description : manager implementation using local threads and STM + Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ A simple implementation of + "Control.ERNet.Foundations.Manager.Manager",+ deploying all processes locally.++-}++module Control.ERNet.Deployment.Local.Manager +(+ ManagerLocal()+)+where++import Control.ERNet.Deployment.Local.Logger+import Control.ERNet.Deployment.Local.Channel++import Control.ERNet.Foundations.Protocol+import Control.ERNet.Foundations.Event+import qualified Control.ERNet.Foundations.Event.Logger as LG+import qualified Control.ERNet.Foundations.Channel as CH+import Control.ERNet.Foundations.Process+import Control.ERNet.Foundations.Manager++import Control.Concurrent as Concurrent++import qualified Data.Map as Map++newtype ManagerLocal =+ ManagerLocal ManagerName+ +instance + Manager + ManagerLocal LoggerLocal + ChannelLocal ChannelLocal + ChannelLocalAnyProt ChannelLocalAnyProt+ where+ new name =+ do+ putStrLn $ "simulating the creation of network manager " ++ name+ return (ManagerLocal name, "ernet-local:/" ++ name)+ connectNeighbour (ManagerLocal name) neighbourID =+ do+ putStrLn $ + "simulating the connection of neighbour " + ++ neighbourID ++ " to the manager " ++ name+ return True+ runProcess (ManagerLocal name) process =+ do+ logger <- LG.new+ forkIO $ (erprocDeploy process) (erprocName process) [] [] (startNet logger)+ return logger+ +startNet + logger + locationDescr+ [] _ processesMappings =+ do+ deployProcesses logger locationDescr "" [] [] processesMappings+ return ()++startNet _ _ _ _ _ = + error $ + "Control.ERNet.Deployment.ManagerLocal: startNet: Illegal attempt to kick-start a network: outermost network cannot have input sockets" ++expandProcess + logger processNamePrefix inCHAs outCHAs -- these 4 provided by manager+ locationDescr inputTypesNames outputTypesNames processesMappings =+ do+ dispatcher Nothing+ where+ (outChTs, outChNs) = unzip outputTypesNames+ (inChTs, inChNs) = unzip inputTypesNames+ + dispatcher maybeN2channel =+ do+ -- wait for a query:+-- putStrLn $ "ERProcessNet: " ++ defName ++ ": waiting for a query on " ++ show (length resCHAs) ++ " channels" + (chN, qryData) <- CH.waitForQueryMulti outCHAs+-- putStrLn $ "ERProcessNet: " ++ defName ++ ": forwarding query on channel " ++ show chN + n2channel <- -- number |-> internal or input channel+ case maybeN2channel of+ Nothing -> -- the first query -> plumb the subnet+ deployProcesses + logger locationDescr processNamePrefix + inCHAs inChNs processesMappings + Just n2channel -> return n2channel+ -- pass on the query to the subnet:+ let fwdCHA = fst $ n2channel $ outChNs !! chN+ let outCHA = outCHAs !! chN+ let chT = outChTs !! chN+ forkIO $ forwardQueryAnswer outCHA fwdCHA chT qryData+ dispatcher (Just n2channel)+ + forwardQueryAnswer causeCHA fwdCHA chT (causeQryId, qryAnyProt) =+ do+ argQryId <- + CH.makeQueryAnyProt locationDescr causeCHA causeQryId fwdCHA qryAnyProt+ -- wait for answer from inside:+ (_, ansAnyProt) <- CH.waitForAnswerMulti causeCHA causeQryId [(fwdCHA, argQryId)]+ -- forward the answer out:+ CH.answerQueryAnyProt locationDescr False causeCHA (causeQryId, ansAnyProt)++deployProcesses :: + (CH.ChannelForScheduler lg sIn sOut sInAnyProt sOutAnyProt) =>+ lg -> + String -> + String -> + [sInAnyProt] -> + [Int] -> + [(ERProcess sInAnyProt sOutAnyProt, ([Int], [Int]))] -> + IO (Int -> (sInAnyProt, sOutAnyProt))+deployProcesses logger locationDescr namePrefix inCHAs inChNs processesMappings =+ do+ -- create required internal channels:+ internalCHAs <- + mapM makeNewChannel internalTypesNamesProcesses+ let n2channel = makeChannelMap internalCHAs+ -- deploy all internal processes:+ mapM (deployProcess n2channel) $ processesMappings+ return n2channel+ where+ makeNewChannel (((chN, chT), (procName, outChN))) =+ CH.new logger (namePrefix ++ procName) outChN chT+ internalTypesNamesProcesses = + concat $ map getProcessChanTypesNames processesMappings+ where+ getProcessChanTypesNames (process, (inNs, outNs)) = + (zip (zip outNs (erprocOutputTypes process)) $ + zip (repeat $ erprocName process) [0..])+ makeChannelMap internalCHAs n =+ case Map.lookup n n2chMap of+ Nothing -> + error $ locationDescr ++ " deployProcess: unknown channel number: " ++ show n+ Just ch -> ch+ where+ n2chMap = + Map.fromList $ + (zip internalChNs internalCHAs) ++ + (zip inChNs $ zip inCHAs (repeat errorOUT))+ errorOUT = + error "ManagerLocal: makeChannelMap: input channel treated as output channel"+ internalChNs = + concat $ map (snd . snd) processesMappings+ deployProcess n2channel (process, (processInChNs, processOutChNs)) =+ do+ forkIO $ + (erprocDeploy process) + name+ processInCHAs processOutCHAs+ (expandProcess logger (name ++ ".") processInCHAs processOutCHAs)+ where+ name = namePrefix ++ erprocName process+ processInCHAs = map (fst . n2channel) processInChNs+ processOutCHAs = map (snd . n2channel) processOutChNs+
+ src/Control/ERNet/Foundations/Channel.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FunctionalDependencies #-}+{-|+ Module : Control.ERNet.Foundations.Channel+ Description : an abstraction of channels within networks+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ Abstraction of data flow channels and its sockets with associated+ query-answer protocol for gradual data communication.+ + To be imported qualified, usually with the prefix CH.+-}++module Control.ERNet.Foundations.Channel where+++import qualified Control.ERNet.Foundations.Event.Logger as LG ++import Control.ERNet.Foundations.Protocol++{-| + A channel type, as it is presented to the processes, + consists of an input socket and an output socket types.+ + Each socket type has a unique protocol associated with+ it. Whenever the protocol can be determined at+ compile time, we use the sIn and sOut types, otherwise+ we use the sInAnyProt and sOutAnyProt types.+ Elements of sInAnyProt and sOutAnyProt can be dynamically+ cast to elements of sIn and sOut once the protocol+ can be deduced by the Haskell type checker. +-}+class Channel sIn sOut sInAnyProt sOutAnyProt+ | sIn -> sOut sInAnyProt sOutAnyProt,+ sOut -> sIn sInAnyProt sOutAnyProt,+ sInAnyProt -> sOutAnyProt sIn sOut, + sOutAnyProt -> sInAnyProt sIn sOut + where+ castIn ::+ (QAProtocol q a) =>+ String {-^ place where function used; for error messages -} -> + sInAnyProt -> + sIn q a+ castOut ::+ (QAProtocol q a) =>+ String {-^ place where function used; for error messages -} -> + sOutAnyProt -> + sOut q a+ castInIO ::+ (QAProtocol q a) =>+ String {-^ place where function used; for error messages -} -> + sInAnyProt -> + IO (sIn q a)+ castOutIO ::+ (QAProtocol q a) =>+ String {-^ place where function used; for error messages -} -> + sOutAnyProt -> + IO (sOut q a)+ {-|+ Register a new query on the given socket. + Return the new query's id.+ + This is a version using a statically typed protocol.+ -}+ makeQuery ::+ (QAProtocol q a, Show q, Show a) =>+ sOut q2 a2 {-^ initiator query socket -} ->+ QueryId {-^ the query to the initiator that this query reacts to -} ->+ sIn q a {-^ socket to send query to -} ->+ q {-^ the query data -} ->+ IO QueryId {-^ query ID to be able to match the answers with queries -}+ {-|+ Register a new query on the given socket. + Return the new query's id.+ + This is a version using a dynamically typed protocol.+ -}+ makeQueryAnyProt ::+ String {-^ place where function used; for error messages -} -> + sOutAnyProt {-^ initiator query socket -} ->+ QueryId {-^ the query to the initiator that this query reacts to -} ->+ sInAnyProt {-^ socket to send query to -} ->+ QueryAnyProt {-^ the query data -} ->+ IO QueryId {-^ query ID to be able to match the answers with queries -}+ {-|+ Wait until the given socket has at least one new query.+ When there is at least one, return the earliest one and set its status to pending.+ + This function uses a statically typed protocol.+ -}+ waitForQuery ::+ (QAProtocol q a, Show q, Show a) =>+ sOut q a {-^ output socket to wait on -} ->+ IO (QueryId, q)+ {-|+ Wait until one of the given sockets has at least one new query.+ When there is at least one, return the earliest one + and set its status to pending.+ + This is function uses a dynamically typed protocol.+ -}+ waitForQueryMulti ::+ [sOutAnyProt] {-^ output sockets to wait on -} ->+ IO (Int, (QueryId, QueryAnyProt))+ {-|+ Send the provided answer to the given socket as an answer to+ the query with the given query ID.+ + This is a version using a statically typed protocol.+ -}+ answerQuery ::+ (QAProtocol q a) =>+ Bool {-^ should the answer be cached? -} ->+ (sOut q a) -> + (QueryId, a) ->+ IO ()+ {-|+ Send the provided answer to the given socket as an answer to+ the query with the given query ID.+ + This is a version using a dynamically typed protocol.+ -}+ answerQueryAnyProt ::+ String {-^ place where function used; for error messages -} -> + Bool {-^ should the answer be cached? -} ->+ sOutAnyProt -> + (QueryId, AnswerAnyProt) ->+ IO ()+ {-|+ Wait for an answer to a query with the given query ID.+ -}+ waitForAnswer ::+ (QAProtocol q a, Show q, Show a) => + sOut q2 a2 {-^ initiator query socket -} ->+ QueryId {-^ the query to the initiator that this query reacted to -} ->+ sIn q a -> + QueryId ->+ IO a+ {-|+ Wait for an answer to one of several queries with the given query IDs.+ -}+ waitForAnswerMulti ::+ sOutAnyProt {-^ initiator query socket -} ->+ QueryId {-^ the query to the initiator that all of these queries reacted to -} ->+ [(sInAnyProt, QueryId)] -> + IO (Int, AnswerAnyProt)+-- {-|+-- Work out the name of process on the other side of the channel+-- that this socket leads to.+-- -}+-- inGetProviderName ::+-- (QAProtocol q a) => +-- sIn q a -> +-- String + ++class (Channel sIn sOut sInAnyProt sOutAnyProt, LG.Logger lg) => + ChannelForScheduler lg sIn sOut sInAnyProt sOutAnyProt+ | sIn -> lg+ where+ {-| create a new channel that is then given to processes -}+ new ::+ lg {-^ a logger to use by the new channel -} -> + String {-^ name of channel responder process -} -> + Int {-^ channel id -} ->+ ChannelType {-^ used to determine the embedded instance of QAProtocol -} -> + IO (sInAnyProt, sOutAnyProt) {-^ the channel's input and output sockets -}+
+ src/Control/ERNet/Foundations/Event.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ExistentialQuantification #-}+{-|+ Module : Control.ERNet.Foundations.Event+ Description : communication events+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ Communication events with various data useful for logging+ and debugging. +-}+module Control.ERNet.Foundations.Event where++import Control.ERNet.Foundations.Protocol++import Data.Time.Clock++{-|+ Data to be logged with every query and answer event.+-}+data ERNetEvent + =+ forall q a. (QAProtocol q a, Show q, Show a) =>+ ERNetEvQryMade+ {+ ernetevTime :: UTCTime,+ ernetevQryId :: QueryId,+ ernetevFromId :: String,+ ernetevFromQryId :: QueryId,+ ernetevToId :: String,+ ernetevQry :: q+ }+ | forall q a. (QAProtocol q a, Show q, Show a) =>+ ERNetEvQryReceived+ {+ ernetevTime :: UTCTime,+ ernetevQryId :: QueryId,+ ernetevToId :: String,+ ernetevQry :: q+ }+ | forall q a. (QAProtocol q a, Show q, Show a) =>+ ERNetEvAnsMade+ {+ ernetevTime :: UTCTime,+ ernetevQryId :: QueryId,+ ernetevToId :: String, -- ^ query target, the one who answered+ ernetevAns :: a+ }+ | forall q a. (QAProtocol q a, Show q, Show a) =>+ ERNetEvAnsReceived+ {+ ernetevTime :: UTCTime,+ ernetevQryId :: QueryId,+ ernetevFromId :: String, -- ^ query originator, receiver of answer+ ernetevFromQryId :: QueryId,+ ernetevToId :: String, -- ^ query target, the one who answered+ ernetevAns :: a,+ ernetevQry :: q+ }+ +instance Show ERNetEvent where+ show (ERNetEvQryMade time qryId from fromQryId to qry) =+ "Q{" ++ (showNQ from fromQryId) ++ " --?-> " ++ (showNQ to qryId) ++ "}\n " ++ show qry+ show (ERNetEvQryReceived time qryId to qry) =+ "QR:" ++ to ++ ": got query " ++ show qryId+ show (ERNetEvAnsMade time qryId to ans) =+ "A:" ++ (showNQ to qryId) ++ ": " ++ show ans+ show (ERNetEvAnsReceived time qryId from fromQryId to ans qry) =+ "A{" ++ (showNQ from fromQryId) ++ " <-!-- " ++ (showNQ to qryId) ++ "}\n " ++ + show qry ++ "\n ===> " ++ show ans++showNQ procName qryId = procName ++ "." ++ (show qryId)
+ src/Control/ERNet/Foundations/Event/JavaScript.hs view
@@ -0,0 +1,108 @@+{-|+ Module : Control.ERNet.Foundations.Event.JavaScript+ Description : communication events+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ Functions that produce a javascipt representation of the+ message dependence graph contained in a set of network events.+-}+module Control.ERNet.Foundations.Event.JavaScript +(+ constructJS+) +where++import Control.ERNet.Foundations.Protocol+import Control.ERNet.Foundations.Event++import Data.Number.ER.ShowHTML++import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe+import Data.List++--{-|+-- Analyse the log and encode the reaction graph of all queries\/answers+-- as javascript functions. Write these functions out into a file called+-- \"thenet.js\".+---}+--outputJS :: +-- LogTV -> +-- IO ()+--outputJS logTV =+-- do+-- events <- getCompletedLog logTV+---- mapM putStrLn $ map show $ mkProcs events +-- writeFile "thenet.js" $ constructJS events+ +constructJS :: + [ERNetEvent] -> + String+constructJS events =+ unlines [getChildrenJS, getRowJS]+ where+ processes = mkProcs events+ getChildrenJS =+ "function getChildren(q){\nvar c = new Array();\nswitch(q){\n" +++ (unlines $ map getChildrenCase processes) ++ + "\n};\nreturn c;\n}\n"+ getChildrenCase (toN, toName, fromN, fromName, qry, ans, childrenNs) =+ "case " ++ show toN ++ ":" ++ (showSetCs childrenNs) ++ "break;"+ getRowJS =+ "function getRow(q){switch(q){\n" +++ (unlines $ map getRowCase processes) +++ "\n}\n}\n"+ getRowCase (toN, toName, fromN, fromName, qry, ans, childrenNs) =+ "case " ++ show toN ++ ": return " +++ "ndRef(" ++ show fromN ++ ",\"" ++ fromName ++ "\") + " +++ "\'<td>" ++ showHTML qry ++ "<br/>" +++ "===> " +++ "" ++ showHTML ans ++ "</td>\' + " +++ "ndRef(" ++ show toN ++ ",\"" ++ toName ++ "\");"+ ++showSetCs ns =+ concat $ map showSetC $ zip [0..] ns+ where+ showSetC (i,n) = "c[" ++ show i ++ "] = " ++ show n ++ ";"++mkProcs events =+ catMaybes $ map processEvent events+ where+ processEvent (ERNetEvAnsReceived time qryId from fromQryId to ans qry) =+ Just $+ (toN, to ++ "." ++ show qryId, + fromN, from ++ "." ++ show fromQryId,+ QueryAnyProt qry, AnswerAnyProt ans, + Set.toAscList $ Map.findWithDefault Set.empty toN from2tos)+ where+ toN = getProcN to qryId+ fromN = getProcN from fromQryId+ processEvent _ = Nothing+ getProcN name qryId =+ case Map.lookup (name, qryId) nameid2n of+ Just n -> n+ Nothing -> error $ "getProcN failed for " ++ show (name, qryId)+ nameid2n =+ Map.fromList $ zip nameids [1..]+ where+ nameids = nub $ concat $ map getNameId events+ getNameId (ERNetEvQryMade time qryId from fromQryId to qry) =+ [(from, fromQryId), (to, qryId)]+ getNameId _ = []+ from2tos =+ foldl addEvent (Map.empty) events+ addEvent m (ERNetEvAnsReceived time qryId from fromQryId to ans qry) =+ Map.insertWith Set.union fromN (Set.singleton toN) m+ where+ toN = getProcN to qryId+ fromN = getProcN from fromQryId+ addEvent m _ = m+ +
+ src/Control/ERNet/Foundations/Event/Logger.hs view
@@ -0,0 +1,31 @@+{-|+ Module : Control.ERNet.Foundations.Event.Logger+ Description : processes and channels within networks+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ Abstraction of an event logger in the IO monad.+ + To be imported qualified, usually with the prefix LG.+-}+module Control.ERNet.Foundations.Event.Logger where++import Control.ERNet.Foundations.Event++class Logger lg where+ new :: IO lg+ addEvent :: lg -> ERNetEvent -> IO ()+ emptyAndDo :: lg -> (ERNetEvent -> IO a) -> IO ()+ emptyAndGetEvents :: lg -> IO ([ERNetEvent])++putLogWhileRunning logger =+ emptyAndDo logger (putStrLn . show)++putCompleteLog logger =+ do+ events <- emptyAndGetEvents logger+ putStrLn $ unlines $ map show events
+ src/Control/ERNet/Foundations/Manager.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-|+ Module : Control.ERNet.Foundations.Manager+ Description : Abstraction of a distributed network manager.+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ Abstraction of a distributed manager for networked ER processes. + Its functions comprise:+ + * initial process deployment+ + * expansion of a process into a sub-network++ To be imported qualified, usually with the prefix MAN.+-}+module Control.ERNet.Foundations.Manager where++import Control.ERNet.Foundations.Protocol +import qualified Control.ERNet.Foundations.Event.Logger as LG +import qualified Control.ERNet.Foundations.Channel as CH +import Control.ERNet.Foundations.Process ++import Control.Concurrent.STM as STM+++class (CH.ChannelForScheduler lg sIn sOut sInAnyProt sOutAnyProt) => + Manager man lg sIn sOut sInAnyProt sOutAnyProt+ | man -> lg sIn sOut sInAnyProt sOutAnyProt+ where+ new :: ManagerName -> IO (man, ManagerID)+ connectNeighbour :: man -> ManagerID -> IO Bool+ runProcess ::+ man {-^ a manager that will deploy the process -} -> + ERProcess sInAnyProt sOutAnyProt + {-^ + a process to be deployed; + it cannot have input channels + -} -> + IO lg++{-| A name given to a ditributed node by a programmer. -}+type ManagerName = String++{-| + A globally unique name as a URL. ++ eg ernet://localhost:4176/miks-ivp-solver-master+ ernet-local:/ivp-solver-master+ ernet-mpi:/ivp-solver-master+ + The port 4176 was unassigned when checked on+ http://www.iana.org/assignments/port-numbers+ on 2nd November 2008.+-}+type ManagerID = String++{-|+ Run a process together with some queries on one of its output sockets.+-}+runDialogue ::+ (Manager man lg sIn sOut sInAnyProt sOutAnyProt,+ QAProtocol q a) =>+ man ->+ ERProcess sInAnyProt sOutAnyProt + {-^ + a process to be deployed and enquired; + it cannot have input channels + -} ->+ Int {-^ the output socket in the above process to use, numbered from 0 -} ->+ ChannelType {-^ type of the above output socket -} ->+ ((q -> IO a) -> IO ())+ {-^ Dialogue action that makes queries into this channel.+ The parameter is a query function that waits for the answer+ and returns it.+ -} ->+ Bool {-^ whether or not to wait until the dialogue is finished -} ->+ IO lg+runDialogue manager process sockN sockT dialogue waitForEnd =+ do+ doneTV <- atomically $ newTVar False+ -- deploy a new process that contains the supplied dialogue:+ logger <- runProcess manager (initProcess doneTV)+ case waitForEnd of+ True ->+ atomically $+ do+ done <- readTVar doneTV+ case done of+ True -> return ()+ False -> retry+ False -> return ()+ return logger+ where + initProcess doneTV =+ ERProcess "" (initDeploy doneTV) [] []+ initDeploy doneTV _ _ _ expandProcess =+ expandProcess + "ERNet.Foundations.Manager: runDialogue: initDeploy: "+ [] -- input sockets+ [] -- output sockets+ [+ (process, ([], processOutSockNs)),+ (startProcess doneTV, ([sockN, startChN],[startChN]))+ ]+ processOutSockNs =+ snd $ unzip $ zip (erprocOutputTypes process) [0..]+ startChN = length processOutSockNs+ startProcess doneTV =+ ERProcess "S" (startDeploy doneTV) [sockT, chTUnit] [chTUnit]+ startDeploy doneTV _ [inCHA, startInCHA] [startOutCHA] _ =+ do+ -- create a dummy output socket that we pretend "initiated" the start query+ dummyLogger <- LG.new+ (_, dummyCHA) <- CH.new dummyLogger "NONE" 0 chTUnit+ dummyCH <- CH.castOutIO "ERNet.Foundations.Manager: runDialogue: startDeploy: dummyCH: " dummyCHA+ -- cast the sockets:+ inCH <- CH.castInIO "ERNet.Foundations.Manager: runDialogue: startDeploy: inCH: " inCHA+ startInCH <- CH.castInIO "ERNet.Foundations.Manager: runDialogue: startDeploy: startInCH: " startInCHA+ startOutCH <- CH.castOutIO "ERNet.Foundations.Manager: runDialogue: startDeploy: startOutCH: " startOutCHA+ let _ = [dummyCH, startOutCH]+ -- make a dummy query to itself on the start channel + -- (which formally causes all dialogue queries):+ startQryInId <- CH.makeQuery dummyCH 0 startInCH QAUnitQ+ (startQryOutId, _) <- CH.waitForQuery startOutCH + -- execute the dialogue:+ let doQueryGetAnswer q = do+ qryId <- CH.makeQuery startOutCH startQryOutId inCH q+ CH.waitForAnswer startOutCH startQryOutId inCH qryId + dialogue doQueryGetAnswer+ -- answer the start query to itself+ CH.answerQuery False startOutCH (startQryOutId, QAUnitA)+ CH.waitForAnswer dummyCH 0 startInCH startQryInId+ -- signal that dialogue is finished+ atomically $ writeTVar doneTV True
+ src/Control/ERNet/Foundations/Process.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-|+ Module : Control.ERNet.Foundations.Process+ Description : processes and channels within networks+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ Kahn process networks with channels + adapted for arbitrary precision real higher-order data communication.+ Executed using a number of parallel threads. + Each process started in a dedicated thread + and each process typically starts further internal threads.+ Each channel is a transactional variable (TVar) + known to both end processes and allows them to communicate+ according to its instance of the 'QAProtocol' class.+-}+module Control.ERNet.Foundations.Process+(+ ERProcess(..),+ ERProcessName,+ ERProcessDeploy,+ ERProcessExpandCallback,+ subnetProcess+)+where++import Control.ERNet.Foundations.Protocol++import Control.Concurrent as Concurrent+import Control.Concurrent.STM as STM+import Data.Number.ER.MiscSTM++import qualified Data.Map as Map+import Data.Maybe+import Data.Typeable++{-|+ All data that define a process, including its behaviour.+ Each executing process is instantiated from one of these descriptions.+-}+data ERProcess sInAnyProt sOutAnyProt+ = ERProcess + {+ erprocName :: ERProcessName, -- ^ undeployed process name+ {-| + On deployment, a process either expands itself using+ the provided callback function and does not use the+ sockets at all+ + OR it uses the sockets and never calls the expansion+ callback.+ -}+ erprocDeploy :: ERProcessDeploy sInAnyProt sOutAnyProt,+ erprocInputTypes :: [ChannelType],+ erprocOutputTypes :: [ChannelType]+ }++type ERProcessName = String++type ERProcessDeploy sInAnyProt sOutAnyProt =+ ERProcessName {--^ deployed process instance name -} -> + [sInAnyProt] {--^ input sockets -} ->+ [sOutAnyProt] {--^ output sockets -} ->+ (ERProcessExpandCallback sInAnyProt sOutAnyProt) + {--^ scheduler callback for expanding this process -} ->+ IO ()++type ERProcessExpandCallback sInAnyProt sOutAnyProt =+ String {--^ place where callback used; for error messages -} -> + [(ChannelType, Int)] {--^ input socket channel types and numbers -} ->+ [(ChannelType, Int)] {--^ output socket channel types and numbers -} ->+ [(ERProcess sInAnyProt sOutAnyProt, ([Int], [Int]))]+ {--^ internal processes and their in/out channel numbers -} ->+ IO ()++subnetProcess ::+ ERProcessName ->+ [(ChannelType, Int)] {-^ input socket channel types and numbers -} ->+ [(ChannelType, Int)] {-^ output socket channel types and numbers -} ->+ [(ERProcess sInAnyProt sOutAnyProt, ([Int], [Int]))]+ {-^ internal processes and their in/out channel numbers -} ->+ ERProcess sInAnyProt sOutAnyProt+subnetProcess defName inSockets outSockets subProcesses =+ ERProcess defName deploy inSocketTypes outSocketTypes+ where+ deploy deployName _ _ expandCallback =+ expandCallback deployName inSockets outSockets subProcesses+ outSocketTypes = map fst outSockets + inSocketTypes = map fst inSockets +++ +
+ src/Control/ERNet/Foundations/Protocol.hs view
@@ -0,0 +1,154 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-|+ Module : Control.ERNet.Foundations.Protocol+ Description : class of protocols for channel communication+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ This module defines the concept of a protocol + for channel communication.+ + + The protocol concept is formalised using the 2-parameter class + 'QAProtocol' and the existential types + 'ChannelType', 'AnswerAnyProt', 'QueryAnyProt'+ indexed by instances of 'QAProtocol'.+ + +-}+module Control.ERNet.Foundations.Protocol+(+ module Control.ERNet.Foundations.Protocol+-- module Control.ERNet.Foundations.Protocol.Types+)+where++--import Control.ERNet.Foundations.Protocol.Types + -- not direcly required here but forms a logical unit with this module+ +import Data.Number.ER.BasicTypes++import Data.Number.ER.ShowHTML+import qualified Text.Html as H++import Data.Typeable++-- | any danger of over 2^29 queries?+type QueryId = Int++{-|+ A class grouping types of queries and answers.+ + Each instance has to define dynamic type checking of answers agains queries.+-}+class (Ord q, H.HTML q, H.HTML a, Show q, Show a, Typeable q, Typeable a) => + QAProtocol q a+ | a -> q, q -> a+ where+ -- | test whether the answer makes sense for a given query (dynamic type checking)+ qaMatch :: q -> a -> Maybe String -- ^ error message+ qaaSetMinGran :: Granularity -> a -> a+ +qaMatchDefaultMessage q a =+ "answer " ++ show a ++ " does not match query " ++ show q ++ +{-|+ This type is used to identify protocols eg for+ the creation of new channels or for dynamic type checking.+ It consists of an example query and an example answer.+-}+data ChannelType =+ forall q a. (QAProtocol q a, Eq q, Show q, Eq a, Show a) =>+ ChannelType q a+ +instance (Eq ChannelType) where+ (ChannelType q1 a1) == (ChannelType q2 a2) =+ case cast (q1,a1) of+ Nothing -> False+ Just (q1c, a1c) ->+ q1c == q2 && a1c == a2+ +instance (Show ChannelType) where+ show (ChannelType q a) =+ "ChT(q=" ++ show q ++ ",a=" ++ show a ++ ")"+ +{-|+ Union of queries from all protocols.+-}+data QueryAnyProt =+ forall q a. (QAProtocol q a, Show q, Show a) =>+ QueryAnyProt q++instance (Show QueryAnyProt) + where+ show (QueryAnyProt qry) = show qry++instance H.HTML QueryAnyProt + where+ toHtml (QueryAnyProt qry) = H.toHtml qry++{-|+ Union of answers from all protocols.+-}+data AnswerAnyProt =+ forall q a. (QAProtocol q a, Show q, Show a) =>+ AnswerAnyProt a++instance (Show AnswerAnyProt) + where+ show (AnswerAnyProt ans) = show ans++instance H.HTML AnswerAnyProt + where+ toHtml (AnswerAnyProt ans) = H.toHtml ans++ +{- protocol for the unit type (for value-less process synchronisation) -}++++instance (QAProtocol QAUnitQ QAUnitA)+ where+ qaMatch _ _ = Nothing -- always matching++data QAUnitQ+ = QAUnitQ+ deriving (Eq, Ord, Show, Typeable)+data QAUnitA+ = QAUnitA+ deriving (Eq, Ord, Show, Typeable)+ +instance H.HTML QAUnitQ where+ toHtml = toHtmlDefault+instance H.HTML QAUnitA where+ toHtml = toHtmlDefault++chTUnit = ChannelType QAUnitQ QAUnitA++{- protocol for booleans -}++instance (QAProtocol QABoolQ Bool)+ where+ qaMatch _ _ = Nothing -- always matching++data QABoolQ + = QABoolQ+ deriving (Eq, Ord, Show, Typeable)+ +instance H.HTML Bool where+ toHtml = toHtmlDefault+instance H.HTML QABoolQ where+ toHtml = toHtmlDefault++chTBool = ChannelType QABoolQ True
+ src/Control/ERNet/Foundations/Protocol/StandardCombinators.hs view
@@ -0,0 +1,371 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-|+ Module : Control.ERNet.Foundations.Protocol.StandardCombinators+ Description : datatype for dynamic typing of channels+ Copyright : (c) Michal Konecny+ License : BSD3++ Maintainer : mik@konecny.aow.cz+ Stability : experimental+ Portability : portable++ This module defines some basic concrete protocols,+ namely protocols for transferring a unit and a boolean.+ + Some protocol combinators are provided to form new protocols+ from old protocols. Eg one can form a product of+ two protocols to get a protocol for query-answer dialogues + about a pair of values. Similarly, one can construct + protocols for a sum of two types, a maybe type and a list type. + + Any protocol can be also extended to include effort indices+ in queries or to allow incremental computation with non-blocking+ queries on progress, multiple dialogue thread tracking and the communication+ of a failure.++ TODO: add protocols for+ + * game-theoretic HO functions++-}++module Control.ERNet.Foundations.Protocol.StandardCombinators where++import Control.ERNet.Foundations.Protocol++import Data.Number.ER.BasicTypes++import Data.Number.ER.ShowHTML+import qualified Text.Html as H++import Data.Typeable++{- "maybe" protocol constructor -}+ +instance (QAProtocol q a, Show q, Show a) => + (QAProtocol (QAMaybeQ q) (QAMaybeA a))+ where+ {- qaMatch -}+ qaMatch (QAMaybeQ q) (QAMaybeA (Just a)) = qaMatch q a+ qaMatch (QAMaybeQ q) (QAMaybeA Nothing) = Nothing+ qaMatch (QAMaybeQIsNothing _) (QAMaybeAIsNothing _) = Nothing+ qaMatch q a = + Just $ "maybe " ++ (qaMatchDefaultMessage q a)++data QAMaybeQ q+ = QAMaybeQ q+ | QAMaybeQIsNothing q+ deriving (Eq, Ord, Show, Typeable)+ +data QAMaybeA a+ = QAMaybeA (Maybe a)+ | QAMaybeAIsNothing Bool + deriving (Eq, Ord, Show, Typeable)++chTMaybe :: ChannelType -> ChannelType+chTMaybe (ChannelType q a) =+ ChannelType (QAMaybeQ q) (QAMaybeA (Just a))++instance (H.HTML q) => (H.HTML (QAMaybeQ q))+ where+ toHtml (QAMaybeQ q) =+ H.toHtmlFromList $+ [H.toHtml "QAMaybeQ", H.toHtml q]+ toHtml (QAMaybeQIsNothing q) =+ H.toHtmlFromList $+ [H.toHtml "QAMaybeQIsNothing", H.toHtml q]+instance (H.HTML a) => (H.HTML (QAMaybeA a))+ where+ toHtml (QAMaybeA a) =+ H.toHtmlFromList $+ [H.toHtml "QAMaybeA", H.toHtml a]+ toHtml (QAMaybeAIsNothing b) =+ H.toHtmlFromList $+ [H.toHtml "QAMaybeQIsNothing", H.toHtml b]+ +makeAnswerMaybe ::+ (QAProtocol q a) =>+ (q -> Maybe a) ->+ (QAMaybeQ q) ->+ (QAMaybeA a)+makeAnswerMaybe makeAnswer qry =+ case qry of+ QAMaybeQ q -> QAMaybeA (makeAnswer q)+ QAMaybeQIsNothing q -> + case makeAnswer q of+ Nothing -> QAMaybeAIsNothing True+ Just _ -> QAMaybeAIsNothing False+ +{- "effort index" protocol constructor -}+ +instance (QAProtocol q a) => + (QAProtocol (QAIxQ q) (QAIxA a))+ where+ {- qaMatch -}+ qaMatch (QAIxQ _ q) (QAIxA a) = qaMatch q a++data QAIxQ q+ = QAIxQ EffortIndex q+ deriving (Eq, Ord, Show, Typeable)+ +data QAIxA a+ = QAIxA a+ deriving (Eq, Ord, Show, Typeable)++chTIx :: ChannelType -> ChannelType+chTIx (ChannelType q a) =+ ChannelType (QAIxQ 10 q) (QAIxA a)++instance (H.HTML q) => (H.HTML (QAIxQ q))+ where+ toHtml (QAIxQ ix q) =+ H.toHtmlFromList $+ [H.toHtml $ "QAIxQ " ++ show ix ++ " ", + H.toHtml q]+instance (H.HTML a) => (H.HTML (QAIxA a))+ where+ toHtml (QAIxA a) =+ H.toHtmlFromList $+ [H.toHtml "QAIxA ", H.toHtml a]++{- "changes" protocol constructor -}+ +instance (QAProtocol q a, Show q, Show a) => + (QAProtocol (QAChangesQ q) (QAChangesA a))+ where+ {- qaMatch -}+ qaMatch (QAChangesQ q) (QAChangesANew a) = qaMatch q a+ qaMatch (QAChangesQWhenNew _ q) (QAChangesANew a) = qaMatch q a+ qaMatch (QAChangesQIfNew _ q) (QAChangesANew a) = qaMatch q a+ qaMatch (QAChangesQIfNew _ q) (QAChangesASame) = Nothing+ qaMatch q a = + Just $ "maybe " ++ (qaMatchDefaultMessage q a)++data QAChangesQ q+ = QAChangesQIfNew QueryId q+ | QAChangesQWhenNew QueryId q+ | QAChangesQ q+ deriving (Eq, Ord, Show, Typeable)+ +data QAChangesA a+ = QAChangesANew a+ | QAChangesASame+ | QAChangesAGivenUp + deriving (Eq, Ord, Show, Typeable)++chTChanges :: ChannelType -> ChannelType+chTChanges (ChannelType q a) =+ ChannelType (QAChangesQIfNew 7 q) (QAChangesANew a)++instance (H.HTML q) => (H.HTML (QAChangesQ q))+ where+ toHtml (QAChangesQ q) =+ H.toHtmlFromList $+ [H.toHtml "QAChangesQ ", H.toHtml q]+ toHtml (QAChangesQIfNew qid q) =+ H.toHtmlFromList $+ [H.toHtml $ "QAChangesQIfNew " ++ show qid ++ " ", + H.toHtml q]+ toHtml (QAChangesQWhenNew qid q) =+ H.toHtmlFromList $+ [H.toHtml $ "QAChangesQWhenNew " ++ show qid ++ " ", + H.toHtml q]+instance (H.HTML a) => (H.HTML (QAChangesA a))+ where+ toHtml (QAChangesANew a) =+ H.toHtmlFromList $+ [H.toHtml "QAChangesANew ", H.toHtml a]+ toHtml (QAChangesASame) =+ H.toHtml "QAChangesASame" + toHtml (QAChangesAGivenUp) =+ H.toHtml "QAChangesAGivenUp" ++{- list protocol constructor -}+ +instance (QAProtocol q a, Show q, Show a) => + (QAProtocol (QAListQ q) (QAListA a))+ where+ {- qaMatch -}+ qaMatch (QAListQAllHomog q) (QAListA as) = firstJust $ map (qaMatch q) as+ qaMatch (QAListQSingle n q) (QAListASingle a) = qaMatch q a + qaMatch (QAListQLength) (QAListALength n) = Nothing+ qaMatch (QAListQPrefix qs) (QAListA as) =+ firstJust $+ (zipWith qaMatch qs as) +++ case length qs == length as of+ True -> [Nothing]+ False -> [Just $ "list " ++ (qaMatchDefaultMessage qs as)]+ qaMatch q a = + Just $ "list " ++ (qaMatchDefaultMessage q a)++firstJust :: [Maybe err] -> Maybe err+firstJust [] = Nothing+firstJust (Nothing : rest) = firstJust rest+firstJust (justErr : _) = justErr ++data QAListQ q+ = QAListQAllHomog q+ | QAListQSingle Int q+ | QAListQPrefix [q]+ | QAListQLength+ deriving (Eq, Ord, Show, Typeable)+ +data QAListA a+ = QAListA [a]+ | QAListASingle a+ | QAListALength Int+ deriving (Eq, Ord, Show, Typeable)++chTList :: ChannelType -> ChannelType+chTList (ChannelType q a) =+ ChannelType (QAListQSingle 0 q) (QAListASingle a)++instance (H.HTML q) => (H.HTML (QAListQ q))+ where+ toHtml (QAListQAllHomog q) =+ H.toHtmlFromList $+ [H.toHtml "QAListQAllHomog ", H.toHtml q]+ toHtml (QAListQSingle n q) =+ H.toHtmlFromList $+ [H.toHtml $ "QAMaybeQIsNothing " ++ show n ++ " ", + H.toHtml q]+ toHtml (QAListQPrefix qs) =+ H.toHtmlFromList $+ [H.toHtml "QAListQPrefix ", H.toHtml qs]+ toHtml QAListQLength = + H.toHtml $ "QAListQLength"+ +instance (H.HTML a) => (H.HTML (QAListA a))+ where+ toHtml (QAListA as) =+ H.toHtmlFromList $+ [H.toHtml "QAListA ", H.toHtml as]+ toHtml (QAListASingle a) =+ H.toHtmlFromList $+ [H.toHtml "QAListASingle ", H.toHtml a]+ toHtml (QAListALength n) =+ H.toHtml $ "QAListALength " ++ show n+ +makeAnswerList ::+ (QAProtocol q a) =>+ ([a]) ->+ (QAListQ q) ->+ (QAListA a)+makeAnswerList list qry =+ case qry of+ QAListQAllHomog _ -> QAListA list+ QAListQSingle n _ -> QAListASingle (list !! n)+ QAListQPrefix as -> QAListA (take (length as) list)+ QAListQLength -> QAListALength (length list) + +{- product protocol constructor -}++instance (QAProtocol q1 a1, QAProtocol q2 a2, Show q1, Show a1, Show q2, Show a2) =>+ (QAProtocol (QAProdQ q1 q2) (QAProdA a1 a2))+ where+ {- qaMatch -}+ qaMatch (QAProdQFirst q1) (QAProdAFirst a1) = qaMatch q1 a1+ qaMatch (QAProdQSecond q2) (QAProdASecond a2) = qaMatch q2 a2+ qaMatch (QAProdQBoth q1 q2) (QAProdABoth a1 a2) = + case (qaMatch q1 a1, qaMatch q2 a2) of+ (Nothing, Nothing) -> Nothing+ (Just msg, _) -> Just $ "in product fst: " ++ msg + (_, Just msg) -> Just $ "in product snd: " ++ msg+ qaMatch q a = + Just $ "product " ++ (qaMatchDefaultMessage q a)++data QAProdQ q1 q2 + = QAProdQFirst q1+ | QAProdQSecond q2+ | QAProdQBoth q1 q2+ deriving (Eq, Ord, Show, Typeable)+ +data QAProdA a1 a2+ = QAProdAFirst a1+ | QAProdASecond a2+ | QAProdABoth a1 a2+ deriving (Eq, Ord, Show, Typeable)++chTProd :: ChannelType -> ChannelType -> ChannelType+chTProd (ChannelType q1 a1) (ChannelType q2 a2) =+ ChannelType (QAProdQBoth q1 q2) (QAProdABoth a1 a2)++instance (H.HTML q1, H.HTML q2) => (H.HTML (QAProdQ q1 q2))+ where+ toHtml (QAProdQFirst q1) =+ H.toHtmlFromList $+ [H.toHtml $ "QAProdQFirst ", H.toHtml q1]+ toHtml (QAProdQSecond q2) =+ H.toHtml $+ [H.toHtml $ "QAProdQSecond ", H.toHtml q2]+ toHtml (QAProdQBoth q1 q2) =+ H.toHtml $+ [H.toHtml $ "QAProdQBoth ", H.toHtml q1, H.toHtml q2]+ +instance (H.HTML a1, H.HTML a2) => (H.HTML (QAProdA a1 a2))+ where+ toHtml (QAProdAFirst a1) =+ H.toHtmlFromList $+ [H.toHtml $ "QAProdAFirst ", H.toHtml a1]+ toHtml (QAProdASecond a2) =+ H.toHtml $+ [H.toHtml $ "QAProdASecond ", H.toHtml a2]+ toHtml (QAProdABoth a1 a2) =+ H.toHtml $+ [H.toHtml $ "QAProdABoth ", H.toHtml a1, H.toHtml a2]+ +makeAnswerProd :: + (QAProtocol q1 a1,+ QAProtocol q2 a2) =>+ (q1 -> a1) ->+ (q2 -> a2) ->+ (QAProdQ q1 q2) ->+ (QAProdA a1 a2)+makeAnswerProd makeAnswer1 makeAnswer2 qry =+ case qry of+ QAProdQFirst qry1 -> + QAProdAFirst (makeAnswer1 qry1) + QAProdQSecond qry2 -> + QAProdASecond (makeAnswer2 qry2)+ QAProdQBoth qry1 qry2 -> + QAProdABoth (makeAnswer1 qry1) (makeAnswer2 qry2)+ +{- arbitrary funQAProdprotocol constructor -}++--instanceQAProdargCH, Show argCH, Typeable argCQAProdProtocol q a) =>+-- (QAProtocol (QAFnQ argCH q) (QAFnA argCH a))+-- where+-- qaMatch (QAFnQ _ q) (QAFnA _ a) = qaMatch q a+-- +--data QAFnQ argCH q2 +-- = QAFnQ argCH q2+-- deriving (Eq, Ord, Show, Typeable)+-- +--data QAFnA argCH a2+-- = QAFnA argCH a2+-- deriving (Eq, Ord, Show, Typeable)+--+--instance (QAProtocol q1 a1, QAProtocol q2 a2) =>+-- (QAProtocol (QASumQ q1 q2) (QASumA a1 a2))+-- where+-- {- qaMatch -}+-- qaMatch (QASumQ q1 q2) (QASumAFirst a1) = qaMatch q1 a1+-- qaMatch (QASumQ q1 q2) (QASumASecond a2) = qaMatch q2 a2+-- qaMatch (QASumQIsFirst) (QASumAIsFirst _) = Nothing +-- qaMatch q a = +-- Just $ "sum " ++ (qaMatchDefaultMessage q a)+--+--data QASumQ q1 q2+-- = QASumQ q1 q2+-- | QASumQIsFirst+-- deriving (Eq, Ord, Show, Typeable)+-- +--data QASumA a1 a2+-- = QASumAFirst a1+-- | QASumASecond a2+-- | QASumAIsFirst Bool+-- deriving (Eq, Ord, Show, Typeable)
+ src/ernet-trace.html view
@@ -0,0 +1,69 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<html>+<head>+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">+<title>Trace of APNet</title>++<script src="ernet-trace.js"></script>++<script type="text/javascript">+function ndRef(nodeNumber, nodeName)+{+ return "<td class=\"noderef\" onclick=\"setQ(" + nodeNumber + ")\">" + nodeName + "</td>";+}+function setQ(queryNumber)+{+ var t = document.getElementById("queryTable");+ t.innerHTML = "";+ + t.insertRow(0);+ t.rows[0].innerHTML = getRow(queryNumber);+ t.rows[0].className = "mainrow";+ t.rows[0].cells[2].className = "maincell";+ + t.insertRow(1); // separator+ t.rows[1].className = "seprow";+ t.rows[1].innerHTML = "<td height=\"1ex\" colspan=\"3\"></td>";+ + var childrenQueries = getChildren(queryNumber);+ var i;+ + for (i=0; i<childrenQueries.length; i++)+ {+ t.insertRow(i+2);+ t.rows[i+2].innerHTML = getRow(childrenQueries[i]);+ }+}+</script>++<style type="text/css">+.noderef+{+ background-color: #dbb;+}+.mainrow+{+} +.seprow+{+ background-color: #d76;+} +.maincell+{+ background-color: #89b;+} +</style>++</head>++<body>++<h1 id="title">Trace of APNet:</h1>++<table id="queryTable" cellpadding="10">+</table>++<script type="text/javascript">setQ(2);</script>++</body>+</html>
+ tests/DemoMax.hs view
@@ -0,0 +1,133 @@+{-|+ A simple two-process network, one providing+ information about the function (1-4(x-1/2)^2)+ and the other one finding the maximum of+ this function in the interval [0,1].+-}+module Main where++import qualified Control.ERNet.Foundations.Manager as MAN+import qualified Control.ERNet.Foundations.Channel as CH+import qualified Control.ERNet.Foundations.Event.Logger as LG+import Control.ERNet.Foundations.Event.JavaScript++import Control.ERNet.Deployment.Local.Manager++import Control.ERNet.Foundations.Protocol+import Control.ERNet.Foundations.Protocol.StandardCombinators+import Control.ERNet.Foundations.Process++import Control.ERNet.Blocks.Basic+import Control.ERNet.Blocks.Control.Basic+import Control.ERNet.Blocks.Real.Basic+import Control.ERNet.Blocks.Real.Protocols+import Control.ERNet.Blocks.RnToRm.Basic+import Control.ERNet.Blocks.RnToRm.Protocols++import qualified Data.Number.ER.Real.Approx as RA+import qualified Data.Number.ER.RnToRm.Approx as FA+import qualified Data.Number.ER.Real.DomainBox as DBox+import qualified Data.Number.ER.Real.Approx.Elementary as RAEL+import Data.Number.ER.BasicTypes++import qualified Data.Number.ER.Real.DefaultRepr as RATypes+import qualified Data.Number.ER.RnToRm.DefaultRepr as FATypes+++type B = RATypes.BAP+type IRA = RATypes.IRA B+type RA = RATypes.RA B+type FA = FATypes.FAPWP B+type Box a = FATypes.Box a++sampleDomRA = (0 :: RA)+sampleRanRA = (0 :: RA)+sampleFA = (0 :: FA)+++waitTillEnd = True +{- + Use the above to produce a HTML+JavaScript document for browsing the trace.+ The fixed HTML page "ernet-trace.html" imports the JavaScript file+ "ernet-trace.js", which is generated by this program.+ + Instead, you can enable the code below for a continual textual log+ to the standard output. This can be overwhelming but is the only+ option when the network does not terminate correctly.+-}+--waitTillEnd = False++main = + do+ RA.initialiseBaseArithmetic (0 :: RA)+ (ernetManager, _) <- MAN.new "main"+ let _ = ernetManager :: ManagerLocal+ logger <- runTheNet ernetManager waitTillEnd+ case waitTillEnd of+ True ->+ do+ events <- LG.emptyAndGetEvents logger+ writeFile "ernet-trace.js" $ constructJS events+ False ->+ LG.emptyAndDo logger $ + putStrLn . show++runTheNet = runMaxFn++runMaxFn ::+ (MAN.Manager man lg sIn sOut sInAnyProt sOutAnyProt) =>+ man ->+ Bool ->+ IO lg+runMaxFn ernetManager waitTillEnd =+ MAN.runDialogue + ernetManager+ maxFnProcess+ maxFnSockN+ maxFnSockT+ maxFnDialogue+ waitTillEnd++maxFnDialogue makeQueryGetAnswer =+ do+ mapM (doQuerySol) [1..8]+ return ()+ where+ doQuerySol ix =+ do+ a <- makeQueryGetAnswer $ QARealQ+ let _ = [a, QARealA sampleRanRA]+ return ()++maxFnSockT = chTReal (0 :: RA)+maxFnSockN = 0++maxFnProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcess sInAnyProt sOutAnyProt+maxFnProcess =+ subnetProcess+ "MAX-FN"+ [] -- input sockets+ [(chTReal sampleDomRA, maxN)] -- output sockets+ -- sub-processes:+ [+ (constantProcess "FN" answerFn (chTFn1 sampleFA)+ ,([], [fnN]))+ ,+ (maxOverDomProcess "MAX" (DBox.unary $ 0 RA.\/ 1) sampleFA+ ,([fnN], [maxN]))+ ]+ where+ maxN : fnN+ : _ = [0..]+ answerFn _ | False = QAFn1A sampleFA -- clarify the type+ answerFn qry =+ makeAnswerFn1ByBoxesNoIx computeFnBounds qry+ computeFnBounds domB =+ [1 - 4*(dom - 0.5)^2]+ where+ [dom] = DBox.elems domB+ _ = [sampleDomRA, dom]++
+ tests/DemoSqrt.hs view
@@ -0,0 +1,147 @@+{-|+ A simple exact real number network, computing the+ square root of 2 using the continued fraction expansion+ of sqrt(x).+-}+module Main where++import qualified Control.ERNet.Foundations.Manager as MAN+import qualified Control.ERNet.Foundations.Channel as CH+import qualified Control.ERNet.Foundations.Event.Logger as LG+import Control.ERNet.Foundations.Event.JavaScript++import Control.ERNet.Deployment.Local.Manager++import Control.ERNet.Foundations.Protocol+import Control.ERNet.Foundations.Protocol.StandardCombinators+import Control.ERNet.Foundations.Process++import Control.ERNet.Blocks.Basic+import Control.ERNet.Blocks.Control.Basic+import Control.ERNet.Blocks.Real.Basic+import Control.ERNet.Blocks.Real.Protocols++import qualified Data.Number.ER.Real.Approx as RA+import Data.Number.ER.BasicTypes++import qualified Data.Number.ER.Real.DefaultRepr as RATypes+++type B = RATypes.BAP+type IRA = RATypes.IRA B+type RA = RATypes.RA B++sampleRA = (0 :: RA)++chtpR = chTIx $ chTReal sampleRA++waitTillEnd = True +{- + Use the above to produce a HTML+JavaScript document for browsing the trace.+ The fixed HTML page "ernet-trace.html" imports the JavaScript file+ "ernet-trace.js", which is generated by this program.+ + Instead, you can enable the code below for a continual textual log+ to the standard output. This can be overwhelming but is the only+ option when the network does not terminate correctly.+-}+--waitTillEnd = False++runTheNet = runSqrtIx++main = + do+ RA.initialiseBaseArithmetic (0 :: RA)+ (ernetManager, _) <- MAN.new "main"+ let _ = ernetManager :: ManagerLocal+ logger <- runTheNet ernetManager waitTillEnd+ case waitTillEnd of+ True ->+ do+ events <- LG.emptyAndGetEvents logger+ writeFile "ernet-trace.js" $ constructJS events+ False ->+ LG.emptyAndDo logger $ + putStrLn . show++runSqrtIx ::+ (MAN.Manager man lg sIn sOut sInAnyProt sOutAnyProt) =>+ man ->+ Bool ->+ IO lg+runSqrtIx ernetManager waitTillEnd =+ MAN.runDialogue + ernetManager+ sqrtProcess+ sqrtSockN+ sqrtSockT+ sqrtDialogue+ waitTillEnd++sqrtDialogue makeQueryGetAnswer =+ do+ mapM doQuerySol [3..12]+ return ()+ where+ doQuerySol ix =+ do+ a <- makeQueryGetAnswer $ QAIxQ ix $ QARealQ+ let _ = [a, (QAIxA $ QARealA sampleRA)]+ return ()++sqrtSockT = chtpR+sqrtSockN = 0++sqrtProcess ::+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>+ ERProcess sInAnyProt sOutAnyProt+sqrtProcess =+ subnetProcess+ "SQRT"+ [] -- input sockets+ [(chtpR, resN)] -- output sockets+ -- sub-processes:+ [+ (constantProcess "A" (makeAnswerR (\ix -> RA.setMinGranularity (2 * (effIx2gran ix) + 10) (2::RA))) chtpR+ ,([], [aN])+ )+ ,+ (passThroughProcess False "A-1" + id (\ _ (QAIxA (QARealA r)) -> (QAIxA $ QARealA $ (r::RA) - 1)) + chtpR chtpR+ ,([aN], [aM1N])+ )+ ,+ (passThroughProcess False "X+1" + id (\ _ (QAIxA (QARealA r)) -> (QAIxA $ QARealA $ (r::RA) + 1)) + chtpR chtpR+ ,([resN], [resP1N])+ )+ ,+ (passThroughBinaryProcess False "(A-1)/(X+1)"+ (\ qry -> (qry,qry)) + (\ _ ((QAIxA (QARealA num)), (QAIxA (QARealA den))) -> (QAIxA $ QARealA $ (num::RA) / den)) + (chtpR, chtpR) chtpR+ ,([aM1N, resP1N], [resM1N])+ )+ ,+ (passThroughProcess False "(A-1)/(X+1) + 1" + id (\ _ (QAIxA (QARealA r)) -> (QAIxA $ QARealA $ (r::RA) + 1)) + chtpR chtpR+ ,([resM1N], [resCycleN])+ )+ ,+ (constantProcess "[0,oo]" + (\(QAIxQ _ QARealQ) -> (QAIxA $ QARealA $ ((max 0 RA.bottomApprox)::RA))) chtpR+ ,([], [resInitN])+ )+ ,+ (improverIxSimpleProcess "IMPR"+ chtpR+ (QARealA (0::RA))+ ,([resInitN, resCycleN], [resN])+ )+ ]+ where+ resN : resInitN : resCycleN : resM1N : resP1N : aM1N : aN+ : _ = [0..]
+ tests/ernet-trace.html view
@@ -0,0 +1,69 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<html>+<head>+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">+<title>Trace of APNet</title>++<script src="ernet-trace.js"></script>++<script type="text/javascript">+function ndRef(nodeNumber, nodeName)+{+ return "<td class=\"noderef\" onclick=\"setQ(" + nodeNumber + ")\">" + nodeName + "</td>";+}+function setQ(queryNumber)+{+ var t = document.getElementById("queryTable");+ t.innerHTML = "";+ + t.insertRow(0);+ t.rows[0].innerHTML = getRow(queryNumber);+ t.rows[0].className = "mainrow";+ t.rows[0].cells[2].className = "maincell";+ + t.insertRow(1); // separator+ t.rows[1].className = "seprow";+ t.rows[1].innerHTML = "<td height=\"1ex\" colspan=\"3\"></td>";+ + var childrenQueries = getChildren(queryNumber);+ var i;+ + for (i=0; i<childrenQueries.length; i++)+ {+ t.insertRow(i+2);+ t.rows[i+2].innerHTML = getRow(childrenQueries[i]);+ }+}+</script>++<style type="text/css">+.noderef+{+ background-color: #dbb;+}+.mainrow+{+} +.seprow+{+ background-color: #d76;+} +.maincell+{+ background-color: #89b;+} +</style>++</head>++<body>++<h1 id="title">Trace of APNet:</h1>++<table id="queryTable" cellpadding="10">+</table>++<script type="text/javascript">setQ(2);</script>++</body>+</html>