#!perl
#**************************************************************************************#
#-------------------------------------------------------------------------------------#
# Optimization_new.pl
#-------------------------------------------------------------------------------------#
# This script is modifying the files for optimization (cases 1 to 5) with the new names (e.g. s01_01_arc)
# To run the script, four ways are available
# 1. No arguments : the script provide a list of the available sgf files to modify.
# the name of the modified file will be (name_of_original_file)_o.sgf
# 2. One argument : the name of the original file (the name of the modified file will be as above)
# 3. Two arguments : the name of the original file and the modified file
# (to overwrite the orginal file just put it twice as arguments)
# 4. Three arguments : same as before. The last argument can be either "-order" or "-copy"
# if "-order" is used only the ordering of elements is done
# if "-copy" is used only the copy of elements is done (Block OPTIMISATION_OBJECTS)
#
# Important : The model should not contain any container
#**************************************************************************************#
$|=10;
print "\n****** Beginning of the reprocessing of TC for optimisation ******\n";
PROCESS_ARGUMENTS: {
if ($#ARGV == 0) {
$file=$ARGV[0]; #the first and only argument is the name of the file to modify
$new_file = $file; #the name of the file to write the modified file in
$new_file =~ s%\.sgf%_o\.sgf%;
} elsif ($#ARGV == 1) { #two arguments, the first one being the initial file and the second one the name of the modified file
($file,$new_file) = ($ARGV[0],$ARGV[1]);
} elsif ($#ARGV == 2) { #three arguments, same as above and the third one should be "-tr"
unless ($ARGV[2] == ("-order"|"-copy")) {die "Error, 3rd argument should be \"-order\" or \"-copy\" or nothing \n";}
($file,$new_file,$operation) = @ARGV;
} elsif ($#ARGV > 2) { die "Too many arguments in the command line ($!)\n"; #if there are more than 3 arguments
} else {
my @list_sgf=glob "*.sgf";
print "\n** Please, enter the name of the file **\nThe available files are : \n","-"x 20,"\n";
$n_file=0; #the number to identify the file where the user can choose from
foreach (@list_sgf) {++$n_file;print "$n_file.: $_\n";}
print "-"x 20,"\nChoose the file you want as an argument: ";
$file = $list_sgf[<STDIN>-1];
$new_file = $file; #the name of the file to write the modified file in
$new_file =~ s%\.sgf%_o\.sgf%;
} #end of else
} #end of block PROCESS_ARGUMENTS
$log_file = $file; $log_file =~ s%(\w+)\.sgf%$1_optim.log%; #name of the log file
#open LOG, ">$log_file" or die "Error while opening log file $log_file ($!)\n"; #for_debug
ORDER_OBJECTS:{ ORDER_OBJECTS; #order by name of objects (lexical order) => to improve
if ($operation eq "-copy") {last ORDER_OBJECTS;} #the 3rd argument is -copy so no order will be made
print LOG "*"x 59,"\n","*"x 25," ORDER ","*"x 25,"\n","*"x 59,"\n"; #to print in the log file
open SGF, "<$file" or die "Error while opening $file ($!)\n";
print "-Opening of original file\n";
@temporary_file=(); #temporary buffer to copy in the file
%objects=(); #hash table with all the objects in the sgf
$line=0;
while (<SGF>) {
++$line;
# print "Line : $_"; #for_debug
if (/<node.*name="(.*)" type="(.*)" visible/) { #node different from synchronous layer
my $object_name=$1;my $type=$2; #define the type and the name
#print "*Hello, object_name: $object_name object_type: $type*\n"; #for_debug
if ($type =~ /container/) { die "Container object found ($!)\n"; #there shouldn't be any container in the model
} elsif ($type eq "synchronous_layer") {
print LOG "Synchronous Layer found (line $line)\n"; #for_debug
}else {
$spec_obj="$_"; #the specification of the object is reset to the first line read of the object
print LOG "Object found : $object_name (line $line)\n"; #for_debug
while (<SGF>) {
++$line;
$spec_obj=$spec_obj . "$_"; #we add the line in the temporary object
if (m%<\/node>%) { last;}#the end of the node is reached
#print "Line read ($line): $_"; #for_debug
} #end of while
$_=""; #we delete the content of the line
# print LOG "--$object_name--\n","*"x 70,"\n",$spec_obj,"\n"; #for_debug
$objects{$object_name}=$spec_obj;
#print "Temp object:",@temp_obj,"\n"; #for_debug
} #else {die "PROBLEM OF NODE ($!)\n";}#end of elsif
}elsif (m%<\/node>%) { #end of symbology layer => we put the objects in order
$line=$_; #copy the content of the line to copy it later
@objects_list=sort(keys %objects); #sort the objects in order
print LOG "**The sorted objects are:\n";foreach (@objects_list) {print LOG "$_\n";} #for_debug
foreach $obj (@objects_list) {push(@temporary_file,$objects{$obj});} #end of foreach object
$_=$line; #copy back the content of the line into $_
} #end of elsif
push(@temporary_file,$_);#copy the lines in the temporary file
} #end of while
open SGF_MODIF, ">$new_file" or die "Error while opening $new_file for modificiation ($!)\n";
print SGF_MODIF @temporary_file;print "**Save ordered sgf in $new_file\n"; #for_debug
print LOG "*"x 59,"\n","*"x 22," END OF ORDER ","*"x 23,"\n","*"x 59,"\n"; #to print in the log file
}#end of block ORDER_OBJECTS
OPTIMISATION_OBJECTS: { #last OPTIMISATION_OBJECTS;
if ($operation eq "-order") {last OPTIMISATION_OBJECTS;} #the 3rd argument is -order so no copy will be made
#print "\n\n","*"x 59,"\n","*"x 24," COPY-PASTE ","*"x 24,"\n","*"x 59,"\n"; #to print in the log file
if ($operation eq "-copy") { #if there is no ordering before
open SGF, "<$new_file" or die "Error while opening $new_file ($!)\n";
print "-Opening of original file\n";
}else {
close SGF_MODIF; #closing of the file is needed only if it has been used before
print "-Close the writing of the ordered sgf-\n-Open it again to read the content-\n";
open SGF, "<$new_file" or die "Error while opening $new_file ($!)\n"; #we take in this case the file ordered as an input
} #end of if/else
$temp_file=""; #temporary buffer
$temp_group=""; #temporary buffer for a group of objects (three sequences)
$line=0; #for the number of the line being read
$number=0; #the number of the object
READ: $read_line="";
while ($read_line = <SGF>) {
++$line; #increment the number of the line
if ($read_line =~ /<node.*name="(s(\d{2})[\w\-]+)" type="(.*)" visible/) {$object_name=$1;$n_seq=$2;last;}
$temp_file = $temp_file . $read_line;
#copy the line in the buffer file except if it's the one with the first object of the first sequence
unless (defined ($read_line)) {
die "No sequence found (line $line)\n"; } # if the end of the file is not reached
} #end of until : first object of the first sequence has been found
# print "At line $line, we have read this text so far:\n $temp_file"; #for_debug
# print "First object $object_name: found line $line (sequence $n_seq) \n"; #for_debug
#print "Read line: $read_line"; #for_debug
OBJECTS: {if ($n_seq =~ /(01|04|07|10|13)/) { #the sequences being used as models
$temp_seq = "$read_line"; #reset the buffer for the sequence with the value of the line just found
while ($read_line = <SGF>) {
++$line;
#print $read_line; #for_debug
if (($read_line =~ /<node name=\"(s(\d+)_\d+_[\w\-]+)\"/)and($2 > $n_seq)) { #we reached the next sequence
$object_name=$1;
last; #we exit the loop
} #end of if node
$temp_seq=$temp_seq . $read_line; #copy the line in the buffer $temporary_object
unless (defined ($read_line)) { die "Error (no new sequence found (line $line)";} #protective_code
} #end of while
# print "*"x 62,"\n *We found object $object_name at line $line\n","*"x 62,"\n"; #for_debug
# print LOG "*"x 30,"Sequence number $n_seq: ","*"x 30,"\n$temp_seq","*"x 70,"\n"; #for_debug
#copy, modify and past the sequences#
$temp_group = $temp_group . $temp_seq; #add temp_object in the $temp_group
$temp_group = $temp_group . &modif_block($temp_seq,"x",1); #add the object translated once in $temp_group
$temp_group = $temp_group . &modif_block($temp_seq,"x",2); #add the object translated twice in $temp_groupmy
#end of processing
$next_numb=$n_seq+3; #the next number of 1st object in the next group
until (($read_line =~ /<node name=\"(s(\d+)_\d+_[\w\-]+)\"/)and($2 == $n_seq + 3)) { #we reached the next sequence
unless (defined ($read_line= <SGF>)) { die "Error (no new sequence found (line $line)";} #protective_code
++$line;
} #end of until
$read_line =~ /<node name=\"(s(\d+)_\d+_[\w\-]+)\"/;$object_name=$1;$n_seq=$2;
# print "*"x 62,"\n We found object $object_name at line $line\n","*"x 62,"\n"; #for_debug
redo OBJECTS; #loop the block OBJECTS
# print "*"x 30,"Group from sequence $n_seq:","*"x 30,"\n$temp_group","*"x 70,"\n"; #for_debug
} elsif ($n_seq =~ /(16)/) { #we are at the 16th sequence which shouldn't be reproduced
$temp_group = $temp_group . $read_line; #reset the buffer for the sequence with the value of the line just found
$found_end_node=0;
while ($read_line = <SGF>) {
++$line;
#print $read_line; #for_debug
unless (defined ($read_line)) { die "Error (no new sequence found (line $line)";} #protective_code
# if ($found_end_node) { print $read_line;} #for_debug (print the line after the end of the node)
if ($read_line =~ m%<\/node%) {
# print "End of node line $line\n"; #print "---$read_line"; #for_debug
$found_end_node ? ($temp_file = $temp_file . $temp_group and goto END_OF_FILE) : ($found_end_node = 1);
#we reached the end of the description of an object (</node>) so if we had a </node> before we do "last" (we reached the end of the layer)
# otherwise we set $found_end_node to 1 so if next line is </node> it will do "last"
}else { $found_end_node = 0; } #this line is not </node> so we reset the variable to 0
if (($read_line =~ /<node.*name="(s(\d+)_\d+_[\w\-]+)"/) and ($2 > 16)) {$object_name = $1;$n_seq=$2; last;} #we found a sequence bigger than 16 so we stop
$temp_group = $temp_group . $read_line; #copy the line in the buffer $temp_group
} #end of while
# print "*"x 62,"\n *We found object $object_name at line $line\n","*"x 62,"\n"; #for_debug
# print LOG "*"x 30,"Sequence number $n_seq: ","*"x 30,"\n$temp_seq","*"x 70,"\n"; #for_debug
#copy, modify and past the sequences#
}else {die "Error: the sgf has a problem in line $line (wrong number of sequence): $read_line"; #protective_code
} #end of if/else
} #end of block OBJECTS
# print "*"x 30,"Group number 1","*"x 30,"\n$temp_group","*"x 70,"\n"; #for_debug
# we now got the first group
#copy, modify and past the blocks#
$temp_file = $temp_file . $temp_group; #copy that group to the temporary buffer for the file
$temp_file = $temp_file . &modif_block($temp_group,"y",1); #same with the second block-line
$temp_file = $temp_file . &modif_block($temp_group,"y",2); #same with the third block-line
#end of processin
$found_end_node=0;
while ($read_line = <SGF>) { #we will stop either either at the 49th sequence (if it exists) or the end of the synchronous layer (2 </node> in a row)
++$line;
# if ($found_end_node) { print $read_line;} #for_debug (print the line after the end of the node)
if ($read_line =~ m%<\/node%) {
# print "End of node line $line\n"; #print "---$read_line"; #for_debug
$found_end_node ? last : ($found_end_node = 1);
#we reached the end of the description of an object (</node>) so if we had a </node> before we do "last" (we reached the end of the layer)
# otherwise we set $found_end_node to 1 so if next line is </node> it will do "last"
}else { $found_end_node = 0; } #this line is not </node> so we reset the variable to 0
if (($read_line =~ /<node.*name="s(\d+)_\d+_[\w\-]+"/) and ($1 > 48)) {last;} #we found a sequence bigger than 48 so we stop
unless (defined ($read_line)) { die "Error (no new sequence found (line $line)";} #protective_code
} #end of while
# print "hello, we are now at line $line and the last \$read_line is $read_line\n"; #for_debug
$temp_file = $temp_file . $read_line; #copy the line with the last object read <node ...
END_OF_FILE: while (<SGF>) {
++$line;
$temp_file = $temp_file . $_; #copy the remaining content of the sgf file into the buffer
} #end of while and block END_OF_FILE
open SGF_MODIF, ">$new_file" or die "Error while opening $new_file for modificiation ($!)\n";
print SGF_MODIF $temp_file;print "**Save modified sgf in $new_file\n"; #for_debug
#print SGF_MODIF $temp_group.&modif_block($temp_group,"y",1); print SGF_MODIF &modif_block($temp_group,"y",2);print "\nSave modification in $new_file\n"; ##for_debug##
print LOG "*"x 59,"\n"; #to print in the log file
} #end of block OPTIMISATION_OBJECTS
print "****** End of the reprocessing of TC for optimisation ******\n";
#-----------------------------------------------------------------------------------------------------------------------
{#-----------------------------------------------------subroutines-------------------------------------------------------
sub modif_block { # 3 arguments : 1=the block, 2="x" or "y", 3=the number to increment (1 or 2)
my ($temp_object,$xy,$incr)=@_; #reads the arguments
unless (defined $incr) {$incr=1;} #$incr is set by default to 1 if nothing is specified
if ($xy eq "x") {$incr2=$incr;$transl=8*$incr;} #value of the horizontal translation
elsif ($xy eq "y") { $incr2=16 * $incr;$transl=-46.706*$incr;} #value of the vertical translation
else {die "Error of type : please enter either x or y as 2 argument ($!)\n";}
#if we do an operation on the block ($xy="y") the incrementation is 16 or 32 and it's 1 or 2 otherwise
#the translation is, for each group, x=+8.333 for "x" and y=-47.323 for "y"
$temp_object =~ s%\n%\n@%g; #put a "@" at the beginning of each new line
my @obj = split /@/, $temp_object; #transforms the text object into an array (each line being an element) using the @
my %out_fill=(); #hash table with the values of outline and filled boolean properties to be changed to
#the keys look like "outline_x_06_1 where
# the first indicates if it is the filled_property or the outlineline_property (outline or filled)
# the second element indicates if the translation is made on x or y
# the third element is the number of the object
# the fourth element indicates how many blocks the translation is done
foreach $j ((1,3,5,7,9)) { #for the odd numbers
foreach (1,2) {$out_fill{sprintf("outline_x_%02d_%1d",$j,$_)}="false";} # x is set to false for outline
foreach (1,2) {$out_fill{sprintf("filled_x_%02d_%1d",$j,$_)}="true";} # x is set to true for filled
foreach (1,2) {$out_fill{sprintf("outline_y_%02d_%1d",$j,$_)}="true";} # y is set to true for outline
$out_fill{sprintf("filled_y_%02d_1",$j)}="false"; # y is set to false for filled and translation by 1
$out_fill{sprintf("filled_y_%02d_2",$j)}="true"; # y is set to true for filled and translation by 2
}
foreach $j ((2,4,6,8)) { #for the odd numbers
foreach (1,2) {$out_fill{sprintf("outline_y_%02d_%1d",$j,$_)}="false";} # y is set to false for outline
foreach (1,2) {$out_fill{sprintf("filled_y_%02d_%1d",$j,$_)}="true";} # y is set to true for filled
foreach (1,2) {$out_fill{sprintf("outline_x_%02d_%1d",$j,$_)}="true";} # x is set to true for outline
$out_fill{sprintf("filled_x_%02d_1",$j)}="false"; # x is set to false for filled and translation by 1
$out_fill{sprintf("filled_x_%02d_2",$j)}="true"; # x is set to true for filled and translation by 2
} #end of establishment of the hash table
#&print_hash(" key ", " value ", %out_fill); #for_debug
my $n_seq=0;#the number of the sequence currently read
my $n_obj=0; #the number of the object currently read
my $name_obj = ""; #the name of the object currently read
if ($obj[0] =~ /<node.*name="s(\d{2})_(\d{2})_([\w\-]+)"/) { $n_seq=$1; $n_obj=$2; $name_obj=$3;}
else {die "Error in the subroutine ($xy | $incr): the first element should be a node\n",@obj,"<--end of object\n";}
for ($i = 0; $i < @obj; $i++) {
if ($obj[$i] =~ s/s(\d{2})_(\d{2})/sprintf("s%02d_%02d", $1 + $incr2, $2)/e) {#change the number of the sequence to the new one
$n_seq=$1;$n_obj=$2; #the number of the sequence and object
# printf ("Seq%02d Obj%02d changed to Seq%02d Obj%02d\n", $n_seq, $n_obj, $n_seq + $incr2,$n_obj); #for_debug
}elsif ($obj[$i] =~ s/( $xy)="([\d\-\.]*)"/sprintf("%s=\"%.3f\"",$1,$2+$transl)/e) {#translate the whole group by $transl in $xy
# printf("Seq%02d Obj%02d: cartesian %s changed to %s\n", $2, $2+$transl); #for_debug
}elsif ($obj[$i] =~ m%<(outline|filled)_property value="(false|true)"%) { #found the line with outline or filled properties
my $new_value= $out_fill{sprintf("%s_%s_%02d_%1d",$1,$xy,$n_obj,$incr)};
unless (($n_obj < 1) or (($xy eq "y")and($n_obj =~ /[2468]/))) { #doesn't apply for even numbers for "y"
# printf "Seq%02d Obj%02d: %7s changed from %5s to %5s\n",$n_seq,$n_obj,$1,$2,$new_value; #for_debug
$obj[$i] =~ s#$2#$new_value#
} #except for Backgroundrectangle and even numbers in y;
} else {}
} #end of FOR
join "",@obj; #returns the result
} #end of sub modif_block
sub print_hash { #print Hash Table
my ($tab1,$tab2,%hash)=@_;
my @keys=sort keys %hash;
print "\n","-" x 150,"\n\n";
printf("%-42s %5s\n", $tab1, $tab2);
printf("%-42s %5s\n", "-"x6, "-------");
foreach (@keys) {
printf("%-30s %-s\n", $_, $hash{$_});
} #end of foreach
print "\n","-" x 150, "\n";
} #end of subroutines to print hash tables
}#end of subroutines
#---------------------------------------------------------------------------------------------------------------------------------