# Copyright (c) 1997-2006
# Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
# http://www.math.tu-berlin.de/polymake, mailto:polymake@math.tu-berlin.de
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any
# later version: http://www.gnu.org/licenses/gpl.txt.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#----------------------------------------------------------------------------
# $Project: polymake $$Id: Rule.pm 7142 2006-03-02 09:37:17Z gawrilow $
use strict;
use namespaces;
package Poly::Rule;
use POSIX qw( :signal_h :sys_wait_h );
# Kinds of special rules
# is_function: does not return anything, can be called arbitrarily many times
# is_precondition: returns a boolean value
# is_dyn_weight: returns an additional weight [major, minor] or 'false' disabling the production rule connected to this
#
use Enum qw(is_function=1 is_precondition is_dyn_weight);
# The result code of a rule execution
# exec_OK: execution successful
# exec_failed: the rule has failed and should be disabled for the object permanently
# exec_retry: execution was not successful, but it's not the rule's fault
#
use Enum qw( exec: failed OK retry );
use Struct (
[ 'new' => '$$@' ],
[ '$header' => '#2' ], # 'ORIGINAL HEADER' for diagnostic and debug output
'@input', # ( [ prop_ref ] ) each inner list encodes a group of alternatives
# prop_ref ::= Property (own) | [ Property, ... ] (of a subobject)
'@output', # ( prop_ref ) or 'kind'
'$code', # sub { ... } compiled perl code of the rule body
'@labels', # rule labels
'$weight', # [ weight_category, weight_value ]
'@preconditions', # ( Rule )
[ '$dyn_weight' => 'undef' ], # Rule also inserted in preconditions
'%triggered_diff', # Property => [ Property ] properties from the diff group created 'from scratch',
# that is, without reading other properties from this group
);
my $std_weight=[2, 10]; # standard rule weight
my $zero_weight=[0, 0];
declare $max_major=$std_weight->[0]+1;
# for the rule parser
declare @prologue;
@prologue=split /(?<=\n)/, <<'_#_#_#_';
my $this=shift;
_#_#_#_
####################################################################################
# private:
sub property_seen {
my ($in, $seen, $change)=@_;
if (!is_object($in)) {
for (my $i=0; $i<$#$in; ++$i) {
$seen=($seen->{$in->[$i]} ||= [ ]);
}
$in=$in->[-1];
}
if ($change) {
my $answer=$seen->{$in};
$seen->{$in}+=$change;
$answer;
} else {
$seen->{$in};
}
}
####################################################################################
# private:
sub parse_input {
my ($self, $proto, $sources, $seen)=@_;
@{$self->input}=map {
my $input_list=$proto->encode_read_request($_);
foreach my $in (@$input_list) {
my $prop= is_object($in) ? $in : $in->[-1];
### FIXME: enable this check when subobjects are implemented
### if ($prop->type eq "object") {
### croak( "only atomic properties of the object stored under ",
### (is_object($in) ? $prop->name : join(".", map { $_->name } @$in) ),
### " may be rule sources, not the whole object\" );
### }
if (property_seen($in, $seen, 1)) {
croak( "source ", (is_object($in) ? $prop->name : join(".", map { $_->name } @$in) ),
" occurs twice" );
}
}
$input_list
} split /\s*,\s*/, $sources;
}
####################################################################################
# private:
sub sensitive_inputs {
my ($input, $generator)=@_;
### FIXME: wrong hash key in the ref($_) case
grep { my $prop= is_object($_) ? $_ : $_->[-1]; exists $prop->apply_diff->{$generator} || $generator==$prop } @$input;
}
####################################################################################
#
# Constructor - compile the rule
#
# new Poly::Rule(Prototype, header, [ special Rule, ... ], \&body);
#
sub new {
my $self=&_new;
my $proto=shift; shift;
my @parts=split /\s*:\s*/, $self->header;
if (@parts==1 && $self->header !~ /:\s*$/ || @parts>3) {
croak( "ill-formed rule header" );
}
my $app=$proto->application;
@{$self->labels}=map { $app->prefs->find_label($_,1) or croak( "unknown label '$_'" ) }
(split /\s*,\s*/, (@parts==3 && shift @parts));
my %seen;
parse_input($self, $proto, $parts[1], \%seen);
# target list
foreach my $req (split /\s*,\s*/, $parts[0]) {
my $out=$proto->encode_request_element($req);
my $prop= is_object($out) ? $out : $out->[-1];
if ($prop->type eq "object") {
croak( "only atomic properties of the object stored under $req may be rule targets, not the whole object" );
}
if (my $seen=property_seen($out, \%seen, -1)) {
if ($seen>0) {
croak( "$req can't be both source and target" );
} else {
croak( "target $req occurs multiply" );
}
}
push @{$self->output}, $out;
$self->triggered_diff->{$_} ||= [ ] for keys %{$prop->apply_diff};
$self->triggered_diff->{$prop} ||= [ ] if defined $prop->diff;
}
# take care of keeping the diff-sensitive properties consistent
DIFF_GROUP:
while (my ($generator, $list)=each %{$self->triggered_diff}) {
foreach my $input (@{$self->input}) {
my @sensitive=sensitive_inputs($input, $generator);
if (@sensitive == @$input) {
# will always read a sensitive property, don't care about this group
delete $self->triggered_diff->{$generator};
next DIFF_GROUP;
}
push @$list, @sensitive;
}
if ($seen{$generator} < 0) {
# for the case this rule gets no sensitive input, it must get a chance
# to compare its output with existing generator property
push @$list, $generator;
}
}
while (@_>1) {
my $special=shift;
if (is_object($special)) {
$special->header .= " ( " . $self->header . " )";
if ($special->output == $is_dyn_weight) {
$self->dyn_weight=$special;
}
push @{$self->preconditions}, $special;
} else {
$self->weight=$special;
assign_max($max_major, $special->[0]+1); # reserve the highest category for preference violation penalties
}
}
$self->weight ||= $self->dyn_weight ? $zero_weight : $std_weight;
$self->code=shift;
$proto->add_production_rule($self);
$self;
}
####################################################################################
#
# Constructor for special rules
#
# special Poly::Rule Prototype, 'Header', kind, \&body
#
sub special {
my $self=&_new;
my $proto=shift; shift;
($self->output, $self->code)=@_;
my %seen;
$self->header =~ /:\s* (.*\S) \s*$/x
and parse_input($self, $proto, $1, \%seen);
$self->weight=$zero_weight;
$self;
}
####################################################################################
#
# Reduced constructor for tiny rules
#
# create Poly::Rule 'Header', [ input list ], kind
sub create {
my $self=&_new; shift;
($self->input, $self->output)=@_;
$self->weight=$zero_weight;
$self
}
####################################################################################
my $break_reason;
sub break_rule {
$break_reason=shift;
if ($break_reason eq 'ALRM') {
$SIG{INT}='IGNORE';
$SIG{ALRM}='IGNORE';
kill -(SIGINT), $$; # kill the subprocesses
}
die "\n" if waitpid(-$$,WNOHANG)==-1; # there were no subprocesses - leave eval{} in execute().
}
my $breaksignals=new POSIX::SigSet(SIGINT, SIGALRM);
my $sa_break=new POSIX::SigAction(\&break_rule, $breaksignals, 0);
my $sa_INT_save=new POSIX::SigAction('IGNORE');
####################################################################################
#
# Execute the rule on a separate transaction level
#
sub execute { # Object => result code
my ($self, $object)=@_;
dbg_print("applying rule ", $self->header) if $Switches::v>1;
my $died=1;
my ($rc, $retval)=(0);
undef $break_reason;
my $trans=$object->begin_transaction($self);
my $trans_level=@{$object->transactions};
eval {
sigaction SIGINT, $sa_break, $sa_INT_save;
sigaction SIGALRM, $sa_break;
sigaction SIGPIPE, $sa_break;
my $is_prod_rule=ref($self->output);
my $alarm_time=$is_prod_rule && $Switches::T;
alarm $alarm_time if $alarm_time;
$retval=$self->code->($object);
alarm 0 if $alarm_time;
if ($is_prod_rule or $self->output==$is_function) {
# ignore the return code of the production rule
$rc=$exec_OK;
} else {
$rc= $retval ? $exec_OK : $exec_failed;
}
if ($rc) {
if ($is_prod_rule) {
# successful production rule
$trans->run_rules->{$self}=$rc;
} elsif ($self->output == $is_precondition) {
dbg_print( $self->header, " satisfied" ) if $Switches::v>2;
$trans->run_rules->{$self}=$rc;
}
$object->commit;
} else {
# precondition or dynamic weight failed
warn_print( $self->header, $self->output == $is_precondition ? " not satisfied" : " failed" ) if $Switches::v;
$trans->run_rules->{$self}=$rc;
$object->commit;
}
$died=0;
};
sigaction SIGINT, $sa_INT_save;
$SIG{ALRM}='IGNORE';
$SIG{PIPE}='DEFAULT';
if ($died) {
$rc=$exec_failed;
if ($break_reason eq "ALRM") {
$@="timeout elapsed\n";
} elsif ($break_reason eq "INT") {
$@="killed by signal\n";
$rc=$exec_retry;
}
$object->failed_rules->{$self}=1 if $self->output != $is_function;
}
$object->rollback if @{$object->transactions} == $trans_level;
wantarray ? ($rc, $retval) : $rc;
}
####################################################################################
package Poly::Rule::Weight;
use Poly::Ext;
sub new {
my $self=pack('i*', (0)x($max_major+1));
bless \$self;
}
sub copy {
my $new=${$_[0]};
bless \$new;
}
sub add {
is_object($_[1]) ? &sum : add_atom($_[0], @{$_[1]});
$_[0];
}
sub decode {
join(".", unpack('i*', $ {$_[0]}));
}
use overload '=' => \©, '""' => \&decode, '+=' => \&add, '<=>' => \&compare;
1
# Local Variables:
# c-basic-offset:3
# End:
syntax highlighted by Code2HTML, v. 0.9.1