let rearrange_treeFuse tree gr edge_id cycle=
match gr with
Right a -> (tree,[])
| Left graph ->
let edge = findedge edge_id tree
in
match edge.edgeway with
Normal -> let (c,t,p) = edge.edge
in let _ = report2 "Fuse normal"
in let target_gnode = DG.findnode t graph
in let target_node = findnode t tree
in let tr = {tree with treeNodes=IdtMap.add t {target_node with node = target_gnode} (IdtMap.remove t tree.treeNodes);
treeEdges = IdtMap.remove c.nameforudg tree.treeEdges}
in let upper_tree_inp = edgefilter tree (fun _ x -> let (_,tt,_) = x.edge in tt=c.sourceid)
in let lower_node_inp = (DG.nodefoldedges (fun y a -> y::a) target_gnode [])
in let rec add_inp so_inputs tr1=
match so_inputs with
(ci,ti,pi)::tail -> let source = ci.sourceid
in let tree_edge =
List.hd (List.filter (fun x -> let (cc,_,_) =x.edge in cc.sourceid == source) upper_tree_inp)
in let (cn,tn,pn) =
List.hd (List.filter (fun (cc,_,_) -> cc.sourceid ==source) lower_node_inp)
in let new_edges =
IdtMap.add cn.nameforudg {edge=(cn,t,pn); edgeway = tree_edge.edgeway; used=true} tr1.treeEdges
in let new_nodes = if tree_edge.edgeway == Normal
then let tn = findnode cn.sourceid tr1
in IdtMap.add (cn.sourceid) {tn with children = t::tn.children} (IdtMap.remove cn.sourceid tr1.treeNodes)
else tr1.treeNodes
in let new_tree = {tr1 with treeEdges = new_edges; treeNodes = new_nodes}
in add_inp tail new_tree
| _ -> tr1
in let upper_inp = (DG.nodefoldedges (fun y a -> y::a) (DG.findnode c.sourceid graph) [])
in let new_cycle = List.filter (fun x -> x != c.sourceid) cycle
in let tree2 = add_inp upper_inp tr
in let lower_tree_out = edgefilter tree2 (fun _ x -> let (cx,tx,px) = x.edge in cx.sourceid == t)
in let rec lower_outputs cyc tre =
match cyc with
(cx,tx,px)::tail -> let tr_e = List.hd (List.filter (fun x -> let (_,tt,_) = x.edge in tt = tx.id) lower_tree_out)
in let (cc,tm,_) = tr_e.edge
in let t_n = findnode tm tre
in let edges =
IdtMap.add cx.nameforudg {edge = (cx,tx.id,px); edgeway = tr_e.edgeway; used = true} (IdtMap.remove cc.nameforudg tre.treeEdges)
in let nodes =
IdtMap.add tx.id {node = tx; number=t_n.number; allDone = true; children = t_n.children} (IdtMap.remove tx.id tre.treeNodes)
in lower_outputs tail {tre with treeNodes = nodes; treeEdges = edges}
| _ -> tre
in let tree3 = lower_outputs (DG.nodefoldoutedges graph (fun y a -> y::a) target_gnode []) tree2
in (tree3, new_cycle)
| Backward -> let (c,t,p) = edge.edge
in let _ = report2 "Fuse back"
in let target_gnode = DG.findnode t graph
in let target_node = findnode t tree
in let tr = {tree with treeNodes=IdtMap.add t {target_node with node = target_gnode } (IdtMap.remove t tree.treeNodes);
treeEdges = IdtMap.remove c.nameforudg tree.treeEdges}
in let lower_node_inp = (DG.nodefoldedges (fun y a -> y::a) target_gnode [])
in let upper_inp = (DG.nodefoldedges (fun y a -> y::a) (DG.findnode c.sourceid graph) [])
in let upper_tree_inp = edgefilter tree (fun _ x -> let (_,tt,_) = x.edge in tt=c.sourceid)
in let lower_out = DG.nodefoldoutedges graph (fun y a -> y::a) target_gnode []
in let lower_tree_out = edgefilter tree (fun _ x -> let (cx,_,_)=x.edge in cx.sourceid == t)
in let rec add_lower_out cyc tre =
match cyc with
(cx,tx,px)::tail -> let tr_e = List.hd (List.filter (fun x -> let (_,tt,_) = x.edge in tt = tx.id) lower_tree_out)
in let (cc,_,_) = tr_e.edge
in if hasnode tx.id tree
then
let t_n = findnode tx.id tre
in let edges =IdtMap.add cx.nameforudg {edge = (cx,tx.id,px); edgeway = tr_e.edgeway; used = true} (IdtMap.remove cc.nameforudg tre.treeEdges)
in let nodes = IdtMap.add tx.id {node = tx; number=t_n.number; allDone = true; children = t_n.children} (IdtMap.remove tx.id tre.treeNodes)
in add_lower_out tail {tre with treeNodes = nodes; treeEdges = edges}
else add_lower_out tail tre
| _ -> tre
in let tree2 = add_lower_out lower_out tr
in let rec add_inp so_inputs tr1 remove=
match so_inputs with
(ci,_,_)::tail -> let source = ci.sourceid
in let tree_edge =
List.hd (List.filter (fun x -> let (cc,_,_) =x.edge in cc.sourceid == source) upper_tree_inp)
in let (cn,tn,pn) =
List.hd (List.filter (fun (cc,_,_) -> cc.sourceid ==source) lower_node_inp)
in let new_way =
match tree_edge.edgeway with
Normal -> Backward
| Forward -> if is_child source t tree then Backward else Forward
| Cross -> if is_child source t tree then Backward else Cross
in let new_edges =
IdtMap.add cn.nameforudg {edge=(cn,t,pn); edgeway = new_way; used=true} tr1.treeEdges
in let new_tree = {tr1 with treeEdges = new_edges}
in let rem = if new_way == Backward
then cn.nameforudg::remove
else remove
in add_inp tail new_tree rem
| _ -> let rec remove_easy edges tr2 =
match edges with
x::tail -> let gr = GrbTrCutStrictCycle.Tr.umake (graph_from_tree tr2) (Right x)
in let (new_tr,_) = rearrange_treeCut tr2 gr x []
in remove_easy tail new_tr
| _ -> tr2
in remove_easy remove tr1
in let tree3 = add_inp upper_inp tree2 []
in (new_tree tree3,[])