AERN-Net 0.2.0 → 0.2.1

raw patch · 13 files changed

+718/−88 lines, 13 filesdep ~AERN-Realdep ~AERN-RnToRmdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: AERN-Real, AERN-RnToRm, base

API changes (from Hackage documentation)

Files

• AERN-Net.cabal +21/−28
• ChangeLog +7/−1
• src/Control/ERNet/Blocks/Basic.hs +65/−45
• src/Control/ERNet/Blocks/Real/LFT.hs +575/−0
• src/Control/ERNet/Blocks/Real/Protocols.hs +3/−3
• src/Control/ERNet/Deployment/Local/Channel.hs +0/−1
• src/Control/ERNet/Foundations/Channel.hs +0/−1
• src/Control/ERNet/Foundations/Event/JavaScript.hs +2/−3
• src/Control/ERNet/Foundations/Manager.hs +2/−2
• src/Control/ERNet/Foundations/Process.hs +18/−1
• src/Control/ERNet/Foundations/Protocol.hs +23/−1
• src/ernet-trace.html +1/−1
• tests/ernet-trace.html +1/−1

@@ -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-

@@ -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     

@@ -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)      

@@ -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)

@@ -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))

@@ -1,6 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE PatternSignatures #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE DeriveDataTypeable #-} {-|

@@ -1,6 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE PatternSignatures #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FunctionalDependencies #-}

@@ -61,9 +61,8 @@     getRowCase (toN, toName, fromN, fromName, qry, ans, childrenNs) =         "case "  ++ show toN ++ ": return " ++         "ndRef(" ++ show fromN ++ ",\"" ++ fromName ++ "\") + " ++-        "\'<td>" ++ showHTML qry ++ "<br/>" ++-        "===&gt; " ++-        "" ++ showHTML ans ++ "</td>\' + " +++        "\'<td> == <b>Query: </b>" ++ showHTML qry ++ " ==&gt; <br/>" +++        " &lt;== <b>Ans: </b>" ++ showHTML ans ++ " == </td>\' + " ++         "ndRef(" ++ show toN ++ ",\"" ++ toName ++ "\");"      

@@ -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

@@ -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 ->

@@ -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)

@@ -23,7 +23,7 @@ 	 	t.insertRow(1); // separator 	t.rows[1].className = "seprow";-	t.rows[1].innerHTML = "<td height=\"1ex\" colspan=\"3\"></td>";+	t.rows[1].innerHTML = "<td height=\"1ex\" colspan=\"3\"> the above answer was deduced using the following queries: </td>"; 	 	var childrenQueries = getChildren(queryNumber); 	var i;

@@ -23,7 +23,7 @@ 	 	t.insertRow(1); // separator 	t.rows[1].className = "seprow";-	t.rows[1].innerHTML = "<td height=\"1ex\" colspan=\"3\"></td>";+	t.rows[1].innerHTML = "<td height=\"1ex\" colspan=\"3\"> the above answer was deduced using the following queries: </td>"; 	 	var childrenQueries = getChildren(queryNumber); 	var i;