{-# LANGUAGE DeriveDataTypeable #-}{-|
Module : Data.Number.ER.RnToRm.BisectionTree
Description : hierarchical domain partitions
Copyright : (c) 2007-2008 Michal Konecny
License : BSD3
Maintainer : mik@konecny.aow.cz
Stability : experimental
Portability : portable
Defines a representation for recursive bisections of @R^n@
by hyperplanes, each of which is perpendicular to a base axis.
Arbitrary data can be associated with the sections of a partition.
To be imported qualified, usually with prefix BISTR.
-}moduleData.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)whereimportPreludehiding(const,map,compare)importqualifiedPreludeimportqualifiedData.Number.ER.Real.ApproxasRAimportqualifiedData.Number.ER.BasicTypes.DomainBoxasDBoximportData.Number.ER.BasicTypes.DomainBox(VariableID(..),DomainBox,DomainBoxMappable,DomainIntBox)importData.Number.ER.BasicTypesimportData.Number.ER.MiscimportData.Number.ER.ShowHTMLimportqualifiedText.HtmlasHimportData.TypeableimportData.Generics.BasicsimportData.Binary--import BinaryDeriveimportData.Maybe{-|
* The root of the tree often represents the whole @R^n@.
* Each node splits the parent's space into two using
a specified variable (ie direction) and an optional splitting point.
* By default, a split is taken at the point defined by the method 'RA.bisect'.
-}dataBisectionTreeboxvariddv=Leaf{bistrDepth::Depth,bistrDom::box,-- ^ domainbistrVal::v-- ^ value estimate}|Node{bistrDepth::Depth,-- ^ depth of this nodebistrDom::box,-- ^ domainbistrDir::varid,-- ^ direction to split inbistrPt::d,-- ^ point that the split is atbistrLO::BisectionTreeboxvariddv,-- ^ the half towards -Infty in split dirbistrHI::BisectionTreeboxvariddv-- ^ the half towards +Infty in split dir}deriving(Typeable,Data)typeDepth=Int{- the following has been generated by BinaryDerive -}instance(Binarya,Binaryb,Binaryc,Binaryd)=>Binary(BisectionTreeabcd)whereput(Leafabc)=putWord80>>puta>>putb>>putcput(Nodeabcdef)=putWord81>>puta>>putb>>putc>>putd>>pute>>putfget=dotag_<-getWord8casetag_of0->get>>=\a->get>>=\b->get>>=\c->return(Leafabc)1->get>>=\a->get>>=\b->get>>=\c->get>>=\d->get>>=\e->get>>=\f->return(Nodeabcdef)_->fail"no parse"{- the above has been generated by BinaryDerive -}instance(VariableIDvarid,Showd,Showv,DomainBoxboxvaridd)=>Show(BisectionTreeboxvariddv)whereshow=showBisectionTreeshowshowBisectionTreeshowValue=showBwhereshowB(LeafdepthdomBval)="\n"++(concat(replicate(depth*2)"."))++"o "++(concatWith","(Prelude.mapshowVD$DBox.toListdomB))++" |---> "++showValuevalshowB(NodedepthdomBdirptlohi)="\n"++(concat(replicate(depth*2)"."))++"o "++(concatWith","(Prelude.mapshowVD$DBox.toListdomB))++" //"++showVardir++"\\\\"++(concat$Prelude.map(showBisectionTreeshowValue)[lo,hi])showVD(v,d)=showVarv++"->"++showdinstance(Showd,H.HTMLv,DomainBoxboxvaridd)=>H.HTML(BisectionTreeboxvariddv)wheretoHtml(LeafdepthdomBval)=H.toHtmlFromList$[H.toHtml$concatWith","(Prelude.mapshowVD$DBox.toListdomB),H.primHtml" &rarr; ",H.toHtmlval]whereshowVD(v,d)=showVarv++" in "++showdtoHtml(NodedepthdomBdirptlohi)=H.toHtml$besidesTable[H.border2][abovesTable[][H.toHtml$"("++showVardir++")"],abovesTable[][H.toHtmllo,H.toHtmlhi]]isLeaf::BisectionTreeboxvariddv->BoolisLeaf(Leaf___)=TrueisLeaf(Node______)=Falseconst::-- (DomainIntBox box varid d) =>box->v->BisectionTreeboxvariddvconstdomBvalue=Leaf0domBvalue{-|
value splitter function - parameters are:
depth, domain of value, value, variable to split by,
point to split at; returns the two split values
-}typeValueSplitterboxvariddv=(EffortIndex->Depth->box->v->varid->d->(v,v))typeValueCombinerboxvariddv=(EffortIndex->Depth->(BisectionTreeboxvariddv)->v)setDepth::Depth->BisectionTreeboxvariddv->BisectionTreeboxvariddvsetDepthdepthbistr|isLeafbistr=bistr{bistrDepth=depth}|otherwise=bistr{bistrLO=setDepthdepthInc$bistrLObistr,bistrHI=setDepthdepthInc$bistrHIbistr}wheredepthInc=depth+1split::(RA.ERIntApproxd,DomainBoxboxvaridd)=>ValueSplitterboxvariddv->EffortIndex->varid{-^ variable @x@ to split by -}->d{-^ point in domain of @x@ to split at -}->box{-^ domain to lookup @x@ in if tree's domain does not have @x@ -}->BisectionTreeboxvariddv->BisectionTreeboxvariddvsplitvalSplitterixsplitDirsplitPtfallbackDombistr=resultBistrwhereresultBistr=splbistrspl(LeafdepthdomBval)=NodedepthdomBsplitDirsplitPtchildLOchildHIwherechildLO=LeafdepthIncdomLOvalLOchildHI=LeafdepthIncdomHIvalHI(valLO,valHI)=valSplitterixdepthdomBvalsplitDirsplitPtdepthInc=depth+1domLO=DBox.insertsplitDirdirDomLOdomBdomHI=DBox.insertsplitDirdirDomHIdomB(dirDomLO,dirDomHI)=RA.bisectDomain(JustsplitPt)dirDomdirDom=DBox.findWithDefault(DBox.lookup"BisectionTree: split: fallbackDom: "splitDirfallbackDom)splitDirdomBsplbistr@(NodedepthdomBdirptchildLOchildHI)|dir==splitDir=caseRA.compareRealsptsplitPtofJustLT->-- split on lower halfNodedepthdomBdirpt(NodedepthIncdomChildLOsplitDirsplitPtchildLOsplitLOchildLOsplitHI)childHIJustGT->-- split on higher halfNodedepthdomBdirptchildLO(NodedepthIncdomChildHIsplitDirsplitPtchildHIsplitLOchildHIsplitHI)_->bistr|otherwise=-- splitDir < dir =NodedepthdomBdirpt(NodedepthIncdomChildLOsplitDirsplitPtchildLOsplitLOchildLOsplitHI)(NodedepthIncdomChildHIsplitDirsplitPtchildHIsplitLOchildHIsplitHI)-- | dir < splitDir =-- Node depth domB dir childLOsplit childHIsplitwheredepthInc=depth+1domChildLO=bistrDomchildLOdomChildHI=bistrDomchildHIchildLOsplit@(Node____childLOsplitLOchildLOsplitHI)=splchildLOchildHIsplit@(Node____childHIsplitLOchildHIsplitHI)=splchildHI{-|
Apply a function to all values, thus creating a new tree.
-}mapWithDom::(DomainBoxboxvaridd)=>(box->v1->v2)->BisectionTreeboxvariddv1->BisectionTreeboxvariddv2mapWithDomfbistr@(Leaf_domBval)=bistr{bistrVal=fdomBval}mapWithDomfbistr@(Node____cLOcHI)=bistr{bistrLO=mapWithDomfcLO,bistrHI=mapWithDomfcHI}{-|
Apply a function to all values, thus creating a new tree.
-}mapLeaves::(BisectionTreeboxvariddv1->BisectionTreeboxvariddv2)->BisectionTreeboxvariddv1->BisectionTreeboxvariddv2mapLeavesfbistr@(Leaf_domBval)=fbistrmapLeavesfbistr@(Node____cLOcHI)=bistr{bistrLO=mapLeavesfcLO,bistrHI=mapLeavesfcHI}{-|
Apply a function to all values, thus creating a list of new trees.
-}mapMultiLeaves::(BisectionTreeboxvariddv1->[BisectionTreeboxvariddv2])->BisectionTreeboxvariddv1->[BisectionTreeboxvariddv2]mapMultiLeavesfbistr@(Leaf_domBval)=fbistrmapMultiLeavesfbistr@(Node____cLOcHI)=Prelude.map(replaceChildrenbistr)$zip(mapMultiLeavesfcLO)(mapMultiLeavesfcHI)wherereplaceChildrenbistr(newLO,newHI)=bistr{bistrLO=newLO,bistrHI=newHI}{-|
Perform a given action on all branches of a bisection tree, left to right.
(optionally now going below the given depth)
-}doBistr::(box->v->IO())->MaybeInt->BisectionTreeboxvariddv->IO()doBistrfNothingbistr=mbistrwherem(Node____lohi)=domlomhim(Leaf_domBval)=fdomBvaldoBistrf(JustmaxDepth)bistr=mmaxDepthbistrwheremmaxDepth(NodedepthdomB__lohi)|maxDepth>0=dom(maxDepth-1)lom(maxDepth-1)hi|otherwise=error$"BisectionTree: doBistr: maxDepth (="++showmaxDepth++") breached"-- m err (Leaf depth domB val)-- where-- val = head $ collectValues lo-- err = m_(Leaf_domBval)=fdomBval{-|
Perform a given action on all branches of a bisection tree, left to right.
(optionally now going below the given depth)
-}doMap::(Depth->box->v->IOv)->MaybeInt->BisectionTreeboxvariddv->IO(BisectionTreeboxvariddv)doMapfNothingbistr=mbistrwherembistr@(Node____lohi)=donewLo<-mlonewHi<-mhireturn$bistr{bistrLO=newLo,bistrHI=newHi}mbistr@(LeafdepthdomBval)=donewVal<-fdepthdomBvalreturn$bistr{bistrVal=newVal}doMapf(JustmaxDepth)bistr=mmaxDepthbistrwheremmaxDepthbistr@(NodedepthdomB__lohi)|maxDepth>0=donewLo<-m(maxDepth-1)lonewHi<-m(maxDepth-1)hireturn$bistr{bistrLO=newLo,bistrHI=newHi}|otherwise=error$"BisectionTree: doBistr: maxDepth (="++showmaxDepth++") breached"-- m err (Leaf depth domB val)-- where-- val = head $ collectValues lo-- err = m_bistr@(LeafdepthdomBval)=donewVal<-fdepthdomBvalreturn$bistr{bistrVal=newVal}{-|
Perform a given action on all branches of a bisection tree, left to right
with the option of further branching the tree.
(optionally now going below the given depth)
-}doMapLeaves::(BisectionTreeboxvariddv->IO(BisectionTreeboxvariddv))->MaybeInt->BisectionTreeboxvariddv->IO(BisectionTreeboxvariddv)doMapLeavesfNothingbistr=mbistrwherembistr@(Node____lohi)=donewLo<-mlonewHi<-mhireturn$bistr{bistrLO=newLo,bistrHI=newHi}mbistr@(LeafdepthdomBval)=dofbistrdoMapLeavesf(JustmaxDepth)bistr=mmaxDepthbistrwheremmaxDepthbistr@(NodedepthdomB__lohi)|maxDepth>0=donewLo<-m(maxDepth-1)lonewHi<-m(maxDepth-1)hireturn$bistr{bistrLO=newLo,bistrHI=newHi}|otherwise=error$"BisectionTree: doBistr: maxDepth (="++showmaxDepth++") breached"-- m err (Leaf depth domB val)-- where-- val = head $ collectValues lo-- err = m_bistr@(LeafdepthdomBval)=dofbistrremoveVars::(RA.ERIntApproxd,DomainIntBoxboxvaridd,DomainBoxMappableboxboxvariddd)=>box->BisectionTreeboxvariddv->BisectionTreeboxvariddvremoveVarssubstitutionsbistr=aux(bistrDepthbistr)bistrwhereauxdepth(Leaf_domBval)=LeafdepthdomNoVarsvalwheredomNoVars=DBox.differencedomBsubstitutionsauxdepth(Node_domBvptlohi)|v`DBox.member`substitutions=case(vVal`RA.refines`vDomLO,vVal`RA.refines`vDomHI)of(True,_)->auxdepthlo(_,True)->auxdepthhi|otherwise=NodedepthdomNoVarsvptloNoVarshiNoVarswherevVal=DBox.lookuplocvsubstitutionsvDomLO=DBox.lookuplocv$bistrDomlovDomHI=DBox.lookuplocv$bistrDomhiloc="RnToRm.BisectionTree: removeVars: "domNoVars=DBox.differencedomBsubstitutionsloNoVars=aux(depth+1)lohiNoVars=aux(depth+1)hi{-|
Ensure both trees have equal structure at the top level:
either they are all leaves or they all split at the same
direction with the same splitting point.
Also, unify the domains at the top level.
-}sync2::(RA.ERIntApproxd,DomainIntBoxboxvaridd)=>ValueSplitterboxvariddv1->ValueSplitterboxvariddv2->EffortIndex->BisectionTreeboxvariddv1->BisectionTreeboxvariddv2->(BisectionTreeboxvariddv1,BisectionTreeboxvariddv2)sync2valSplitter1valSplitter2ixbistr1bistr2=casegetPtbistr1bistr2ofNothing->unifyDombistr1bistr2Just(var,pt,domB)->unifyDom(splitvalSplitter1ixvarptdomBbistr1)(splitvalSplitter2ixvarptdomBbistr2)wheregetPtbistr1bistr2|isLeafbistr1&&isLeafbistr2=Nothing|isLeafbistr1=Just(bistrDirbistr2,bistrPtbistr2,bistrDombistr2)|otherwise=Just(bistrDirbistr1,bistrPtbistr1,bistrDombistr1)unifyDombistr1bistr2=(bistr1{bistrDom=domB},bistr2{bistrDom=domB})wheredomB=DBox.unify"RnToRm.BisectionTree: sync: "dom1dom2dom1=bistrDombistr1dom2=bistrDombistr2{-|
Ensure all the trees have equal structure at the top level:
either they are all leaves or they all split at the same
direction with the same splitting point.
Also, unify the domains at the top level.
-}syncMany::(RA.ERIntApproxd,DomainIntBoxboxvaridd)=>ValueSplitterboxvariddv->EffortIndex->[BisectionTreeboxvariddv]->[BisectionTreeboxvariddv]syncManyvalSplitterixbistrs=casegetPtbistrsofNothing->unifyDombistrsJust(var,pt,domB)->unifyDom$Prelude.map(splitvalSplitterixvarptdomB)bistrswheregetPt[]=NothinggetPt(bistr:rest)|isLeafbistr=getPtrest|otherwise=Just(bistrDirbistr,bistrPtbistr,bistrDombistr)unifyDombistrs=Prelude.map(setDomdomB)bistrswheresetDomdomBbistr=bistr{bistrDom=domB}domB=foldl(DBox.unify"RnToRm.BisectionTree: sync: ")DBox.noinfo$Prelude.mapbistrDombistrs{-|
Combine two bisection trees using a given value combining function.
Where necessary, leaves are split so that the resulting tree's structure
is the union of the two argument tree structures. Such splitting of
values in leaves is performed by the provided functions.
-}combineWith::(RA.ERIntApproxd,DomainIntBoxboxvaridd)=>ValueSplitterboxvariddv1{-^ value splitter function for tree 1 -}->ValueSplitterboxvariddv2{-^ value splitter function for tree 2 -}->(box->v1->v2->(Mayberes,aux)){-^ partial function to combine values with -}->EffortIndex->(BisectionTreeboxvariddv1)->(BisectionTreeboxvariddv2)->(Maybe(BisectionTreeboxvariddres),[aux])combineWithvalSplitter1valSplitter2fixbistr1bistr2=combineAuxbistr1syncbistr2syncwhere(bistr1sync,bistr2sync)=sync2valSplitter1valSplitter2ixbistr1bistr2combineAuxbistr1@(Leaf_domBval1)bistr2@(Leaf__val2)=casefdomBval1val2of(Nothing,aux)->(Nothing,[aux])(Justval,aux)->(Just$bistr1{bistrVal=val},[aux])combineAuxbistr1@(Node_domB__lo1hi1)bistr2@(Node____lo2hi2)=(Just$bistr1{bistrLO=fromJustmbistrLO,bistrHI=fromJustmbistrHI},auxLO++auxHI)where(mbistrLO,auxLO)=combineAuxlo1Synclo2Sync(mbistrHI,auxHI)=combineAuxhi1Synchi2Sync(lo1Sync,lo2Sync)=sync2valSplitter1valSplitter2ixlo1lo2(hi1Sync,hi2Sync)=sync2valSplitter1valSplitter2ixhi1hi2{-|
return all values in leafs (except those within some CE subtree)
as a list (from the leftmost to the rightmost)
-}collectValues::BisectionTreeboxvaridba->[a]collectValues(Leaf__val)=[val]collectValues(Node____cLOcHI)=(collectValuescLO)++(collectValuescHI){-|
return all values in leafs (except those within some CE subtree)
as a list (from the leftmost to the rightmost)
-}collectDomValues::BisectionTreeboxvariddv->[(box,v)]collectDomValues(Leaf_domBval)=[(domB,val)]collectDomValues(Node____cLOcHI)=(collectDomValuescLO)++(collectDomValuescHI){-|
linear ordering on bisection trees
-}compare::(Ordvarid,DomainBoxboxvaridd)=>(d->d->Ordering)->(v->v->Ordering)->(BisectionTreeboxvariddv)->(BisectionTreeboxvariddv)->OrderingcomparecompDomscompValues(Leaf___)(Node______)=LTcomparecompDomscompValues(Node______)(Leaf___)=GTcomparecompDomscompValues(Leafdepth1dom1val1)(Leafdepth2dom2val2)=compareComposeMany[Prelude.comparedepth1depth2,DBox.comparecompDomsdom1dom2,compValuesval1val2]comparecompDomscompValues(Nodedepth1dom1dir1pt1lo1hi1)(Nodedepth2dom2dir2pt2lo2hi2)=compareComposeMany[Prelude.comparedir1dir2,compDomspt1pt2,comparecompDomscompValueslo1lo2,comparecompDomscompValueshi1hi2]{-|
lookup all maximal subtrees whose domain intersect the given rectangle
-}lookupSubtreeDoms::(RA.ERIntApproxd,DomainBoxboxvaridd)=>(BisectionTreeboxvariddv)->box{-^ domain to look up within the tree -}->[BisectionTreeboxvariddv]lookupSubtreeDomsorigBistrdomB=lkorigBistrwherelkbistr@(Leaf___)=[bistr]lkbistr@(Node____lohi)|loDisjoint=lkhi|hiDisjoint=lklo|otherwise=(lklo)++(lkhi)whereloDisjoint=and$Prelude.mapsnd$DBox.zipWithDefaultRA.bottomApprox(RA.isDisjoint)domBdomLOhiDisjoint=and$Prelude.mapsnd$DBox.zipWithDefaultRA.bottomApprox(RA.isDisjoint)domBdomHIdomLO=bistrDomlodomHI=bistrDomhi{-|
Update a value on a given sub-domain,
bisecting the tree if necessary to obtain
a better fit for the domain, but not below
a given depth limit.
With multiple domain dimensions, split the domain according to
`DBox.bestSplit'.
-}updateVal::(RA.ERIntApproxd,DomainIntBoxboxvaridd,DomainBoxMappableboxboxvariddd)=>ValueSplitterboxvariddv->EffortIndex->Depth{-^ depth limit -}->box{-^ domain to update on -}->(box->v->v){-^ how to update values that intersect the above domain -}->(BisectionTreeboxvariddv)->(BisectionTreeboxvariddv)updateValvalSplitterixmaxDepthupdateDomupdateFnbistr=updbistrwhereupdbistr|noOverlap=bistr|edgeTouch&&(isLeafbistr)=updateLeafbistr-- assuming we can update values on edges without-- influence on the interior|insideUpdateDom=mapLeavesupdateLeafbistr|depth>=maxDepth=mapLeavesupdateLeafbistr|otherwise=-- divide and conquer:NodedepthdomBdirptbistrLdonebistrRdonewhereupdateLeafbistr=bistr{bistrVal=updateFn(bistrDombistr)(bistrValbistr)}noOverlap=or$Prelude.map(not.RA.isConsistent)$DBox.elemsdomOverlapdomOverlap=DBox.intersectionWith(RA./\)domBupdateDominsideUpdateDom=and$Prelude.mapsnd$DBox.zipWithRA.refinesdomBupdateDomedgeTouch=and$Prelude.mapsnd$DBox.zipWithDefaultSecondRA.bottomApproxendPointTouchdomBupdateDomendPointTouchi1i2=i1L==i2R||i1R==i2Lwhere(==)=RA.eqSingletons(i1L,i1R)=RA.boundsi1(i2L,i2R)=RA.boundsi2depth=bistrDepthbistrdomB=bistrDombistrbistrLdone=updbistrLbistrRdone=updbistrR(Node____bistrLbistrR)|(isLeafbistr)=splitvalSplitterixdirptDBox.noinfobistr|otherwise=bistr(dir,(_,pt))=DBox.bestSplitdomB