module Wumpus.Tree.Draw
(
drawTree
, drawFamilyTree
) where
import Wumpus.Tree.Base
import Wumpus.Tree.TreeBuildMonad
import Wumpus.Basic.Kernel
import Wumpus.Drawing.Dots.AnchorDots
import Wumpus.Core
import Control.Monad
import qualified Data.IntMap as IntMap
import Data.Tree hiding ( drawTree )
drawTree :: (Real u, Floating u, FromPtSize u)
=> NodeAnnoRefs u -> CoordTree u (TreeNodeAns u) -> TreeDrawing u
drawTree annos tree = drawStep annos radialConns tree >> return ()
drawFamilyTree :: (Real u, Floating u, FromPtSize u)
=> NodeAnnoRefs u -> CoordTree u (TreeNodeAns u) -> TreeDrawing u
drawFamilyTree annos tree = drawStep annos familyConn tree >> return ()
drawStep :: (Real u, Floating u)
=> NodeAnnoRefs u
-> (DotAnchor u -> [DotAnchor u] -> Graphic u)
-> CoordTree u (TreeNodeAns u) -> TraceDrawing u (DotAnchor u)
drawStep annos connF (Node (pt,(fn, mb_ix)) ns) = do
ancr <- drawi $ fn `at` pt
xs <- mapM (drawStep annos connF) ns
when (not $ null xs) $ draw $ connF ancr xs
drawAnno annos ancr mb_ix
return ancr
drawAnno :: NodeAnnoRefs u -> DotAnchor u -> Maybe Int -> TraceDrawing u ()
drawAnno _ _ Nothing = return ()
drawAnno refs ancr (Just ix) = maybe (return ()) sk $ IntMap.lookup ix refs
where
sk fn = draw $ fn ancr
radialConns :: ( Real u, Floating u
, CenterAnchor a, RadialAnchor a, u ~ DUnit a )
=> a -> [a] -> Graphic u
radialConns a [] = emptyLocGraphic `at` center a
radialConns a (x:xs) = oconcat (connector a x) (map (connector a) xs)
connector :: ( Real u, Floating u
, CenterAnchor a, RadialAnchor a, u ~ DUnit a )
=> a -> a -> Graphic u
connector a1 a2 = openStroke $ vertexPath [p1,p2]
where
(ang0,ang1) = anchorAngles (center a1) (center a2)
p1 = radialAnchor ang0 a1
p2 = radialAnchor ang1 a2
anchorAngles :: (Real u, Floating u)
=> Point2 u -> Point2 u -> (Radian,Radian)
anchorAngles f t = (theta0, theta1)
where
conn_v = pvec f t
theta0 = vdirection conn_v
theta1 = if theta0 < pi then theta0 + pi else theta0 pi
familyConn :: ( Real u, Fractional u
, CenterAnchor a, CardinalAnchor a, u ~ DUnit a )
=> a -> [a] -> Graphic u
familyConn a [] = emptyLocGraphic `at` center a
familyConn a xs = famconn (south a) (map north xs)
famconn :: (Fractional u, Ord u) => Point2 u -> [Point2 u] -> Graphic u
famconn _ [] = error "famconn - empty list"
famconn pt_from [p1] = famconn1 pt_from p1
famconn pt_from xs@(p1:_) = oconcat downtick (horizontal : upticks)
where
hh = halfHeight pt_from p1
downtick = straightLine (vvec (hh)) `at` pt_from
horizontal = midline (displaceV (hh) pt_from) xs
upticks = map (straightLine (vvec hh) `at`) xs
midline :: (Fractional u, Ord u) => Point2 u -> [Point2 u] -> Graphic u
midline _ [] = error "midline - empty list"
midline (P2 _ y) (P2 x0 _:zs) =
let (a,b) = foldr fn (x0,x0) zs in straightLineGraphic (P2 a y) (P2 b y)
where
fn (P2 x _) (lo,hi) | x < lo = (x,hi)
| x > hi = (lo,x)
| otherwise = (lo,hi)
halfHeight :: Fractional u => Point2 u -> Point2 u -> u
halfHeight (P2 _ ya) (P2 _ yb) = 0.5 * (abs $ ya yb)
famconn1 :: Fractional u => Point2 u -> Point2 u -> Graphic u
famconn1 a@(P2 xa _) b@(P2 xb _)
| xa == xb = straightLineGraphic a b
| otherwise = openStroke $ vertexPath [a,m1,m2,b]
where
hh = halfHeight a b
m1 = displaceV (hh) a
m2 = displaceH (xb xa) m1