module Wumpus.Tree.Base
(
TreeMonad
, OTMAnchorConn
, TreeProps(..)
, TreeDirection(..)
, runTreeMonad
, drawConn
) where
import Wumpus.Basic.Kernel
import Wumpus.Core
import Control.Applicative
import Data.Monoid
data TreeMonad node u a = TreeMonad {
getTreeMonad :: TreeProps node u -> LocDrawing u a }
type instance DUnit (TreeMonad node u a) = u
type OTMAnchorConn node u = TreeDirection -> u -> node -> [node] -> Graphic u
data TreeProps node u = TreeProps
{ tp_sibling_distance :: u
, tp_level_distance :: u
, tp_direction :: TreeDirection
, tp_otm_connector :: OTMAnchorConn node u
}
type instance DUnit (TreeProps node u) = u
data TreeDirection = TREE_UP | TREE_DOWN | TREE_LEFT | TREE_RIGHT
deriving (Eq,Ord,Show)
instance Functor (TreeMonad node u) where
fmap f ma = TreeMonad $ \env -> fmap f $ getTreeMonad ma env
instance Applicative (TreeMonad node u) where
pure a = TreeMonad $ \_ -> pure a
mf <*> ma = TreeMonad $ \env ->
getTreeMonad mf env <*> getTreeMonad ma env
instance Monad (TreeMonad node u) where
return a = TreeMonad $ \_ -> return a
ma >>= k = TreeMonad $ \env ->
getTreeMonad ma env >>= \ans -> getTreeMonad (k ans) env
instance Monoid a => Monoid (TreeMonad node u a) where
mempty = TreeMonad $ \_ -> mempty
ma `mappend` mb = TreeMonad $ \env ->
getTreeMonad ma env `mappend` getTreeMonad mb env
instance DrawingCtxM (TreeMonad node u) where
askDC = TreeMonad $ \_ -> askDC
asksDC fn = TreeMonad $ \_ -> asksDC fn
localize upd ma = TreeMonad $ \env -> localize upd (getTreeMonad ma env)
instance InterpretUnit u => LocDrawM (TreeMonad node u) where
inserti gf = TreeMonad $ \_ -> inserti gf
insertli p1 gf = TreeMonad $ \_ -> insertli p1 gf
insertci p1 p2 gf = TreeMonad $ \_ -> insertci p1 p2 gf
runTreeMonad :: (Translate a, InterpretUnit u, u ~ DUnit a)
=> TreeMonad node u a -> TreeProps node u -> LocImage u a
runTreeMonad ma props = runLocDrawing $ getTreeMonad ma props
drawConn :: InterpretUnit u
=> node -> [node] -> TreeMonad node u ()
drawConn start kids = TreeMonad $ \(TreeProps { tp_level_distance = h
, tp_otm_connector = conn
, tp_direction = tdir
}) ->
let gf = conn tdir h start kids in inserti_ gf