let rearrange_treeMUX tree gr edge_id cycle=
match gr with
Right a -> (tree,[])
| Left graph ->
let edge = (findedge edge_id tree)
in let (c,t,p) = edge.edge
in
match edge.edgeway with
Normal -> let mux_inp = (DG.nodefoldedges (fun y a -> y::a) (DG.findnode c.sourceid graph) [])
in let _ = report2 "Mux normal"
in let old_mux = DG.findnode c.sourceid graph
in let old_mux_t = findnode c.sourceid tree
in let op_tnode = findnode t tree
in let tree1 = {tree with
treeNodes =IdtMap.add c.sourceid {node = old_mux; number = old_mux_t.number; allDone = true; children = old_mux_t.children}
(IdtMap.remove c.sourceid tree.treeNodes)}
in let op_inp = edgefilter tree (fun _ x -> let (_,ta,_) = x.edge in t == ta)
in let op_out = edgefilter tree (fun _ x -> let (ca,_,_) = x.edge in ca.sourceid == t)
in let mux_normal_in = edgefilter tree (fun y x ->let (_,ti,_) = x.edge in x.edgeway == Normal && ti == c.sourceid)
in let rec remove_op_inp inp tr1 =
match inp with
x::tail -> let (co,_,_) = x.edge
in remove_op_inp tail {tr1 with treeEdges = IdtMap.remove co.nameforudg tr1.treeEdges}
| _ -> tr1
in let tr = remove_op_inp op_inp {tree1 with treeNodes = IdtMap.remove t tree1.treeNodes}
in let add_normal tr1 =
let (cm,tm,pm) = (List.hd mux_normal_in).edge
in let in_outputs = DG.nodefoldoutedges graph (fun y a -> y::a) (DG.findnode cm.sourceid graph) []
in let in_toutputs = edgefilter tree (fun _ x -> let (ca,_,_) = x.edge in cm.sourceid == ca.sourceid)
in let in_id_outputs = List.map (fun (ca,_,_) -> ca.nameforudg) in_outputs
in let in_id_toutputs = List.map (fun x -> let (ca,_,_) = x.edge in ca.nameforudg) in_toutputs
in let new_out =
let rec no g_in =
match g_in with
x::tail -> if not (List.mem x in_id_toutputs) then x else no tail
| _ -> NewName.invalid_id
in no in_id_outputs
in let (cn,op_node,pn) = DG.findedge new_out graph
in let (cou,new_mux,pou) = List.hd (DG.nodefoldoutedges graph (fun y a -> y::a) op_node [])
in let new_mux_inp = DG.nodefoldedges (fun y a -> y::a) new_mux []
in let new_mux_out = DG.nodefoldoutedges graph (fun y a -> y::a) new_mux []
in let t_op_mux = {tr1 with
treeNodes = IdtMap.add new_mux.id {node = new_mux; number = op_tnode.number; allDone = true; children = op_tnode.children}
(IdtMap.add op_node.id {node = op_node; number = op_tnode.number; allDone = true; children = [new_mux.id]} tr1.treeNodes)
}
in let rec mux_out out_list tr2 =
match out_list with
x::tail -> let (cx,tx,px) = x.edge
in let (ccx,ttx,ppx) = List.hd (List.filter (fun (_,xx,_) -> xx.id ==tx) new_mux_out)
in let tno_out = findnode ttx.id tr2
in let nodes = IdtMap.add ttx.id {tno_out with node = ttx} (IdtMap.remove ttx.id tr2.treeNodes)
in mux_out tail {tr2 with
treeNodes = nodes;
treeEdges = IdtMap.add ccx.nameforudg {edge= (ccx,ttx.id,ppx); edgeway = x.edgeway; used = true} (IdtMap.remove cx.nameforudg tr2.treeEdges)}
| _ -> tr2
in let t_mux_out = mux_out op_out t_op_mux
in let rec mux_in in_list tr2=
match in_list with
(cx,tx,px)::tail -> if cx.sourceid = op_node.id
then let tr22 = {tr2 with
treeEdges = IdtMap.add cx.nameforudg {edge = (cx,tx.id,px); edgeway = Normal; used = true} tr2.treeEdges}
in mux_in tail tr22
else mux_in tail {tr2 with
treeNodes =IdtMap.add cx.sourceid {node = DG.findnode cx.sourceid graph; number = NodeNumber.get (); allDone = true; children = [new_mux.id]} tr2.treeNodes;
treeEdges = IdtMap.add cx.nameforudg {edge = (cx,tx.id,px); edgeway = Cross; used = true} tr2.treeEdges}
| _ -> tr2
in let t_mux_in = mux_in new_mux_inp t_mux_out
in let op_inp_graph = DG.nodefoldedges (fun y a -> y::a) op_node []
in let rec op_in in_list tr2 =
match in_list with
x::tail -> let (cx,tx,px) = x.edge
in let l = List.filter (fun (cc,_,_) -> cc.sourceid == cx.sourceid) op_inp_graph
in let (gc,gt,gp) = List.hd l
in let sourcenode = findnode cx.sourceid tr2
in let nodes = if x.edgeway == Normal
then IdtMap.add cx.sourceid {sourcenode with children =tx::sourcenode.children} (IdtMap.remove cx.sourceid tr2.treeNodes)
else IdtMap.add cx.sourceid {sourcenode with children = List.concat [sourcenode.children;[tx]]} (IdtMap.remove cx.sourceid tr2.treeNodes)
in op_in tail {tr2 with treeEdges = IdtMap.add gc.nameforudg {edge=(gc,gt.id,gp); edgeway = x.edgeway; used = true} tr2.treeEdges; treeNodes = nodes}
| _ -> tr2
in let sss = findnode cn.sourceid t_mux_in
in let ttt = {t_mux_in with
treeEdges = IdtMap.add cn.nameforudg {edge = (cn,op_node.id,pn); edgeway = Normal; used = true} t_mux_in.treeEdges;
treeNodes = IdtMap.add cn.sourceid {sss with children = op_node.id::sss.children} (IdtMap.remove cn.sourceid t_mux_in.treeNodes)}
in let t_op_in = op_in (List.filter (fun x -> let (c1,_,_)=x.edge in c1.sourceid !=c.sourceid) op_inp) ttt
in let rec split cyc seen =
match cyc with
x::tail -> if x == c.sourceid
then (List.rev (List.tl seen),tail)
else split tail (x::seen)
| _ -> ([],List.rev seen)
in let (f,s) = split cycle []
in let cyc = List.concat [f;[new_mux.id;op_node.id];s]
in (t_op_in,cyc)
in let (normal_added,cyc) = add_normal tr
in let rec add_op_inp inp tr1 =
match inp with
(cm,tm,pm)::tail -> let mux_input_edge = findedge cm.nameforudg tr1
in if mux_input_edge.edgeway == Normal
then add_op_inp tail tr1
else
let in_outputs = DG.nodefoldoutedges graph (fun y a -> y::a) (DG.findnode cm.sourceid graph) []
in let in_toutputs = edgefilter tree (fun _ x -> let (ca,_,_) = x.edge in cm.sourceid == ca.sourceid)
in let in_id_outputs = List.map (fun (ca,_,_) -> ca.nameforudg) in_outputs
in let in_id_toutputs = List.map (fun x -> let (ca,_,_) = x.edge in ca.nameforudg) in_toutputs
in let new_out =
let rec no g_in =
match g_in with
x::tail -> if not (List.mem x in_id_toutputs) then x else no tail
| _ -> NewName.invalid_id
in no in_id_outputs
in let (cn,tn,pn) = DG.findedge new_out graph
in let op_inp_graph = DG.nodefoldedges (fun y a -> y::a) tn []
in
if mux_input_edge.edgeway == Forward
then
let rec op_in in_list tre =
match in_list with
x::ta -> let (cx,tx,px) = x.edge
in let (gc,gt,gp) = List.hd (List.filter (fun (cc,_,_) -> cc.sourceid == cx.sourceid) op_inp_graph)
in let sourcenode = findnode gc.sourceid tre
in let ttt = {tre with
treeNodes =IdtMap.add gc.sourceid {sourcenode with children = List.concat [sourcenode.children;[gt.id]]} (IdtMap.remove gc.sourceid tre.treeNodes);
treeEdges = IdtMap.add gc.nameforudg {edge=(gc,gt.id,gp); edgeway = x.edgeway; used = true} tre.treeEdges}
in op_in ta ttt
| _ -> tre
in let sourcenode2 = findnode cm.sourceid tr1
in let nodes =
IdtMap.add cm.sourceid {sourcenode2 with children = List.concat [sourcenode2.children;[tn.id]]} (IdtMap.remove cm.sourceid tr1.treeNodes)
in let ttt = {tr1 with treeNodes = nodes;
treeEdges = IdtMap.add cn.nameforudg {edge = (cn,tn.id,pn); edgeway = Normal; used = true} tr1.treeEdges}
in add_op_inp tail (op_in (List.filter (fun x -> let (c1,_,_)=x.edge in c1.sourceid !=c.sourceid) op_inp) ttt)
else
let forward_inp = List.filter (fun x -> x.edgeway == Forward) op_inp
in if (List.length forward_inp) ==0
then
let rec op_in in_list tre =
match in_list with
x::ta -> let (cx,tx,px) = x.edge
in let (gc,gt,gp) = List.hd (List.filter (fun (cc,_,_) -> cc.sourceid == cx.sourceid) op_inp_graph)
in let sourcenode = findnode gc.sourceid tre
in op_in ta {tre with
treeNodes =IdtMap.add gc.sourceid {sourcenode with children = List.concat [sourcenode.children;[gt.id]]} (IdtMap.remove gc.sourceid tre.treeNodes);
treeEdges = IdtMap.add gc.nameforudg {edge=(gc,gt.id,gp); edgeway = x.edgeway; used = true} tre.treeEdges}
| _ -> tre
in let sourcenode2 = findnode cm.sourceid tr1
in let nodes =IdtMap.add cm.sourceid {sourcenode2 with children = List.concat [sourcenode2.children;[tn.id]] } (IdtMap.remove cm.sourceid tr1.treeNodes)
in let tt = op_in (List.filter (fun x -> let (c1,_,_)=x.edge in c1.nameforudg !=c.nameforudg) op_inp) {tr1 with treeNodes = nodes; treeEdges = IdtMap.add cn.nameforudg {edge = (cn,tn.id,pn); edgeway = Normal; used = true} tr1.treeEdges}
in add_op_inp tail tt
else
let rec deepest_forward_input inp =
match inp with
x::ta -> let (cx,_,_)= x.edge
in if (List.for_all (fun a -> let (ca,_,_)=a.edge in ca.sourceid == cx.sourceid || is_child cx.sourceid ca.sourceid tree) forward_inp)
then x
else deepest_forward_input ta
| _ -> List.hd forward_inp
in let deepest = deepest_forward_input forward_inp
in let (hc,ht,hp) = deepest.edge
in let sourcenode2 = findnode cm.sourceid tr1
in let nodes =
IdtMap.add cm.sourceid {sourcenode2 with children = List.concat [sourcenode2.children;[tn.id]] } (IdtMap.remove cm.sourceid tr1.treeNodes)
in let add_cross =
{tr1 with treeNodes= nodes; treeEdges = IdtMap.add cn.nameforudg {edge = (cn,tn.id,pn);edgeway = Cross;used = true} tr1.treeEdges}
in let (gc,gt,gp) = List.hd (List.filter (fun (cc,_,_) -> cc.sourceid == hc.sourceid) op_inp_graph)
in let sourcenode3 = findnode gc.sourceid add_cross
in let nodes3 =
IdtMap.add gc.sourceid {sourcenode3 with children = List.concat [sourcenode3.children;[gt.id]] } (IdtMap.remove gc.sourceid add_cross.treeNodes)
in let add_normal2 =
{add_cross with treeNodes = nodes3; treeEdges =IdtMap.add gc.nameforudg {edge = (gc,gt.id,gp); edgeway = Normal; used = true} add_cross.treeEdges}
in let rec op_in in_list tre =
(match in_list with
x::ta -> let (cx,tx,px) = x.edge
in let (gcc,gtc,gpc) = List.hd (List.filter (fun (cc,_,_) -> cc.sourceid == cx.sourceid)
op_inp_graph)
in let sourcen = findnode gcc.sourceid tre
in let nodesn =
IdtMap.add gcc.sourceid {sourcen with children = List.concat [sourcen.children;[gtc.id]]} (IdtMap.remove gcc.sourceid tre.treeNodes)
in op_in ta {tre with treeNodes = nodesn; treeEdges = IdtMap.add gcc.nameforudg {edge=(gcc,gtc.id,gpc); edgeway = x.edgeway; used = true} tre.treeEdges}
| _ -> tre)
in add_op_inp tail (op_in (List.filter (fun x -> let (s,_,_)=x.edge in s.nameforudg != hc.nameforudg && s.sourceid != c.sourceid) op_inp) add_normal2)
| _ -> tr1
in let end_tree = add_op_inp mux_inp normal_added
in (rearrange end_tree (List.hd (List.rev cyc)) cyc, cyc)
| Backward -> let mux_inp = (DG.nodefoldedges (fun y a -> y::a) (DG.findnode c.sourceid graph) [])
in let _ = report2 "MUX backward"
in let mux_inputs_below_op = mux_inp
in let rec remove_edges inputs (gr1,remained_edges,newmux) =
match inputs with
(cm,tm,pm)::tail -> let in_outputs =
DG.nodefoldoutedges graph (fun y a -> y::a) (DG.findnode cm.sourceid graph) []
in let in_toutputs =
edgefilter tree (fun _ x -> let (ca,_,_) = x.edge in cm.sourceid == ca.sourceid)
in let in_id_outputs =
List.map (fun (ca,_,_) -> ca.nameforudg) in_outputs
in let in_id_toutputs =
List.map (fun x -> let (ca,_,_) = x.edge in ca.nameforudg) in_toutputs
in let new_out =
let rec no g_in =
match g_in with
x::tail -> if not (List.mem x in_id_toutputs) then x else no tail
| _ -> NewName.invalid_id
in no in_id_outputs
in let (cn,new_op,pn) = DG.findedge new_out gr1
in let (co,nn_mux,_) = List.hd (DG.nodefoldoutedges gr1 (fun y a -> y::a) new_op [])
in let graa = GrbTrCutStrictCycle.Tr.umake gr1 (Right co.nameforudg)
in (match graa with
Right _ -> remove_edges tail (gr1,(co.nameforudg::remained_edges),nn_mux.id)
| Left g ->let _ = report2 "kustutasin serva" in remove_edges tail (g,remained_edges,nn_mux.id))
| _ -> (gr1,remained_edges,newmux)
in let target_node = findnode t tree
in let target_out = edgefilter tree (fun _ x -> let (cx,_,_) = x.edge in cx.sourceid == t)
in let target_normal_in = edgefilter tree (fun _ x -> let (_,tx,_) = x.edge in tx == t && x.edgeway == Normal)
in let (gra1,remained_edges,newmux) = remove_edges mux_inputs_below_op (graph,[],NewName.invalid_id)
in if (List.length remained_edges == 0) || (List.length target_normal_in == 0)
then
let new_mux = DG.findnode newmux gra1
in let _ = report2 "MUX back korrastab puud, uuel mux tipule ainult sisendid Error tippudest"
in let new_inp = DG.nodefoldedges (fun a y -> a::y) new_mux []
and mux_out = DG.nodefoldoutedges gra1 (fun a y -> a::y) new_mux []
and graph1 = graph_from_tree tree
in let target = DG.findnode t graph1
in let target_inp = DG.nodefoldedges (fun a y -> a::y) target []
and target_out = DG.nodefoldoutedges graph1 (fun a y -> a::y) target []
in let rec remove_tedges edgelist tr =
match edgelist with
(cx,_,_)::tail ->
remove_tedges tail {tr with treeEdges = IdtMap.remove cx.nameforudg tr.treeEdges}
| _ -> tr
in let tree1 = remove_tedges target_inp {tree with treeNodes = IdtMap.remove t tree.treeNodes}
in let tree2 = remove_tedges target_out tree1
in let tree3 = {tree2 with
treeNodes = IdtMap.add newmux {node = new_mux; allDone = true; children = []; number = NodeNumber.invalid_num} tree2.treeNodes}
in let rec add_mux_inp inplist tr =
match inplist with
(cx,tx,px)::tail -> let edges =
IdtMap.add cx.nameforudg {edge = (cx,tx.id,px); used = true; edgeway = Unknown} tr.treeEdges
in let error_node = DG.findnode cx.sourceid gra1
in let nodes =
IdtMap.add cx.sourceid {node = error_node; children = [newmux]; allDone = true; number = NodeNumber.invalid_num} tr.treeNodes
in add_mux_inp tail {tr with treeEdges = edges; treeNodes = nodes}
| _ -> tr
in let tree4 = add_mux_inp new_inp tree3
in let rec add_mux_out outlist tr =
match outlist with
(cx,tx,px)::tail -> let edges =
IdtMap.add cx.nameforudg {edge = (cx,tx.id,px); used = true; edgeway = Unknown} tr.treeEdges
in let nodes =
IdtMap.add tx.id {node = tx; children = [newmux]; allDone = true; number = NodeNumber.invalid_num} (IdtMap.remove tx.id tr.treeNodes)
in add_mux_out tail {tr with treeNodes = nodes; treeEdges = edges}
| _ -> tr
in let tree5 = add_mux_out mux_out tree4
in (new_tree tree5,[])
else
let (_,new_mux,_) = DG.findedge (List.hd remained_edges) gra1
in let _ = report2 "MUX back korrastab puud"
in let new_mux_out = DG.nodefoldoutedges gra1 (fun y a -> y::a) new_mux []
in let target_inp = edgefilter tree (fun _ x -> let (_,tx,_) = x.edge in tx == t)
in let rec removeAdd_out outlist tr =
match outlist with
x::tail -> let (cx,tx,px) = x.edge
in let t_gnode = DG.findnode tx gra1
in let t_node = findnode tx tr
in let t_changed =
{tr with
treeNodes = IdtMap.add tx {t_node with node = t_gnode} (IdtMap.remove tx tr.treeNodes)}
in let graph_edge = List.filter (fun (_,tt,_) -> tt.id ==tx) new_mux_out
in let (cg,_,_) = List.hd graph_edge
in let edges_changed =
{t_changed with
treeNodes = t_changed.treeNodes;
treeEdges =IdtMap.add cg.nameforudg {edge = (cg,tx,px); used = true; edgeway = x.edgeway} (IdtMap.remove cx.nameforudg t_changed.treeEdges)}
in removeAdd_out tail edges_changed
| _ -> tr
in let ttt =
{tree with
treeNodes = IdtMap.add new_mux.id {node=new_mux; number = target_node.number; allDone = true; children = target_node.children} (IdtMap.remove t tree.treeNodes);
treeEdges =IdtMap.remove c.nameforudg tree.treeEdges}
in let tree1 = removeAdd_out target_out ttt
in let rec remove_op_inp inplist tr =
match inplist with
x::tail -> let (cx,_,_) = x.edge
in remove_op_inp tail {tr with treeNodes = tr.treeNodes; treeEdges = IdtMap.remove cx.nameforudg tr.treeEdges}
| _ -> tr
in let tree2 = remove_op_inp target_inp tree1
in let rec addInp inplist tr =
match inplist with
x::tail -> let (cm,tm,pm) = DG.findedge x gra1
in let new_op = DG.findnode cm.sourceid gra1
in let added_op =
{tr with treeEdges = tr.treeEdges;
treeNodes = IdtMap.add new_op.id {target_node with node=new_op; children = [new_mux.id]} tr.treeNodes}
in let added_op_mux =
match tail with
y::m -> {added_op with
treeNodes=added_op.treeNodes;
treeEdges =
IdtMap.add cm.nameforudg {edge = (cm,tm.id,pm); edgeway = Cross; used = true} added_op.treeEdges}
| _ ->{added_op with
treeNodes=added_op.treeNodes;
treeEdges =
IdtMap.add cm.nameforudg {edge = (cm,tm.id,pm); edgeway = Normal; used = true} added_op.treeEdges}
in let op_inp = DG.nodefoldedges (fun y a -> y::a) new_op []
in let rec add_old_inp op_inplist tr1 =
match op_inplist with
y::ta -> let (co,_,_) = y.edge
in let (cc,tt,pp) =
List.hd (List.filter (fun (cx,_,_) -> cx.sourceid == co.sourceid) op_inp)
in let sourcen = findnode cc.sourceid tr1
in let nodesn =
IdtMap.add cc.sourceid {sourcen with children = tt.id::sourcen.children} (IdtMap.remove cc.sourceid tr1.treeNodes)
in add_old_inp ta {tr1 with treeNodes = nodesn; treeEdges = IdtMap.add cc.nameforudg {y with edge = (cc,tt.id,pp)} (IdtMap.remove co.nameforudg tr1.treeEdges)}
| _ -> tr1
in let op_inp_added1 =
add_old_inp (List.filter (fun x -> let (cx,_,_) = x.edge in cx.nameforudg !=c.nameforudg ) target_inp) added_op_mux
in let op_inp_added =
add_old_inp (List.filter (fun x -> let (cx,_,_) = x.edge in cx.nameforudg !=c.nameforudg && x.edgeway == Normal) target_inp) op_inp_added1
in let op_new_inp =
List.filter (fun (cx,_,_) -> not (hasedge cx.nameforudg op_inp_added)) op_inp
in let new_tree = if List.length op_new_inp == 0
then op_inp_added
else let (cc1,_,pp1) = List.hd op_new_inp
in let sourcen = findnode cc1.sourceid op_inp_added
in let nodesn =
IdtMap.add cc1.sourceid {sourcen with children = List.concat [sourcen.children;[new_op.id]]} (IdtMap.remove cc1.sourceid op_inp_added.treeNodes)
in {op_inp_added with
treeNodes = nodesn;
treeEdges =
IdtMap.add cc1.nameforudg {edge = (cc1,new_op.id,pp1); edgeway = Cross; used = true} op_inp_added.treeEdges}
in addInp tail new_tree
| _ -> tr
in let tree3 = addInp remained_edges tree2
in let new_mux_inp = (DG.nodefoldedges (fun y a -> y::a) new_mux [])
in let new_mux_error_inp = List.filter (fun (cx,_,_) -> not (hasedge cx.nameforudg tree3)) new_mux_inp
in let rec add_errors errorlist tr =
match errorlist with
(cx,tx,px)::tail -> let ttt =
{tr with
treeNodes =IdtMap.add cx.sourceid {node = (DG.findnode cx.sourceid gra1); number = NodeNumber.get (); allDone = true; children = [new_mux.id]} tr.treeNodes;
treeEdges = IdtMap.add cx.nameforudg {edge = (cx,tx.id,px); edgeway = Cross; used = true} tr.treeEdges}
in add_errors tail ttt
| _ -> tr
in let tree4 = add_errors new_mux_error_inp tree3
in (new_tree tree4 ,[])