rewrite-cf-with-new-scores [plain text]
use strict;
my $NUM_SCORESETS = 4;
my ($scoreset, $oldscores, $newscores) = @ARGV;
$scoreset = int($scoreset) if defined $scoreset;
if (!defined $newscores || $scoreset < 0 || $scoreset >= $NUM_SCORESETS ) {
die "usage: rewrite-cf-with-new-scores scoreset oldscores.cf newscores.cf\n";
}
our %rules;
my %gascores = ();
my $pre = ''; my $end = ''; my %oldscores; my %comment; my %fixed;
read_rules();
read_gascores();
read_oldscores();
print $pre;
print_gen();
print $end;
sub read_rules {
system ("./parse-rules-for-masses -s $scoreset") and die;
if (-e "tmp/rules.pl") {
require "./tmp/rules.pl";
}
else {
die "parse-rules-for-masses had no error but no tmp/rules.pl";
}
}
sub read_gascores {
open (STDIN, "<$newscores") or die "cannot open $newscores";
while (<STDIN>) {
next unless /^score\s+(\S+)\s+(-?\d+(?:\.\d+)?)/;
my $name = $1;
my $score = $2;
if (!exists $rules{$name}) {
warn "$name is not defined in tmp/rules.pl\n";
next;
}
if ($rules{$name}->{issubrule}) {
warn "$name is an indirect sub-rule in tmp/rules.pl\n";
next;
}
if ($rules{$name} =~ /^__/) {
warn "$name has an indirect sub-rule \"__\" prefix\n";
next;
}
if ($name eq '(null)') {
warn "$name is (null)\n";
next;
}
$gascores{$name} = $score;
}
}
sub read_oldscores {
open (IN, "<$oldscores") or die "cannot open $oldscores";
my $where = "pre";
while (my $line = <IN>) {
if ($line =~ /<\/gen:mutable>/) {
$where = "end";
}
if ($where eq "pre") {
readline_fix($line);
$pre .= $line;
}
elsif ($where eq "gen") {
readline_gen($line);
}
elsif ($where eq "end") {
readline_fix($line);
$end .= $line;
}
if ($line =~ /<gen:mutable>/) {
$where = "gen";
}
}
}
sub readline_fix {
my ($line) = @_;
my $comment;
if ($line =~ s/\s* $comment = $1;
}
if ($line =~ /^\s*score\s+(\S+)\s/) {
my (undef, $name, @scores) = split(' ', $line);
$fixed{$name}++;
$comment{$name} = $comment if $comment;
}
}
sub readline_gen {
my ($line) = @_;
my $comment;
if ($line =~ s/\s* $comment = $1;
$comment =~ s/ n=$scoreset//;
}
if ($line =~ /^\s*score\s+(\S+)\s/) {
my (undef, $name, @scores) = split(' ', $line);
for (my $i = 1; $i < $NUM_SCORESETS; $i++) {
$scores[$i] = $scores[0] unless defined $scores[$i];
}
@{$oldscores{$name}} = @scores;
$comment{$name} = $comment if $comment;
}
}
sub print_gen {
print "\n";
my %gen; $gen{$_} = 1 for keys %gascores; $gen{$_} = 1 for keys %oldscores;
for (keys %fixed) {
delete $gen{$_};
}
for my $name (sort keys %gen) {
next if ($rules{$name}->{lang}); next if ($rules{$name}->{issubrule}); next if ($name eq 'AWL');
my @scores = ();
my $comment = '';
$comment = $comment{$name} if defined $comment{$name};
@scores = @{$oldscores{$name}} if exists $oldscores{$name};
if (defined $gascores{$name}) {
$scores[$scoreset] = $gascores{$name};
delete $oldscores{$name};
}
else {
if (defined $rules{$name}->{score} && !$rules{$name}->{issubrule}) {
}
if (defined $oldscores{$name}) {
$comment .= " n=$scoreset";
}
}
my %unique;
$unique{$_} = 1 for split(' ', $comment);
$comment = join(' ', sort keys %unique);
printf("score %s %s%s\n", $name,
join(" ", generate_scores($name, @scores)),
($comment) ? ' # ' . $comment : '');
}
print "\n";
}
sub generate_scores {
my ($name, @scores) = @_;
my $isnet = 0;
my $islearn = 0;
if (defined $rules{$name}->{tflags}) {
$isnet = ($rules{$name}->{tflags} =~ /\bnet\b/);
$islearn = ($rules{$name}->{tflags} =~ /\blearn\b/);
}
if (!defined $scores[0]) {
warn "$name does not have a default score\n";
$scores[0] ||= 0;
}
$scores[$scoreset] = 0 if !$gascores{$name};
my $flag = 1;
for (my $i = 1; $i < $NUM_SCORESETS; $i++) {
$scores[$i] = $scores[0] unless defined $scores[$i];
$flag = 0 if ($scores[$i] != $scores[$i-1]);
};
for (my $i = 0; $i < $NUM_SCORESETS; $i++) {
if ($isnet && ($i & 1) == 0) {
$scores[$i] = 0;
$flag = 0 if ($i > 0 && $scores[$i] != $scores[$i-1]);
}
if ($islearn && ($i & 2) == 0) {
$scores[$i] = 0;
$flag = 0 if ($i > 0 && $scores[$i] != $scores[$i-1]);
}
}
if ($flag) {
splice @scores, 1;
}
return @scores;
}