module Wumpus.Tree.DrawLoc
(
AnnoNode
, TreeSpec
, plainTree
, treeDrawing
, leaf
, xleaf
, tree
, xtree
) where
import Wumpus.Tree.Base
import Wumpus.Tree.Design
import Wumpus.Basic.Kernel
import Wumpus.Core
import Control.Applicative
import Data.Tree hiding ( drawTree )
data AnnoNode ix u a = PlainNode (LocImage u a)
| RefNode ix (LocImage u a)
type TreeSpec ix u a = Tree (AnnoNode ix u a)
plainTree :: (elt -> LocImage u a) -> Tree elt -> TreeSpec ix u a
plainTree gf = fmap (PlainNode . gf)
treeDrawing :: (Real u, Floating u, Translate node, InterpretUnit u, u ~ DUnit node)
=> TreeProps node u -> TreeSpec ix u node -> LocGraphic u
treeDrawing props t1 = promoteLoc $ \pt ->
liftQuery (runDesign props t1) >>= \t2 -> applyLoc (phase1 props t2) pt
leaf :: LocImage u a -> TreeSpec ix u a
leaf a = Node (PlainNode a) []
xleaf :: ix -> LocImage u a -> TreeSpec ix u a
xleaf ix a = Node (RefNode ix a) []
tree :: LocImage u a -> [TreeSpec ix u a] -> TreeSpec ix u a
tree a kids = Node (PlainNode a) kids
xtree :: ix -> LocImage u a -> [TreeSpec ix u a] -> TreeSpec ix u a
xtree ix a kids = Node (RefNode ix a) kids
phase1 :: (Translate node, InterpretUnit u, u ~ DUnit node)
=> TreeProps node u -> TreeSpec ix u node -> LocGraphic u
phase1 props t1 = ignoreAns $ runTreeMonad (step1 t1) props
where
step1 (Node nd []) = insert1 nd
step1 (Node nd xs) = insert1 nd >>= \r1 ->
mapM step1 xs >>= \rs ->
drawConn r1 rs >>
return r1
insert1 (PlainNode gf) = insertli zeroPt gf
insert1 (RefNode _ gf) = insertli zeroPt gf
runDesign :: (Real u, Floating u, InterpretUnit u)
=> TreeProps node u -> TreeSpec ix u a -> Query u (TreeSpec ix u a)
runDesign props t1 =
fmap post <$> designOrientateScale props t1
where
post ((P2 x y), PlainNode gf) = PlainNode $ moveStart (vec x y) gf
post ((P2 x y), RefNode ix gf) = RefNode ix $ moveStart (vec x y) gf
designOrientateScale :: (Real u, Floating u, InterpretUnit u)
=> TreeProps node u -> TreeSpec ix u a
-> Query u (Tree (Point2 u, AnnoNode ix u a))
designOrientateScale props t1 =
scaleTree sx sy (design t1) >>= \ans -> return $ orientateTree dir ans
where
dir = tp_direction props
sx = tp_sibling_distance props
sy = tp_level_distance props