wumpus-tree 0.16.0 → 0.17.0

raw patch · 9 files changed

+257/−481 lines, 9 filesdep ~wumpus-basicdep ~wumpus-drawingPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-basic, wumpus-drawing

API changes (from Hackage documentation)

Files

• demo/Demo01.hs +30/−10
• src/Wumpus/Tree.hs +5/−21
• src/Wumpus/Tree/Base.hs +89/−20
• src/Wumpus/Tree/Design.hs +4/−1
• src/Wumpus/Tree/DrawLoc.hs +71/−59
• src/Wumpus/Tree/OTMConnectors.hs +48/−48
• src/Wumpus/Tree/TreeBuilder.hs +0/−316
• src/Wumpus/Tree/VersionNumber.hs +2/−2
• wumpus-tree.cabal +8/−4

@@ -41,30 +41,50 @@ tree_pic1 = udrawTracing (0::Double) $ do     --     draw $ dcTextlabel "Tree 1:"        `at` (P2 0  550)-    drawl (P2 10 500) $ runTreeLoc props1 (const red_dot) tree1+    drawl (P2 10 500) $ treeDrawing props1 $ plainTree (const red_dot) tree1     --     draw $ dcTextlabel "Tree 2:"       `at` (P2 200 550) -    drawl (P2 300 550) $ runTreeLoc props2 dotChar tree2+    drawl (P2 300 550) $ treeDrawing props2 $ plainTree dotChar tree2      draw $ dcTextlabel "Tree 3:"       `at` (P2 0  410)      localize (set_font_size 12) $ -        drawl (P2 280 410) $ runTreeLoc props3 dotChar tree3+        drawl (P2 280 410) $ treeDrawing props3 $ plainTree dotChar tree3      --     draw $ dcTextlabel "Tree 4:"       `at` (P2 0  190)-    drawl (P2 80 190) $ runTreeLoc props4 (const circ_dot) tree4+    drawl (P2 80 190) $ treeDrawing props4 $ plainTree (const circ_dot) tree4     --     draw $ dcTextlabel "Tree 5:"        `at` zeroPt-    drawl (P2 320 0) $ runTreeLoc props5 (const circ_dot) tree5+    drawl (P2 320 0) $ treeDrawing props5 $ plainTree (const circ_dot) tree5+   where     red_dot  = localize (fill_colour red) dotDisk     circ_dot = localize (stroke_colour black) dotCircle -    props1 = tree_direction TREE_RIGHT $ standardTreeProps 30 30 radialOTMC-    props2 = standardTreeProps 30 40 familyOTMC-    props3 = tree_direction TREE_DOWN $ standardTreeProps 25 30 familyOTMC-    props4 = standardTreeProps 20 30 radialOTMC-    props5 = standardTreeProps 30 36 radialOTMC+    props1 = TreeProps { tp_level_distance   = 30+                       , tp_sibling_distance = 30+                       , tp_direction        = TREE_RIGHT+                       , tp_otm_connector    = radialOTM }++    props2 = TreeProps { tp_level_distance   = 40+                       , tp_sibling_distance = 30+                       , tp_direction        = TREE_DOWN+                       , tp_otm_connector    = familyOTM }++    props3 = TreeProps { tp_level_distance   = 30+                       , tp_sibling_distance = 25+                       , tp_direction        = TREE_DOWN+                       , tp_otm_connector    = familyOTM  }++    props4 = TreeProps { tp_level_distance   = 30+                       , tp_sibling_distance = 20+                       , tp_direction        = TREE_DOWN+                       , tp_otm_connector    = radialOTM }++    props5 = TreeProps { tp_level_distance   = 36+                       , tp_sibling_distance = 30+                       , tp_direction        = TREE_DOWN+                       , tp_otm_connector    = radialOTM }   tree1 :: Tree Char

@@ -17,14 +17,10 @@ module Wumpus.Tree   (   -- * Re-exports-    module Wumpus.Tree.OTMConnectors--  , TreeDirection(..) -  , tree_direction-  , runTreeLoc--  -- * Definitions-  , standardTreeProps+    module Wumpus.Tree.Base+  , module Wumpus.Tree.DrawLoc+  , module Wumpus.Tree.OTMConnectors+  , module Wumpus.Tree.VersionNumber    )   where@@ -32,18 +28,6 @@ import Wumpus.Tree.Base import Wumpus.Tree.DrawLoc import Wumpus.Tree.OTMConnectors-----+import Wumpus.Tree.VersionNumber -standardTreeProps :: Fractional u -                  => u -> u -> OTMAnchorConn u a -> TreeProps u a-standardTreeProps sx sy otm_conn = -    TreeProps { tp_sibling_distance = sx -              , tp_level_distance   = sy-              , tp_multiconn        = otm_conn         -              , tp_direction        = TREE_DOWN-              }   

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-} @@ -18,43 +19,111 @@ module Wumpus.Tree.Base   ( -    OTMAnchorConn+    TreeMonad+  , OTMAnchorConn   , TreeProps(..)-  , TreePropsF   , TreeDirection(..)-  , tree_direction-  , getTreeConnector -  ) where+  , runTreeMonad +  , drawConn +  ) where + import Wumpus.Basic.Kernel                      -- package: wumpus-basic +import Wumpus.Core                              -- package: wumpus-core -type OTMAnchorConn u a = TreeDirection -> u -> a -> [a] -> Graphic u+import Control.Applicative+import Data.Monoid +data TreeMonad node u a = TreeMonad { +        getTreeMonad :: TreeProps node u -> LocDrawing u a } -data TreeProps u a = TreeProps-      { tp_sibling_distance :: u-      , tp_level_distance   :: u-      , tp_multiconn        :: OTMAnchorConn u a-      , tp_direction        :: TreeDirection+type instance DUnit (TreeMonad node u a) = u+++type OTMAnchorConn node u = TreeDirection -> u -> node -> [node] -> Graphic u++++-- Design note - as the TreeMonad will be used internally there+-- doesn\'t seem to be a need for user state.++data TreeProps node u = TreeProps+      { tp_sibling_distance     :: u+      , tp_level_distance       :: u+      , tp_direction            :: TreeDirection+      , tp_otm_connector        :: OTMAnchorConn node u       }   -type TreePropsF u a = TreeProps u a -> TreeProps u a+type instance DUnit (TreeProps node u) = u + data TreeDirection = TREE_UP | TREE_DOWN | TREE_LEFT | TREE_RIGHT   deriving (Eq,Ord,Show) -tree_direction :: TreeDirection -> TreePropsF u a-tree_direction dir props = props { tp_direction = dir }  -getTreeConnector :: (DrawingCtxM m, InterpretUnit u)-                 => TreeProps u a -> m (a -> [a] -> Graphic u)-getTreeConnector (TreeProps { tp_level_distance   = lvl-                            , tp_multiconn        = conn-                            , tp_direction        = dir  }) = -    uconvertCtx1 lvl >>= \ulvl -> return (conn dir ulvl)++-- Note - not entirely sure TreeDrawing is a LocTrace, it will+-- certainly need branching if it is.++-- Functor++instance Functor (TreeMonad node u) where+  fmap f ma = TreeMonad $ \env -> fmap f $ getTreeMonad ma env ++-- Applicative+ +instance Applicative (TreeMonad node u) where+  pure a    = TreeMonad $ \_   -> pure a+  mf <*> ma = TreeMonad $ \env -> +                getTreeMonad mf env <*> getTreeMonad ma env+++-- Monad++instance Monad (TreeMonad node u) where+  return a  = TreeMonad $ \_   -> return a+  ma >>= k  = TreeMonad $ \env -> +                getTreeMonad ma env >>= \ans -> getTreeMonad (k ans) env++-- Monoid ++instance Monoid a => Monoid (TreeMonad node u a) where+  mempty          = TreeMonad $ \_   -> mempty+  ma `mappend` mb = TreeMonad $ \env -> +                      getTreeMonad ma env `mappend` getTreeMonad mb env+++-- DrawingCtxM++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 

@@ -21,6 +21,9 @@ -- original. -- -- Any mistakes are mine of course.+--+-- Note - although this module is exposed, it is not expected to +-- be indenpendently useful for client code. --  -------------------------------------------------------------------------------- @@ -303,7 +306,7 @@           => u -> u -> CoordTree a -> m (Tree (Point2 u, a)) scaleTree sib_dist lvl_dist tree =      getFontSize >>= \sz -> -    let fn = mkFun sz in return $ fmap (bimapL fn) tree+    let fn = mkFun sz in return $ fmap (\(a,b) -> (fn a, b)) tree   where     mkFun sz = \(P2 x y) -> let ux = sib_dist * (dinterp sz $ realToFrac x)                                 uy = lvl_dist * (dinterp sz $ realToFrac y)

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -17,8 +18,16 @@ module Wumpus.Tree.DrawLoc   (     -    runTreeLoc+    AnnoNode+  , TreeSpec    +  , plainTree+  , treeDrawing +  , leaf+  , xleaf+  , tree+  , xtree+   ) where  import Wumpus.Tree.Base@@ -29,84 +38,87 @@  import Wumpus.Core                              -- package: wumpus-core +import Control.Applicative import Data.Tree hiding ( drawTree )  ------ DESIGN NOTE ------ Only simplistic trees can be drawn as LocGraphics.------ Technically, this is because LocImages only support --- /production/ of /answers/ and not their /introspection/, so--- we cannot query anchors directly[*] during construction. Thus --- we can\'t have /graph-links/ which need /located/ anchors.------ [*] Though we can use @dblelaborate@ for a special case.---+data AnnoNode ix u a = PlainNode (LocImage u a)+                   | RefNode ix (LocImage u a)  --- | Build a LocGraphic from a @Data.Tree@.------ Nodes support custom drawing as the value of the /label/ at --- each node is interpreted (naturally, all node drawings must --- be of the same type). +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 should build a Data.Tree node with no kids... ---runTreeLoc :: (Real u, Floating u, InterpretUnit u) -           => TreeProps u a -> (elt -> LocImage u a) -> Tree elt -           -> LocGraphic u-runTreeLoc props drawF tree = promoteLoc $ \pt ->-    let tree1 = fmap drawF tree-    in zapQuery (runDesign props tree1) >>= \ans -> -       ignoreAns (drawStep props ans `at` 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) []  -drawStep :: (Real u, Floating u, InterpretUnit u) -         => TreeProps u a -> Tree (LocImage u a) -> LocImage u a-drawStep props (Node gf ns) =-    getTreeConnector props >>= \conn ->-    let imgs = sequence $ map (drawStep props) ns-    in dblelaborate gf imgs conn-      +tree :: LocImage u a -> [TreeSpec ix u a] -> TreeSpec ix u a+tree a kids = Node (PlainNode a) kids --- | This is not really a generally function - the types are not--- complementary and it returns only the first answer but consumes --- the second, so it doesn\'t belong in Wumpus-Basic. --- --- However, it is a problematic that it needs to --- deconstruct the Ans directly - this suggests there is a need --- for a more general version of this combinator in Wumpus-Basic.--- -dblelaborate :: LocImage u a -> LocImage u b -             -> (a -> b -> Graphic u) -             -> LocImage u a-dblelaborate ma mb fn = promoteLoc $ \pt -> -    both (ma `at` pt) (mb `at` pt) >>= \(a,b) -> fn a b >> return a+xtree :: ix -> LocImage u a -> [TreeSpec ix u a] -> TreeSpec ix u a+xtree ix a kids = Node (RefNode ix a) kids -designOrientateScale :: (Real u, Floating u, InterpretUnit u)-                     => TreeProps u a  -> Tree (LocImage u a) -                     -> Query u (Tree (Point2 u, LocImage u a))-designOrientateScale props tree =  -    scaleTree sx sy (design tree) >>= \ans -> return $ orientateTree dir ans+++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-    dir = tp_direction props-    sx  = tp_sibling_distance props-    sy  = tp_level_distance props+    step1 (Node nd []) = insert1 nd +    step1 (Node nd xs) = insert1 nd    >>= \r1 -> +                         mapM step1 xs >>= \rs ->+                         drawConn r1 rs >>+                         return r1 +    -- TODO ix+    insert1 (PlainNode gf)         = insertli zeroPt gf+    insert1 (RefNode _ gf)         = insertli zeroPt gf ++++ -- | Transform a tree where each node is a LocImage into a tree -- where each LocImage is displaced by the necessary coordinate -- so it can be drawn. -- runDesign :: (Real u, Floating u, InterpretUnit u)-          => TreeProps u a  -> Tree (LocImage u a) -          -> Query u (Tree (LocImage u a))-runDesign props tree =  -    designOrientateScale props tree >>= \tree2 -> -    return $ fmap fn tree2+          => TreeProps node u -> TreeSpec ix u a -> Query u (TreeSpec ix u a)+runDesign props t1 =  +     fmap post <$> designOrientateScale props t1   where-    fn ((P2 x y), gf) = moveStart (vec x y) gf+    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  

@@ -19,16 +19,16 @@ module Wumpus.Tree.OTMConnectors   ( -    radialOTMC-  , blankOTMC-  , familyOTMC-  , splayOTMC+    radialOTM+  , blankOTM+  , familyOTM+  , splayOTM    ) where  import Wumpus.Tree.Base -import Wumpus.Drawing.Paths.Absolute            -- package: wumpus-drawing+import Wumpus.Drawing.Paths.Absolute  import Wumpus.Basic.Kernel                      -- package: wumpus-basic @@ -36,12 +36,21 @@  import Data.AffineSpace                         -- package: vector-space +import Data.Maybe import Data.Monoid+import Prelude hiding ( lookup )   +radialOTM :: ( Real u, Floating u, InterpretUnit u+             , RadialAnchor node, CenterAnchor node, u ~ DUnit node) +          => OTMAnchorConn node u +radialOTM _ _ a as = mconcat $ map fn $ radialNodes a as+  where+    fn (s,t)      = connect s t straightConnector  + -- Pulling out the points (nodes) from parent plus list of  -- children. @@ -66,67 +75,58 @@     theta1  = if theta0 < pi then theta0 + pi else theta0 - pi  +++blankOTM :: OTMAnchorConn node u+blankOTM _ _ _ _ = mempty+++ --  -- @radialConn@ cannot be represented as a connector from -- one-point-to-many-points as the initial points all start from -- slightly different places.  -- ---- | 'radialOTMC' has no need for the TreeDirection or height step.--- -radialOTMC :: ( Real u, Floating u, InterpretUnit u-              , CenterAnchor a, RadialAnchor a -              , u ~ DUnit a) -           => OTMAnchorConn u a-radialOTMC _ _ a xs = mconcat $ map fn $ radialNodes a xs-  where-    fn (p0,p1) = zapQuery (vertexPP [p0,p1]) >>= dcOpenPath---- | Blank connector - nothing is drawn.----blankOTMC :: ( Real u, Floating u, InterpretUnit u-            , CenterAnchor a-            , u ~ DUnit a) -         => OTMAnchorConn u a-blankOTMC _ _ a _ = emptyLocImage `at` center a-- -------------------------------------------------------------------------------- --   -- Note - can the \"crossbar\" of a famillyConn cannot be --- calcuated parent-to-arbitrary-child?+-- calculated parent-to-arbitrary-child? -- --- Probably we need to know half the height step, rather than --- calculate it from anchors.+-- Probably we need to know half the height step +-- (vcenter-to-vcenter), rather than calculate it from anchors. -- --- Drawing a fmaily connector is quite horrible...   -familyOTMC :: ( Real u, Floating u, Ord u, Tolerance u, InterpretUnit u-              , CenterAnchor a, CardinalAnchor a -              , u ~ DUnit a ) -           => OTMAnchorConn u a-familyOTMC _   _ _ [] = mempty-familyOTMC dir h a xs = +-- Drawing a family connector is quite horrible, we need to know+-- both the tree direction and the vertical height between layers.++++familyOTM :: ( Real u, Floating u, Ord u, Tolerance u, InterpretUnit u+             , CenterAnchor node, CardinalAnchor node+             , u ~ DUnit node ) +          => OTMAnchorConn node u+familyOTM _   _ _ [] = mempty+familyOTM dir h a xs =      let hh        = 0.5 * h         (paF,caF) = famAnchors dir         ptick     = outtick hh (center a) (paF a)         cticks    = map (\o -> outtick hh (center o) (caF o)) xs         kids      = sequence cticks-    in ignoreAns ptick `mappend` (ignoreAns $ elaborate kids fn)+    in ignoreAns ptick `mappend` (ignoreAns $ selaborate kids fn)   where     fn ps = case linkAll ps of               Nothing -> emptyLocImage `at` (center a)-              Just path -> zapQuery (toPrimPath path) >>= dcOpenPath+              Just path -> drawOpenPath_ path    famAnchors :: (CardinalAnchor a, u ~ DUnit a ) -             => TreeDirection -> (a -> Anchor u, a -> Anchor u)+           => TreeDirection -> (a -> Anchor u, a -> Anchor u) famAnchors TREE_UP    = (north, south) famAnchors TREE_DOWN  = (south, north) famAnchors TREE_LEFT  = (west,  east)@@ -154,17 +154,17 @@   -splayOTMC :: ( Real u, Floating u, Ord u, Tolerance u, InterpretUnit u-              , CenterAnchor a, CardinalAnchor a -              , u ~ DUnit a ) -           => OTMAnchorConn u a-splayOTMC _   _ _ [] = mempty-splayOTMC dir _ a xs = -    let (paF,caF) = famAnchors dir-        p0        = paF a-    in mconcat $ map (\x -> fn p0 (caF x)) xs+splayOTM :: ( Real u, Floating u, Ord u, Tolerance u, InterpretUnit u+            , CenterAnchor node, CardinalAnchor node +            , u ~ DUnit node) +          => OTMAnchorConn node u+splayOTM _   _ _ [] = mempty+splayOTM dir _ a xs = let (paF,caF) = famAnchors dir+                          p0        = paF a+                      in mconcat $ map (\x -> fn p0 (caF x)) xs   where-    fn p0 p1 = zapQuery (vertexPP [p0,p1]) >>= dcOpenPath+    fn p0 p1 = straightLine p0 p1+   

@@ -1,316 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Tree.TreeBuilder--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Monadic building - trees with references for indirect --- node-to-node connections and decoration--------------------------------------------------------------------------------------module Wumpus.Tree.TreeBuilder-  (-    AbsTreeSpec-  , TreeSpec-  , TbNode--  , ref -  , leaf-  , root-  , mkleaf-  , linkref    --  , drawTreeSpec--  ) where--import Wumpus.Tree.Base-import Wumpus.Tree.Design--import Wumpus.Drawing.Basis.TraceGraphic        -- package: wumpus-drawing--import Wumpus.Basic.Kernel                      -- package: wumpus-basic-import Wumpus.Basic.Utils.HList--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative-import qualified Data.IntMap as IM-import Data.Monoid-import Data.Tree---- TODO - are you sure this needs to build a Graphic rather than --- a LocGraphic?---data TbNode u a = RefNode Int (LocImage u a)-                | PlainNode (LocImage u a)--type instance DUnit (TbNode u a) = u----type RefTree u a = Tree (TbNode u a)--type CoordRefTree u a = Tree (Point2 u, TbNode u a)----type LinkDraw u node  = (node -> node -> Graphic u)----- | This allows special connectors or edge labels.----type LinkRef u node = (Int,Int, LinkDraw u node)---newtype TreeSpec node u a = TreeSpec { -          getTreeSpec :: Int -> (a, Int, H (LinkRef u node)) }--type instance MonUnit (TreeSpec node u a) = u---type AbsTreeSpec u node = TreeSpec node u (RefTree u node)----- Functor--instance Functor (TreeSpec node u) where-  fmap f ma = TreeSpec $ \s0 -> let (a,s1,w1) = getTreeSpec ma s0 -                                in (f a, s1, w1)----- Applicative--instance Applicative (TreeSpec node u) where-  pure a    = TreeSpec $ \s0  -> (a, s0, mempty)-  mf <*> ma = TreeSpec $ \s0 -> -                let (f,s1,w1) = getTreeSpec mf s0-                    (a,s2,w2) = getTreeSpec ma s1-                in (f a, s2, w1 `mappend` w2)----- Monad--instance Monad (TreeSpec node u) where-  return a = TreeSpec $ \s0 -> (a, s0, mempty)-  ma >>= k = TreeSpec $ \s0 -> let (a,s1,w1) = getTreeSpec ma s0-                                   (b,s2,w2) = (getTreeSpec . k) a s1-                               in (b,s2, w1 `mappend` w2)---runTreeSpec :: AbsTreeSpec u node -> (RefTree u node, [LinkRef u node])-runTreeSpec ma = let (a,_,w1) = getTreeSpec ma 0 -                 in (a, toListH w1)---ref :: LocImage u node -> TreeSpec node u (TbNode u node)-ref img = TreeSpec $ \s0 -> (RefNode s0 img, s0+1, mempty)--leaf :: TbNode u node -> RefTree u node -leaf nod = Node nod []--root :: TbNode u node -> [RefTree u node ] -> RefTree u node -root n1 xs = Node n1 xs--mkleaf :: LocImage u node -> RefTree u node-mkleaf img = Node (PlainNode img) []---linkref :: TbNode u node -> TbNode u node -> LinkDraw u node -> TreeSpec node u ()-linkref (RefNode ix _) (RefNode jx _) fn = TreeSpec $ \s0 -> -   ((), s0, wrapH $ (ix,jx, fn))--linkref _              _              _  = TreeSpec $ \s0 -> ((), s0, mempty)-------------------------------------------------------------------- ------- | Map for indexed objects that support taking anchors.----type ObjectMap node = IM.IntMap node----drawTreeSpec :: ( Real u, Floating u, InterpretUnit u-                , DrawingCtxM m, TraceM m, u ~ MonUnit (m ())-                )-             => TreeProps u node -> Point2 u -             -> AbsTreeSpec u node-             -> m ()-drawTreeSpec props rootpt ma = -    let (rtree,links) = runTreeSpec ma-    in  makeCoordRefTree props rootpt rtree >>= \ctree -> -        askDC >>= \ctx ->-        let prim = rawBuildPrim ctx props ctree links-        in trace prim --makeCoordRefTree :: ( Real u, Floating u, InterpretUnit u-                    , DrawingCtxM m, u ~ MonUnit (m ())-                    )-                 => TreeProps u a -> Point2 u -> RefTree u a -                 -> m (CoordRefTree u a)-makeCoordRefTree props (P2 x y) tree = -    scaleTree sx sy (design tree) >>= \ans -> return $ moveTree $ orient ans-  where-    orient   = orientateTree (tp_direction props)-    moveTree = fmap (bimapL (displace $ V2 x y))-    sx       = tp_sibling_distance props-    sy       = tp_level_distance props----- Whoa - have to be very careful about producing something that --- is consistent with the DrawingContext.--- --- If we fork the DrawingContext we don\'t want to produce a --- Graphic as a Graphic should be able to be (re-)drawn various --- times in updated Contexts and reflect the changes each time.------ Need a custom draw function... ----rawBuildPrim :: InterpretUnit u -             => DrawingContext -> TreeProps u node -             -> CoordRefTree u node-             -> [LinkRef u node]-             -> HPrim u-rawBuildPrim ctx props tree links = -    let (_,w1,o) = runBuilder ctx props (node1 tree) -        w2       = foldr (fn o) mempty links-    in w1 `mappend` w2-  where-    fn imap (i,j,drawF) acc = case (IM.lookup i imap, IM.lookup j imap) of-        (Just a, Just b) -> let (PrimW o _) = runImage ctx (drawF a b)-                            in singleH o `mappend` acc-        _                -> acc---node1 :: InterpretUnit u-      => CoordRefTree u node -> Builder node u node-node1 (Node (pt, RefNode ix gf) kids) = -    let img = applyLoc gf pt-    in do { a <- tellImage img-          ; addNodeRef ix a-          ; as <- mapM node1 kids-          ; conn <- currentConnector-          ; tellImage_ (conn a as)-          ; return a-          }--node1 (Node (pt, PlainNode gf) kids) = -    let img = applyLoc gf pt-    in do { a <- tellImage img-          ; as <- mapM node1 kids-          ; conn <- currentConnector-          ; tellImage_ (conn a as)-          ; return a-          }-------------------------------------------------------------------------------------- Here a dependency on MTL would be useful...--newtype MonBase node u a = MonBase { -    getMonBase :: TreeProps u node -> ObjectMap node -> (a, ObjectMap node) }--newtype Builder node u a = Builder { -    getBuilder :: TraceGraphicT u (MonBase node u) a } --type instance MonUnit (MonBase node u a) = u-type instance MonUnit (Builder node u a) = u----- Functor--instance Functor (MonBase node u) where-  fmap f ma = MonBase $ \env s0 -> let (a,s1) = getMonBase ma env s0 -                                   in (f a, s1)--instance Functor (Builder node u) where-  fmap f = Builder . fmap f . getBuilder ----- Applicative--instance Applicative (MonBase node u) where-  pure a    = MonBase $ \_   s0  -> (a, s0)-  mf <*> ma = MonBase $ \env s0 -> -                let (f,s1) = getMonBase mf env s0-                    (a,s2) = getMonBase ma env s1-                in (f a, s2)--instance Applicative (Builder node u) where-  pure a    = Builder $ pure a-  mf <*> ma = Builder $ getBuilder mf <*> getBuilder ma ----- Monad--instance Monad (MonBase node u) where-  return a = MonBase $ \_   s0 -> (a, s0)-  ma >>= k = MonBase $ \env s0 -> let (a,s1) = getMonBase ma env s0-                                   in (getMonBase . k) a env s1---instance Monad (Builder node u) where-  return a = Builder $ return a-  ma >>= f = Builder $ getBuilder ma >>= getBuilder . f----- TraceGraphicM--instance TraceGraphicM (Builder node u) where-  tellImage img = Builder $ tellImage img----- DrawingCtxM--instance DrawingCtxM (Builder node u) where-  askDC           = Builder $ askDC-  asksDC f        = Builder $ asksDC f-  localize upd ma = Builder $ localize upd (getBuilder ma)----liftBSt :: MonBase node u a -> Builder node u a-liftBSt ma = Builder $ liftTraceGraphicT ma--addNodeRef :: Int -> node -> Builder node u ()-addNodeRef i a = liftBSt inside-  where-    inside = MonBase $ \_ s0 -> ((), IM.insert i a s0)---currentConnector :: InterpretUnit u -                 => Builder node u (node -> [node] -> Graphic u)-currentConnector = liftBSt inside >>= getTreeConnector-  where-    inside = MonBase $ \env s0 -> (env,s0)---runMonBase :: TreeProps u node -> MonBase node u a -> (a, ObjectMap node)-runMonBase props ma = getMonBase ma props mempty---runBuilder :: DrawingContext -           -> TreeProps u node -           -> (Builder node u a) -           -> (a, HPrim u, ObjectMap node)-runBuilder ctx props ma = -    let ((a,wp),s) = runMonBase props (runTraceGraphicT ctx (getBuilder ma)) in (a,wp,s)-

@@ -22,7 +22,7 @@  -- | Version number ----- > (0,16,0)+-- > (0,17,0) -- wumpus_tree_version :: (Int,Int,Int)-wumpus_tree_version = (0,16,0)+wumpus_tree_version = (0,17,0)

@@ -1,5 +1,5 @@ name:             wumpus-tree-version:          0.16.0+version:          0.17.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -32,6 +32,11 @@   .   Changelog:   .+  v0.16.0 to v0.17.0:+  .+  * Reworked internals to use the @LocDrawing@ monad from +    Wumpus-Basic.+  .   v0.15.0 to v0.16.0:   .   * Re-worked so tree drawings form a @LocGraphic@ rather than a @@ -58,8 +63,8 @@                       containers        >= 0.3.0     && <= 0.6.0,                       vector-space      >= 0.6       && <  1.0,                       wumpus-core       >= 0.51.0    && <  0.52.0,-                      wumpus-basic      == 0.18.0,-                      wumpus-drawing    == 0.4.0+                      wumpus-basic      == 0.21.0,+                      wumpus-drawing    == 0.6.0       exposed-modules:@@ -68,7 +73,6 @@     Wumpus.Tree.Design,     Wumpus.Tree.DrawLoc,     Wumpus.Tree.OTMConnectors,-    Wumpus.Tree.TreeBuilder,     Wumpus.Tree.VersionNumber    other-modules: