{-| 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.BasicTypes.DomainBox as DBox import Data.Number.ER.BasicTypes.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.Misc.STM {-| 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 domB 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 domB (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 domB (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 domB var pt (bistrLO { BISTR.bistrVal = Just boundLO }) (bistrHI { BISTR.bistrVal = Just boundHI }) where (var, (_,pt)) = DBox.bestSplit domB (domLO, domHI) = DBox.split domB var (Just pt) BISTR.Node _ _ _ _ bistrLO bistrHI = BISTR.split undefined 0 var pt domB 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 (-RA.plusInfinity, -RA.plusInfinity) $ 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 domB Nothing = Nothing removeIrrelevantBound domB (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) --