diff --git a/AERN-Net.cabal b/AERN-Net.cabal
--- a/AERN-Net.cabal
+++ b/AERN-Net.cabal
@@ -1,5 +1,5 @@
Name: AERN-Net
-Version: 0.2.0
+Version: 0.2.1
Cabal-Version: >= 1.2
Build-Type: Simple
License: BSD3
@@ -10,7 +10,7 @@
Stability: experimental
Category: Math, Distributed Computing
Synopsis: Compositional lazy dataflow networks for exact real number computation
-Tested-with: GHC ==6.8.3
+Tested-with: GHC ==6.10.1
Description:
AERN-Net provides
datatypes and abstractions for defining and executing
@@ -41,33 +41,26 @@
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
+ Build-Depends:
+ base >= 3, base < 4, containers, binary >= 0.4, html, time, stm, AERN-Real >= 0.9.9, AERN-RnToRm >= 0.4.9
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.Deployment.Local.Manager,
+ Control.ERNet.Deployment.Local.Logger,
+ Control.ERNet.Deployment.Local.Channel,
+ Control.ERNet.Blocks.Basic,
+ Control.ERNet.Blocks.Control.Basic,
+ Control.ERNet.Blocks.RnToRm.Basic,
+ Control.ERNet.Blocks.RnToRm.Protocols,
+ Control.ERNet.Blocks.Real.Basic,
+ Control.ERNet.Blocks.Real.LFT,
+ Control.ERNet.Blocks.Real.Protocols,
+ Control.ERNet.Foundations.Protocol.StandardCombinators,
+ Control.ERNet.Foundations.Manager,
+ Control.ERNet.Foundations.Event,
+ Control.ERNet.Foundations.Event.JavaScript,
+ Control.ERNet.Foundations.Event.Logger,
+ Control.ERNet.Foundations.Channel,
+ Control.ERNet.Foundations.Process,
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
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,10 @@
-0.2.0: ?? November 2008
+0.2.1: 23 February 2009
+ * Added support for linear fractional transformation (LFT) real number representation
+ of Potts & Edalat (1997) and added some simple processes that work with it.
+ * Improved the presentation of network traces in a web browser.
+ * Added a natural number protocol.
+
+0.2.0: 2 December 2008
* initial public release of AERN-Net after two years of work and many internal experiments
and refactorings
diff --git a/src/Control/ERNet/Blocks/Basic.hs b/src/Control/ERNet/Blocks/Basic.hs
--- a/src/Control/ERNet/Blocks/Basic.hs
+++ b/src/Control/ERNet/Blocks/Basic.hs
@@ -55,7 +55,7 @@
constantStatefulProcess defName responderTransferFn ()
where
responderTransferFn _ (_, q) =
- (responderFn q, Nothing)
+ ((True, responderFn q), Nothing)
{-|
A generic process with no inputs that answers using a ChTChanges protocol.
@@ -82,7 +82,7 @@
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 -> (QueryId, q) -> ((Bool, a), Maybe s)) {- ^ function to answer queries and transform state -} ->
s {-^ initial state -} ->
ChannelType {- ^ result channel type -} ->
ERProcess sInAnyProt sOutAnyProt
@@ -106,40 +106,42 @@
dispatcher stateTV
responder stateTV (qryId, qry) =
do
- ans <- atomically updateState
- CH.answerQuery True resCH (qryId, ans)
+ (useCache, ans) <- atomically updateState
+ CH.answerQuery useCache 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) ->
+ (ansData, Nothing) -> return ansData
+ (ansData, Just newState) ->
do
writeTVar stateTV newState
- return ans
+ return ansData
+
{-|
- 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.
+ A process with one input and one output socket.
+ Upon receiving a query or an answer related to a previously received query,
+ the process uses the provided functions to decide whether to answer
+ the query, make a new query or wait until the state meets a certain condition.
+ When the condition is met, the event (query or answer) in question is processed
+ again using the same function.
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 -} ->
+ (s -> (QueryId, q1) -> (ERProcessAction s q2 a1, Maybe s)) {-^ what to do with a query + forward or reply -} ->
+ (s -> (QueryId, q1) -> (q2,a2) -> (ERProcessAction s 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 =
+passThroughStatefulProcess defName qryStFn ansStFn initState chtpIn chtpRes =
ERProcess defName deploy [chtpIn] [chtpRes]
where
deploy deployName [argCHA] [resCHA] _ =
@@ -161,15 +163,24 @@
dispatcher stateTV
responder stateTV qryData@(resQryId, qry) =
do
- qry2OrAns <- atomically $ processQuery stateTV qryData
- proceed stateTV qryData qry2OrAns
- proceed stateTV qryData@(resQryId, qry) (Left qry2) =
+ action <- atomically $ processQuery stateTV qryData
+ proceed stateTV qryData action
+ proceed stateTV qryData (ERProcessActionRetryWhen triggerCond) =
do
+ atomically $
+ do
+ state <- readTVar stateTV
+ case triggerCond state of
+ True -> return ()
+ False -> retry
+ responder stateTV qryData
+ proceed stateTV qryData@(resQryId, qry) (ERProcessActionQuery qry2) =
+ do
argQryId <- CH.makeQuery resCH resQryId argCH qry2
ans2 <- CH.waitForAnswer resCH resQryId argCH argQryId
- qry2OrAns <- atomically $ processAnswer stateTV qryData ans2
+ qry2OrAns <- atomically $ processAnswer stateTV qryData (qry2,ans2)
proceed stateTV qryData qry2OrAns
- proceed stateTV qryData@(resQryId, qry) (Right ans) =
+ proceed stateTV qryData@(resQryId, qry) (ERProcessActionAnswer useCache ans) =
CH.answerQuery useCache resCH (resQryId, ans)
processQuery stateTV qryData =
do
@@ -203,10 +214,10 @@
ChannelType {-^ result channel type -} ->
ERProcess sInAnyProt sOutAnyProt
passThroughProcess useCache defName preFn postFn =
- passThroughStatefulProcess useCache defName preStFn postStFn ()
+ passThroughStatefulProcess defName preStFn postStFn ()
where
- preStFn _ (_, q) = (Left (preFn q), Nothing)
- postStFn _ (_, q) a = (Right (postFn q a), Nothing)
+ preStFn _ (_, q) = (ERProcessActionQuery (preFn q), Nothing)
+ postStFn _ (_, q) (_,a) = (ERProcessActionAnswer useCache (postFn q a), Nothing)
{-|
A simple process that either responds with no further queries
@@ -229,15 +240,15 @@
ChannelType {-^ output channel type -} ->
ERProcess sInAnyProt sOutAnyProt
maybePassThroughProcess useCache defName noPass noPassResponder preFn postFn =
- passThroughStatefulProcess useCache defName qryStFn ansStFn ()
+ passThroughStatefulProcess defName qryStFn ansStFn ()
where
qryStFn _ (_, q)
| noPass q =
- (Right (noPassResponder q), Nothing) -- answer
+ (ERProcessActionAnswer useCache (noPassResponder q), Nothing) -- answer
| otherwise =
- (Left (preFn q), Nothing) -- pass on translated query
- ansStFn _ (_, q) a =
- (Right (postFn q a), Nothing) -- reply translated answer
+ (ERProcessActionQuery (preFn q), Nothing) -- pass on translated query
+ ansStFn _ (_, q) (_, a) =
+ (ERProcessActionAnswer useCache (postFn q a), Nothing) -- reply translated answer
{-|
A process passing on information without modification, except for improving the
@@ -260,18 +271,18 @@
ChannelType {-^ number channel type -} ->
ERProcess sInAnyProt sOutAnyProt
rateProcess defName goodEnough maxAttepts chtp =
- passThroughStatefulProcess False defName qryStFn ansStFn initState chtp chtp
+ passThroughStatefulProcess 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
+ (ERProcessActionQuery qry, Nothing)
+ ansStFn (Nothing, _) qryData (_, ans) =
+ (ERProcessActionAnswer False 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
+ (ERProcessActionAnswer False ans, Just (Just ans, 0)) -- reset attempt counter
| otherwise =
- (Left qry, Just (Just prevAns, prevAttemptNo + 1)) -- increase attempt counter
+ (ERProcessActionQuery qry, Just (Just prevAns, prevAttemptNo + 1)) -- increase attempt counter
{-|
A trivial passthrough process that only:
@@ -308,18 +319,17 @@
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))
+ (s -> (QueryId, q) -> (ERProcessAction s (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))
+ (s -> (QueryId, q) -> (Maybe a1, Maybe a2) -> (ERProcessAction s (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 =
+passThroughBinaryStatefulProcess defName qryStFn ansStFn initState (chtpIn1, chtpIn2) chtpRes =
ERProcess defName deploy [chtpIn1, chtpIn2] [chtpRes]
where
deploy deployName [arg1CHA, arg2CHA] [resCHA] _ =
@@ -348,8 +358,17 @@
qry12OrAns <- atomically $ processQuery stateTV qryData
proceed stateTV qryData qry12OrAns
- proceed stateTV qryData@(resQryId, qry) (Left (mqry1, mqry2)) =
+ proceed stateTV qryData (ERProcessActionRetryWhen triggerCond) =
do
+ atomically $
+ do
+ state <- readTVar stateTV
+ case triggerCond state of
+ True -> return ()
+ False -> retry
+ responder stateTV qryData
+ proceed stateTV qryData@(resQryId, qry) (ERProcessActionQuery (mqry1, mqry2)) =
+ do
mans1 <- maybeQuerySync arg1CH mqry1
mans2 <- maybeQuerySync arg2CH mqry2
qry12OrAns <- atomically $ processAnswer stateTV qryData (mans1, mans2)
@@ -362,8 +381,9 @@
ans <- CH.waitForAnswer resCH resQryId argCH argQryId
return $ Just ans
- proceed stateTV qryData@(resQryId, qry) (Right ans) =
+ proceed stateTV qryData@(resQryId, qry) (ERProcessActionAnswer useCache ans) =
CH.answerQuery useCache resCH (resQryId, ans)
+
processQuery stateTV qryData =
do
@@ -400,10 +420,10 @@
ERProcess sInAnyProt sOutAnyProt
passThroughBinaryProcess useCache defName preFn postFn =
- passThroughBinaryStatefulProcess useCache defName preStFn postStFn ()
+ passThroughBinaryStatefulProcess defName preStFn postStFn ()
where
- preStFn _ (_, q) = (Left (Just q1, Just q2), Nothing)
+ preStFn _ (_, q) = (ERProcessActionQuery (Just q1, Just q2), Nothing)
where
(q1, q2) = preFn q
- postStFn _ (_, q) (Just a1, Just a2) = (Right (postFn q (a1, a2)), Nothing)
+ postStFn _ (_, q) (Just a1, Just a2) = (ERProcessActionAnswer useCache (postFn q (a1, a2)), Nothing)
diff --git a/src/Control/ERNet/Blocks/Real/LFT.hs b/src/Control/ERNet/Blocks/Real/LFT.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/ERNet/Blocks/Real/LFT.hs
@@ -0,0 +1,575 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-|
+ Module : Control.ERNet.Blocks.Real.LFT
+ Description : real protocol using LFTs as digits
+ Copyright : (c) Michal Konecny
+ License : BSD3
+
+ Maintainer : mik@konecny.aow.cz
+ Stability : experimental
+ Portability : portable
+
+ A protocol for sending a real number using a stream
+ of LFT digits based on the work of Potts and Edalat (1997).
+
+-}
+module Control.ERNet.Blocks.Real.LFT
+(
+ -- * protocol
+ QALFTRealQ(..),
+ QALFTRealA(..),
+ LFTDigit(..),
+ lftDigit2Tensor,
+ chTLFTReal,
+ -- * processes
+ lftRealNumberIncremProcess,
+ lftRealNumberBufferForkProcess,
+-- lftBinaryTensorIncremProcess,
+-- lftParametrisedBinaryTensorIncremProcess,
+ -- * arithmetic
+ LFTTensor(..),
+ lftConst,
+ lftMatrix,
+ lftTensorBinary,
+ lftTensorInfo,
+ lftTensorIsPositive,
+ lftTensorCompose,
+ lftTensorComposeUnary
+)
+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 qualified Data.Number.ER.Real.Approx as RA
+import Data.Number.ER.BasicTypes
+import Data.Number.ER.Real.DefaultRepr
+
+import Data.Number.ER.ShowHTML
+import qualified Text.Html as H
+import Data.Number.ER.Misc
+
+import qualified Data.Map as Map
+
+import Data.Typeable
+
+instance
+ (QAProtocol QALFTRealQ QALFTRealA)
+ where
+ qaMatch (QALFTRealQ n) (QALFTRealA digits)
+ | length digits == 1 = Nothing -- when using incrementally
+ | length digits == n = Nothing -- non-incremental interpretation
+ | otherwise = Just "Prtocol QALFTReal: wrong number of digits in answer"
+
+
+data QALFTRealQ
+ = QALFTRealQ Int
+ deriving (Eq, Ord, Show, Typeable)
+
+data QALFTRealA
+ = QALFTRealA [LFTDigit]
+ deriving (Eq, Ord, Show, Typeable)
+
+data LFTDigit =
+ LFT_L | LFT_M | LFT_R | LFT_SG_ZER | LFT_SG_INF | LFT_SG_POS | LFT_SG_NEG
+ deriving (Eq, Ord, Typeable)
+
+instance Show LFTDigit
+ where
+ show LFT_L = "L"
+ show LFT_M = "M"
+ show LFT_R = "R"
+ show LFT_SG_ZER = "S[-1,1]"
+ show LFT_SG_INF = "S[1,-1]"
+ show LFT_SG_POS = "S[0,oo]"
+ show LFT_SG_NEG = "S[oo,0]"
+
+instance H.HTML LFTDigit
+ where
+ toHtml = toHtmlDefault
+
+instance H.HTML QALFTRealQ
+ where
+ toHtml = toHtmlDefault
+
+instance H.HTML QALFTRealA
+ where
+ toHtml (QALFTRealA digits) =
+ H.toHtml $
+ concat $ map show digits
+
+chTLFTReal :: ChannelType
+chTLFTReal = ChannelType (QALFTRealQ 3) (QALFTRealA [LFT_SG_ZER, LFT_R, LFT_M])
+
+
+{-|
+ Interpret the LFT digits as LFTs.
+-}
+lftDigit2Tensor :: LFTDigit -> LFTTensor
+lftDigit2Tensor d =
+ tensor
+ where
+ tensor =
+ case d of
+ LFT_L -> lftMatrix 1 0 1 2
+ LFT_M -> lftMatrix 3 1 1 3
+ LFT_R -> lftMatrix 2 1 0 1
+ LFT_SG_INF -> lftMatrix 1 1 (-1) 1
+ LFT_SG_NEG -> lftMatrix 0 1 (-1) 0
+ LFT_SG_ZER -> lftMatrix 1 (-1) 1 1
+ LFT_SG_POS -> lftMatrix 1 0 0 1
+
+
+lftDigits2Tensor ::
+ [LFTDigit] ->
+ LFTTensor
+lftDigits2Tensor digits =
+ foldl1 lftTensorComposeUnary $ map lftDigit2Tensor digits
+
+lftDigitsInfo ::
+ (RA.ERApprox ra) =>
+ Granularity ->
+ [LFTDigit] ->
+ ExtInterval ra
+lftDigitsInfo gran digits =
+ lftTensorInfoUnary gran $ lftDigits2Tensor digits
+
+
+{-|
+ A process communicating a real number to a single client
+ incrementally digit by digit.
+-}
+lftRealNumberIncremProcess ::
+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt,
+ RA.ERIntApprox ra, Typeable ra) =>
+ ERProcessName ->
+ (EffortIndex -> ra)
+ {-^
+ the number to represent;
+ intersection of this sequence has to converge to a singleton
+ -} ->
+ ERProcess sInAnyProt sOutAnyProt
+lftRealNumberIncremProcess defName xByIx =
+ constantStatefulProcess defName responderTransferFn initState (chTChanges chTLFTReal)
+ where
+-- initState ::
+-- (
+-- Int, -- the prvious query
+-- (LFTTensor, EffortIndex, ra)
+-- -- the composition of the previously emitted digits
+-- -- and information about progress with using xByIx
+-- )
+ initState = (0, (lftTensorId, 10, xByIx 10))
+
+ responderTransferFn
+ prevState@(prevQuery, precomp@(prevTensor, prevIx, prevRA))
+ (qryId, qry) =
+ -- non-incremental query
+-- unsafePrint "A" $
+ case qry of
+ QAChangesQ (QALFTRealQ n)
+ | n == 1 && prevQuery == 0 ->
+ -- initial query
+ (
+ (False, QAChangesANew $ QALFTRealA [signDigit])
+ ,
+ Just (1, (signTensor, signIx, signRA))
+ )
+ QAChangesQWhenNew prevQry (QALFTRealQ n)
+ | prevQry == prevQuery && prevQry == (n - 1) ->
+ (
+ (False, QAChangesANew $ QALFTRealA $ [newDigit])
+ ,
+ Just (n, (newTensor, newIx, newRA))
+ )
+ _ ->
+ error $
+ "ERNet.Blocks.Real.LFT: lftRealNumberProcess: " ++
+ "query " ++ show qry ++ " is not strictly incremental."
+ where
+ (signDigit, signTensor, signIx, signRA) =
+ searchSignDigit prevIx prevRA
+ (newDigit, newTensor, newIx, newRA) =
+ searchDigit (10 + prevQuery) prevTensor prevIx prevRA
+
+ searchSignDigit ix ra
+ | ra `refinesRAExtInt` infoZ = (LFT_SG_ZER, tZ, ix, ra)
+ | ra `refinesRAExtInt` infoI = (LFT_SG_INF, tI, ix, ra)
+ | ra `refinesRAExtInt` infoP = (LFT_SG_POS, tP, ix, ra)
+ | ra `refinesRAExtInt` infoN = (LFT_SG_NEG, tN, ix, ra)
+ | otherwise =
+ searchSignDigit nextIx (xByIx nextIx)
+ where
+ nextIx = ix + 1
+ infoZ = lftTensorInfoUnary gran tZ
+ infoI = lftTensorInfoUnary gran tI
+ infoP = lftTensorInfoUnary gran tP
+ infoN = lftTensorInfoUnary gran tN
+ gran = 10
+ searchDigit gran tensor ix ra
+ | ra `refinesRAExtInt` infoL = (LFT_L, compWithL, ix, ra)
+ | ra `refinesRAExtInt` infoM = (LFT_M, compWithM, ix, ra)
+ | ra `refinesRAExtInt` infoR = (LFT_R, compWithR, ix, ra)
+ | otherwise =
+ searchDigit gran tensor nextIx nextRA
+ where
+ nextIx = ix + 1
+ nextRA = xByIx nextIx
+ infoL = lftTensorInfoUnary gran compWithL
+ compWithL = lftTensorComposeUnary tensor tL
+ infoM = lftTensorInfoUnary gran compWithM
+ compWithM = lftTensorComposeUnary tensor tM
+ infoR = lftTensorInfoUnary gran compWithR
+ compWithR = lftTensorComposeUnary tensor tR
+ [tZ, tI, tP, tN, tL, tM, tR] =
+ map lftDigit2Tensor
+ [LFT_SG_ZER, LFT_SG_INF, LFT_SG_POS, LFT_SG_NEG, LFT_L, LFT_M, LFT_R]
+
+{-|
+ A process that receives a real number incrementally digit by digit
+ and makes it available to multiple clients incrementally or non-incrementally.
+-}
+lftRealNumberBufferForkProcess ::
+ (CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>
+ ERProcessName ->
+ ERProcess sInAnyProt sOutAnyProt
+lftRealNumberBufferForkProcess defName =
+ passThroughStatefulProcess
+ defName qryStFn ansStFn initState
+ (chTChanges chTLFTReal) (chTChanges chTLFTReal)
+ where
+ initState ::
+ (
+ Map.Map QueryId Int, -- memory of past queries
+ [LFTDigit],
+ -- memoising past replies
+ -- the number of digits equals the highest answered query so far
+ -- the most significant digit is last
+ Int, -- the higest query answered so far
+ Int
+ -- current highest target query
+ -- it is larger or equal to the number above
+ -- the numbers are equal iff each incoming query either has been answered
+ -- or can be answered without further queries
+ )
+ initState = (Map.empty, [], 0, 0)
+
+ qryStFn
+ prevState@(pastQueries, prevDigits, largestAnswered, target)
+ (qryId, qry1) =
+ case (n > largestAnswered, largestAnswered == target, n > target) of
+ (False, _, _) -> -- can answer immediately
+ (
+ ERProcessActionAnswer False $ QAChangesANew $ QALFTRealA $ reverse $
+ case qry1 of
+ QAChangesQ (QALFTRealQ n) ->
+ drop (largestAnswered - n) prevDigits
+ QAChangesQWhenNew prevQry (QALFTRealQ n) ->
+ take (n - p) $
+ drop (largestAnswered - n) prevDigits
+ where
+ p =
+ case Map.lookup prevQry pastQueries of
+ Just p -> p
+ Nothing ->
+ error $ "ERNet.Blocks.Real.LFT: lftRealNumberProcess:"
+ ++ " query refers to non-existent previous query"
+ ,
+ Just (pastQueriesNew, prevDigits, largestAnswered, target)
+ )
+ (True, False, False) -> -- have to wait until the desired level is reached
+ (
+ ERProcessActionRetryWhen $ \ (_, _, largestAnswered, _) -> largestAnswered >= n
+ ,
+ Just (pastQueriesNew, prevDigits, largestAnswered, target)
+ )
+ (True, False, True) -> -- have to wait until the previous target is reached
+ (
+ ERProcessActionRetryWhen $ \ (_, _, largestAnswered, _) -> largestAnswered == target
+ ,
+ Just (pastQueriesNew, prevDigits, largestAnswered, target)
+ )
+ (True, True, True) -> -- have to set a new target and start working towards it
+ (
+ ERProcessActionQuery $
+ case largestAnswered > 0 of
+ True -> QAChangesQWhenNew largestAnswered $ QALFTRealQ (largestAnswered + 1)
+ False -> QAChangesQ $ QALFTRealQ (largestAnswered + 1)
+ ,
+ Just (pastQueriesNew, prevDigits, largestAnswered, n)
+ )
+ where
+ pastQueriesNew = Map.insert qryId n pastQueries
+ n =
+ case qry1 of
+ QAChangesQ (QALFTRealQ n) -> n
+ QAChangesQWhenNew prevQuery (QALFTRealQ n) -> n
+
+ ansStFn
+ prevState@(pastQueries, prevDigits, largestAnswered, target)
+ (qryId, qry1)
+ (_, QAChangesANew (QALFTRealA [newDigit]))
+ =
+ -- add ans2 to the state
+ -- if target reached, reply qry1, else, make another query
+ (action, Just newState)
+ where
+ newState = (pastQueries, newDigits, largestAnsweredNew, target)
+ newDigits = newDigit : prevDigits
+ largestAnsweredNew = largestAnswered + 1
+ action
+ | largestAnsweredNew == target =
+ ERProcessActionAnswer True $ QAChangesANew $ QALFTRealA $ reverse $
+ case qry1 of
+ QAChangesQ (QALFTRealQ n) ->
+ drop (largestAnswered - n) newDigits
+ QAChangesQWhenNew prevQry (QALFTRealQ n) ->
+ take (n - p) $
+ drop (largestAnswered - n) newDigits
+ where
+ p =
+ case Map.lookup prevQry pastQueries of
+ Just p -> p
+ Nothing ->
+ error "ERNet.Blocks.Real.LFT: lftRealNumberProcess: query refers to non-existent previous query"
+ | otherwise =
+ ERProcessActionQuery $
+ QAChangesQWhenNew largestAnsweredNew $ QALFTRealQ (largestAnsweredNew + 1)
+
+{-|
+ A multi-dimensional linear fractional transformation with integer coefficients.
+-}
+data LFTTensor =
+ LFTTensor
+ {
+ lftTNSrank :: Int,
+ lftTNScoeffs :: Map.Map [Bool] Integer
+ -- ^ the first Bool indicates whether or not the term is in the numerator of the LFT
+ }
+ deriving (Show)
+
+{-|
+ Constructor for a 0-ary LFT with integer coefficients.
+-}
+lftConst ::
+ Integer -> Integer ->
+ LFTTensor
+lftConst a b =
+ LFTTensor 1 $ Map.fromList
+ [([True], a),
+ ([False], b)]
+
+{-|
+ Constructor for a unary LFT with integer coefficients.
+-}
+lftMatrix ::
+ Integer -> Integer -> Integer -> Integer ->
+ LFTTensor
+lftMatrix a b c d =
+ LFTTensor 2 $ Map.fromList
+ [([True, True], a), ([True, False], b),
+ ([False, True], c), ([False, False], d)]
+
+lftTensorId :: LFTTensor
+lftTensorId = lftMatrix 1 0 0 1
+
+{-|
+ Constructor for a binary LFT with integer coefficients.
+-}
+lftTensorBinary ::
+ Integer -> Integer -> Integer -> Integer ->
+ Integer -> Integer -> Integer -> Integer ->
+ LFTTensor
+lftTensorBinary a b c d e f g h =
+ LFTTensor 3 $ Map.fromList
+ [([True, True, True], a), ([True, True, False], b),
+ ([True, False, True], c), ([True, False, False], d),
+ ([False, True, True], e), ([False, True, False], f),
+ ([False, False, True], g), ([False, False, False], h)]
+
+data ExtInterval ra =
+ ExtInterval
+ {
+ extIntervalL :: ra,
+ extIntervalR :: ra
+ }
+ deriving (Show)
+
+refinesRAExtInt ::
+ (RA.ERIntApprox ra) =>
+ ra ->
+ ExtInterval ra ->
+ Bool
+ra `refinesRAExtInt` (ExtInterval lRA rRA) =
+ case lRA `RA.compareReals` rRA of
+ Just LT ->
+ ra `RA.refines` (lRA RA.\/ rRA)
+ Just GT ->
+ (ra `RA.refines` (lRA RA.\/ infty))
+ ||
+ (ra `RA.refines` ((-infty) RA.\/ rRA))
+ where
+ infty = 1/0
+
+{-|
+ Work out what interval is the image of the lft when all
+ variables are given the value [0,oo].
+ The returned interval may be slightly bigger than the
+ exact image due to rounding but it always contains the
+ whole exact image.
+-}
+lftTensorInfo ::
+ (RA.ERApprox ra) =>
+ Granularity ->
+ LFTTensor ->
+ ExtInterval ra
+lftTensorInfo gran t@(LFTTensor n coeffs)
+ | n == 1 = lftTensorInfoConst gran t
+ | n == 2 = lftTensorInfoUnary gran t
+-- | n == 3 = lftTensorInfoBinary gran t
+ | otherwise =
+ error $ "ERNet.Blocks.Real.LFT: lftTensorInfo: unsupported rank " ++ show n
+
+{-|
+ Like "lftTensorInfo" but assuming the lft is constant.
+-}
+lftTensorInfoConst ::
+ (RA.ERApprox ra) =>
+ Granularity ->
+ LFTTensor ->
+ ExtInterval ra
+lftTensorInfoConst gran t@(LFTTensor _ coeffs) =
+ ExtInterval ratio ratio
+ where
+ ratio = aRA / bRA
+ aRA = RA.setMinGranularity gran $ fromInteger a
+ bRA = RA.setMinGranularity gran $ fromInteger b
+ [b, a] = map snd $ Map.toAscList coeffs
+
+{-|
+ Like "lftTensorInfo" but assuming the lft is unary.
+-}
+lftTensorInfoUnary ::
+ (RA.ERApprox ra) =>
+ Granularity ->
+ LFTTensor ->
+ ExtInterval ra
+lftTensorInfoUnary gran t@(LFTTensor _ coeffs)
+ | det == 0 =
+ ExtInterval ratioL ratioL
+ | det > 0 =
+ ExtInterval ratioL ratioR
+ | det < 0 =
+ ExtInterval ratioR ratioL
+ where
+ ratioL = bRA / dRA
+ ratioR = aRA / cRA
+ aRA = RA.setMinGranularity gran $ fromInteger a
+ bRA = RA.setMinGranularity gran $ fromInteger b
+ cRA = RA.setMinGranularity gran $ fromInteger c
+ dRA = RA.setMinGranularity gran $ fromInteger d
+ [d, c, b, a] = map snd $ Map.toAscList coeffs
+ det = a * d - b * c
+
+--{-|
+-- Like "lftTensorInfo" but assuming the lft is binary.
+---}
+--lftTensorInfoBinary ::
+-- (RA.ERApprox ra) =>
+-- Granularity ->
+-- LFTTensor ->
+-- ExtInterval ra
+--lftTensorInfoBinary gran t@(LFTTensor _ coeffs)
+-- | det == 0 =
+-- ExtInterval ratioLL ratioLL
+-- where
+-- ratioLL = dRA / hRA
+-- ratioLR = cRA / gRA
+-- ratioRL = bRA / fRA
+-- ratioRR = aRA / eRA
+-- [aRA, bRA, cRA, dRA, eRA, fRA, gRA, hRA] =
+-- map (RA.setMinGranularity gran . fromInteger)
+-- [a, b, c, d, e, f, g, h]
+-- [h, g, f, e, d, c, b, a] = map snd $ Map.toAscList coeffs
+-- det = a * d - b * c
+
+lftTensorIsPositive ::
+ LFTTensor ->
+ Bool
+lftTensorIsPositive t@(LFTTensor n coeffs) =
+ allEqualNotZero cornerSigns
+ where
+ allEqualNotZero [] = True
+ allEqualNotZero (x:xs) =
+ sx /= 0 && (and $ map (((==) sx) . signum) xs)
+ where
+ sx = signum x
+ cornerSigns =
+ zipWith signOfVector coeffsUp coeffsDown
+ (coeffsDown, coeffsUp) =
+ splitAt ((length coeffsList) `div` 2) coeffsList
+ coeffsList =
+ map snd $ Map.toAscList coeffs
+ signOfVector a b
+ | a == 0 = signum b
+ | a < 0 && b > 0 = 0
+ | a < 0 = -1
+ | a > 0 && b < 0 = 0
+ | a > 0 = 1
+
+{-|
+ Compose two unary LFTs, ie substituting one into the other.
+-}
+lftTensorComposeUnary ::
+ LFTTensor ->
+ LFTTensor ->
+ LFTTensor
+lftTensorComposeUnary lft1 lft2 =
+ lftTensorCompose lft1 1 lft2
+
+{-|
+ Compose two LFTs, ie substituting one into another
+ using one of its variables.
+-}
+lftTensorCompose ::
+ LFTTensor ->
+ Int ->
+ LFTTensor ->
+ LFTTensor
+lftTensorCompose (LFTTensor n1 coeffs1) k (LFTTensor n2 coeffs2) =
+ LFTTensor n $ Map.fromList
+ [(tensorIndex, tensorCoeff tensorIndex) |
+ tensorIndex <- allIndices n
+ ]
+ where
+ n = n1 + n2 - 2
+ tensorCoeff tensorIndex =
+ sum $ map getCoeffProd [True, False]
+ where
+ getCoeffProd linkingIndexComponent =
+ coeff1 * coeff2
+ where
+ coeff1 = coeffs1 Map.! index1
+ coeff2 = coeffs2 Map.! index2
+ (index1pre, index2pre) = splitAt (n1 - 1) tensorIndex
+ index1 = insertAt k linkingIndexComponent index1pre
+ index2 = linkingIndexComponent : index2pre
+
+insertAt k a as =
+ preK ++ [a] ++ postK
+ where
+ (preK, postK) = splitAt k as
+
+allIndices n
+ | n == 0 = [[]]
+ | otherwise =
+ (map (True : ) indicesNM1) ++ (map (False :) indicesNM1)
+ where
+ indicesNM1 =
+ allIndices (n - 1)
diff --git a/src/Control/ERNet/Blocks/Real/Protocols.hs b/src/Control/ERNet/Blocks/Real/Protocols.hs
--- a/src/Control/ERNet/Blocks/Real/Protocols.hs
+++ b/src/Control/ERNet/Blocks/Real/Protocols.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
@@ -12,7 +11,8 @@
Stability : experimental
Portability : portable
- Basic protocols for transferring approximations of a single real number.
+ Basic protocol for transferring approximations of a single real number
+ using intervals.
-}
module Control.ERNet.Blocks.Real.Protocols where
@@ -31,7 +31,7 @@
import Data.Typeable
-{- protocol for real numbers -}
+{- protocol for real numbers based on RA intervals -}
instance (RAEL.ERApproxElementary ira, Typeable ira) =>
(QAProtocol QARealQ (QARealA ira))
diff --git a/src/Control/ERNet/Deployment/Local/Channel.hs b/src/Control/ERNet/Deployment/Local/Channel.hs
--- a/src/Control/ERNet/Deployment/Local/Channel.hs
+++ b/src/Control/ERNet/Deployment/Local/Channel.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE PatternSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-|
diff --git a/src/Control/ERNet/Foundations/Channel.hs b/src/Control/ERNet/Foundations/Channel.hs
--- a/src/Control/ERNet/Foundations/Channel.hs
+++ b/src/Control/ERNet/Foundations/Channel.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE PatternSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FunctionalDependencies #-}
diff --git a/src/Control/ERNet/Foundations/Event/JavaScript.hs b/src/Control/ERNet/Foundations/Event/JavaScript.hs
--- a/src/Control/ERNet/Foundations/Event/JavaScript.hs
+++ b/src/Control/ERNet/Foundations/Event/JavaScript.hs
@@ -61,9 +61,8 @@
getRowCase (toN, toName, fromN, fromName, qry, ans, childrenNs) =
"case " ++ show toN ++ ": return " ++
"ndRef(" ++ show fromN ++ ",\"" ++ fromName ++ "\") + " ++
- "\'" ++ showHTML qry ++ "
" ++
- "===> " ++
- "" ++ showHTML ans ++ " | \' + " ++
+ "\' == Query: " ++ showHTML qry ++ " ==>
" ++
+ " <== Ans: " ++ showHTML ans ++ " == | \' + " ++
"ndRef(" ++ show toN ++ ",\"" ++ toName ++ "\");"
diff --git a/src/Control/ERNet/Foundations/Manager.hs b/src/Control/ERNet/Foundations/Manager.hs
--- a/src/Control/ERNet/Foundations/Manager.hs
+++ b/src/Control/ERNet/Foundations/Manager.hs
@@ -70,7 +70,7 @@
ERProcess sInAnyProt sOutAnyProt
{-^
a process to be deployed and enquired;
- it cannot have input channels
+ it cannot have input sockets
-} ->
Int {-^ the output socket in the above process to use, numbered from 0 -} ->
ChannelType {-^ type of the above output socket -} ->
@@ -117,7 +117,7 @@
do
-- create a dummy output socket that we pretend "initiated" the start query
dummyLogger <- LG.new
- (_, dummyCHA) <- CH.new dummyLogger "NONE" 0 chTUnit
+ (_, dummyCHA) <- CH.new dummyLogger "S" 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
diff --git a/src/Control/ERNet/Foundations/Process.hs b/src/Control/ERNet/Foundations/Process.hs
--- a/src/Control/ERNet/Foundations/Process.hs
+++ b/src/Control/ERNet/Foundations/Process.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE PatternSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-|
@@ -28,6 +27,7 @@
ERProcessName,
ERProcessDeploy,
ERProcessExpandCallback,
+ ERProcessAction(..),
subnetProcess
)
where
@@ -80,6 +80,23 @@
[(ERProcess sInAnyProt sOutAnyProt, ([Int], [Int]))]
{--^ internal processes and their in/out channel numbers -} ->
IO ()
+
+
+{-|
+ Explicit representation of a process' action, able to distinguish
+ between answering and making a query or pausing one internal thread
+ until the internal state (TV) has met some condition.
+
+ This is useful for producing highly customisable `templates' for processes
+ as Haskell functions whose parameters are functions that determine
+ what the process should do as a response to some external or internal events.
+ See for example 'Control.ERNet.Blocks.Basic.passThroughStatefulProcess'.
+-}
+data ERProcessAction s q a =
+ ERProcessActionRetryWhen (s -> Bool)
+ | ERProcessActionQuery q
+ | ERProcessActionAnswer Bool a -- whether to cache the answer or not
+
subnetProcess ::
ERProcessName ->
diff --git a/src/Control/ERNet/Foundations/Protocol.hs b/src/Control/ERNet/Foundations/Protocol.hs
--- a/src/Control/ERNet/Foundations/Protocol.hs
+++ b/src/Control/ERNet/Foundations/Protocol.hs
@@ -58,6 +58,7 @@
-- | test whether the answer makes sense for a given query (dynamic type checking)
qaMatch :: q -> a -> Maybe String -- ^ error message
qaaSetMinGran :: Granularity -> a -> a
+ qaaSetMinGran _ a = a
qaMatchDefaultMessage q a =
"answer " ++ show a ++ " does not match query " ++ show q
@@ -136,7 +137,7 @@
chTUnit = ChannelType QAUnitQ QAUnitA
-{- protocol for booleans -}
+{- protocol for communicating a single boolean value -}
instance (QAProtocol QABoolQ Bool)
where
@@ -152,3 +153,24 @@
toHtml = toHtmlDefault
chTBool = ChannelType QABoolQ True
+
+{- protocol for communicating a single natural number -}
+
+instance (QAProtocol QANatQ QANatA)
+ where
+ qaMatch _ _ = Nothing -- always matching
+
+data QANatQ
+ = QANatQ
+ deriving (Eq, Ord, Show, Typeable)
+
+data QANatA
+ = QANatA Integer
+ deriving (Eq, Ord, Show, Typeable)
+
+instance H.HTML QANatQ where
+ toHtml = toHtmlDefault
+instance H.HTML QANatA where
+ toHtml = toHtmlDefault
+
+chTNat = ChannelType QANatQ (QANatA 0)
diff --git a/src/ernet-trace.html b/src/ernet-trace.html
--- a/src/ernet-trace.html
+++ b/src/ernet-trace.html
@@ -23,7 +23,7 @@
t.insertRow(1); // separator
t.rows[1].className = "seprow";
- t.rows[1].innerHTML = " | ";
+ t.rows[1].innerHTML = " the above answer was deduced using the following queries: | ";
var childrenQueries = getChildren(queryNumber);
var i;
diff --git a/tests/ernet-trace.html b/tests/ernet-trace.html
--- a/tests/ernet-trace.html
+++ b/tests/ernet-trace.html
@@ -23,7 +23,7 @@
t.insertRow(1); // separator
t.rows[1].className = "seprow";
- t.rows[1].innerHTML = " | ";
+ t.rows[1].innerHTML = " the above answer was deduced using the following queries: | ";
var childrenQueries = getChildren(queryNumber);
var i;