#  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 '=' => \&copy, '""' => \&decode, '+=' => \&add, '<=>' => \&compare;

1

# Local Variables:
# c-basic-offset:3
# End: