# 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: Object.pm 7557 2007-01-12 17:48:17Z gawrilow $
use strict;
use namespaces;
use Poly::PropertyValue;
use Poly::File;
package Poly::Object;
use Poly::Ext;
use Struct (
[ '$name' => 'undef' ], # unique(?) object name
'@contents', # PropertyValues in the chronological (file) order
'%dictionary', # Property => index in @contents
[ '$persistent' => 'undef' ],# some object with load() and save() methods
'@transactions', # Transaction
'%failed_rules', # Rule => undef rules should not be applied to the object any more
'$changed', # Object changed since last load() or save()
);
####################################################################################
package Poly::Transaction;
use Struct (
'$content_end', # length of Object->contents at the transaction start
'%backup', # overwritten data: content_index => old PropertyValue
[ '$activeRule' => 'undef' ],# Rule
'$keep_overwritten', # boolean true in verification mode
'$changed', # boolean object was changed during the transaction
'%run_rules', # Rule => exit code rules already executed
'%extra', # additional parameters for context-specific use
);
sub new { # CLASS, Object =>
my $self=&_new;
my ($object)=@_;
$self->content_end=$#{$object->contents};
$self->keep_overwritten= do {
my $trans=$object->transactions->[0];
defined($trans) && $trans->keep_overwritten && $trans->extra->{inherit_keep_overwritten}
};
return $self;
}
sub merge {
my ($self, $trans)=@_;
while (my ($content_index, $old_pv)=each %{$trans->backup}) {
if ($content_index <= $self->content_end) {
$self->backup->{$content_index} ||= $old_pv;
}
}
while (my ($rule, $code)=each %{$trans->run_rules}) {
$self->run_rules->{$rule}=$code;
}
$self->changed |= $trans->changed;
}
####################################################################################
package Poly::Object;
sub new {
my $self=&_new;
if (@_==1 and is_object($_[0])) {
my $ph=shift;
if ($ph->can("save")) {
$self->persistent=$ph;
} else {
croak( ref($ph), " doesn't implement the persistency handler interface" );
}
} else {
if (@_%2) {
$self->name=shift;
}
$self->begin_transaction;
if (@_) {
while (my ($prop_name, $value)=splice @_, 0, 2) {
my ($prop)=$self->prototype->property($prop_name); # allow undeclared properties
if (exists $self->dictionary->{$prop}) {
croak( "multiple values for property '$prop_name'" );
} else {
my $pv=new Poly::PropertyValue($prop, $value, $self);
push @{$self->contents}, $pv;
$self->dictionary->{$prop}=$#{$self->contents};
if ($prop->temporary) {
need_cleanup($self, $#{$self->contents});
}
}
}
$self->transactions->[0]->changed=1;
}
}
$self;
}
####################################################################################
sub load {
my $self=is_object($_[0]) ? shift : &_new;
( $self->persistent ||= do {
my $ph=shift;
is_object($ph) ? $ph : new File($ph);
}
)->load($self, @_);
$self;
}
####################################################################################
sub exists { # 'request' || [request] => boolean
my ($self, $req)=@_;
if (!is_ARRAY($req)) {
$req=$self->prototype->encode_read_request($req);
}
foreach my $prop (@$req) {
if (defined (my $content_index=$self->dictionary->{$prop})) {
return 1 if defined($self->contents->[$content_index]);
}
}
0
}
####################################################################################
sub isa {
my ($self, $proto_name)=@_;
my $object_pkg=namespaces::lookup_class($self, $proto_name);
$object_pkg && UNIVERSAL::isa($self, $object_pkg->prototype->object_type);
}
####################################################################################
sub lookup_pv { # 'request' || [request] => PropertyValue
my ($self, $req)=@_;
my $proto=$self->prototype;
if (!is_ARRAY($req)) {
$req=$proto->encode_read_request($req);
}
foreach my $prop (@$req) {
if (defined (my $content_index=$self->dictionary->{$prop})) {
if (my $trans=$self->transactions->[0] and
!defined($self->contents->[$content_index]->value)) {
if (defined($trans->activeRule) and
$content_index > $trans->content_end || exists $trans->backup->{$content_index}) {
die "rule '", $trans->activeRule->header, "' attempts to read its output property ", $prop->name,
" before it is created\n";
}
}
return $self->contents->[$content_index];
}
}
undef;
}
sub lookup {
my $pv=&lookup_pv;
$pv && $pv->value;
}
####################################################################################
sub put {
my ($self, $prop, $data)=@_;
my $trans=$self->transactions->[0];
confess( "Poly::Object::put out of transaction scope" ) if !defined $trans;
my $pv=new PropertyValue($prop, $data, $self);
my $content_index=$self->dictionary->{$prop};
if (defined $trans->activeRule) {
# creating a property in a rule
if (!defined $content_index or
$content_index<=$trans->content_end && !exists $trans->backup->{$content_index}) {
die "attempt to create property '", $prop->name, "' which is not declared as a rule target\n";
}
$self->contents->[$content_index]=$pv;
} elsif (defined $content_index) {
# overwriting an existing property
my $old_pv=$self->contents->[$content_index];
$self->contents->[$content_index]=$pv;
$trans->backup->{$content_index} ||= $old_pv;
$trans->changed=1 if $trans->keep_overwritten;
return;
} else {
# new property created outside of a production rule
push @{$self->contents}, $pv;
$self->dictionary->{$prop}=$content_index=$#{$self->contents};
}
if ($prop->temporary) {
need_cleanup($self, $content_index);
} else {
$trans->changed=1;
}
defined(wantarray) && $pv->value;
}
####################################################################################
sub add {
my ($self, $prop, $data)=@_;
croak( "multiple values for property ", $prop->name, "\n" )
if exists $self->dictionary->{$prop};
my ($value, $conv)=new PropertyValue($prop, $data, $self);
push @{$self->contents}, $value;
$self->dictionary->{$prop}=$#{$self->contents};
if ($conv) {
$self->changed=1;
$main::scope->cleanup->{$self} ||= [ undef ];
}
}
####################################################################################
sub take {
my ($self, $prop_name, $data)=@_;
if (@_==2) {
# empty property
$data=[ ];
} elsif (defined($data) and !ref($data)) {
# mixed data stream
my (@data);
foreach my $line (@_[2..$#_]) {
foreach (split /\n/, $line) {
s/^\s+//;
next if length==0;
if (substr($_,0,1) ne "#") {
push @data, "$_\n";
}
}
}
$data=\@data;
}
my $trans=$self->transactions->[0] || $self->begin_transaction;
my $prop=
defined($trans->activeRule)
? $self->prototype->property($prop_name)
: ( $self->prototype->property($prop_name) )[0]; # let it create a new property if undeclared
$self->put($prop, $data);
}
####################################################################################
sub remove($$) {
my ($self, $prop_name)=@_;
my $trans=$self->transactions->[0];
confess( "Poly::Object::remove out of transaction scope" ) if !defined $trans;
my $prop=$self->prototype->property($prop_name);
if (defined (my $content_index=delete $self->dictionary->{$prop})) {
$trans->backup->{$content_index} ||= $self->contents->[$content_index];
undef $self->contents->[$content_index];
$trans->changed=1;
} elsif (defined $trans->activeRule) {
die "attempt to remove property '$prop_name' not declared as a rule source\n";
}
}
####################################################################################
sub begin_transaction {
my ($self, $active_rule)=@_;
my $trans=new Transaction($self);
unshift @{$self->transactions}, $trans;
if (defined $active_rule) {
$trans->activeRule=$active_rule;
if (ref($active_rule->output)) {
# is a production rule
foreach my $prop (@{$active_rule->output}) {
my $pv=new PropertyValue($prop);
if (defined (my $content_index=$self->dictionary->{$prop})) {
$trans->backup->{$content_index}=$self->contents->[$content_index];
$self->contents->[$content_index]=$pv;
} else {
push @{$self->contents}, $pv;
$self->dictionary->{$prop}=$#{$self->contents};
}
}
}
}
return $trans;
}
####################################################################################
sub remember_failed_rules {
my ($self, $trans)=@_;
while (my ($rule, $code)=each %{$trans->run_rules}) {
if ($code==$Poly::Rule::exec_failed) {
$self->failed_rules->{$rule}=1;
}
}
}
####################################################################################
sub commit {
my ($self)=@_;
my $trans=shift @{$self->transactions};
confess( "Poly::Object::commit out of transaction scope" ) if !defined $trans;
if ($trans->keep_overwritten) {
commit_overwrite($self, $trans);
} else {
commit_ignore($self, $trans);
}
if (@{$self->transactions}) {
$self->transactions->[0]->merge($trans);
} else {
if (!$self->changed and
$self->changed = $trans->changed || $#{$self->contents} > $trans->content_end) {
$main::scope->cleanup->{$self} ||= [ undef ];
}
remember_failed_rules($self,$trans);
}
}
####################################################################################
sub commit_ignore {
my ($self, $trans)=@_;
my $proto=$self->prototype;
while (my ($index, $old_pv)=each %{$trans->backup}) {
my $pv=$self->contents->[$index];
next if !defined($pv) || !defined (my $old_value=$old_pv->value);
my $prop=$pv->property;
if (defined (my $diff_sub=$prop->diff)) {
my @need_diff=grep { $_ > $trans->content_end } map { $self->dictionary->{$_} } @{$prop->diff_sensitive};
if (@need_diff) {
my $diff=eval { select_method($diff_sub, $self)->($self->contents->[$index]->value, $old_value) };
if ($@) {
$self->rollback($trans);
die "calculation of diff(".$prop->name.") failed: $@";
}
if (defined $diff) {
# make new properties created together with $prop (which is going to be discarded soon) compatible
# with the old version of $prop
foreach my $other_index (@need_diff) {
my $other_pv=$self->contents->[$other_index];
if (defined($other_pv->value)) {
my $other_prop=$other_pv->property;
dbg_print( "applying diff(".$prop->name.") to ", $other_prop->name ) if $Switches::v>=2;
eval {
$other_pv->set_value( select_method($other_prop->apply_diff->{$prop}, $self)
->($other_pv->value, $diff) )
};
if ($@) {
$self->rollback($trans);
die "applying diff(".$prop->name.") to ".$other_prop->name." failed: $@";
}
}
}
}
}
}
$self->contents->[$index]=$old_pv;
delete $trans->backup->{$index};
}
}
####################################################################################
sub equal_floats($$) {
no integer;
my ($x1, $x2)=@_;
my $a=max(abs($x1),abs($x2));
$a<=1e-7 or abs($x1-$x2)<=1e-7*$a;
}
sub equal_lines($$) {
my ($l1, $l2)=@_;
return 1 if $l1 eq $l2;
return 0 if $l1 !~ /^[-+\d.eE\s]+$/ or $l2 !~ /^[-+\d.eE\s]+$/;
my @d1=split /\s+/, $l1;
my @d2=split /\s+/, $l2;
return 0 if $#d1 != $#d2;
for (my $i=0; $i<=$#d1; ++$i) {
return 0 if !equal_floats($d1[$i], $d2[$i]);
}
1;
}
sub plain_compare($$) {
my ($new, $old)=@_;
if (ref($new) ne ref($old)) {
return "type mismatch: new " . ref($new) . " old " . ref($old) . "\n";
}
if (ref($new) eq "ARRAY") {
if ($#$new != $#$old) {
return "length mismatch: new " . ($#$new+1) . " old " . ($#$old+1) . "\n";
}
my $diff="";
for (my $i=0; $i<=$#$new; ++$i) {
if (!equal_lines($new->[$i], $old->[$i])) {
$diff .= "line $i mismatch: new <";
$_=$new->[$i]; chomp; $diff.=$_;
$diff .= "> old <";
$_=$old->[$i]; chomp; $diff.=$_;
$diff .= ">\n";
}
}
return $diff;
}
if (ref($new)) {
die "don't know how to compare ", ref($new), "\n";
}
!equal_lines($new, $old)
&& "value mismatch: new <$new> old <$old>\n";
}
####################################################################################
sub commit_overwrite {
my ($self, $trans)=@_;
my (%add_to_backup, %compared);
my $proto=$self->prototype;
my $errors="";
while (my ($index, $old_pv)=each %{$trans->backup}) {
my $pv=$self->contents->[$index];
$compared{$index}=undef, next if !defined $pv;
# first simple check: defined-ness must not change
my $prop=$pv->property;
my $old_value=$old_pv->value;
my $is_defined=defined($pv->value);
if ($is_defined != defined($old_value)) {
$errors .= "verification of '" . $prop->name . "' failed:\n" .
"new <" . ($is_defined ? "defined value" : "UNDEFINED ") .
"> old <" . ($is_defined ? "UNDEFINED" : "defined value") . ">\n";
$compared{$index}=undef, next;
}
$compared{$index}=undef, next unless $is_defined;
if (defined (my $diff_sub=$prop->diff)) {
my $diff=eval { select_method($diff_sub, $self)->($old_value, $pv->value) };
$compared{$index}=undef;
if ($@) {
$errors .= "verification of ".$prop->name." failed: $@";
next;
} elsif ($Switches::v) {
dbg_print( "verification of ".$prop->name." successful" );
}
if (defined $diff) {
foreach my $other_prop (@{$prop->diff_sensitive}) {
my $other_index=$self->dictionary->{$other_prop};
# is the sensitive property older than this transaction?
if (defined ($other_index)
and $other_index <= $trans->content_end
and defined (my $other_pv=$self->contents->[$other_index])) {
$compared{$other_index}=undef, next if !defined $other_pv->value; # no need to synchronize UNDEF
if (defined (my $other_old_pv=$trans->backup->{$other_index})) {
# got overwritten together with the generator: prepare the old value for comparison
if (defined $other_old_pv->value) {
my $cmp_value=eval {
select_method($other_prop->apply_diff->{$prop}, $self)->($other_old_pv->value, $diff)
};
if ($@ && $Switches::v) {
warn_print( "applying diff(".$prop->name.") to ".$other_prop->name." failed: $@",
"verification not performed" );
}
$compared{$other_index}=$cmp_value;
}
} else {
# must be synchronized
my $new_value=eval {
select_method($other_prop->apply_diff->{$prop}, $self)->($other_pv->value, $diff)
};
if ($@) {
warn_print( "applying diff(".$prop->name.") to ".$other_prop->name." failed: $@" ) if $Switches::v;
delete $self->dictionary->{$other_prop};
undef $self->contents->[$other_index];
$compared{$other_index}=undef;
} else {
$self->contents->[$other_index]=new PropertyValue($other_prop, $new_value);
}
$add_to_backup{$other_index}=$other_pv;
}
}
}
}
}
}
while (my ($index, $old_pv)=each %{$trans->backup}) {
my $old_value;
if (exists $compared{$index}) {
next unless defined($old_value=$compared{$index});
} else {
$old_value=$old_pv->value;
}
my $pv=$self->contents->[$index];
my $diff=plain_compare($pv->value, $old_value);
if (length($diff)) {
$errors .= "verification of ".$pv->property->name." failed:\n$diff";
} elsif ($Switches::v) {
dbg_print( "verification of ".$pv->property->name." successful" );
}
}
if (length($errors)) {
$self->rollback($trans);
die $errors;
}
while (my ($index, $pv)=each %add_to_backup) {
$trans->backup->{$index} ||= $pv;
}
}
####################################################################################
sub restore($$) {
my ($self, $trans)=@_;
while (my ($index, $pv)=each %{$trans->backup}) {
if (!defined($self->contents->[$index])) {
$self->dictionary->{$pv->property}=$index;
}
$self->contents->[$index]=$pv;
}
%{$trans->backup}=();
}
####################################################################################
sub rollback { # [ Transaction (only if called from commit) => ]
my ($self, $trans)=@_;
$trans ||= shift @{$self->transactions};
confess( "Poly::Object::rollback out of transaction scope" ) if !defined $trans;
restore($self, $trans);
my $limit=$trans->content_end;
foreach my $pv (@{$self->contents}[$limit+1..$#{$self->contents}]) {
delete $self->dictionary->{$pv->property} if ref($pv);
}
$#{$self->contents}=$limit;
remember_failed_rules($self,$trans);
}
####################################################################################
# private:
sub rollback_open {
my ($self)=@_;
if (@{$self->transactions}) {
$self->rollback($self->transactions->[-1]);
@{$self->transactions}=();
}
}
####################################################################################
sub cleanup {
my ($self, $index)=@_;
rollback_open($self);
if (defined($index)) {
my $gap=0;
for (my $last=$#{$self->contents}; $index<=$last; ++$index) {
my $pv=$self->contents->[$index];
if (ref($pv)) {
my $prop=$pv->property;
if ($prop->temporary) {
delete $self->dictionary->{$prop};
++$gap;
} elsif ($gap) {
$self->contents->[$index-$gap]=$self->contents->[$index];
$self->dictionary->{$prop}=$index-$gap;
}
} else {
++$gap;
}
}
$#{$self->contents}-=$gap;
}
if ($self->changed && defined($self->persistent) && @{$self->contents}) {
$self->persistent->save($self);
$self->changed=0;
}
}
####################################################################################
sub save {
# if with optional TRUE argument, then save temporaries too
cleanup($_[0], $_[1] ? 0 : undef);
}
####################################################################################
sub need_cleanup {
my ($self, $index)=@_;
my $cleanup_action=($main::scope->cleanup->{$self} ||= [ undef ]);
if (is_ARRAY($cleanup_action)) {
assign_min($cleanup_action->[0], $index);
}
}
####################################################################################
sub DESTROY {
my $self=shift;
if ($main::scope and my $action=delete $main::scope->cleanup->{$self}) {
cleanup($self, @$action);
}
}
####################################################################################
use Poly::Scheduler;
sub eval_input_list($$) { # [ Property ] => true if ready
my ($self, $input_list)=@_;
my ($content_index, $pv);
foreach my $prop (@$input_list) {
return 1 if defined ($content_index=$self->dictionary->{$prop})
&& defined ($pv=$self->contents->[$content_index]);
}
0
}
####################################################################################
sub provide_request {
my ($self, $request)=@_;
my $request_rule=create Rule('request', $request, $Poly::Rule::is_function);
my $chain=initial RuleChain($self,$request_rule);
if ((my $success=$chain && $chain->resolve($self)) <= 0) {
my @lacking;
foreach my $input_list (@$request) {
if (! $self->eval_input_list($input_list)) {
push @lacking, "'" . join(" | ", map { $_->name } @$input_list) . "'";
}
}
die $success==0 ? "available data insufficient to make " : "no more rules available to make ",
join(", ", @lacking), "\n";
}
}
####################################################################################
# private:
sub _give {
my $self=shift;
my $give=pop @_;
my $req=is_ARRAY($_[0]) ? \@_ : [ map { $self->prototype->encode_read_request($_) } @_ ];
if (!@{$self->transactions} || !$self->transactions->[0]->activeRule) {
provide_request($self, $req);
}
if (wantarray) {
map { $give->($self,$_) } @$req;
} elsif (defined wantarray and @$req==1) {
$give->($self,@$req);
}
}
sub give_pv {
push @_, \&lookup_pv;
&_give;
}
sub give {
push @_, \&lookup;
&_give;
}
####################################################################################
sub give_schedule {
my $self=shift;
my $request=is_ARRAY($_[0]) ? \@_ : [ map { $self->prototype->encode_read_request($_) } @_ ];
my $request_rule=create Rule('request', $request, $Poly::Rule::is_function);
my $chain=initial RuleChain($self,$request_rule);
return $chain->resolve($self, 0);
}
####################################################################################
sub create_prop_accessor {
my $prop=shift;
my $accessor=sub : method { _prop_set_accessor($prop) ? &put : &get };
declare_lvalue($accessor);
$accessor;
}
####################################################################################
sub get {
my ($self, $prop)=@_;
my $content_index=$self->dictionary->{$prop};
if (defined $content_index) {
_get_alternatives();
} else {
my @alt=_get_alternatives();
TRY_ALT: {
foreach my $alt_prop (@alt) {
$alt_prop=$self->prototype->lookup_property($alt_prop)
|| die "unknown property $alt_prop\n";
last TRY_ALT if defined ($content_index=$self->dictionary->{$alt_prop});
}
my $trans=$self->transactions->[0];
if (defined($trans) && $trans->activeRule) {
if (@alt) {
die "attempt to access undefined properties ", join(" | ", map { $_->name} $prop, @alt), "\n";
} else {
die "attempt to access an undefined property ", $prop->name, "\n";
}
}
unshift @alt, $prop;
provide_request($self, [ \@alt ]);
foreach $prop (@alt) {
last if defined ($content_index=$self->dictionary->{$prop});
}
}
}
$self->contents->[$content_index]->value;
}
####################################################################################
sub verify {
my $self=shift;
my $trans=$self->begin_transaction;
$trans->keep_overwritten=1;
$trans->extra->{inherit_keep_overwritten}=1;
my $scope=new Scope();
$scope->cleanup->{$self}=\&rollback_open;
my $proto=$self->prototype;
my (@request, $preferred);
REQ:
foreach (@_) {
if (defined (my $prop=$proto->lookup_property($_))) {
if (defined (my $content_index=$self->dictionary->{$prop})) {
my $pv=$self->contents->[$content_index];
if (defined($pv)) {
$trans->backup->{$content_index}=$pv;
$self->contents->[$content_index]=undef;
push @request, [ $prop ];
next;
} else {
# maybe just repeating argument?
foreach my $seen (@request) {
next REQ if $seen == $prop;
}
}
}
die "cannot verify non-existing property $_\n";
} elsif (defined (my $label=$proto->application->prefs->find_label($_))) {
$label->set_temp_preferred($scope);
$preferred=1;
} else {
die "unknown property or label: '$_'\n";
}
}
my $chain=new InitRuleChain($self, create Rule('verify', \@request, $Poly::Rule::is_function));
restore($self, $trans);
my $success= defined($chain) && do {
$chain->gather_rules($self);
$chain->constrain_to_preferred if $preferred;
$chain->resolve($self, !$Switches::n);
};
if ($Switches::n && $success) {
print $success->report, "\n";
} elsif ($success <= 0) {
if ($success<0) {
my @lacking;
foreach my $input_list (@request) {
my $prop=$input_list->[0];
my $content_index=$self->dictionary->{$prop};
if (! exists $trans->backup->{$content_index}) {
push @lacking, $prop->name;
}
}
die "no more rules available to verify " . join(", ", @lacking);
} else {
die $preferred ? "no matching rules\n" : "data insufficient for verification\n";
}
}
}
####################################################################################
sub take_verify {
my $self=shift;
$main::scope->cleanup->{$self}=\&rollback_open;
my $trans=$self->begin_transaction;
$trans->keep_overwritten=1;
$trans->extra->{inherit_keep_overwritten}=1;
$self->begin_transaction;
while (@_) {
$self->take(splice @_, 0, 2);
}
$self->commit;
}
declare @EXPORT_METHODS=qw( verify );
1
# Local Variables:
# c-basic-offset:3
# End:
syntax highlighted by Code2HTML, v. 0.9.1