module Wumpus.Tree.TreeBuildMonad
(
NodeId
, ZNodeId
, NodeAnno
, NodeAnnoRefs
, TreeBuild
, TreeSpec
, ZTreeSpec
, TreeNodeAns
, TreeBuildAns
, runTreeBuild
, regularBuild
, nodeId
, label
, branch
, zbranch
, leaf
, zleaf
) where
import Wumpus.Tree.Base
import Wumpus.Basic.Kernel
import Wumpus.Drawing.Dots.AnchorDots
import Control.Applicative
import qualified Data.IntMap as IntMap
import Data.Monoid
import Data.Tree
data NodeId a = NodeId Int
| RegularNode a
deriving (Eq)
type ZNodeId u = NodeId (UNil u)
type NodeDrawRefs u = IntMap.IntMap (TreeNode u)
type NodeAnno u = DotAnchor u -> Graphic u
type NodeAnnoRefs u = IntMap.IntMap (NodeAnno u)
data St u = St
{ uid_counter :: Int
, node_refs :: NodeDrawRefs u
, anno_refs :: NodeAnnoRefs u
}
zeroSt :: St u
zeroSt = St { uid_counter = 0, node_refs = mempty, anno_refs = mempty }
newtype TreeBuild u a = TreeBuild { getTreeBuild :: St u -> (a, St u) }
instance Functor (TreeBuild u) where
fmap f ma = TreeBuild $ \s -> let (a,s1) = getTreeBuild ma s in (f a, s1)
instance Applicative (TreeBuild u) where
pure a = TreeBuild $ \s -> (a,s)
mf <*> ma = TreeBuild $ \s -> let (f,s1) = getTreeBuild mf s
(a,s2) = getTreeBuild ma s1
in (f a,s2)
instance Monad (TreeBuild u) where
return a = TreeBuild $ \s -> (a,s)
ma >>= k = TreeBuild $ \s -> let (a,s1) = getTreeBuild ma s
in getTreeBuild (k a) s1
type TreeSpec a = Tree (NodeId a)
type ZTreeSpec u = TreeSpec (UNil u)
type TreeNodeAns u = (TreeNode u, Maybe Int)
type TreeBuildAns u = (Tree (TreeNodeAns u), NodeAnnoRefs u)
runTreeBuild :: (Real u, Floating u, InterpretUnit u)
=> (a -> TreeNode u) -> TreeBuild u (TreeSpec a) -> TreeBuildAns u
runTreeBuild regDrawF ma =
let (a,s) = getTreeBuild ma zeroSt
t1 = postRun regDrawF (a, node_refs s)
in (t1, anno_refs s)
postRun :: (Real u, Floating u, InterpretUnit u)
=> (a -> TreeNode u) -> (TreeSpec a,NodeDrawRefs u)
-> Tree (TreeNode u, Maybe Int)
postRun regDrawF (tree1,table) = fmap changeNode tree1
where
changeNode (RegularNode a) = (regDrawF a, Nothing)
changeNode (NodeId ix) = maybe fk (sk ix) $ IntMap.lookup ix table
sk ix = \a -> (a, Just ix)
fk = (dotText "Error missing node", Nothing)
regularBuild :: Tree a -> TreeBuild u (TreeSpec a)
regularBuild (Node a kids) =
Node (RegularNode a) <$> mapM regularBuild kids
nodeId :: TreeNode u -> TreeBuild u (NodeId a)
nodeId drawF =
TreeBuild $ \(St ix nodes annos) ->
let nodes' = IntMap.insert ix drawF nodes
in (NodeId ix, St (ix+1) nodes' annos)
label :: a -> NodeId a
label a = RegularNode a
branch :: NodeId a -> [TreeSpec a] -> TreeSpec a
branch uid kids = Node uid kids
zbranch :: [ZTreeSpec u] -> ZTreeSpec u
zbranch kids = Node (RegularNode UNil) kids
leaf :: NodeId a -> TreeSpec a
leaf uid = Node uid []
zleaf :: ZTreeSpec u
zleaf = Node (RegularNode UNil) []