# * node_weight -- array of node weights
#****
proc writePartitions {node_weight} {
- global nparts;
- global node_list;
- global link_list;
- global split_list;
- global finalpartition;
+ global nparts;
+ global node_list;
+ global link_list;
+ global split_list;
+ global finalpartition;
- upvar $node_weight nweight;
+ upvar $node_weight nweight;
- #counts how many nodes are in each partition
- array set nr_nodes_partition {};
- #sum up the weight of each partition
- array set weight_partition {};
+ #counts how many nodes are in each partition
+ array set nr_nodes_partition {};
+ #sum up the weight of each partition
+ array set weight_partition {};
- for {set i 0} {$i<$nparts} {incr i} {
- set nr_nodes_partition($i) 0;
- set weight_partition($i) 0;
- }
-
- set i 0;
- foreach node $node_list {
- #write to node its partition
- setPartition $node $finalpartition($i);
- incr nr_nodes_partition($finalpartition($i)) 1;
- incr weight_partition($finalpartition($i)) $nweight($i);
- incr i;
- }
-
- #disconnect for algorithm connected nodes
- foreach split $split_list {
- set node1 [lindex $split 0];
- set node2 [lindex $split 1];
- set linkToSplit [linkByPeers $node1 $node2];
- splitGUILink $linkToSplit ;
- }
-
- set outstr "";
- for {set i 0} {$i < $nparts} {incr i} {
- set outstr "p$i: $nr_nodes_partition($i) vertices with weight $weight_partition($i)";
- #puts [format %s $outstr];
- }
+ for {set i 0} {$i<$nparts} {incr i} {
+ set nr_nodes_partition($i) 0;
+ set weight_partition($i) 0;
+ }
+
+ set i 0;
+ foreach node $node_list {
+ #write to node its partition
+ setPartition $node $finalpartition($i);
+ incr nr_nodes_partition($finalpartition($i)) 1;
+ incr weight_partition($finalpartition($i)) $nweight($i);
+ incr i;
+ }
+
+ #disconnect for algorithm connected nodes
+ foreach split $split_list {
+ set node1 [lindex $split 0];
+ set node2 [lindex $split 1];
+ set linkToSplit [linkByPeers $node1 $node2];
+ splitGUILink $linkToSplit ;
+ }
+
+ set outstr "";
+ for {set i 0} {$i < $nparts} {incr i} {
+ set outstr "p$i: $nr_nodes_partition($i) vertices with weight $weight_partition($i)";
+ #puts [format %s $outstr];
+ }
- redrawAll;
- updateUndoLog;
- tk_dialog .dialog1 "Graph partitioning output" "Done.\n" info 0 Dismiss;
+ redrawAll;
+ updateUndoLog;
+ tk_dialog .dialog1 "Graph partitioning output" "Done.\n" info 0 Dismiss;
}
-
+
#****f* graph_partitioning.tcl/setPartition
# NAME
# setPartition -- set partition
# * partition -- partition of the node
#****
proc setPartition { node partition } {
- global $node;
-
- set p [lsearch [set $node] "partition *"];
- if { $p >= 0 } {
- set $node [lreplace [set $node] $p $p "partition p$partition"];
- } else {
- set $node [linsert [set $node] end "partition p$partition"];
- }
+ global $node;
+
+ set p [lsearch [set $node] "partition *"];
+ if { $p >= 0 } {
+ set $node [lreplace [set $node] $p $p "partition p$partition"];
+ } else {
+ set $node [linsert [set $node] end "partition p$partition"];
+ }
}
#****f* graph_partitioning.tcl/getNodePartition
# * part -- the node's partition
#****
proc getNodePartition { node } {
- global $node;
- set part [lindex [lsearch -inline [set $node] "partition *"] 1];
- return $part;
+ global $node;
+ set part [lindex [lsearch -inline [set $node] "partition *"] 1];
+ return $part;
}
#****f* graph_partitioning.tcl/debug
# * message -- a messege to be printed
#****
proc debug { message } {
- global debug;
- if ![info exists debug(enabled)] {
- #do nothing
- return;
- }
- puts stderr $message;
+ global debug;
+ if ![info exists debug(enabled)] {
+ #do nothing
+ return;
+ }
+ puts stderr $message;
}
#****f* graph_partitioning.tcl/graphPartition
# * partNum -- number of partitions
#****
proc graphPartition {partNum} {
- global node_list;
- global link_list;
- global finalpartition;
-
- global nparts;
- global tpwgts;
- global max_nweight;
-
- array set node_weight {};
- array set edge_weight {};
- array set node_neighbour {};
- array set edge_array {};
- array set tpwgts {};
- array set node_map {};
-
- puts "";
- #puts " Starting graph partitioning...";
- #puts "+------------------------------------------------+";
- #puts "";
-
- set start [clock clicks -milliseconds];
-
- #initialise the arrays for the algorithm
- set nparts $partNum;
- initNodes node_weight;
- set nvertices [array size node_weight];
- initNeighbours node_neighbour edge_array edge_weight;
+ global node_list link_list finalpartition
+
+ global nparts tpwgts max_nweight
+
+ array set node_weight {};
+ array set edge_weight {};
+ array set node_neighbour {};
+ array set edge_array {};
+ array set tpwgts {};
+ array set node_map {};
+
+ puts "";
+ #puts " Starting graph partitioning...";
+ #puts "+------------------------------------------------+";
+ #puts "";
- if {$nparts > $nvertices} then {
- debug "Number of vertices should be greater then number of partitions.";
- displayErrorMessage "Number of vertices should be greater then number of partitions.";
- return;
- } elseif {$nparts < 2} {
- debug "Number of partition should be greater then 1.";
- displayErrorMessage "Number of partition should be greater then 1.";
- return;
- }
-
- #calculate tpwgts array
- for {set i 0} {$i < $nparts} {incr i} {
- set tpwgts($i) [expr {1.0 / (1.0 * $nparts)}];
- }
+ set start [clock clicks -milliseconds];
+
+ #initialise the arrays for the algorithm
+ set nparts $partNum;
+ initNodes node_weight;
+ set nvertices [array size node_weight];
+ initNeighbours node_neighbour edge_array edge_weight;
- set t [time {
- recursiveBisection $nvertices node_weight node_neighbour edge_array edge_weight tpwgts $nparts 0 node_map;
- } 1];
- set microsec [lindex $t 0];
- puts "total time: [expr {$microsec * 0.000001}] sec";
+ if {$nparts > $nvertices} then {
+ debug "Number of vertices should be greater then number of partitions.";
+ displayErrorMessage "Number of vertices should be greater then number of partitions.";
+ return;
+ } elseif {$nparts < 2} {
+ debug "Number of partition should be greater then 1.";
+ displayErrorMessage "Number of partition should be greater then 1.";
+ return;
+ }
+
+ #calculate tpwgts array
+ for {set i 0} {$i < $nparts} {incr i} {
+ set tpwgts($i) [expr {1.0 / (1.0 * $nparts)}];
+ }
+ set t [time { recursiveBisection $nvertices node_weight node_neighbour edge_array edge_weight tpwgts $nparts 0 node_map; } 1];
+ set microsec [lindex $t 0];
+ puts "total time: [expr {$microsec * 0.000001}] sec";
- #compute cut
+ #compute cut
set cut 0;
for {set i 0} {$i < $nvertices} {incr i} {
set id($i) 0;
# calculates the sum of the edge weights of the adjacent vertices of i
if {[info exists node_neighbour($i)]} then {
- foreach ngb $node_neighbour($i) {
+ foreach ngb $node_neighbour($i) {
if {$curr_partition == $finalpartition($ngb)} then {
- # vertice in the same partition
- incr id($i) 1;#$edge_weight([getEdgeBetween $i $ngb edge_array]);
+ # vertice in the same partition
+ incr id($i) 1;
+ #$edge_weight([getEdgeBetween $i $ngb edge_array]);
} else {
- # vertice in a different partition
- incr ed($i) 1;#$edge_weight([getEdgeBetween $i $ngb edge_array]);
+ # vertice in a different partition
+ incr ed($i) 1;
+ #$edge_weight([getEdgeBetween $i $ngb edge_array]);
};#if-else
- };#foreach
+ };#foreach
- if {$ed($i) > 0 || [llength $node_neighbour($i)] == 0} then { ;#vanjski node, ili nema susjeda
- incr cut $ed($i);
- }
+ if {$ed($i) > 0 || [llength $node_neighbour($i)] == 0} then {
+ #vanjski node, ili nema susjeda
+ incr cut $ed($i);
+ }
+ }
}
- }
- set cut [expr {$cut / 2}];
- puts "end cut: $cut";
+ set cut [expr {$cut / 2}];
+ puts "end cut: $cut";
- #save the partitions
- writePartitions node_weight;
+ #save the partitions
+ writePartitions node_weight;
- set end [clock clicks -milliseconds];
- puts [format "total elapsed time: %.6f s" [expr {($end - $start) * 0.001}]];
+ set end [clock clicks -milliseconds];
+ puts [format "total elapsed time: %.6f s" [expr {($end - $start) * 0.001}]];
- puts "";
- puts " Done graph partitioning.";
- puts "+------------------------------------------------+";
- puts "";
+ puts "";
+ puts " Done graph partitioning.";
+ puts "+------------------------------------------------+";
+ puts "";
}
#****f* graph_partitioning.tcl/initNodes
# * node_weight -- empty array of node weights
#****
proc initNodes {node_weight} {
- global node_list;
- upvar $node_weight nweight;
+ global node_list;
+ upvar $node_weight nweight;
- set i 0;
- foreach node $node_list {
- #if the node is pseudo, remove it
- if {[nodeType $node] == "pseudo"} then {
- mergePseudoLink $node
- } else {
- #seve node's weight into array
- set nweight($i) [getNodeWeight $node];
- incr i;
- }
- }
+ set i 0;
+ foreach node $node_list {
+ #if the node is pseudo, remove it
+ if {[nodeType $node] == "pseudo"} then {
+ mergePseudoLink $node
+ } else {
+ #seve node's weight into array
+ set nweight($i) [getNodeWeight $node];
+ incr i;
+ }
+ }
}
#****f* graph_partitioning.tcl/mergePseudoLink
# * pnode -- pseudo node id
#****
proc mergePseudoLink { pnode } {
- global node_list;
- global split_list;
+ global node_list;
+ global split_list;
- foreach n $node_list {
- #get the links connecting the both pseudo node's
- set l1 [linkByPeers $pnode $n];
- if {$l1 != ""} then {
- set l2 [getLinkMirror $l1];
- #set peers1 [linkPeers $l1];
- set peers2 [linkPeers $l2];
-
- #get it's not-pseudo peers
- #set n1 [lindex $peers1 0];
- set n2 [lindex $peers2 0];
-
- mergeLink $l1;
- if {[lsearch $split_list "$n $n2"] < 0 && [lsearch $split_list "$n2 $n"] < 0} then {
- lappend split_list "$n $n2";
- break;
- }
+ foreach n $node_list {
+ #get the links connecting the both pseudo node's
+ set l1 [linkByPeers $pnode $n];
+ if {$l1 != ""} then {
+ set l2 [getLinkMirror $l1];
+ #set peers1 [linkPeers $l1];
+ set peers2 [linkPeers $l2];
+
+ #get it's not-pseudo peers
+ #set n1 [lindex $peers1 0];
+ set n2 [lindex $peers2 0];
+
+ mergeLink $l1;
+ if {[lsearch $split_list "$n $n2"] < 0 && [lsearch $split_list "$n2 $n"] < 0} then {
+ lappend split_list "$n $n2";
+ break;
+ }
+ }
}
- }
}
#****f* graph_partitioning.tcl/initNeighbours
# * edge_weight -- empty array
#****
proc initNeighbours {node_neighbour edge_array edge_weight} {
- global node_list;
- global link_list;
-
- upvar $edge_array earray;
- upvar $node_neighbour nneighbour;
- upvar $edge_weight eweight;
-
- for {set i 0} {$i < [llength $link_list]} {incr i} {
- #take the edge one after the other
- set edge [lindex $link_list $i];
- #read nodes incident to edge
- set peers [linkPeers $edge];
- set node1 [lindex $peers 0];
- set node2 [lindex $peers 1];
- #read node's index in the node_list
- set idx_n1 [lsearch $node_list $node1];
- set idx_n2 [lsearch $node_list $node2];
- #node1 is adjacent to node2
- lappend nneighbour($idx_n1) $idx_n2;
- lappend nneighbour($idx_n2) $idx_n1;
- set earray($i) "$idx_n1 $idx_n2";
- #calculate the link weight
- set eweight($i) [expr {[getLinkWeight $edge] / 100000}]; #!!!!!!s
- }
+ global node_list link_list
+
+ upvar $edge_array earray;
+ upvar $node_neighbour nneighbour;
+ upvar $edge_weight eweight;
+
+ for {set i 0} {$i < [llength $link_list]} {incr i} {
+ #take the edge one after the other
+ set edge [lindex $link_list $i];
+ #read nodes incident to edge
+ set peers [linkPeers $edge];
+ set node1 [lindex $peers 0];
+ set node2 [lindex $peers 1];
+ #read node's index in the node_list
+ set idx_n1 [lsearch $node_list $node1];
+ set idx_n2 [lsearch $node_list $node2];
+ #node1 is adjacent to node2
+ lappend nneighbour($idx_n1) $idx_n2;
+ lappend nneighbour($idx_n2) $idx_n1;
+ set earray($i) "$idx_n1 $idx_n2";
+ #calculate the link weight
+ set eweight($i) [expr {[getLinkWeight $edge] / 100000}]; #!!!!!!s
+ }
}
#****f* graph_partitioning.tcl/recursiveBisection
# * up_map --
#****
proc recursiveBisection {nvertices node_weight node_neighbour edge_array edge_weight tpart_wgts new_parts part_nr up_map} {
- global part_mincut;
- global finalpartition;
- global part_partition;
-
- upvar $node_weight nweight;
- upvar $node_neighbour nneighbour;
- upvar $edge_array earray;
- upvar $edge_weight eweight;
- upvar $tpart_wgts tpwgts;
- upvar $up_map upmap;
-
- array set tpwgts2 {};
-
- set nparts $new_parts;
- set cut 0;
- debug "recursiveBisection!!!!";
- debug "RB: nparts=$nparts";
-
- #calculate for each partition its wished weight
- set tvwgt [sum_array $nvertices nweight];
- set sum_tpwgt [sum_array [expr {$nparts / 2}] tpwgts];
- set tpwgts2(0) [expr {int ( ceil($tvwgt * $sum_tpwgt))}];
- set tp2 [expr {ceil($sum_tpwgt * $tvwgt)}];
- set tpwgts2(1) [expr {int($tvwgt - $tpwgts2(0))}];
- debug "RB: tvwgt=$tvwgt, tpwgts2(0)=$tpwgts2(0), tpwgts2(1)=$tpwgts2(1), sum_tpwgt=$sum_tpwgt";
-
- #start partitioning
- coarseGraph $nvertices nweight nneighbour earray eweight tpwgts2;
- #minimal cut
- set cut $part_mincut;
+ global part_mincut;
+ global finalpartition;
+ global part_partition;
+
+ upvar $node_weight nweight;
+ upvar $node_neighbour nneighbour;
+ upvar $edge_array earray;
+ upvar $edge_weight eweight;
+ upvar $tpart_wgts tpwgts;
+ upvar $up_map upmap;
+
+ array set tpwgts2 {};
+
+ set nparts $new_parts;
+ set cut 0;
+ debug "recursiveBisection!!!!";
+ debug "RB: nparts=$nparts";
+
+ #calculate for each partition its wished weight
+ set tvwgt [sum_array $nvertices nweight];
+ set sum_tpwgt [sum_array [expr {$nparts / 2}] tpwgts];
+ set tpwgts2(0) [expr {int ( ceil($tvwgt * $sum_tpwgt))}];
+ set tp2 [expr {ceil($sum_tpwgt * $tvwgt)}];
+ set tpwgts2(1) [expr {int($tvwgt - $tpwgts2(0))}];
+ debug "RB: tvwgt=$tvwgt, tpwgts2(0)=$tpwgts2(0), tpwgts2(1)=$tpwgts2(1), sum_tpwgt=$sum_tpwgt";
+
+ #start partitioning
+ coarseGraph $nvertices nweight nneighbour earray eweight tpwgts2;
+ #minimal cut
+ set cut $part_mincut;
- #calculate for each vertex its right partition by adding to "0" and "1" partition a number
- for {set i 0} {$i < $nvertices} {incr i} {
- if {[array size upmap] > 0} {
- set finalpartition($upmap($i)) [expr {$part_partition($i) + $part_nr}];
- } else {
- set finalpartition($i) [expr {$part_partition($i) + $part_nr}];
+ #calculate for each vertex its right partition by adding to "0" and "1" partition a number
+ for {set i 0} {$i < $nvertices} {incr i} {
+ if {[array size upmap] > 0} {
+ set finalpartition($upmap($i)) [expr {$part_partition($i) + $part_nr}];
+ } else {
+ set finalpartition($i) [expr {$part_partition($i) + $part_nr}];
+ }
}
- }
- #when partition in more then 2 parts, divide the graph in 2 halfs (subgraph "0" and subgraph "1")
- if {$nparts > 2} then {
- array set snode_neighbour {};
- array set snode_weight {};
+ #when partition in more then 2 parts, divide the graph in 2 halfs (subgraph "0" and subgraph "1")
+ if {$nparts > 2} then {
+ array set snode_neighbour {};
+ array set snode_weight {};
array set sedge_array {};
array set sedge_weight {};
array set snode_map {};
array set sedge_weight0 {};
array set snode_map0 {};
- array set snode_neighbour1 {};
+ array set snode_neighbour1 {};
array set snode_weight1 {};
array set sedge_array1 {};
array set sedge_weight1 {};
#save the node characteristics from both subgraphs in two different arrays
for {set i 0} {$i < $sn_vtxs(0)} {incr i} {
- if {[info exists snode_neighbour(0,$i)]} then {
- set snode_neighbour0($i) $snode_neighbour(0,$i);
- }
- if {[array size upmap] > 0} then {
- set snode_map0($i) $upmap($snode_map_help(0,$i));
- } else {
- set snode_map0($i) $snode_map_help(0,$i);
- }
- debug "snode_map0($i)=$snode_map0($i)";
- set snode_weight0($i) $snode_weight(0,$i);
+ if {[info exists snode_neighbour(0,$i)]} then {
+ set snode_neighbour0($i) $snode_neighbour(0,$i);
+ }
+ if {[array size upmap] > 0} then {
+ set snode_map0($i) $upmap($snode_map_help(0,$i));
+ } else {
+ set snode_map0($i) $snode_map_help(0,$i);
+ }
+ debug "snode_map0($i)=$snode_map0($i)";
+ set snode_weight0($i) $snode_weight(0,$i);
}
- for {set i 0} {$i < $sn_vtxs(1)} {incr i} {
- if {[info exists snode_neighbour(1,$i)]} then {
- set snode_neighbour1($i) $snode_neighbour(1,$i);
- }
- if {[array size upmap] > 0} then {
- set snode_map1($i) $upmap($snode_map_help(1,$i));
- } else {
- set snode_map1($i) $snode_map_help(1,$i);
- }
- debug "snode_map1($i)=$snode_map1($i)";
- set snode_weight1($i) $snode_weight(1,$i);
+ for {set i 0} {$i < $sn_vtxs(1)} {incr i} {
+ if {[info exists snode_neighbour(1,$i)]} then {
+ set snode_neighbour1($i) $snode_neighbour(1,$i);
+ }
+ if {[array size upmap] > 0} then {
+ set snode_map1($i) $upmap($snode_map_help(1,$i));
+ } else {
+ set snode_map1($i) $snode_map_help(1,$i);
+ }
+ debug "snode_map1($i)=$snode_map1($i)";
+ set snode_weight1($i) $snode_weight(1,$i);
}
#save the link characteristics from both subgraphs in two different arrays
for {set i 0} {$i < $sn_edges(0)} {incr i} {
- set sedge_array0($i) $sedge_array(0,$i);
- set sedge_weight0($i) $sedge_weight(0,$i);
+ set sedge_array0($i) $sedge_array(0,$i);
+ set sedge_weight0($i) $sedge_weight(0,$i);
}
for {set i 0} {$i < $sn_edges(1)} {incr i} {
- set sedge_array1($i) $sedge_array(1,$i);
- set sedge_weight1($i) $sedge_weight(1,$i);
+ set sedge_array1($i) $sedge_array(1,$i);
+ set sedge_weight1($i) $sedge_weight(1,$i);
}
- }
+ }
- #update the tpwgts (partition's ratio of the graph)
- mult_array 0 [expr {int($nparts / 2)}] tpwgts [expr {1 / $sum_tpwgt}];
- mult_array [expr {int($nparts / 2)}] $nparts tpwgts [expr {1.0 / (1.0 - $sum_tpwgt)}];
- set max [expr {int($nparts - $nparts / 2)}];
+ #update the tpwgts (partition's ratio of the graph)
+ mult_array 0 [expr {int($nparts / 2)}] tpwgts [expr {1 / $sum_tpwgt}];
+ mult_array [expr {int($nparts / 2)}] $nparts tpwgts [expr {1.0 / (1.0 - $sum_tpwgt)}];
+ set max [expr {int($nparts - $nparts / 2)}];
- for {set i 0} {$i < $max} {incr i} {
- set new_tpwgts($i) $tpwgts([expr {$i + int($nparts / 2)}]);
+ for {set i 0} {$i < $max} {incr i} {
+ set new_tpwgts($i) $tpwgts([expr {$i + int($nparts / 2)}]);
debug " new_tpwgts($i)=$new_tpwgts($i)";
- }
-
- #call recursive itself
- if {$nparts > 3} then {
- #partition the first subgraph
- recursiveBisection $sn_vtxs(0) snode_weight0 snode_neighbour0 sedge_array0 sedge_weight0 tpwgts [expr {int($nparts / 2)}] $part_nr snode_map0;
- #partition the second subgraph
- recursiveBisection $sn_vtxs(1) snode_weight1 snode_neighbour1 sedge_array1 sedge_weight1 new_tpwgts [expr {int($nparts - $nparts / 2)}] [expr {int($part_nr + $nparts / 2)} ] snode_map1;
- } elseif {$nparts == 3} then {
- #partition the second subgraph
- recursiveBisection $sn_vtxs(1) snode_weight1 snode_neighbour1 sedge_array1 sedge_weight1 new_tpwgts [expr {int($nparts - $nparts / 2)}] [expr {int($part_nr + $nparts / 2)}] snode_map1;
- }
+ }
+
+ #call recursive itself
+ if {$nparts > 3} then {
+ #partition the first subgraph
+ recursiveBisection $sn_vtxs(0) snode_weight0 snode_neighbour0 sedge_array0 sedge_weight0 tpwgts [expr {int($nparts / 2)}] $part_nr snode_map0;
+ #partition the second subgraph
+ recursiveBisection $sn_vtxs(1) snode_weight1 snode_neighbour1 sedge_array1 sedge_weight1 new_tpwgts [expr {int($nparts - $nparts / 2)}] [expr {int($part_nr + $nparts / 2)} ] snode_map1;
+ } elseif {$nparts == 3} then {
+ #partition the second subgraph
+ recursiveBisection $sn_vtxs(1) snode_weight1 snode_neighbour1 sedge_array1 sedge_weight1 new_tpwgts [expr {int($nparts - $nparts / 2)}] [expr {int($part_nr + $nparts / 2)}] snode_map1;
+ }
}
#****f* graph_partitioning.tcl/coarseGraph
# * tpwgts2 -- array of each partition size of the graph
#****
proc coarseGraph {nvertices node_weight node_neighbour edge_array edge_weight tpwgts2} {
- global nparts;
- global max_nweight;
- global COARSEN_TO;
+ global nparts;
+ global max_nweight;
+ global COARSEN_TO;
- upvar $node_weight nweight;
- upvar $node_neighbour nneighbour;
- upvar $edge_array earray;
- upvar $edge_weight eweight;
- upvar $tpwgts2 tpwgts;
+ upvar $node_weight nweight;
+ upvar $node_neighbour nneighbour;
+ upvar $edge_array earray;
+ upvar $edge_weight eweight;
+ upvar $tpwgts2 tpwgts;
- debug "MatchRm... $nvertices";
+ debug "MatchRm... $nvertices";
- array set cnweight {};
- array set nmap {};
- array set nmatch {};
+ array set cnweight {};
+ array set nmap {};
+ array set nmatch {};
- set matched "";
- set cnvertices 0;
-
- #permute the nodes
- set permList [makePermList $nvertices ];
- #array with random permuted nodes
- array set permArray $permList;
- set sum_nweight [sum_array $nvertices nweight];
- set max_nweight [expr {1.5 * $sum_nweight / 20}];
-
- #match the vertices
- for {set i 0} {[llength $matched] < $nvertices} {incr i} {
+ set matched "";
+ set cnvertices 0;
+
+ #permute the nodes
+ set permList [makePermList $nvertices ];
+ #array with random permuted nodes
+ array set permArray $permList;
+ set sum_nweight [sum_array $nvertices nweight];
+ set max_nweight [expr {1.5 * $sum_nweight / 20}];
+
+ #match the vertices
+ for {set i 0} {[llength $matched] < $nvertices} {incr i} {
set unmatched_node $permArray($i);
- if {[lsearch $matched $unmatched_node] == -1} then {
- lappend matched $unmatched_node;
- set matched_ngb 0;
- set max_eweight 0;
- debug "matched=$matched";
-
- #node has an unmatched, passend neighbor, and is matched with it
-if {$nvertices > $COARSEN_TO && [info exists nneighbour($unmatched_node)]} then {
- foreach ngb $nneighbour($unmatched_node) {
- if {[lsearch $matched $ngb] == -1 && [expr {$nweight($i) + $nweight($ngb)}] < $max_nweight && $max_eweight < $eweight([getEdgeBetween $unmatched_node $ngb earray])} then {
- set matched_ngb 1;
- lappend matched $ngb;
- set max_eweight $eweight([getEdgeBetween $unmatched_node $ngb earray]);
- set nmatch($unmatched_node) $ngb;
- set nmatch($ngb) $unmatched_node;
- set nmap($unmatched_node) $cnvertices; #potrebno za uncoarse
- set nmap($ngb) $cnvertices; #potrebno za uncoarse
- set cnweight($cnvertices) [expr {$nweight($unmatched_node) + $nweight($ngb)}];
-
+ if {[lsearch $matched $unmatched_node] == -1} then {
+ lappend matched $unmatched_node;
+ set matched_ngb 0;
+ set max_eweight 0;
+ debug "matched=$matched";
+
+ #node has an unmatched, passend neighbor, and is matched with it
+ if {$nvertices > $COARSEN_TO && [info exists nneighbour($unmatched_node)]} then {
+ foreach ngb $nneighbour($unmatched_node) {
+ if {[lsearch $matched $ngb] == -1 && [expr {$nweight($i) + $nweight($ngb)}] < $max_nweight && $max_eweight < $eweight([getEdgeBetween $unmatched_node $ngb earray])} then {
+ set matched_ngb 1;
+ lappend matched $ngb;
+ set max_eweight $eweight([getEdgeBetween $unmatched_node $ngb earray]);
+ set nmatch($unmatched_node) $ngb;
+ set nmatch($ngb) $unmatched_node;
+ set nmap($unmatched_node) $cnvertices; #potrebno za uncoarse
+ set nmap($ngb) $cnvertices; #potrebno za uncoarse
+ set cnweight($cnvertices) [expr {$nweight($unmatched_node) + $nweight($ngb)}];
+ }
+ }
+ }
+ #node is matched with itself
+ if {$matched_ngb == 0} then {
+ set nmatch($unmatched_node) $unmatched_node;
+ set nmap($unmatched_node) $cnvertices;
+ set cnweight($cnvertices) $nweight($unmatched_node);
+ }
+ debug "nmap($unmatched_node)=$nmap($unmatched_node),$unmatched_node,$nmatch($unmatched_node) ";
+ incr cnvertices;
}
- }
-}
- #node is matched with itself
- if {$matched_ngb == 0} then {
- set nmatch($unmatched_node) $unmatched_node;
- set nmap($unmatched_node) $cnvertices;
- set cnweight($cnvertices) $nweight($unmatched_node);
- }
- debug "nmap($unmatched_node)=$nmap($unmatched_node),$unmatched_node,$nmatch($unmatched_node) ";
- incr cnvertices;
}
- }
- array set cnneighbour {};
- set used_nodes "";
- set cngb 0;
+ array set cnneighbour {};
+ set used_nodes "";
+ set cngb 0;
- #coarse graph
- for {set i 0} {[llength $used_nodes] < $cnvertices} {incr i} {
- set parent1 $i;
- set parent2 $nmatch($i);
- set cnode $nmap($parent1);
-
- if {[lsearch $used_nodes $cnode] > -1} {
- continue;
- }
- lappend used_nodes $cnode;
-
- #save all neighbours from the 2 parent nodes to their coarse node
- set temp_ngb_list "";
-if {[info exists nneighbour($parent1)] && [info exists nneighbour($parent2)]} then {
- # take all neighbours from "parent"-nodes
- set all_neighbours [concat $nneighbour($parent1) $nneighbour($parent2)];
- foreach ngb $all_neighbours {
- set ngb_map $nmap($ngb);
+ #coarse graph
+ for {set i 0} {[llength $used_nodes] < $cnvertices} {incr i} {
+ set parent1 $i;
+ set parent2 $nmatch($i);
+ set cnode $nmap($parent1);
+
+ if {[lsearch $used_nodes $cnode] > -1} {
+ continue;
+ }
+ lappend used_nodes $cnode;
+
+ #save all neighbours from the 2 parent nodes to their coarse node
+ set temp_ngb_list "";
+ if {[info exists nneighbour($parent1)] && [info exists nneighbour($parent2)]} then {
+ # take all neighbours from "parent"-nodes
+ set all_neighbours [concat $nneighbour($parent1) $nneighbour($parent2)];
+ foreach ngb $all_neighbours {
+ set ngb_map $nmap($ngb);
#don't save duplicates
- if {$ngb_map == $cnode} then {
+ if {$ngb_map == $cnode} then {
continue;
}
- if {[lsearch $temp_ngb_list $ngb_map] == -1} then {
- lappend temp_ngb_list $ngb_map;
- }
- }
+ if {[lsearch $temp_ngb_list $ngb_map] == -1} then {
+ lappend temp_ngb_list $ngb_map;
+ }
+ }
- set cnneighbour($cnode) $temp_ngb_list;
+ set cnneighbour($cnode) $temp_ngb_list;
+ }
}
- }
-############## EDGES ###############
+ ############## EDGES ###############
- array set cearray {};
- set cnum_edges 0;
+ array set cearray {};
+ set cnum_edges 0;
- #coarse edges
- for {set i 0} {$i < [array size earray]} {incr i} {
- set twin 0;
- set node1 [lindex $earray($i) 0];
- set node2 [lindex $earray($i) 1];
+ #coarse edges
+ for {set i 0} {$i < [array size earray]} {incr i} {
+ set twin 0;
+ set node1 [lindex $earray($i) 0];
+ set node2 [lindex $earray($i) 1];
- set cnode1 $nmap($node1);
- set cnode2 $nmap($node2);
+ set cnode1 $nmap($node1);
+ set cnode2 $nmap($node2);
- if {$cnode1 == $cnode2} then { ;#edge between two coarsed nodes disappears
- } else {
- #check if the link already exists in coarsed graph
- for {set j 0} {$j < [array size cearray]} {incr j} {
- if {$cearray($j) == "$cnode1 $cnode2" || $cearray($j) == "$cnode2 $cnode1"} then {
- set twin 1;
- #add the edge weight to the weight of coarsed edge
- incr ceweight($j) $eweight($i);
- break;
+ if {$cnode1 == $cnode2} then {
+ #edge between two coarsed nodes disappears
+ } else {
+ #check if the link already exists in coarsed graph
+ for {set j 0} {$j < [array size cearray]} {incr j} {
+ if {$cearray($j) == "$cnode1 $cnode2" || $cearray($j) == "$cnode2 $cnode1"} then {
+ set twin 1;
+ #add the edge weight to the weight of coarsed edge
+ incr ceweight($j) $eweight($i);
+ break;
+ }
+ }
+ #if its no double edge, make a new edge in coarsed graph
+ if {$twin == 0} then {
+ set cearray($cnum_edges) "$cnode1 $cnode2";
+ set ceweight($cnum_edges) $eweight($i);
+ incr cnum_edges;
+ }
}
- }
- #if its no double edge, make a new edge in coarsed graph
- if {$twin == 0} then {
- set cearray($cnum_edges) "$cnode1 $cnode2";
- set ceweight($cnum_edges) $eweight($i);
- incr cnum_edges;
- }
}
- }
- #repeat coarsening
- if {$cnvertices > $COARSEN_TO && $nvertices > $cnvertices} {
- coarseGraph $cnvertices cnweight cnneighbour cearray ceweight tpwgts;
- } else {
- #enough coarsed, partition the coarsest graph
- makePartitions $cnvertices cnweight cnneighbour cearray ceweight tpwgts;
- }
+ #repeat coarsening
+ if {$cnvertices > $COARSEN_TO && $nvertices > $cnvertices} {
+ coarseGraph $cnvertices cnweight cnneighbour cearray ceweight tpwgts;
+ } else {
+ #enough coarsed, partition the coarsest graph
+ makePartitions $cnvertices cnweight cnneighbour cearray ceweight tpwgts
+ }
debug "match Over !!!";
-
+
#balance, refine and uncoarse the graph
balance $cnvertices cnneighbour cnweight cearray ceweight tpwgts 4;
FMRefinement $cnvertices cnneighbour cnweight cearray ceweight tpwgts 4;
# * tpwgts2 -- array of each partition size of the graph
#****
proc makePartitions {nvertices node_weight node_neighbour edge_array edge_weight tpwgts2} {
- global COARSEN_TO;
- global part_pwgts;
- global part_partition;
- global part_boundary;
- global part_id;
- global part_ed;
- global part_mincut;
+ global COARSEN_TO;
+ global part_pwgts;
+ global part_partition;
+ global part_boundary;
+ global part_id;
+ global part_ed;
+ global part_mincut;
- upvar $node_weight nweight;
- upvar $node_neighbour nneighbour;
- upvar $edge_array earray;
- upvar $edge_weight eweight;
- upvar $tpwgts2 tpwgts;
-
- #the sum of weight of all neighbours
- array set wsum_ngbs {};
- array set bestpartition {};
- array set part_partition {};
- array set visited {};
- array set part_ed {};
- array set part_id {};
+ upvar $node_weight nweight;
+ upvar $node_neighbour nneighbour;
+ upvar $edge_array earray;
+ upvar $edge_weight eweight;
+ upvar $tpwgts2 tpwgts;
+
+ #the sum of weight of all neighbours
+ array set wsum_ngbs {};
+ array set bestpartition {};
+ array set part_partition {};
+ array set visited {};
+ array set part_ed {};
+ array set part_id {};
- set part_mincut 0;
+ set part_mincut 0;
- #calculate the sum of all edge-weights in graph
- set wsum 1;
- for {set i 0} {$i < $nvertices} {incr i} {
+ #calculate the sum of all edge-weights in graph
+ set wsum 1;
+ for {set i 0} {$i < $nvertices} {incr i} {
if {[info exists nneighbour($i)]} then {
- foreach ngb $nneighbour($i) {
+ foreach ngb $nneighbour($i) {
set e [getEdgeBetween $i $ngb earray];
incr wsum $eweight($e);
- }
+ }
}
set bestpartitions($i) -1;
- }
- set bestcut $wsum;
+ }
+ set bestcut $wsum;
- if {$nvertices <= $COARSEN_TO} then {
- set nbfs 4;
- } else {
- set nbfs 9;
- }
+ if {$nvertices <= $COARSEN_TO} then {
+ set nbfs 4;
+ } else {
+ set nbfs 9;
+ }
while {$nbfs > 1} {
incr nbfs -1;
set part_boundary "";
# set all vertices to partition 1, and for all vertices to not visited
for {set i 0} {$i < $nvertices} {incr i} {
- set part_partition($i) 1;
- set visited($i) 0;
+ set part_partition($i) 1;
+ set visited($i) 0;
}
set part_pwgts(0) 0;
set visited($start_node) 1;
while {1} {
- #graph is disconnected
- if {[llength $queue] == 0} {
- set more_left 0;
- for {set n 0} {$n < $nvertices} {incr n} {
- if {$visited($n) == 0} then {
- set queue $n;
- set visited($n) 1;
- set more_left 1;
- break;
- }
- }
- if {$more_left == 0} then {
- debug "no more left!";
- break;
- }
+ #graph is disconnected
+ if {[llength $queue] == 0} {
+ set more_left 0;
+ for {set n 0} {$n < $nvertices} {incr n} {
+ if {$visited($n) == 0} then {
+ set queue $n;
+ set visited($n) 1;
+ set more_left 1;
+ break;
+ }
+ }
+ if {$more_left == 0} then {
+ debug "no more left!";
+ break;
+ }
}
- # take the first node from queue
- set i [lindex $queue 0];
- set queue [lreplace $queue 0 0];
+ # take the first node from queue
+ set i [lindex $queue 0];
+ set queue [lreplace $queue 0 0];
- if {$part_pwgts(0) > 0 && [expr {$part_pwgts(1) - $nweight($i)}] < $tpwgts(1)} then {
- debug "preveliko, dalje...";
- continue;
- }
- #change partition of i from 1 to 0
- set part_partition($i) 0;
+ if {$part_pwgts(0) > 0 && [expr {$part_pwgts(1) - $nweight($i)}] < $tpwgts(1)} then {
+ debug "preveliko, dalje...";
+ continue;
+ }
+ #change partition of i from 1 to 0
+ set part_partition($i) 0;
- #update the partitions weight
- set part_pwgts(0) [expr {$part_pwgts(0) + $nweight($i)}];
- set part_pwgts(1) [expr {$part_pwgts(1) - $nweight($i)}];
+ #update the partitions weight
+ set part_pwgts(0) [expr {$part_pwgts(0) + $nweight($i)}];
+ set part_pwgts(1) [expr {$part_pwgts(1) - $nweight($i)}];
- #partition is bigger than it should be
- if {$part_pwgts(1) <= $tpwgts(1)} then {
- debug "tpwgts(1)=$tpwgts(1)";
- break;
- }
+ #partition is bigger than it should be
+ if {$part_pwgts(1) <= $tpwgts(1)} then {
+ debug "tpwgts(1)=$tpwgts(1)";
+ break;
+ }
- #search for the not visited neighbors, and attach them to the queue
- if {[info exists nneighbour($i)]} then {
- foreach ngb $nneighbour($i) {
- if {$visited($ngb) == 0} {
- set visited($ngb) 1;
- lappend queue $ngb;
- };#if
- };#foreach
- }
-
- };#while
+ #search for the not visited neighbors, and attach them to the queue
+ if {[info exists nneighbour($i)]} then {
+ foreach ngb $nneighbour($i) {
+ if {$visited($ngb) == 0} {
+ set visited($ngb) 1;
+ lappend queue $ngb;
+ };#if
+ };#foreach
+ }
+
+ };#while
- array set pwgts2 {};
- set pwgts2(0) 0;
- set pwgts2(1) 0;
+ array set pwgts2 {};
+ set pwgts2(0) 0;
+ set pwgts2(1) 0;
- #calculate ID and ED for each vertex
- for {set i 0} {$i < $nvertices} {incr i} {
- set part_id($i) 0;
- set part_ed($i) 0;
+ #calculate ID and ED for each vertex
+ for {set i 0} {$i < $nvertices} {incr i} {
+ set part_id($i) 0;
+ set part_ed($i) 0;
- set curr_partition $part_partition($i);
- incr pwgts2($curr_partition) $nweight($i);
+ set curr_partition $part_partition($i);
+ incr pwgts2($curr_partition) $nweight($i);
- # calculates the sum of the edge weights of the adjacent vertices of i
- if {[info exists nneighbour($i)]} then {
- foreach ngb $nneighbour($i) {
- if {$curr_partition == $part_partition($ngb)} then {
+ # calculates the sum of the edge weights of the adjacent vertices of i
+ if {[info exists nneighbour($i)]} then {
+ foreach ngb $nneighbour($i) {
+ if {$curr_partition == $part_partition($ngb)} then {
# vertice in the same partition
incr part_id($i) $eweight([getEdgeBetween $i $ngb earray]);
- } else {
+ } else {
# vertice in a different partition
incr part_ed($i) $eweight([getEdgeBetween $i $ngb earray]);
- };#if-else
- };#foreach
+ };#if-else
+ };#foreach
- if {$part_ed($i) > 0 || [llength $nneighbour($i)] == 0} then { ;#vanjski node, ili nema susjeda
- incr part_mincut $part_ed($i);
- lappend part_boundary $i;
- }
- }
- }
+ if {$part_ed($i) > 0 || [llength $nneighbour($i)] == 0} then {
+ #vanjski node, ili nema susjeda
+ incr part_mincut $part_ed($i);
+ lappend part_boundary $i;
+ }
+ }
+ }
- set part_mincut [expr {$part_mincut / 2}];
- set sum 0;
- debug "init part: part_mincut=$part_mincut";
- for {set k 0} {$k < $nvertices} {incr k} {
- incr sum $nweight($k);
- }
+ set part_mincut [expr {$part_mincut / 2}];
+ set sum 0;
+ debug "init part: part_mincut=$part_mincut";
+ for {set k 0} {$k < $nvertices} {incr k} {
+ incr sum $nweight($k);
+ }
- if {$pwgts2(0) + $pwgts2(1) != $sum} {
+ if {$pwgts2(0) + $pwgts2(1) != $sum} {
error "refine: partition weigth wrong!";
- }
+ }
- #balance the graph
- balance $nvertices nneighbour nweight earray eweight tpwgts 4;
- # edge - based FM refinement
- FMRefinement $nvertices nneighbour nweight earray eweight tpwgts 4;
+ #balance the graph
+ balance $nvertices nneighbour nweight earray eweight tpwgts 4;
+ # edge - based FM refinement
+ FMRefinement $nvertices nneighbour nweight earray eweight tpwgts 4;
- #save the partitions if better then current saved
- if {$bestcut > $part_mincut} then {
- set bestcut $part_mincut;
- set bestboundary $part_boundary;
- set bestpwgts(0) $part_pwgts(0);
- set bestpwgts(1) $part_pwgts(1);
- for {set i 0} {$i < $nvertices} {incr i} {
+ #save the partitions if better then current saved
+ if {$bestcut > $part_mincut} then {
+ set bestcut $part_mincut;
+ set bestboundary $part_boundary;
+ set bestpwgts(0) $part_pwgts(0);
+ set bestpwgts(1) $part_pwgts(1);
+ for {set i 0} {$i < $nvertices} {incr i} {
set bestpartitions($i) $part_partition($i); #save the best partitions
set bestid($i) $part_id($i);
set bested($i) $part_ed($i);
- }
- if {$part_mincut == 0} then {
+ }
+ if {$part_mincut == 0} then {
break;
+ }
}
-
}
- }
-
- #save to globals the best found partitions
- set part_mincut $bestcut;
- set part_boundary $bestboundary;
- set part_pwgts(0) $bestpwgts(0);
- set part_pwgts(1) $bestpwgts(1);
- for {set i 0} {$i < $nvertices} {incr i} {
+
+ #save to globals the best found partitions
+ set part_mincut $bestcut;
+ set part_boundary $bestboundary;
+ set part_pwgts(0) $bestpwgts(0);
+ set part_pwgts(1) $bestpwgts(1);
+ for {set i 0} {$i < $nvertices} {incr i} {
set part_partition($i) $bestpartitions($i);
set part_id($i) $bestid($i);
set part_ed($i) $bested($i);
- }
+ }
}
#****f* graph_partitioning.tcl/balance
# * npasses -- number of swap tries
#****
proc balance {nvertices node_neighbour node_weight edge_array edge_weight tpart_wgts npasses} {
- global part_pwgts;
- global part_partition;
- global part_boundary;
- global part_id;
- global part_ed;
- global part_mincut;
+ global part_pwgts;
+ global part_partition;
+ global part_boundary;
+ global part_id;
+ global part_ed;
+ global part_mincut;
- upvar $node_neighbour nneighbour;
- upvar $node_weight nweight;
- upvar $edge_array earray;
- upvar $edge_weight eweight;
- upvar $tpart_wgts tpwgts;
-
-
- set move_from -1;
- set move_to -1;
-
- #there is no boundary nodes
- if {[llength $part_boundary] == 0} then {
- return;
- }
-
- # chose the the bigger partition to move from
- if {($tpwgts(0) - $part_pwgts(0)) < ($tpwgts(1) - $part_pwgts(1))} then {
- set move_from 0;
- set move_to 1;
- } else {
- set move_from 1;
- set move_to 0;
- }
-
- #prority queue
- array set queue {};
-
- #put all boundary nodes from move_from partition into queue
- for {set i 0} {$i < [llength $part_boundary]} {incr i} {
- set b [lindex $part_boundary $i];
- if {$part_partition($b) == $move_from} then {
- set b_gain [expr {$part_ed($b) - $part_id($b)}];
- push queue($move_from) "$b $b_gain";
+ upvar $node_neighbour nneighbour;
+ upvar $node_weight nweight;
+ upvar $edge_array earray;
+ upvar $edge_weight eweight;
+ upvar $tpart_wgts tpwgts;
+
+ set move_from -1;
+ set move_to -1;
+
+ #there is no boundary nodes
+ if {[llength $part_boundary] == 0} then {
+ return;
}
- }
- # set all vertices free to move
- for {set i 0} {$i < $nvertices} {incr i} {
- set moved($i) -1;
- }
+ # chose the the bigger partition to move from
+ if {($tpwgts(0) - $part_pwgts(0)) < ($tpwgts(1) - $part_pwgts(1))} then {
+ set move_from 0;
+ set move_to 1;
+ } else {
+ set move_from 1;
+ set move_to 0;
+ }
+ #prority queue
+ array set queue {};
- for {set pass 0} {$pass < $npasses} {incr pass} {
- # doesn't exists, if nodes are not connected
- if {![info exists queue($move_from)]} then {
- break;
+ #put all boundary nodes from move_from partition into queue
+ for {set i 0} {$i < [llength $part_boundary]} {incr i} {
+ set b [lindex $part_boundary $i];
+ if {$part_partition($b) == $move_from} then {
+ set b_gain [expr {$part_ed($b) - $part_id($b)}];
+ push queue($move_from) "$b $b_gain";
+ }
}
- # chose the node with the highest gain
- set hi_gain [pop queue($move_from)];
- if {$hi_gain == ""} {
- debug "queue($move_from) empty.";
- break;
+ # set all vertices free to move
+ for {set i 0} {$i < $nvertices} {incr i} {
+ set moved($i) -1;
}
+
+
+ for {set pass 0} {$pass < $npasses} {incr pass} {
+ # doesn't exists, if nodes are not connected
+ if {![info exists queue($move_from)]} then {
+ break;
+ }
+
+ # chose the node with the highest gain
+ set hi_gain [pop queue($move_from)];
+ if {$hi_gain == ""} {
+ debug "queue($move_from) empty.";
+ break;
+ }
- #if the size of the partition, in which the node should be moved is to small
- #dont move it
- if {$part_pwgts($move_to) + $nweight($hi_gain) > $tpwgts($move_to)} then {
- break;
- }
+ #if the size of the partition, in which the node should be moved
+ #is to small, dont move it
+ if {$part_pwgts($move_to) + $nweight($hi_gain) > $tpwgts($move_to)} then {
+ break;
+ }
- #update partitions weight
- incr part_pwgts($move_from) [expr {-$nweight($hi_gain)}];
- incr part_pwgts($move_to) $nweight($hi_gain);
+ #update partitions weight
+ incr part_pwgts($move_from) [expr {-$nweight($hi_gain)}];
+ incr part_pwgts($move_to) $nweight($hi_gain);
- set part_partition($hi_gain) $move_to;
+ set part_partition($hi_gain) $move_to;
- #all the "extern" links are now "intern", and umgekehrt
- set tmp $part_ed($hi_gain);
- set part_ed($hi_gain) $part_id($hi_gain);
- set part_id($hi_gain) $tmp;
-
- #if it's no more boundary node
- if {$part_ed($hi_gain) == 0} then {
- #remove it from the bndy list
- set bndy [lreplace $part_boundary [lsearch $part_boundary $hi_gain] [lsearch $part_boundary $hi_gain]];
- }
+ #all the "extern" links are now "intern", and umgekehrt
+ set tmp $part_ed($hi_gain);
+ set part_ed($hi_gain) $part_id($hi_gain);
+ set part_id($hi_gain) $tmp;
+
+ #if it's no more boundary node
+ if {$part_ed($hi_gain) == 0} then {
+ #remove it from the bndy list
+ set bndy [lreplace $part_boundary [lsearch $part_boundary $hi_gain] [lsearch $part_boundary $hi_gain]];
+ }
- #update part_id, part_ed values
- # go throught all neighbours of node "hi_gain"
- if {[info exists nneighbour($hi_gain)]} then {
- foreach ngb $nneighbour($hi_gain) {
- set is_bnd_node $part_ed($ngb); #if the value is > 0, it is a boundary node
- set edgeBetween [getEdgeBetween $hi_gain $ngb earray];
- if {$part_partition($ngb) == $move_to} then {
- incr part_id($ngb) $eweight($edgeBetween);
- incr part_ed($ngb) -$eweight($edgeBetween);
- } else {
- incr part_ed($ngb) $eweight($edgeBetween);
- incr part_id($ngb) -$eweight($edgeBetween);
- }
+ #update part_id, part_ed values
+ # go throught all neighbours of node "hi_gain"
+ if {[info exists nneighbour($hi_gain)]} then {
+ foreach ngb $nneighbour($hi_gain) {
+ set is_bnd_node $part_ed($ngb); #if the value is > 0, it is a boundary node
+ set edgeBetween [getEdgeBetween $hi_gain $ngb earray];
+ if {$part_partition($ngb) == $move_to} then {
+ incr part_id($ngb) $eweight($edgeBetween);
+ incr part_ed($ngb) -$eweight($edgeBetween);
+ } else {
+ incr part_ed($ngb) $eweight($edgeBetween);
+ incr part_id($ngb) -$eweight($edgeBetween);
+ }
- if {$is_bnd_node > 0} then {
- #node "ngb" is no longer an boundary node
- if {$part_ed($ngb) == 0} then {
- #remove it from the boundary list
- set part_boundary [lreplace $part_boundary [lsearch $part_boundary $ngb] [lsearch $part_boundary $ngb]];
- if {$moved($ngb) == -1 && ($part_partition($ngb)==$move_from)} then {
- #if not moved -> remove it from the queue
- removeFromQueue queue($part_partition($ngb)) $ngb;
- }
- } else {
- #if it wasn't been moved, update it in queue
- if {$moved($ngb) == -1 && ($part_partition($ngb) == $move_from)} then {
- removeFromQueue queue($part_partition($ngb)) $ngb;
- set new_gain [expr {$part_ed($ngb) - $part_id($ngb)}];
- push queue($part_partition($ngb)) "$ngb $new_gain";
- }
+ if {$is_bnd_node > 0} then {
+ #node "ngb" is no longer an boundary node
+ if {$part_ed($ngb) == 0} then {
+ #remove it from the boundary list
+ set part_boundary [lreplace $part_boundary [lsearch $part_boundary $ngb] [lsearch $part_boundary $ngb]];
+ if {$moved($ngb) == -1 && ($part_partition($ngb)==$move_from)} then {
+ #if not moved -> remove it from the queue
+ removeFromQueue queue($part_partition($ngb)) $ngb;
+ }
+ } else {
+ #if it wasn't been moved, update it in queue
+ if {$moved($ngb) == -1 && ($part_partition($ngb) == $move_from)} then {
+ removeFromQueue queue($part_partition($ngb)) $ngb;
+ set new_gain [expr {$part_ed($ngb) - $part_id($ngb)}];
+ push queue($part_partition($ngb)) "$ngb $new_gain";
+ }
+ }
+ } else {
+ #puts "not boundary node: $ngb";
+ if {$part_ed($ngb) > 0} then {
+ #new boundary node
+ lappend part_boundary $ngb;
+ #add it to the queue
+ if {$moved($ngb) == -1} then {
+ push queue($part_partition($ngb)) "$ngb [expr {$part_ed($ngb) - $part_id($ngb)}]";
+ }
+ }
+ }
}
- } else { ;#puts "not boundary node: $ngb";
- if {$part_ed($ngb) > 0} then { ;#new boundary node
- lappend part_boundary $ngb;
- #add it to the queue
- if {$moved($ngb) == -1} then {
- push queue($part_partition($ngb)) "$ngb [expr {$part_ed($ngb) - $part_id($ngb)}]";
- }
- }
}
- }
- }
- }
+ }
}
#****f* graph_partitioning.tcl/FMRefinement
# * npasses -- number of swap tries
#****
proc FMRefinement {nvertices node_neighbour node_weight edge_array edge_weight tpart_wgt npasses} {
- global part_pwgts;
- global part_partition;
- global part_boundary;
- global part_id;
- global part_ed;
- global part_mincut;
+ global part_pwgts;
+ global part_partition;
+ global part_boundary;
+ global part_id;
+ global part_ed;
+ global part_mincut;
- upvar $node_weight nweight;
- upvar $node_neighbour nneighbour;
- upvar $edge_array earray;
- upvar $edge_weight eweight;
- upvar $tpart_wgt tpwgts;
-
-
- array set queue {};
- array set bak_id {};
- array set bak_ed {};
- array set bak_part {};
- array set bak_pwgts {};
-
- set bak_bndy -1;
- set orig_diff [expr {abs ($tpwgts(0) - $part_pwgts(0))}];
- set avg1 [expr {($part_pwgts(0) + $part_pwgts(1)) / 20}];
- set avg2 [expr {2 * ($part_pwgts(0) + $part_pwgts(1)) / $nvertices}];
- if {$avg1 < $avg2} then {
- set avg_pwgt $avg1;
- } else {
- set avg_pwgt $avg2;
- }
+ upvar $node_weight nweight;
+ upvar $node_neighbour nneighbour;
+ upvar $edge_array earray;
+ upvar $edge_weight eweight;
+ upvar $tpart_wgt tpwgts;
+
+ array set queue {};
+ array set bak_id {};
+ array set bak_ed {};
+ array set bak_part {};
+ array set bak_pwgts {};
+
+ set bak_bndy -1;
+ set orig_diff [expr {abs ($tpwgts(0) - $part_pwgts(0))}];
+ set avg1 [expr {($part_pwgts(0) + $part_pwgts(1)) / 20}];
+ set avg2 [expr {2 * ($part_pwgts(0) + $part_pwgts(1)) / $nvertices}];
+ if {$avg1 < $avg2} then {
+ set avg_pwgt $avg1;
+ } else {
+ set avg_pwgt $avg2;
+ }
- set swap_limit [expr {int(0.01 * $nvertices)}];
- if {$swap_limit < 15} then {
- set swap_limit 15;
- }
+ set swap_limit [expr {int(0.01 * $nvertices)}];
+ if {$swap_limit < 15} then {
+ set swap_limit 15;
+ }
- #pamti najbolju kombinaciju
- set bak_bndy $part_boundary;
- for {set i 0} {$i < $nvertices} {incr i} {
- set bak_part($i) $part_partition($i);
- set bak_id($i) $part_id($i);
- set bak_ed($i) $part_ed($i);
- }
- set bak_pwgts(0) $part_pwgts(0);
- set bak_pwgts(1) $part_pwgts(1);
+ #pamti najbolju kombinaciju
+ set bak_bndy $part_boundary;
+ for {set i 0} {$i < $nvertices} {incr i} {
+ set bak_part($i) $part_partition($i);
+ set bak_id($i) $part_id($i);
+ set bak_ed($i) $part_ed($i);
+ }
+ set bak_pwgts(0) $part_pwgts(0);
+ set bak_pwgts(1) $part_pwgts(1);
- # set all vertices free to move
- for {set i 0} {$i < $nvertices} {incr i} {
- set moved($i) -1;
- }
+ # set all vertices free to move
+ for {set i 0} {$i < $nvertices} {incr i} {
+ set moved($i) -1;
+ }
- for {set pass 0} {$pass < $npasses} {incr pass} {
- #set all variables to their's initial values
- set bndy $part_boundary;
- set newcut $part_mincut;
- set mincut $part_mincut;
- set min_diff [expr {abs ($tpwgts(0) - $part_pwgts(0))}];
+ for {set pass 0} {$pass < $npasses} {incr pass} {
+ #set all variables to their's initial values
+ set bndy $part_boundary;
+ set newcut $part_mincut;
+ set mincut $part_mincut;
+ set min_diff [expr {abs ($tpwgts(0) - $part_pwgts(0))}];
- for {set i 0} {$i < 2} {incr i} {
- set pwgts($i) $part_pwgts($i);
- set queue($i) "";
- }
+ for {set i 0} {$i < 2} {incr i} {
+ set pwgts($i) $part_pwgts($i);
+ set queue($i) "";
+ }
- for {set i 0} {$i < $nvertices} {incr i} {
- set part($i) $part_partition($i);
- set id($i) $part_id($i);
- set ed($i) $part_ed($i);
- }
-
- # insert boundary nodes in the priority queue
- set permList [makePermArray bndy];
- array set permArray $permList;
- set mincutorder -1;
+ for {set i 0} {$i < $nvertices} {incr i} {
+ set part($i) $part_partition($i);
+ set id($i) $part_id($i);
+ set ed($i) $part_ed($i);
+ }
- for {set i 0} {$i < [array size permArray]} {incr i} {
- set node $permArray($i);
- #calculate the node's gain
- set node_gain [expr {$ed($node) - $id($node)}];
- # push in the queue 0 or 1 (depends in which partition node is) the node and its gain
- push queue($part($node)) "$node $node_gain";
- };#foreach
+ # insert boundary nodes in the priority queue
+ set permList [makePermArray bndy];
+ array set permArray $permList;
+ set mincutorder -1;
+
+ for {set i 0} {$i < [array size permArray]} {incr i} {
+ set node $permArray($i);
+ #calculate the node's gain
+ set node_gain [expr {$ed($node) - $id($node)}];
+ # push in the queue 0 or 1 (depends in which partition node is) the node and its gain
+ push queue($part($node)) "$node $node_gain";
+ };#foreach
- # chose the best-gain move
- for {set nswaps 0} {$nswaps < $nvertices} {incr nswaps} {
- debug "nswaps=$nswaps";
- # chose the node from the bigger partition to move to the smaller
- if {($tpwgts(0) - $pwgts(0)) < ($tpwgts(1) - $pwgts(1))} then {
- set move_from 0;
- set move_to 1;
- } else {
- set move_from 1;
- set move_to 0;
- }
+ # chose the best-gain move
+ for {set nswaps 0} {$nswaps < $nvertices} {incr nswaps} {
+ debug "nswaps=$nswaps";
+ # chose the node from the bigger partition to move to the smaller
+ if {($tpwgts(0) - $pwgts(0)) < ($tpwgts(1) - $pwgts(1))} then {
+ set move_from 0;
+ set move_to 1;
+ } else {
+ set move_from 1;
+ set move_to 0;
+ }
- # chose the node with the highest gain
- set hi_gain [pop queue($move_from)];
- if {$hi_gain == ""} {
+ # chose the node with the highest gain
+ set hi_gain [pop queue($move_from)];
+ if {$hi_gain == ""} {
break;
- }
+ }
- # update the cut and partitions weight
- set newcut [expr {$newcut - $ed($hi_gain) + $id($hi_gain)}];
- incr pwgts($move_from) [expr {-$nweight($hi_gain)}];
- incr pwgts($move_to) $nweight($hi_gain);
+ # update the cut and partitions weight
+ set newcut [expr {$newcut - $ed($hi_gain) + $id($hi_gain)}];
+ incr pwgts($move_from) [expr {-$nweight($hi_gain)}];
+ incr pwgts($move_to) $nweight($hi_gain);
- #check if the new cut better is than the old one
- set new_diff [expr {abs ($tpwgts(0) - $pwgts(0))}];
- if {($newcut < $mincut) && ($new_diff <= $orig_diff + $avg_pwgt) ||
+ #check if the new cut better is than the old one
+ set new_diff [expr {abs ($tpwgts(0) - $pwgts(0))}];
+ if {($newcut < $mincut) && ($new_diff <= $orig_diff + $avg_pwgt) ||
($newcut == $mincut) && ($new_diff < $min_diff)} then {
set mincutorder $nswaps;
set mincut $newcut;
set min_diff $new_diff;
- } elseif {$nswaps - $mincutorder > $swap_limit} {
+ } elseif {$nswaps - $mincutorder > $swap_limit} {
incr newcut [expr {$ed($hi_gain) - $id($hi_gain)}];
incr pwgts($move_to) [expr {-$nweight($hi_gain)}];
incr pwgts($move_from) $nweight($hi_gain);
break;
- }
+ }
- #move node to the other partion
- set part($hi_gain) $move_to;
- set moved($hi_gain) $nswaps;
- set swaps($nswaps) $hi_gain;
-
- #all the "extern" links are now "intern", and reverse
- set tmp $ed($hi_gain);
- set ed($hi_gain) $id($hi_gain);
- set id($hi_gain) $tmp;
-
- #if it's no more boundary node
- if {$ed($hi_gain) == 0} then {
+ #move node to the other partion
+ set part($hi_gain) $move_to;
+ set moved($hi_gain) $nswaps;
+ set swaps($nswaps) $hi_gain;
+
+ #all the "extern" links are now "intern", and reverse
+ set tmp $ed($hi_gain);
+ set ed($hi_gain) $id($hi_gain);
+ set id($hi_gain) $tmp;
+
+ #if it's no more boundary node
+ if {$ed($hi_gain) == 0} then {
#remove it from the bndy list
set bndy [lreplace $bndy [lsearch $bndy $hi_gain] [lsearch $bndy $hi_gain]];
- }
+ }
- #update ID, ED values
- # go throught all neighbours of node "hi_gain"
- if {[info exists nneighbour($hi_gain)]} then {
+ #update ID, ED values
+ # go throught all neighbours of node "hi_gain"
+ if {[info exists nneighbour($hi_gain)]} then {
foreach ngb $nneighbour($hi_gain) {
- set is_bnd_node $ed($ngb); #if the value is > 0, it is a boundary node
- set edgeBetween [getEdgeBetween $hi_gain $ngb earray];
- if {$part($ngb) == $move_to} then {
+ set is_bnd_node $ed($ngb); #if the value is > 0, it is a boundary node
+ set edgeBetween [getEdgeBetween $hi_gain $ngb earray];
+ if {$part($ngb) == $move_to} then {
incr id($ngb) $eweight($edgeBetween);
incr ed($ngb) -$eweight($edgeBetween);
- } else {
+ } else {
incr ed($ngb) $eweight($edgeBetween);
incr id($ngb) -$eweight($edgeBetween);
- }
- if {$is_bnd_node > 0} then {
- #node "ngb" is no longer an boundary node
+ }
+ if {$is_bnd_node > 0} then {
+ #node "ngb" is no longer an boundary node
if {$ed($ngb) == 0} then {
- #remove it from the boundary list
- set bndy [lreplace $bndy [lsearch $bndy $ngb] [lsearch $bndy $ngb]];
- if {$moved($ngb) == -1} then {
- #if not moved -> remove it from the queue
- removeFromQueue queue($part($ngb)) $ngb;
- }
+ #remove it from the boundary list
+ set bndy [lreplace $bndy [lsearch $bndy $ngb] [lsearch $bndy $ngb]];
+ if {$moved($ngb) == -1} then {
+ #if not moved -> remove it from the queue
+ removeFromQueue queue($part($ngb)) $ngb;
+ }
} else {
- #if it wasn't been moved, update it in queue
- if {$moved($ngb) == -1} then {
- removeFromQueue queue($part($ngb)) $ngb;
+ #if it wasn't been moved, update it in queue
+ if {$moved($ngb) == -1} then {
+ removeFromQueue queue($part($ngb)) $ngb;
set new_gain [expr {$ed($ngb) - $id($ngb)}];
push queue($part($ngb)) "$ngb $new_gain";
+ }
}
- }
- } else { ;#puts "not boundary node: $ngb";
+ } else {
+ #puts "not boundary node: $ngb";
if {$ed($ngb) > 0} then { ;#new boundary node
- lappend bndy $ngb;
- #add it to the queue
- if {$moved($ngb) == -1} then {
- push queue($part($ngb)) "$ngb [expr {$ed($ngb) - $id($ngb)}]";
- }
+ lappend bndy $ngb;
+ #add it to the queue
+ if {$moved($ngb) == -1} then {
+ push queue($part($ngb)) "$ngb [expr {$ed($ngb) - $id($ngb)}]";
+ }
}
+ }
}
+ }
+
+ if {$mincutorder > -1} then {
+ set mincutorder -1;
+ set mincut $newcut;
+ set bak_bndy $bndy;
+ for {set j 0} {$j < $nvertices} {incr j} {
+ set bak_id($j) $id($j);
+ set bak_ed($j) $ed($j);
+ set bak_part($j) $part($j);
}
- }
- if {$mincutorder > -1} then {
- set mincutorder -1;
- set mincut $newcut;
- set bak_bndy $bndy;
- for {set j 0} {$j < $nvertices} {incr j} {
- set bak_id($j) $id($j);
- set bak_ed($j) $ed($j);
- set bak_part($j) $part($j);
- }
- set bak_pwgts(0) $pwgts(0);
- set bak_pwgts(1) $pwgts(1);
- }
- };#inner loop
- };#outer loop
-
- #save the best partitions
- set part_mincut $mincut;
- set part_boundary $bak_bndy;
- for {set i 0} {$i < $nvertices} {incr i} {
- set part_partition($i) $bak_part($i);
- set part_id($i) $bak_id($i);
- set part_ed($i) $bak_ed($i);
- }
- set part_pwgts(0) $bak_pwgts(0);
- set part_pwgts(1) $bak_pwgts(1);
+ set bak_pwgts(0) $pwgts(0);
+ set bak_pwgts(1) $pwgts(1);
+ }
+ };#inner loop
+ };#outer loop
+
+ #save the best partitions
+ set part_mincut $mincut;
+ set part_boundary $bak_bndy;
+ for {set i 0} {$i < $nvertices} {incr i} {
+ set part_partition($i) $bak_part($i);
+ set part_id($i) $bak_id($i);
+ set part_ed($i) $bak_ed($i);
+ }
+ set part_pwgts(0) $bak_pwgts(0);
+ set part_pwgts(1) $bak_pwgts(1);
}
#****f* graph_partitioning.tcl/project2waypartition
# * cnvw -- array of node weights in coarse graph
#****
proc project2waypartition {nvertices edge_array edge_weight node_neighbour node_map node_weight cnv cnvw} {
- global part_pwgts;
- global part_mincut;
- global part_partition;
- global part_id;
- global part_ed;
- global part_boundary;
+ global part_pwgts;
+ global part_mincut;
+ global part_partition;
+ global part_id;
+ global part_ed;
+ global part_boundary;
- upvar $cnvw cnw;
- upvar $node_weight nweight;
- upvar $edge_array earray;
- upvar $edge_weight eweight;
- upvar $node_neighbour nneighbour;
- upvar $node_map nmap;
-
- array set part_ed {};
- array set part_id {};
- set part_boundary "";
- array set pwgts2 {};
+ upvar $cnvw cnw;
+ upvar $node_weight nweight;
+ upvar $edge_array earray;
+ upvar $edge_weight eweight;
+ upvar $node_neighbour nneighbour;
+ upvar $node_map nmap;
+
+ array set part_ed {};
+ array set part_id {};
+ set part_boundary "";
+ array set pwgts2 {};
- #sum the weight of nodes in finer graph
- set n 0; set p 0;
- for {set i 0} {$i < $nvertices} {incr i} {
- incr n $nweight($i);
- }
- #sum the weight of nodes in coarsed graph
- for {set i 0} {$i < $cnv} {incr i} {
- incr p $cnw($i);
- }
-
- #get partition for each vertex in finer graph
- for {set i 0} {$i < $nvertices} {incr i} {
- set cnode $nmap($i); #get the node in coarsed graph which corresponse to the node in finer graph
- set partition($i) $part_partition($cnode); #get it's partition too
- set part_ed($i) 0;
- set part_id($i) 0;
- set pwgts2(0) 0;
- set pwgts2(1) 0;
-}
+ #sum the weight of nodes in finer graph
+ set n 0; set p 0;
+ for {set i 0} {$i < $nvertices} {incr i} {
+ incr n $nweight($i);
+ }
+ #sum the weight of nodes in coarsed graph
+ for {set i 0} {$i < $cnv} {incr i} {
+ incr p $cnw($i);
+ }
- #calculate ID and ED
- for {set i 0} {$i < $nvertices} {incr i} {
+ #get partition for each vertex in finer graph
+ for {set i 0} {$i < $nvertices} {incr i} {
+ set cnode $nmap($i); #get the node in coarsed graph which corresponse to the node in finer graph
+ set partition($i) $part_partition($cnode); #get it's partition too
+ set part_ed($i) 0;
+ set part_id($i) 0;
+ set pwgts2(0) 0;
+ set pwgts2(1) 0;
+ }
+
+ #calculate ID and ED
+ for {set i 0} {$i < $nvertices} {incr i} {
if {![info exists nneighbour($i)] || [llength $nneighbour($i)] == 0} then {
- lappend part_boundary $i;
+ lappend part_boundary $i;
} else {
- foreach ngb $nneighbour($i) {
- if {$partition($ngb) == $partition($i)} then {
- incr part_id($i) $eweight([getEdgeBetween $i $ngb earray]); #mogu uzeti stare tezine - posto iste
- #incr id($ngb) $eweight([...]);
- } else {
- incr part_ed($i) $eweight([getEdgeBetween $i $ngb earray]);
- #incr ed($ngb) $eweight([...]);
- }
- };#foreach
-
- if {[expr $part_ed($i) > 0 || [llength $nneighbour($i)] == 0]} then {
- lappend part_boundary $i;
+ foreach ngb $nneighbour($i) {
+ if {$partition($ngb) == $partition($i)} then {
+ incr part_id($i) $eweight([getEdgeBetween $i $ngb earray]); #mogu uzeti stare tezine - posto iste
+ #incr id($ngb) $eweight([...]);
+ } else {
+ incr part_ed($i) $eweight([getEdgeBetween $i $ngb earray]);
+ #incr ed($ngb) $eweight([...]);
}
+ };#foreach
+
+ if {[expr $part_ed($i) > 0 || [llength $nneighbour($i)] == 0]} then {
+ lappend part_boundary $i;
+ }
}
set part_partition($i) $partition($i);
incr pwgts2($partition($i)) $nweight($i);
# * snode_map_help -- help variable, needed for later connecting, in this procedure disconnected graphs
#****
proc splitGraph {nvertices node_neighbour node_weight edge_array edge_weight snode_neighbour snode_weight sedge_array sedge_weight snode_map sn_vtxs sn_edges snode_map_help} {
- global part_partition;
-
- upvar $node_neighbour nneighbour;
- upvar $node_weight nweight;
- upvar $edge_array earray;
- upvar $edge_weight eweight;
- upvar $snode_neighbour snneighbour;
- upvar $snode_weight snweight;
- upvar $sedge_array searray;
- upvar $sedge_weight seweight;
- upvar $snode_map snmap;
- upvar $snode_map_help snmap_h;
- upvar $sn_vtxs snvtxs;
- upvar $sn_edges snedges;
-
- array set sum_np {};
- set sum_np(0) 0;
- set sum_np(1) 0;
-
- array set auxn {};
- array set auxw {};
-
- #sets variables needed later for connecting the splited graph
- for {set i 0} {$i < $nvertices} {incr i} {
+ global part_partition;
+
+ upvar $node_neighbour nneighbour;
+ upvar $node_weight nweight;
+ upvar $edge_array earray;
+ upvar $edge_weight eweight;
+ upvar $snode_neighbour snneighbour;
+ upvar $snode_weight snweight;
+ upvar $sedge_array searray;
+ upvar $sedge_weight seweight;
+ upvar $snode_map snmap;
+ upvar $snode_map_help snmap_h;
+ upvar $sn_vtxs snvtxs;
+ upvar $sn_edges snedges;
+
+ array set sum_np {};
+ set sum_np(0) 0;
+ set sum_np(1) 0;
+
+ array set auxn {};
+ array set auxw {};
+
+ #sets variables needed later for connecting the splited graph
+ for {set i 0} {$i < $nvertices} {incr i} {
set p $part_partition($i);
set snmap($p,$i) $snvtxs($p);
set snmap_h($p,$snvtxs($p)) $i;
incr snvtxs($p);
- }
-
- #split the graph
- for {set i 0} {$i < $nvertices} {incr i} {
- set p_i $part_partition($i);
- set s_i $snmap($p_i,$i);
- set sum 0;
-
- if {[info exists nneighbour($i)]} then {
- foreach ngb $nneighbour($i) {
- set p $part_partition($ngb);
- if {$p == $p_i} then {
- set twin 0;
- set sngb $snmap($p_i,$ngb);
- lappend snneighbour($p_i,$s_i) $sngb;
- for {set a 0} {$a < $snedges($p_i)} {incr a} {
- if {$searray($p_i,$a) == "$s_i $sngb" || $searray($p_i,$a) == "$sngb $s_i"} then {
- set twin 1;
- break;
- }
- }
- if {$twin == 0} then {
- set searray($p_i,$snedges($p_i)) "$s_i $sngb";
- set seweight($p_i,$snedges($p_i)) $eweight([getEdgeBetween $i $ngb earray]);
- incr snedges($p_i);
- }
- incr sum $nweight($ngb);
- } else {
- incr sum [expr {-$nweight($ngb)}]
- }
+ }
- };#foreach
-}
+ #split the graph
+ for {set i 0} {$i < $nvertices} {incr i} {
+ set p_i $part_partition($i);
+ set s_i $snmap($p_i,$i);
+ set sum 0;
+
+ if {[info exists nneighbour($i)]} then {
+ foreach ngb $nneighbour($i) {
+ set p $part_partition($ngb);
+ if {$p == $p_i} then {
+ set twin 0;
+ set sngb $snmap($p_i,$ngb);
+ lappend snneighbour($p_i,$s_i) $sngb;
+ for {set a 0} {$a < $snedges($p_i)} {incr a} {
+ if {$searray($p_i,$a) == "$s_i $sngb" || $searray($p_i,$a) == "$sngb $s_i"} then {
+ set twin 1;
+ break;
+ }
+ }
+ if {$twin == 0} then {
+ set searray($p_i,$snedges($p_i)) "$s_i $sngb";
+ set seweight($p_i,$snedges($p_i)) $eweight([getEdgeBetween $i $ngb earray]);
+ incr snedges($p_i);
+ }
+ incr sum $nweight($ngb);
+ } else {
+ incr sum [expr {-$nweight($ngb)}]
+ }
+ };#foreach
+ }
set snweight($p_i,$s_i) $nweight($i);
set sadjwgtsum($p_i,$s_i)) $sum;
- }
-
+ }
}
-
-
-#####################PROCEDURES ##########################
-
#****f* graph_partitioning.tcl/sum_array
# NAME
# sum_array
# * sum -- the sum of first "end" numbers
#****
proc sum_array {end arr} {
- upvar 1 $arr a;
- set sum 0.0;
+ upvar 1 $arr a;
+ set sum 0.0;
- for {set i 0} {$i < $end} {incr i} {
+ for {set i 0} {$i < $end} {incr i} {
set sum [expr {$sum + $a($i)}];
- }
+ }
- return $sum;
+ return $sum;
}
#****f* graph_partitioning.tcl/mult_array
# *
#****
proc mult_array {start end arr prod} {
- upvar 1 $arr a;
- for {set i $start} {$i < $end} {incr i} {
- set a($i) [expr {$a($i) * $prod }];
- }
+ upvar 1 $arr a;
+ for {set i $start} {$i < $end} {incr i} {
+ set a($i) [expr {$a($i) * $prod }];
+ }
}
#****f* graph_partitioning.tcl/makePermList
# * list -- permuted list
#****
proc makePermList {num} {
- array set permList "";
+ array set permList "";
- for {set i 0} {$i < $num} {incr i} {
- set permList($i) $i;
- }
+ for {set i 0} {$i < $num} {incr i} {
+ set permList($i) $i;
+ }
- if {$num > 4} {
+ if {$num > 4} {
for {set i 0} {$i < $num} {incr i 16} {
- set rand1 [expr {int(rand() * ($num - 4))}]
- set rand2 [expr {int(rand() * ($num - 4))}]
+ set rand1 [expr {int(rand() * ($num - 4))}]
+ set rand2 [expr {int(rand() * ($num - 4))}]
- swap permList $rand1 $rand2;
- swap permList [expr $rand1+1] [expr $rand2+1];
- swap permList [expr $rand1+2] [expr $rand2+2];
- swap permList [expr $rand1+3] [expr $rand2+3];
+ swap permList $rand1 $rand2;
+ swap permList [expr $rand1+1] [expr $rand2+1];
+ swap permList [expr $rand1+2] [expr $rand2+2];
+ swap permList [expr $rand1+3] [expr $rand2+3];
}
- }
+ }
- return [array get permList];
+ return [array get permList];
}
#****f* graph_partitioning.tcl/makePermArray
# * list -- permuted list
#****
proc makePermArray {arr} {
- upvar $arr a;
- array set permList "";
- set a_size [llength $a];
- for {set i 0} {$i < $a_size} {incr i} {
- set permList($i) [lindex $a $i];
- }
-
- if {$a_size > 4} {
+ upvar $arr a;
+ array set permList "";
+ set a_size [llength $a];
+ for {set i 0} {$i < $a_size} {incr i} {
+ set permList($i) [lindex $a $i];
+ }
+
+ if {$a_size > 4} {
for {set i 0} {$i < $a_size} {incr i 16} {
- set rand1 [expr {int(rand() * ($a_size - 4))}]
- set rand2 [expr {int(rand() * ($a_size - 4))}]
+ set rand1 [expr {int(rand() * ($a_size - 4))}]
+ set rand2 [expr {int(rand() * ($a_size - 4))}]
- swap permList $rand1 $rand2;
- swap permList [expr $rand1+1] [expr $rand2+1];
- swap permList [expr $rand1+2] [expr $rand2+2];
- swap permList [expr $rand1+3] [expr $rand2+3];
+ swap permList $rand1 $rand2;
+ swap permList [expr $rand1+1] [expr $rand2+1];
+ swap permList [expr $rand1+2] [expr $rand2+2];
+ swap permList [expr $rand1+3] [expr $rand2+3];
}
- }
+ }
- return [array get permList];
+ return [array get permList];
}
#****f* graph_partitioning.tcl/swap
# * idx2 -- index of the second element
#****
proc swap {permArray idx1 idx2} {
- upvar $permArray rarray;
+ upvar $permArray rarray;
- set temp $rarray($idx1);
- set rarray($idx1) $rarray($idx2);
- set rarray($idx2) $temp;
+ set temp $rarray($idx1);
+ set rarray($idx1) $rarray($idx2);
+ set rarray($idx2) $temp;
}
#****f* graph_partitioning.tcl/getEdgeBetween
# * i -- index of the edge connecting the nodes, or null
#****
proc getEdgeBetween {node1 node2 edge_array} {
- upvar $edge_array earray;
- for {set i 0} {$i < [array size earray]} {incr i} {
+ upvar $edge_array earray;
+ for {set i 0} {$i < [array size earray]} {incr i} {
if {$earray($i) == "$node1 $node2" || $earray($i) == "$node2 $node1"} then {
- return $i;
- };#if
- };#foreach
+ return $i;
+ }
+ }
}
#****f* graph_partitioning.tcl/push
# * hi_elem -- element from the array
#****
proc pop {queue_name} {
- upvar 1 $queue_name queue;
-
- #sort items after priority
- set queue [lsort -integer -decreasing -index 1 $queue];
- set hi_ [lindex $queue 0];
- set hi_elem [lindex $hi_ 0];
- set queue [lrange $queue 1 end];
- return $hi_elem;
+ upvar 1 $queue_name queue;
+
+ #sort items after priority
+ set queue [lsort -integer -decreasing -index 1 $queue];
+ set hi_ [lindex $queue 0];
+ set hi_elem [lindex $hi_ 0];
+ set queue [lrange $queue 1 end];
+ return $hi_elem;
}
#****f* graph_partitioning.tcl/removeFromQueue
# * node -- node id
#****
proc removeFromQueue {queue_name node } {
- upvar 1 $queue_name queue;
+ upvar 1 $queue_name queue;
- foreach q $queue {
- set n [lindex $q 0];
- if {$n == $node} then {
- set node_idx [lsearch $queue $q];
- set queue [lreplace $queue $node_idx $node_idx];
- }
+ foreach q $queue {
+ set n [lindex $q 0];
+ if {$n == $node} then {
+ set node_idx [lsearch $queue $q];
+ set queue [lreplace $queue $node_idx $node_idx];
}
+ }
}
projects / imunes.git / commitdiff