module Data.Number.ER.RnToRm.BisectionTree.Path where
import qualified Data.Number.ER.RnToRm.Approx as FA
import qualified Data.Number.ER.Real.Approx as RA
import Data.Number.ER.BasicTypes.DomainBox (VariableID(..))
import Data.Number.ER.BasicTypes
import Data.Typeable
import Data.Generics.Basics
import Data.Binary
data BisecTreePath =
BTP_H | BTP_R BisecTreePath | BTP_L BisecTreePath
deriving (Eq, Typeable, Data)
instance Binary BisecTreePath where
put BTP_H = putWord8 0
put (BTP_R a) = putWord8 1 >> put a
put (BTP_L a) = putWord8 2 >> put a
get = do
tag_ <- getWord8
case tag_ of
0 -> return BTP_H
1 -> get >>= \a -> return (BTP_R a)
2 -> get >>= \a -> return (BTP_L a)
_ -> fail "no parse"
instance Show BisecTreePath
where
show BTP_H = ""
show (BTP_L rest) = "L" ++ show rest
show (BTP_R rest) = "R" ++ show rest
instance Read BisecTreePath
where
readsPrec p ('L' : rest) =
case readsPrec p rest of
[(restParsed, s)] -> [(BTP_L restParsed, s)]
_ -> []
readsPrec p ('R' : rest) =
case readsPrec p rest of
[(restParsed, s)] -> [(BTP_R restParsed, s)]
_ -> []
readsPrec p s = [(BTP_H, s)]
path2dom ::
(RA.ERIntApprox ira) =>
ira ->
BisecTreePath ->
ira
path2dom rootdom path =
p2d path rootdom
where
p2d BTP_H acc = acc
p2d (BTP_L rest) acc =
p2d rest $ fst $ RA.bisectDomain Nothing $ acc
p2d (BTP_R rest) acc =
p2d rest $ snd $ RA.bisectDomain Nothing $ acc
data FnZipper f
= FnZ_H f
| FnZ_L (FnZipper f) f
| FnZ_R f (FnZipper f)
lookupSubdomain ::
(FA.ERFnDomApprox box varid domra ranra fa) =>
fa ->
BisecTreePath ->
(fa, FnZipper fa)
lookupSubdomain fn BTP_H = (fn, FnZ_H fn)
lookupSubdomain fn (BTP_L restPath) =
(resFn, FnZ_L subZipper hiFn)
where
(resFn, subZipper) = lookupSubdomain loFn restPath
(loFn, hiFn) = FA.bisect defaultVar Nothing fn
lookupSubdomain fn (BTP_R restPath) =
(resFn, FnZ_R loFn subZipper)
where
(resFn, subZipper) = lookupSubdomain hiFn restPath
(loFn, hiFn) = FA.bisect defaultVar Nothing fn
updateFnZ ::
(FA.ERFnDomApprox box varid domra ranra fa) =>
(FnZipper fa) ->
fa ->
fa
updateFnZ (FnZ_H _) fn = fn
updateFnZ (FnZ_L loZipper hiFn) fn =
FA.unBisect defaultVar (loFn, hiFn)
where
loFn = updateFnZ loZipper fn
updateFnZ (FnZ_R loFn hiZipper) fn =
FA.unBisect defaultVar (loFn, hiFn)
where
hiFn = updateFnZ hiZipper fn