module Control.ERNet.Blocks.RnToRm.Basic
(
boundingProcess,
integrateFAProcess,
integrateIsectMeasureFAProcess,
applyFieldProcess,
joinFADomProcess,
splitFADomProcess,
rateFnProcess,
getEndpointValsProcess,
maxOverDomProcess
)
where
import Control.ERNet.Foundations.Protocol
import Control.ERNet.Foundations.Protocol.StandardCombinators
import qualified Control.ERNet.Foundations.Channel as CH
import Control.ERNet.Foundations.Process
import Control.ERNet.Blocks.Basic
import Control.ERNet.Blocks.RnToRm.Protocols
import Control.ERNet.Blocks.Real.Protocols
import qualified Data.Number.ER.RnToRm.Approx as FA
import qualified Data.Number.ER.Real.Approx as RA
import qualified Data.Number.ER.Real.Approx.Elementary as RAEL
import qualified Data.Number.ER.Real.DomainBox as DBox
import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainIntBox)
import Data.Number.ER.BasicTypes
import qualified Data.Number.ER.RnToRm.BisectionTree as BISTR
import qualified Text.Html as H
import Data.Typeable
import Data.Maybe
import qualified Data.Map as Map
import Control.Concurrent as Concurrent
import Control.Concurrent.STM as STM
import Data.Number.ER.MiscSTM
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 ->
ERProcessName ->
ChannelType->
fa ->
EffortIndex
->
[(domra, ranra)]
->
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
(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
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 ->
ChannelType ->
fa ->
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
_ = [derivCH, valueAtOriginCH]
_ = CH.answerQuery False resCH (0, QAIxA $ QAFn1A sampleFA)
dispatcher =
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]
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 ->
fa ->
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
_ = CH.answerQuery False resCH (0, QAIxA $ QAProdABoth (QAFn1A sampleFA) (QAFn1A sampleFA))
dispatcher maybePrevFA maybeOriginData =
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
derivQryId <-
CH.makeQuery resCH resQryId derivCH (QAIxQ ix fnQ)
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)
(QAChangesANew (QARealA updatedOriginRA), Just prevFA) ->
do
initFnQryId <-
CH.makeQuery resCH resQryId initFnCH QAFn1QAll
(QAFn1A updatedFA) <-
CH.waitForAnswer resCH resQryId initFnCH initFnQryId
return (updatedOriginRA, updatedFA)
(_, Nothing) ->
do
initFnQryId <-
CH.makeQuery resCH resQryId initFnCH QAFn1QAll
(QAFn1A initialFA) <-
CH.waitForAnswer resCH resQryId initFnCH initFnQryId
return (originRA, initialFA)
(QAIxA (QAFn1A derivFA)) <-
CH.waitForAnswer resCH resQryId derivCH derivQryId
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))
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 ->
fa ->
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 =
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]
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)
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 ->
fa ->
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 =
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
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 ->
fa ->
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]
(maybeAnsFA, updatedMaybeFnSideQry) <- case (maybeFnSideQry, cast qry) of
(Just (fnFA, prevN, prevQry), Just newQry)
| chN /= prevN && prevQry == newQry ->
return (Just $ getHalfFA chN fnFA, Nothing)
(_, Just qry) ->
do
fnQryId <- CH.makeQuery (resCH chN) resQryId fnCH qry
ans <- CH.waitForAnswer (resCH chN) resQryId fnCH fnQryId
return $
case ans of
(QAFn1A fullFA) ->
(Just $ getHalfFA chN fullFA, Just (fullFA, chN, qry))
CH.answerQuery False (resCH chN) (resQryId, makeAns maybeAnsFA)
dispatcher updatedMaybeFnSideQry
where
resCH chN = [res1CH, res2CH] !! chN
makeAns (Just resFA) =
QAFn1A resFA
getHalfFA chN fullFA =
([fst, snd] !! chN) $ FA.bisect defaultVar Nothing fullFA
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 ->
Rational ->
Int ->
fa ->
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
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 ->
fa ->
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)
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 ->
box ->
fa ->
ERProcess sInAnyProt sOutAnyProt
maxOverDomProcess defName dom sampleFA =
ERProcess defName deploy [chtpFnNoIx] [chtpRNoIx]
where
chtpFnNoIx = chTFn1 sampleFA
chtpRNoIx = chTReal sampleRanRA
sampleDomRA = 0
sampleRanRA = head $ FA.eval (DBox.unary sampleDomRA) sampleFA
deploy _ [fnCHA] [resCHA] _ =
do
dispatcher (RA.bottomApprox, BISTR.const dom (Just RA.bottomApprox))
where
fnCH =
CH.castIn "ERNet.Blocks.RnToRm.Basic: maxOverDomProcess: fnCH:"
fnCHA
resCH =
CH.castOut "ERNet.Blocks.RnToRm.Basic: maxOverDomProcess: resCH:"
resCHA
_ = CH.answerQuery False 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
(newResult, newBistr) <- responder (prevResult, prevBistr) qryData
dispatcher (newResult, newBistr)
responder (prevResult, prevBistr) qryData@(qryId, qry) =
do
splitBistr <- BISTR.doMapLeaves (processLeaf qryId) Nothing prevBistr
let (newBistr, newResult) = normalisePartition prevResult splitBistr
CH.answerQuery False resCH (qryId, QARealA newResult)
return (newResult, newBistr)
processLeaf _ bistr@(BISTR.Leaf _ _ Nothing) =
return bistr
processLeaf resQryId bistr@(BISTR.Leaf depth dom (Just b)) =
do
domLOQryId <-
CH.makeQuery resCH resQryId fnCH $
QAFn1QPt domLO
domHIQryId <-
CH.makeQuery resCH resQryId fnCH $
QAFn1QPt domHI
(QAFn1APt [boundLO]) <-
CH.waitForAnswer resCH resQryId fnCH domLOQryId
(QAFn1APt [boundHI]) <-
CH.waitForAnswer resCH resQryId fnCH domHIQryId
return $
BISTR.Node depth dom var pt
(bistrLO { BISTR.bistrVal = Just boundLO })
(bistrHI { BISTR.bistrVal = Just boundHI })
where
(var, pt) = DBox.bestSplit dom
(domLO, domHI) = DBox.split dom var pt
BISTR.Node _ _ _ _ bistrLO bistrHI =
BISTR.split undefined 0 var pt dom bistr
normalisePartition prevQryBound bistr =
(normalisedBistr, resBound RA./\ prevQryBound)
where
resBound = resBoundLO RA.\/ resBoundHI
(resBoundLO, resBoundHI) =
foldl addBound (1/0, 1/0) $ BISTR.collectValues bistr
where
addBound prevBounds Nothing = prevBounds
addBound (prevBoundLO, prevBoundHI) (Just newBound) =
(max newBoundLO prevBoundLO, max newBoundHI prevBoundHI)
where
(newBoundLO, newBoundHI) = RA.bounds newBound
normalisedBistr =
BISTR.mapWithDom removeIrrelevantBound bistr
where
removeIrrelevantBound dom Nothing = Nothing
removeIrrelevantBound dom (Just bound)
| boundHI `RA.ltSingletons` resBoundLO = Nothing
| boundHI `RA.eqSingletons` resBoundLO && boundHI `RA.ltSingletons` resBoundHI = Nothing
| otherwise = Just bound
where
(_, boundHI) = RA.bounds bound