TreeGraph.hs

module Data.Sifflet.TreeGraph 
    (LayoutGraph, 
     flayoutToGraph, treeLayoutToGraph,
     -- treeToGraph, 
     orderedTreeToGraph, 
     treeGraphNodesTree, graphToTreeOriginal,
     graphToTreeStructure, 
     flayoutToGraphRoots,
     graphToOrderedTree, graphToOrderedTreeFrom,
     orderedChildren, adjCompareEdge,
     nextNodes, -- exported for testing; any other reason?
     grTranslateNode, grTranslateSubtree, grTranslateGraph,

     -- moved from Workspace.hs:
     functoidToFunction, graphToExprTree,

    )

where

import Data.List (sort, sortBy)

import Data.Graph.Inductive as G

import Data.Sifflet.Functoid
import Data.Sifflet.Geometry
import Data.Sifflet.Tree as T
import Data.Sifflet.TreeLayout
import Data.Sifflet.WGraph

import Language.Sifflet.Expr
import Language.Sifflet.ExprTree
import Language.Sifflet.TypeCheck

import Language.Sifflet.Util

type LayoutGraph n e = Gr (LayoutNode n) e

flayoutToGraph :: FunctoidLayout -> WGraph
flayoutToGraph tlo = 
    case tlo of 
      FLayoutTree t -> treeLayoutToGraph t
      FLayoutForest ts _bbox -> 
          foldl grAddGraph wgraphNew (map treeLayoutToGraph ts)

treeLayoutToGraph :: TreeLayout ExprNode -> WGraph
treeLayoutToGraph = orderedTreeToGraph . fmap WSimple


-- flayoutToGraphRoots returns a list of graph nodes (Ints)
-- corresponding to the root of the tree, or the roots of
-- the trees in the forest.
-- The list is ordered in the same sense as the graph nodes.

flayoutToGraphRoots :: FunctoidLayout -> [G.Node]
flayoutToGraphRoots (FLayoutTree _t) = [1]
flayoutToGraphRoots (FLayoutForest trees _bbox) =
    let loop _ [] res = reverse res
        loop next (t:ts) res =
            loop (next + treeSize t) ts (next:res)
    in loop 1 trees []


-- {-# DEPRECATED treeToGraph "use ??? instead" #-}

-- treeToGraph :: Tree e -> Gr e ()
-- treeToGraph (T.Node root subtrees)  = 
--     -- Convert an ordered tree to a graph.
--     -- The graph edge labels from parent to child 
--     -- are integers corresponding to the order of the children.
--     -- So, to recover the ordered list of children, 
--     -- sort by the edge label.
--     let g0 = empty :: Gr e ()
--         g1 = insNode (1, root) g0

--         grow :: Gr e () -> [(Tree e, G.Node)] -> G.Node -> Gr e ()
--         -- grow graph [(tree, parent)] node
--         grow g [] _ = g
--         grow g ((t, p):tps) n =
--             -- insert t forming g', insert ts into g'
--             let edge = ((), p) -- predecessors, or both?
--                 g' = ([edge], n, (rootLabel t), []) & g -- assume pred only
--             in grow g' (tps ++ [(s, n) | s <- subForest t])
--                        (succ n)

--     in grow g1 [(s, 1) | s <- subtrees] 2

sprout :: G.Node -> Tree e -> [(G.Node, WEdge, Tree e)]
sprout parent (T.Node _ subtrees) =
    -- create triples (parent graph node, edge, subtree)
    let m = length subtrees - 1
    in [(parent, WEdge e, s) | (e, s) <- zip [0..m] subtrees]


orderedTreeToGraph :: Tree e -> Gr e WEdge
orderedTreeToGraph otree  = 
    -- Convert an ordered tree to a graph.
    -- The graph edge labels from parent to child 
    -- are integers corresponding to the order of the children.
    -- So, to recover the ordered list of children, 
    -- sort by the edge label.
    let g0 = empty :: Gr e WEdge
        g1 = insNode (1, rootLabel otree) g0

        grow :: Gr e WEdge -> [(G.Node, WEdge, Tree e)] -> G.Node -> Gr e WEdge
        -- grow graph [(parent, edgeLabel, subtree), ...] node
        grow g [] _ = g
        grow g ((p, e, t):pets) n =
            -- insert pet forming g', insert pets into g';
            -- n is the node id for the root of this subtree
            let adj = (e, p) -- to parent (priority, node)
                g' = ([adj], n, (rootLabel t), []) & g 
                n' = succ n
            in grow g' (pets ++ 
                        sprout n t
                        -- [(s, n) | s <- subForest t])
                        )
                       n'

    in grow g1 (sprout 1 otree) 2

-- And what about this (e, Node) type?  Is it some sort of monad?

treeGraphNodesTree :: Tree e -> Tree Node
treeGraphNodesTree atree =
    -- returns a tree of Nodes of the Graph (treeToGraph atree)
    let gnTree :: Tree e -> Node -> Node -> (Tree Node, Node)
        gnTree (T.Node _root subtrees) rootNode next =
            -- rootNode = Node (number) for the root,
            -- next = next unused Node
            let (nNodes, next') = nextNodes subtrees next
                (subtrees', next'') = gnSubtrees subtrees nNodes next'
            in (T.Node rootNode subtrees', next'')

        gnSubtrees :: [Tree e] -> [Node] -> Node -> ([Tree Node], Node)
        gnSubtrees [] [] next = ([], next)
        gnSubtrees (t:ts) (n:ns) next = 
            let (t', next') = gnTree t n next
                (ts', next'') = gnSubtrees ts ns next'
            in ((t' : ts'), next'')
        gnSubtrees _ _ _ = error "gnSubtrees: list lengths do not match"

    in fst (gnTree atree 1 2)

nextNodes :: [e] -> Node -> ([Node], Node)
nextNodes items next = 
  -- next is the next unused Node (number).
  -- Returns list of new nodes, and a new "next" node
  -- E.g., nextNodes [a, b] 3 = ([3, 4], 5)
  --       nextNodes [c, d, e] 5 = ([5, 6, 7], 8)
  --       nextNodes [] 8 = ([], 8)
  let n = length items
      next' = next + n
  in ([next .. (next' - 1)], next')

-- When a tree is converted to a graph,
-- each tree node's ordered children get graph node numbers
-- in ascending order.  Therefore, when reconstructing the tree,
-- sorting the graph nodes restores the order of the children
-- as in the tree.

graphToOrderedTree :: Gr e WEdge -> Tree e
-- inverse of orderedTreeToGraph
graphToOrderedTree g = graphToOrderedTreeFrom g 1

graphToOrderedTreeFrom :: Gr e WEdge -> G.Node -> Tree e
graphToOrderedTreeFrom g n =
    case lab g n of
      Just label -> 
          T.Node label (map (graphToOrderedTreeFrom g) (orderedChildren g n))
      Nothing -> 
          errcats ["missing label for node", show n]

-- | List of the nodes children, ordered by edge number
orderedChildren :: Gr e WEdge -> G.Node -> [G.Node]
orderedChildren g = map fst . sortBy adjCompareEdge . lsuc g

adjCompareEdge :: (Node, WEdge) -> (Node, WEdge) -> Ordering
adjCompareEdge (_n1, e1) (_n2, e2) = compare e1 e2

{-# DEPRECATED graphToTreeOriginal "use ??? instead" #-}

graphToTreeOriginal :: Gr e () -> G.Node -> Tree e
-- (\g -> graphToTreeOriginal g 1) is the inverse of treeToGraph
graphToTreeOriginal g n =
    case lab g n of
      Just label -> T.Node label (map (graphToTreeOriginal g) 
                                      (sort (suc g n)))
      _ -> errcats ["missing label for node", show n]

{-# DEPRECATED graphToTreeStructure "use ??? instead" #-}

graphToTreeStructure :: Gr n e -> G.Node -> Tree G.Node
-- This is *not* an inverse of treeToGraph.
-- Rather, graphToTreeStructure (treeToGraph t 1) is a tree t' of Nodes
-- (i.e., integer identifiers of nodes in the graph)
-- which parallels the structure of t.

graphToTreeStructure g n = T.Node n (map (graphToTreeStructure g)
                                         (sort (suc g n)))

grTranslateNode :: 
  Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e
grTranslateNode node dx dy graph = 
    grUpdateNodeLabel graph node (translate dx dy)

grTranslateSubtree :: 
  Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e
grTranslateSubtree root dx dy graph = 
    let trSubtrees :: [Node] -> LayoutGraph n e -> LayoutGraph n e
        trSubtrees [] g = g
        trSubtrees (r:rs) g = trSubtrees (rs ++ suc g r)
                              (grTranslateNode r dx dy g)
    in trSubtrees [root] graph

grTranslateGraph :: Double -> Double -> LayoutGraph n e -> LayoutGraph n e
grTranslateGraph dx dy graph = nmap (translate dx dy) graph

grUpdateNodeLabel :: (DynGraph g) => g a b -> Node -> (a -> a) -> g a b
grUpdateNodeLabel graph node updater =
  case match node graph of
    (Nothing, _) -> error "no such node"
    (Just (preds, jnode, label, succs), graph') ->
        -- jnode == node
        (preds, jnode, updater label, succs) & graph'

functoidToFunction :: 
    Functoid -> WGraph -> G.Node -> Env -> SuccFail Function
functoidToFunction functoid graph frameNode env =
    case functoid of
      FunctoidFunc f -> Succ f
      FunctoidParts {fpName = name, fpArgs = args} ->
          case suc graph frameNode of
            [root] ->
                do
                  {
                    expr <- treeToExpr $ graphToExprTree graph root
                  ; let impl = Compound args expr
                  ; (atypes, rtype) <- decideTypes name expr args env
                  ; Succ (Function (Just name) atypes rtype impl)
                  }
            _ -> Fail "The graph structure is not a tree!"

graphToExprTree :: WGraph -> G.Node -> Tree ExprNode
graphToExprTree g root =
    let extractExprNode wnode =
            case wnode of
              WSimple layoutNode -> gnodeValue (nodeGNode layoutNode)
              WFrame _ -> error "graphToExprTreeFrom: unexpected WFrame node"
    in fmap extractExprNode (graphToOrderedTreeFrom g root)