{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE ScopedTypeVariables #-}{-# OPTIONS -Wall #-}---------------------------------------------------------------------------------- |-- Module : Wumpus.Tree.Design-- Copyright : (c) Stephen Tetley 2010-- License : BSD3---- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>-- Stability : highly unstable-- Portability : GHC---- A variant of the tree drawing algorithm from -- Andrew Kennedy - Functional Pearls Drawing Trees 1996.---- Acknowledgment - although based on Andrew Kennedy\'s algorithm,-- this version uses absolute extents rather than relative ones -- and is a somewhat different in detail if not in spirit to the -- original.---- Any mistakes are mine of course.-- --------------------------------------------------------------------------------moduleWumpus.Tree.Design(design,rotateAboutRoot)whereimportWumpus.Tree.BaseimportWumpus.Basic.Kernel-- package: wumpus-basicimportWumpus.Core-- package: wumpus-coreimportData.ListimportData.MaybeimportData.Tree-- | XPos is an absolute position--typeXPosu=utypeXTreeua=Tree(XPosu,a)-- | Delta - difference in X-positions.--typeDeltau=u-- A horizontal span.--dataHSpanu=HSpan!u!uderiving(Eq,Ord,Show)outsideMerge::HSpanu->HSpanu->HSpanuoutsideMerge(HSpanp_)(HSpan_q)=HSpanpqmoveSpan::Numu=>Deltau->HSpanu->HSpanumoveSpand(HSpanpq)=HSpan(p+d)(q+d)newtypeExtentu=Extent{span_list::[HSpanu]}deriving(Eq,Show)extlink::u->Extentu->Extentuextlinka(Extentas)=Extent$(HSpanaa):as-- note is this just for left ... ?--midtop::Fractionalu=>u->Extentu->XPosumidtopr(Extent[])=rmidtop_(Extent(HSpanpq:_))=p+(0.5*(q-p))-- merge \"moving right\"...--mergeMR::Numu=>Deltau->Extentu->Extentu->ExtentumergeMRdx(Extentxs)(Extentys)=Extent$stepxsyswherestepps[]=psstep[]qs=map(moveSpandx)qsstep(p:ps)(q:qs)=outsideMergep(moveSpandxq):steppsqs-- dx is negative...--mergeML::Numu=>Deltau->Extentu->Extentu->ExtentumergeMLdx(Extentxs)(Extentys)=Extent$stepxsyswherestepps[]=map(moveSpandx)psstep[]qs=qsstep(p:ps)(q:qs)=outsideMerge(moveSpandxp)q:steppsqsextentZero::ExtentuextentZero=Extent[]extentOne::XPosu->ExtentuextentOnex=Extent[HSpanxx]-- 'moveTree' is now recursive...--moveTree::Numu=>Deltau->XTreeua->XTreeuamoveTreedx(Node(x,a)subtrees)=Node((x+dx),a)subtrees'wheresubtrees'=map(moveTreedx)subtreesfit::(Fractionalu,Ordu)=>Extentu->Extentu->ufitab=go(span_lista)(span_listb)0.0wherego(HSpan_p:ps)(HSpanq_:qs)acc=gopsqs(maxacc(p-q+1.0))go__acc=acc-- Fitting the children of a node...fitleft::(Fractionalu,Ordu)=>[(XTreeua,Extentu)]->([XTreeua],Extentu)fitleft[]=([],extentZero)fitleft((l,ext):xs)=(l:ts,ext')-- left-most child unchangedwhere(ext',ts)=mapAccumLstepextxsstepaex(t,ex)=letdx=fitaexexin(mergeMRdxaexex,moveTreedxt)fitright::(Fractionalu,Ordu)=>[(XTreeua,Extentu)]->([XTreeua],Extentu)fitright=post.foldrfnNothingwherepost=fromMaybe([],extentZero)fn(t,ex)Nothing=Just([t],ex)fn(t,ex)(Just(ts,aex))=Just(t':ts,aex')wheredx=negate$fitexaext'=moveTreedxtaex'=mergeMLdxexaex-- Note - this will tell how wide the tree is...-- though the last exten is not necessarily the widest.designl::forallau.(Fractionalu,Ordu)=>Treea->(XTreeua,Extentu)designl(Nodea[])=(Node(0.0,a)[],extentOne0.0)designl(Nodeakids)=(Node(xpos,a)kids',ext1)wherexs::[(XTreeua,Extentu)]xs=mapdesignlkidskids'::[XTreeua]ext0,ext1::Extentu(kids',ext0)=fitleftxsxpos=midtop0.0ext0ext1=xpos`extlink`ext0designr::forallua.(Fractionalu,Ordu)=>XPosu->Treea->(XTreeua,Extentu)designrr(Nodea[])=(Node(r,a)[],extentOner)designrr(Nodeakids)=(Node(xpos,a)kids',ext1)wherexs::[(XTreeua,Extentu)]xs=map(designrr)kidskids'::[XTreeua]ext0,ext1::Extentu(kids',ext0)=fitrightxsxpos=midtoprext0ext1=xpos`extlink`ext0-- | Design a tree, properly balancing the child nodes oriented -- at root. ---- As the design has no y-positions (but by recursion they can be -- counted) and x-positions are respective to the unit distance -- 1.0 separating nodes it is rescaled as a post-processing step-- into drawable coordinates. --design::(Fractionalu,Ordu)=>Point2u->ScalingContextuIntu->Treea->CoordTreeuadesignrosctxt=rootOrientatero$scaleDesignsctx0t3where(t1,ext)=designlt(_,HSpanxminxmax)=statsextwidth=xmax-xmin(t2,_)=designrwidtht-- reconcile the left and right drawings...t3=treeZipWithzfnt1t2zfn(x0,a)(x1,_)=(meanx0x1,a)-- Scale the tree. Originally the tree has no y-positions (but by -- recursion they can be counted) and x-positions are respective -- to the unit width 1.0.--scaleDesign::Numuy=>ScalingContextuxuyu->uy->Tree(XPosux,a)->CoordTreeuascaleDesignctxlvl(Node(xpos,a)kids)=Node(pt,a)kids'wherept=scalePtctxxposlvlkids'=map(scaleDesignctx(lvl-1))kidsrootOrientate::Numu=>Point2u->CoordTreeua->CoordTreeuarootOrientate(P2oxoy)(Node(P2x0y0,val)kids)=Node(P2oxoy,val)$map(mv(ox-x0)(oy-y0))kidswheremvdxdy(Node(P2xy,a)ks)=letks'=map(mvdxdy)ksinNode(P2(x+dx)(y+dy),a)ks'rotateAboutRoot::(Realu,Floatingu)=>Radian->CoordTreeua->CoordTreeuarotateAboutRootang(Node(ogin,val)kids)=Node(ogin,val)$mapstepkidswherestep(Node(p0,a)ks)=Node(rotAp0,a)$mapstepksrotA=rotateAboutangogin-- find height and width--stats::(Numu,Ordu)=>Extentu->(Int,HSpanu)stats(Extent[])=(0,HSpan00)stats(Extent(e:es))=foldrfn(1,e)eswherefns1(h,acc_span)=(h+1,minmaxMerges1acc_span)mean::Fractionalu=>u->u->umeanxy=(x+y)/2.0minmaxMerge::Ordu=>HSpanu->HSpanu->HSpanuminmaxMerge(HSpanpq)(HSpanp'q')=HSpan(minpp')(maxqq')treeZipWith::(a->b->c)->Treea->Treeb->TreectreeZipWithf(Nodeaxs)(Nodebys)=Node(fab)(stepxsys)wherestep(p:ps)(q:qs)=treeZipWithfpq:steppsqsstep__=[]