module Data.Number.ER.RnToRm.BisectionTree
(
BisectionTree(..),
Depth,
ValueSplitter,
ValueCombiner,
isLeaf,
const,
removeVars,
sync2,
syncMany,
setDepth,
split,
mapWithDom,
mapLeaves,
doBistr,
doMap,
doMapLeaves,
combineWith,
collectValues,
collectDomValues,
compare,
lookupSubtreeDoms
)
where
import Prelude hiding (const, map, compare)
import qualified Prelude
import qualified Data.Number.ER.Real.Approx as RA
import qualified Data.Number.ER.Real.DomainBox as DBox
import Data.Number.ER.Real.DomainBox (VariableID(..), DomainBox, DomainBoxMappable, DomainIntBox)
import Data.Number.ER.BasicTypes
import Data.Number.ER.Misc
import Data.Number.ER.ShowHTML
import qualified Text.Html as H
import Data.Typeable
import Data.Generics.Basics
import Data.Binary
import Data.Maybe
data BisectionTree box varid d v =
Leaf
{
bistrDepth :: Depth,
bistrDom :: box,
bistrVal :: v
}
|
Node
{
bistrDepth :: Depth,
bistrDom :: box,
bistrDir :: varid,
bistrPt :: d,
bistrLO :: BisectionTree box varid d v,
bistrHI :: BisectionTree box varid d v
}
deriving (Typeable, Data)
type Depth = Int
instance (Binary a, Binary b, Binary c, Binary d) => Binary (BisectionTree a b c d) where
put (Leaf a b c) = putWord8 0 >> put a >> put b >> put c
put (Node a b c d e f) = putWord8 1 >> put a >> put b >> put c >> put d >> put e >> put f
get = do
tag_ <- getWord8
case tag_ of
0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (Leaf a b c)
1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> return (Node a b c d e f)
_ -> fail "no parse"
instance (VariableID varid, Show d, Show v, DomainBox box varid d) =>
Show (BisectionTree box varid d v)
where
show = showBisectionTree show
showBisectionTree showValue =
showB
where
showB (Leaf depth dom val) =
"\n" ++
(concat (replicate (depth * 2) ".")) ++ "o "
++
(concatWith "," (Prelude.map showVD $ DBox.toList dom))
++
" |---> " ++ showValue val
showB (Node depth dom dir pt lo hi) =
"\n" ++
(concat (replicate (depth * 2) ".")) ++ "o "
++
(concatWith "," (Prelude.map showVD $ DBox.toList dom))
++
" //" ++ showVar dir ++ "\\\\"
++
(concat $ Prelude.map (showBisectionTree showValue) [lo,hi])
showVD (v,d) =
showVar v ++ "->" ++ show d
instance (Show d, H.HTML v, DomainBox box varid d) =>
H.HTML (BisectionTree box varid d v)
where
toHtml (Leaf depth dom val) =
H.toHtmlFromList $
[
H.toHtml $ concatWith "," (Prelude.map showVD $ DBox.toList dom)
,
H.primHtml " → "
,
H.toHtml val
]
where
showVD (v,d) =
showVar v ++ " in " ++ show d
toHtml (Node depth dom dir pt lo hi) =
H.toHtml $
besidesTable [H.border 2]
[
abovesTable [] [H.toHtml $ "(" ++ showVar dir ++ ")"]
,
abovesTable [] [H.toHtml lo, H.toHtml hi]
]
isLeaf ::
BisectionTree box varid d v ->
Bool
isLeaf (Leaf _ _ _) = True
isLeaf (Node _ _ _ _ _ _) = False
const ::
box ->
v ->
BisectionTree box varid d v
const dom value =
Leaf 0 dom value
type ValueSplitter box varid d v =
(EffortIndex -> Depth -> box -> v -> varid -> d -> (v,v))
type ValueCombiner box varid d v =
(EffortIndex -> Depth -> (BisectionTree box varid d v) -> v)
setDepth ::
Depth ->
BisectionTree box varid d v ->
BisectionTree box varid d v
setDepth depth bistr
| isLeaf bistr =
bistr { bistrDepth = depth }
| otherwise =
bistr
{
bistrLO = setDepth depthInc $ bistrLO bistr,
bistrHI = setDepth depthInc $ bistrHI bistr
}
where
depthInc = depth + 1
split ::
(RA.ERIntApprox d, DomainBox box varid d) =>
ValueSplitter box varid d v ->
EffortIndex ->
varid ->
d ->
box ->
BisectionTree box varid d v ->
BisectionTree box varid d v
split valSplitter ix splitDir splitPt fallbackDom bistr =
resultBistr
where
resultBistr = spl bistr
spl (Leaf depth dom val) =
Node depth dom splitDir splitPt childLO childHI
where
childLO =
Leaf depthInc domLO valLO
childHI =
Leaf depthInc domHI valHI
(valLO, valHI) =
valSplitter ix depth dom val splitDir splitPt
depthInc = depth + 1
domLO =
DBox.insert splitDir dirDomLO dom
domHI =
DBox.insert splitDir dirDomHI dom
(dirDomLO, dirDomHI) =
RA.bisectDomain (Just splitPt) dirDom
dirDom =
DBox.findWithDefault
(DBox.lookup "BisectionTree: split: fallbackDom: " splitDir fallbackDom)
splitDir dom
spl bistr@(Node depth dom dir pt childLO childHI)
| dir == splitDir =
case RA.compareReals pt splitPt of
Just LT ->
Node depth dom dir pt
(Node depthInc domChildLO splitDir splitPt childLOsplitLO childLOsplitHI)
childHI
Just GT ->
Node depth dom dir pt
childLO
(Node depthInc domChildHI splitDir splitPt childHIsplitLO childHIsplitHI)
_ -> bistr
| otherwise =
Node depth dom dir pt
(Node
depthInc domChildLO splitDir splitPt childLOsplitLO childLOsplitHI)
(Node
depthInc domChildHI splitDir splitPt childHIsplitLO childHIsplitHI)
where
depthInc = depth + 1
domChildLO = bistrDom childLO
domChildHI = bistrDom childHI
childLOsplit@(Node _ _ _ _ childLOsplitLO childLOsplitHI) =
spl childLO
childHIsplit@(Node _ _ _ _ childHIsplitLO childHIsplitHI) =
spl childHI
mapWithDom ::
(DomainBox box varid d) =>
(box -> v1 -> v2) ->
BisectionTree box varid d v1 ->
BisectionTree box varid d v2
mapWithDom f bistr@(Leaf _ dom val) =
bistr { bistrVal = f dom val }
mapWithDom f bistr@(Node _ _ _ _ cLO cHI) =
bistr
{
bistrLO = mapWithDom f cLO,
bistrHI = mapWithDom f cHI
}
mapLeaves ::
(BisectionTree box varid d v1 -> BisectionTree box varid d v2) ->
BisectionTree box varid d v1 ->
BisectionTree box varid d v2
mapLeaves f bistr@(Leaf _ dom val) =
f bistr
mapLeaves f bistr@(Node _ _ _ _ cLO cHI) =
bistr
{
bistrLO = mapLeaves f cLO,
bistrHI = mapLeaves f cHI
}
mapMultiLeaves ::
(BisectionTree box varid d v1 -> [BisectionTree box varid d v2]) ->
BisectionTree box varid d v1 ->
[BisectionTree box varid d v2]
mapMultiLeaves f bistr@(Leaf _ dom val) =
f bistr
mapMultiLeaves f bistr@(Node _ _ _ _ cLO cHI) =
Prelude.map (replaceChildren bistr) $ zip (mapMultiLeaves f cLO) (mapMultiLeaves f cHI)
where
replaceChildren bistr (newLO, newHI) =
bistr
{
bistrLO = newLO,
bistrHI = newHI
}
doBistr ::
(box -> v -> IO ()) ->
Maybe Int ->
BisectionTree box varid d v ->
IO ()
doBistr f Nothing bistr =
m bistr
where
m (Node _ _ _ _ lo hi) =
do
m lo
m hi
m (Leaf _ dom val) =
f dom val
doBistr f (Just maxDepth) bistr =
m maxDepth bistr
where
m maxDepth (Node depth dom _ _ lo hi)
| maxDepth > 0 =
do
m (maxDepth 1) lo
m (maxDepth 1) hi
| otherwise =
error $ "BisectionTree: doBistr: maxDepth (=" ++ show maxDepth ++ ") breached"
m _ (Leaf _ dom val) =
f dom val
doMap ::
(Depth -> box -> v -> IO v) ->
Maybe Int ->
BisectionTree box varid d v ->
IO (BisectionTree box varid d v)
doMap f Nothing bistr =
m bistr
where
m bistr@(Node _ _ _ _ lo hi) =
do
newLo <- m lo
newHi <- m hi
return $ bistr { bistrLO = newLo, bistrHI = newHi }
m bistr@(Leaf depth dom val) =
do
newVal <- f depth dom val
return $ bistr { bistrVal = newVal }
doMap f (Just maxDepth) bistr =
m maxDepth bistr
where
m maxDepth bistr@(Node depth dom _ _ lo hi)
| maxDepth > 0 =
do
newLo <- m (maxDepth 1) lo
newHi <- m (maxDepth 1) hi
return $ bistr { bistrLO = newLo, bistrHI = newHi }
| otherwise =
error $ "BisectionTree: doBistr: maxDepth (=" ++ show maxDepth ++ ") breached"
m _ bistr@(Leaf depth dom val) =
do
newVal <- f depth dom val
return $ bistr { bistrVal = newVal }
doMapLeaves ::
(BisectionTree box varid d v -> IO (BisectionTree box varid d v)) ->
Maybe Int ->
BisectionTree box varid d v ->
IO (BisectionTree box varid d v)
doMapLeaves f Nothing bistr =
m bistr
where
m bistr@(Node _ _ _ _ lo hi) =
do
newLo <- m lo
newHi <- m hi
return $ bistr { bistrLO = newLo, bistrHI = newHi }
m bistr@(Leaf depth dom val) =
do
f bistr
doMapLeaves f (Just maxDepth) bistr =
m maxDepth bistr
where
m maxDepth bistr@(Node depth dom _ _ lo hi)
| maxDepth > 0 =
do
newLo <- m (maxDepth 1) lo
newHi <- m (maxDepth 1) hi
return $ bistr { bistrLO = newLo, bistrHI = newHi }
| otherwise =
error $ "BisectionTree: doBistr: maxDepth (=" ++ show maxDepth ++ ") breached"
m _ bistr@(Leaf depth dom val) =
do
f bistr
removeVars ::
(RA.ERIntApprox d, DomainIntBox box varid d,
DomainBoxMappable box box varid d d) =>
box ->
BisectionTree box varid d v ->
BisectionTree box varid d v
removeVars substitutions bistr =
aux (bistrDepth bistr) bistr
where
aux depth (Leaf _ dom val) =
Leaf depth domNoVars val
where
domNoVars =
DBox.difference dom substitutions
aux depth (Node _ dom v pt lo hi)
| v `DBox.member` substitutions =
case (vVal `RA.refines` vDomLO, vVal `RA.refines` vDomHI) of
(True, _) -> aux depth lo
(_, True) -> aux depth hi
| otherwise =
Node depth domNoVars v pt loNoVars hiNoVars
where
vVal = DBox.lookup loc v substitutions
vDomLO = DBox.lookup loc v $ bistrDom lo
vDomHI = DBox.lookup loc v $ bistrDom hi
loc = "RnToRm.BisectionTree: removeVars: "
domNoVars =
DBox.difference dom substitutions
loNoVars = aux (depth + 1) lo
hiNoVars = aux (depth + 1) hi
sync2 ::
(RA.ERIntApprox d, DomainIntBox box varid d) =>
ValueSplitter box varid d v1 ->
ValueSplitter box varid d v2 ->
EffortIndex ->
BisectionTree box varid d v1 ->
BisectionTree box varid d v2 ->
(BisectionTree box varid d v1, BisectionTree box varid d v2)
sync2 valSplitter1 valSplitter2 ix bistr1 bistr2 =
case getPt bistr1 bistr2 of
Nothing ->
unifyDom bistr1 bistr2
Just (var, pt, dom) ->
unifyDom
(split valSplitter1 ix var pt dom bistr1)
(split valSplitter2 ix var pt dom bistr2)
where
getPt bistr1 bistr2
| isLeaf bistr1 && isLeaf bistr2 = Nothing
| isLeaf bistr1 =
Just (bistrDir bistr2, bistrPt bistr2, bistrDom bistr2)
| otherwise =
Just (bistrDir bistr1, bistrPt bistr1, bistrDom bistr1)
unifyDom bistr1 bistr2 =
(bistr1 { bistrDom = dom },
bistr2 { bistrDom = dom })
where
dom =
DBox.unify "RnToRm.BisectionTree: sync: " dom1 dom2
dom1 = bistrDom bistr1
dom2 = bistrDom bistr2
syncMany ::
(RA.ERIntApprox d, DomainIntBox box varid d) =>
ValueSplitter box varid d v ->
EffortIndex ->
[BisectionTree box varid d v] ->
[BisectionTree box varid d v]
syncMany valSplitter ix bistrs =
case getPt bistrs of
Nothing -> unifyDom bistrs
Just (var, pt, dom) ->
unifyDom $
Prelude.map (split valSplitter ix var pt dom) bistrs
where
getPt [] = Nothing
getPt (bistr : rest)
| isLeaf bistr = getPt rest
| otherwise = Just (bistrDir bistr, bistrPt bistr, bistrDom bistr)
unifyDom bistrs =
Prelude.map (setDom dom) bistrs
where
setDom dom bistr = bistr { bistrDom = dom }
dom =
foldl (DBox.unify "RnToRm.BisectionTree: sync: ") DBox.noinfo $
Prelude.map bistrDom bistrs
combineWith ::
(RA.ERIntApprox d, DomainIntBox box varid d) =>
ValueSplitter box varid d v1
->
ValueSplitter box varid d v2
->
(box -> v1 -> v2 -> (Maybe res, aux))
->
EffortIndex ->
(BisectionTree box varid d v1) ->
(BisectionTree box varid d v2) ->
(Maybe (BisectionTree box varid d res), [aux])
combineWith valSplitter1 valSplitter2 f ix bistr1 bistr2 =
combineAux bistr1sync bistr2sync
where
(bistr1sync, bistr2sync) =
sync2 valSplitter1 valSplitter2 ix bistr1 bistr2
combineAux
bistr1@(Leaf _ dom val1)
bistr2@(Leaf _ _ val2) =
case f dom val1 val2 of
(Nothing, aux) -> (Nothing, [aux])
(Just val, aux) -> (Just $ bistr1 { bistrVal = val }, [aux])
combineAux
bistr1@(Node _ dom _ _ lo1 hi1)
bistr2@(Node _ _ _ _ lo2 hi2) =
(
Just $ bistr1
{
bistrLO = fromJust mbistrLO,
bistrHI = fromJust mbistrHI
}
,
auxLO ++ auxHI
)
where
(mbistrLO, auxLO) = combineAux lo1Sync lo2Sync
(mbistrHI, auxHI) = combineAux hi1Sync hi2Sync
(lo1Sync, lo2Sync) =
sync2 valSplitter1 valSplitter2 ix lo1 lo2
(hi1Sync, hi2Sync) =
sync2 valSplitter1 valSplitter2 ix hi1 hi2
collectValues ::
BisectionTree box varid b a -> [a]
collectValues (Leaf _ _ val) = [val]
collectValues (Node _ _ _ _ cLO cHI) =
(collectValues cLO) ++ (collectValues cHI)
collectDomValues ::
BisectionTree box varid d v -> [(box, v)]
collectDomValues (Leaf _ dom val) = [(dom,val)]
collectDomValues (Node _ _ _ _ cLO cHI) =
(collectDomValues cLO) ++ (collectDomValues cHI)
compare ::
(Ord varid, DomainBox box varid d) =>
(d -> d -> Ordering) ->
(v -> v -> Ordering) ->
(BisectionTree box varid d v) ->
(BisectionTree box varid d v) ->
Ordering
compare compDoms compValues (Leaf _ _ _) (Node _ _ _ _ _ _) = LT
compare compDoms compValues (Node _ _ _ _ _ _) (Leaf _ _ _) = GT
compare compDoms compValues (Leaf depth1 dom1 val1) (Leaf depth2 dom2 val2) =
compareComposeMany
[
Prelude.compare depth1 depth2,
DBox.compare compDoms dom1 dom2,
compValues val1 val2
]
compare compDoms compValues
(Node depth1 dom1 dir1 pt1 lo1 hi1)
(Node depth2 dom2 dir2 pt2 lo2 hi2) =
compareComposeMany
[
Prelude.compare dir1 dir2,
compDoms pt1 pt2,
compare compDoms compValues lo1 lo2,
compare compDoms compValues hi1 hi2
]
lookupSubtreeDoms ::
(RA.ERIntApprox d, DomainBox box varid d) =>
(BisectionTree box varid d v) ->
box ->
[BisectionTree box varid d v]
lookupSubtreeDoms origBistr dom =
lk origBistr
where
lk bistr@(Leaf _ _ _) = [bistr]
lk bistr@(Node _ _ _ _ lo hi)
| loDisjoint = lk hi
| hiDisjoint = lk lo
| otherwise = (lk lo) ++ (lk hi)
where
loDisjoint =
and $ Prelude.map snd $
DBox.zipWithDefault RA.bottomApprox (RA.isDisjoint) dom domLO
hiDisjoint =
and $ Prelude.map snd $
DBox.zipWithDefault RA.bottomApprox (RA.isDisjoint) dom domHI
domLO = bistrDom lo
domHI = bistrDom hi
updateVal ::
(RA.ERIntApprox d, DomainIntBox box varid d,
DomainBoxMappable box box varid d d) =>
ValueSplitter box varid d v ->
EffortIndex ->
Depth
->
box
->
(box -> v -> v)
->
(BisectionTree box varid d v) ->
(BisectionTree box varid d v)
updateVal valSplitter ix maxDepth updateDom updateFn bistr =
upd bistr
where
upd bistr
| noOverlap = bistr
| edgeTouch && (isLeaf bistr) =
updateLeaf bistr
| insideUpdateDom =
mapLeaves updateLeaf bistr
| depth >= maxDepth =
mapLeaves updateLeaf bistr
| otherwise =
Node depth dom dir pt bistrLdone bistrRdone
where
updateLeaf bistr =
bistr { bistrVal = updateFn (bistrDom bistr) (bistrVal bistr) }
noOverlap =
or $ Prelude.map RA.isEmpty $ DBox.elems domOverlap
domOverlap =
DBox.intersectionWith (RA./\) dom updateDom
insideUpdateDom =
and $ Prelude.map snd $ DBox.zipWith RA.refines dom updateDom
edgeTouch =
and $ Prelude.map snd $ DBox.zipWithDefaultSecond RA.bottomApprox endPointTouch dom updateDom
endPointTouch i1 i2 =
i1L == i2R || i1R == i2L
where
(==) = RA.eqSingletons
(i1L, i1R) = RA.bounds i1
(i2L, i2R) = RA.bounds i2
depth = bistrDepth bistr
dom = bistrDom bistr
bistrLdone = upd bistrL
bistrRdone = upd bistrR
(Node _ _ _ _ bistrL bistrR)
| (isLeaf bistr) =
split valSplitter ix dir pt DBox.noinfo bistr
| otherwise = bistr
(dir, pt) =
DBox.bestSplit dom