diff --git a/AERN-Net.cabal b/AERN-Net.cabal new file mode 100644 --- /dev/null +++ b/AERN-Net.cabal @@ -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 . + . + 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 + diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -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 + diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/src/Control/ERNet/Blocks/Basic.hs b/src/Control/ERNet/Blocks/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Blocks/Basic.hs @@ -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) + diff --git a/src/Control/ERNet/Blocks/Control/Basic.hs b/src/Control/ERNet/Blocks/Control/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Blocks/Control/Basic.hs @@ -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 + + diff --git a/src/Control/ERNet/Blocks/Real/Basic.hs b/src/Control/ERNet/Blocks/Real/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Blocks/Real/Basic.hs @@ -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 + + diff --git a/src/Control/ERNet/Blocks/Real/Protocols.hs b/src/Control/ERNet/Blocks/Real/Protocols.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Blocks/Real/Protocols.hs @@ -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 + diff --git a/src/Control/ERNet/Blocks/RnToRm/Basic.hs b/src/Control/ERNet/Blocks/RnToRm/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Blocks/RnToRm/Basic.hs @@ -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) +-- diff --git a/src/Control/ERNet/Blocks/RnToRm/Protocols.hs b/src/Control/ERNet/Blocks/RnToRm/Protocols.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Blocks/RnToRm/Protocols.hs @@ -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) + diff --git a/src/Control/ERNet/Deployment/Local/Channel.hs b/src/Control/ERNet/Deployment/Local/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Deployment/Local/Channel.hs @@ -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 + diff --git a/src/Control/ERNet/Deployment/Local/Logger.hs b/src/Control/ERNet/Deployment/Local/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Deployment/Local/Logger.hs @@ -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 + diff --git a/src/Control/ERNet/Deployment/Local/Manager.hs b/src/Control/ERNet/Deployment/Local/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Deployment/Local/Manager.hs @@ -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 + diff --git a/src/Control/ERNet/Foundations/Channel.hs b/src/Control/ERNet/Foundations/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Foundations/Channel.hs @@ -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 -} + diff --git a/src/Control/ERNet/Foundations/Event.hs b/src/Control/ERNet/Foundations/Event.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Foundations/Event.hs @@ -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) diff --git a/src/Control/ERNet/Foundations/Event/JavaScript.hs b/src/Control/ERNet/Foundations/Event/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Foundations/Event/JavaScript.hs @@ -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 ++ "\") + " ++ + "\'" ++ showHTML qry ++ "
" ++ + "===> " ++ + "" ++ showHTML ans ++ "\' + " ++ + "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 + + diff --git a/src/Control/ERNet/Foundations/Event/Logger.hs b/src/Control/ERNet/Foundations/Event/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Foundations/Event/Logger.hs @@ -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 diff --git a/src/Control/ERNet/Foundations/Manager.hs b/src/Control/ERNet/Foundations/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Foundations/Manager.hs @@ -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 diff --git a/src/Control/ERNet/Foundations/Process.hs b/src/Control/ERNet/Foundations/Process.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Foundations/Process.hs @@ -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 + + + + diff --git a/src/Control/ERNet/Foundations/Protocol.hs b/src/Control/ERNet/Foundations/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Foundations/Protocol.hs @@ -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 diff --git a/src/Control/ERNet/Foundations/Protocol/StandardCombinators.hs b/src/Control/ERNet/Foundations/Protocol/StandardCombinators.hs new file mode 100644 --- /dev/null +++ b/src/Control/ERNet/Foundations/Protocol/StandardCombinators.hs @@ -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) diff --git a/src/ernet-trace.html b/src/ernet-trace.html new file mode 100644 --- /dev/null +++ b/src/ernet-trace.html @@ -0,0 +1,69 @@ + + + + +Trace of APNet + + + + + + + + + + + +

Trace of APNet:

+ + +
+ + + + + diff --git a/tests/DemoMax.hs b/tests/DemoMax.hs new file mode 100644 --- /dev/null +++ b/tests/DemoMax.hs @@ -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] + + diff --git a/tests/DemoSqrt.hs b/tests/DemoSqrt.hs new file mode 100644 --- /dev/null +++ b/tests/DemoSqrt.hs @@ -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..] diff --git a/tests/ernet-trace.html b/tests/ernet-trace.html new file mode 100644 --- /dev/null +++ b/tests/ernet-trace.html @@ -0,0 +1,69 @@ + + + + +Trace of APNet + + + + + + + + + + + +

Trace of APNet:

+ + +
+ + + + +