#  Copyright (c) 1997-2010
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
#  http://www.polymake.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 10012 2011-01-12 23:19:57Z gawrilow $

use strict;
use namespaces;

package Polymake::Core::Object;

use Polymake::Struct (
   [ '$name' => 'undef' ],		# unique(?) object name
   '$description',			# textual description
   '%credits',				# credit records from producing rules
   '@contents',				# PropertyValues in the chronological (file) order
   '%dictionary',			# Property => index in @contents
   '%attachments',			# "name" => data object
   [ '$transaction' => 'undef' ],	# Transaction
   '$changed',				# Object changed since last load() or save() (only at top-level)
   '%failed_rules | sensitive_to',	# Rule => undef  rules should not be applied to the object any more
					# Property->key (permutation) => contains properties sensitive to this permutation
   [ '$persistent' => 'undef' ],	# some object with load() and save() methods (only for top-level objects)
   [ '$has_cleanup' => 'undef' ],	# has registered a cleanup handler
   [ '$parent' => 'undef' ],		# parent Object
   [ '$property' => 'undef' ],		# as what this is kept in the parent object
   [ '$is_temporary' => 'undef' ],	# subobject or its ancestor was temporarily added
   [ '$parent_index' => 'undef' ],	# index in parent's PropertyValue (if multiple)
);

sub value { shift }		# for compatibility for PropertyValue

use Polymake::Ext;
use Polymake::Enum 'Rule::exec';

####################################################################################
package Polymake::Core::Transaction;

use Polymake::Struct (
   [ new => '$@' ],
   [ '$content_end' => '$#{ #1 ->contents}' ],	# length of Object->contents at the transaction start
   '%subobjects',				# subobjects with active transactions
   '@temporaries',				# properties and subobjects temporarily added during the transaction
   [ '$changed' => 'undef' ],			# boolean:  object was changed during the transaction
   [ '$outer' => '#1 ->transaction' ],
   [ '$entirely_temp' => '$this->outer && $this->outer->entirely_temp' ],  # all changes are temporary by default
   '%backup',					# overwritten or deleted properties: content_index => PropertyValue
);

sub rule { undef }

# Lists stored under temporaries have the following structure:
# leading element is the smallest index of a gap in contents (resulting from a remove() operation),
# the rest is a mix of entries of four kinds:
# Property                      : property added temporarily
# [ Property, index ]           : multiple subobject added temporarily
# [ Property, [ list ] ]        : single subobject with its own list of temporaries
# [ Property, index, [ list ] ] : multiple subobject with its own list of temporaries

# compare two entries from temporaries
# => -1     : the first dominates
# => 0      : both equal
# => 1      : the second dominates
# => undef  : independent

sub cmp_temporaries {
   my ($t1, $t2)=@_;
   if (is_object($t1)) {
      if (is_object($t2)) {
	 return $t1->key == $t2->key ? 0 : undef;
      } else {
	 return $t1->key == $t2->[0]->key ? -1 : undef;
      }
   }
   if (is_object($t2)) {
      return $t1->[0]->key == $t2->key ? 1 : undef;
   }
   return undef if $t1->[0]->key != $t2->[0]->key or is_integer($t1->[1]) && $t1->[1] != $t2->[1];
   $#$t1 <=> $#$t2 || (merge_temporaries($t1->[-1], $t2->[-1]), 0);
}

sub include_temporary_item {
   my ($list, $t2)=@_;
   for (my $i=1; $i<=$#$list; ++$i) {
      if (defined (my $cmp=cmp_temporaries($list->[$i], $t2))) {
	 if ($cmp>0) {
	    $list->[$i]=$t2;
	 } elsif ($cmp<0 && !ref($t2->[-1]) && $t2->[-1] eq "!") {
	    splice @$list, $i, 1;
	 }
	 return;
      }
   }
   push @$list, $t2;
}

sub merge_temporaries {
   my ($dst, $src)=@_;
   assign_min($dst->[0], shift @$src);
   include_temporary_item($dst,$_) for @$src;
}

sub propagate_temporaries {
   my ($self, $object, $parent_temp)=@_;
   assign_max($#$parent_temp,0);
   include_temporary_item($parent_temp,
			  $object->property->flags & $Property::is_multiple
			  ? [ $object->property, $object->parent_index, $self->temporaries ]
			  : [ $object->property, $self->temporaries ]);
}

sub drop_temp_mark {
   my ($self, $object, $subobject)=@_;
   assign_max($#{$self->temporaries},0);
   include_temporary_item($self->temporaries,
			  $subobject->property->flags & $Property::is_multiple
			  ? [ $subobject->property, $subobject->parent_index, "!" ]
			  : [ $subobject->property, "!" ]);
}

my ($at_end, %save_at_end);

sub register_object_saving {
   add AtEnd("Object", sub {
		foreach my $obj (keys %save_at_end) {
		   if (defined $obj->transaction) {
		      $obj->rollback;
		   }
		   if ($obj->has_cleanup) {
		      err_print( "object $obj ", defined($obj->name) && "(".$obj->name.")",
				 ": pending cleanup at end" );
		   } elsif (!$obj->changed) {
		      err_print( "object $obj ", defined($obj->name) && "(".$obj->name.")",
				 ": registered for save at end without changes" );
		   } else {
		      $obj->persistent->save($obj);
		      $obj->changed=0;
		   }
		}
	     });
   1;
}

sub commit {
   my ($self, $object, $parent_trans)=@_;
   $object->transaction=$self->outer;
   $_->commit($self) for keys %{$self->subobjects};

   if (defined $parent_trans) {
      if (@{$self->temporaries} && !$object->is_temporary) {
	 propagate_temporaries($self,$object,$parent_trans->temporaries);
      }
      $parent_trans->changed ||= $self->changed;
      return;
   }
   if (defined $self->outer) {
      if (@{$self->temporaries} && !$object->is_temporary) {
	 if (@{$self->outer->temporaries}) {
	    merge_temporaries($self->outer->temporaries, $self->temporaries);
	 } else {
	    $self->outer->temporaries=$self->temporaries;
	 }
      }
      $self->outer->changed ||= $self->changed;
      return;
   }
   if (defined (my $parent_obj=$object->parent)) {
      return if $object->is_temporary;
      if (@{$self->temporaries}) {
	 if (defined ($parent_trans=$parent_obj->transaction)) {
	    propagate_temporaries($self,$object,$parent_trans->temporaries);
	    $parent_trans->changed ||= $self->changed;
	 } else {
	    $parent_trans=$parent_obj->begin_transaction;
	    propagate_temporaries($self,$object,$parent_trans->temporaries);
	    $parent_trans->changed=$self->changed;
	    $parent_trans->commit($parent_obj);
	 }
	 return;
      }
      if ($self->changed) {
	 do {
	    $object=$parent_obj;
	    if (defined $object->transaction) {
	       $object->transaction->changed=1;
	       return;
	    }
	 } while (defined($parent_obj=$object->parent));
      } else {
	 return;
      }
   }
   if ($self->changed) {
      if (!$object->changed) {
	 $object->changed=1;
	 if ($object->persistent) {
	    $at_end ||= register_object_saving();
	    $save_at_end{$object}=undef;
	 }
      }
   }
   if (@{$self->temporaries}) {
      if ($object->has_cleanup) {
	 merge_temporaries($Scope->cleanup->{$object},$self->temporaries);
      } else {
	 $object->has_cleanup=1;
	 $Scope->cleanup->{$object}=$self->temporaries;
      }
   }
}

sub rollback {
   my ($self, $object)=@_;
   if ((my $limit=$self->content_end)>=0) {
      while (my ($index, $old_pv)=each %{$self->backup}) {
         if ($index <= $limit) {
            if (!defined($object->contents->[$index])) {
               $object->dictionary->{$old_pv->property->key}=$index;
            }
            $object->contents->[$index]=$old_pv;
         }
      }

      foreach my $pv (@{$object->contents}[$limit+1..$#{$object->contents}]) {
	 if (ref($pv)) {
	    delete $object->dictionary->{$pv->property->key};
	    if (instanceof Object($pv)) {
	       delete $self->subobjects->{$pv};
	    } elsif (instanceof PropertyMultipleValue($pv)) {
	       delete @{$self->subobjects}{@{$pv->values}};
	    }
	 }
      }
      $#{$object->contents}=$limit;
      $_->value->rollback for keys %{$self->subobjects};
   } else {
      $#{$object->contents}=-1;
      $object->dictionary={ };
   }
   $object->transaction=$self->outer;
}

sub descend {
   my ($self, $sub_obj)=@_;
   $self->subobjects->{$sub_obj}=undef;
   $sub_obj->transaction ||= $self->sub_type->_new($sub_obj,$self->rule);
}

sub sub_type { shift }

####################################################################################
package Polymake::Core::RuleTransaction;

use Polymake::Struct (
   [ '@ISA' => 'Transaction' ],
   [ new => '$$' ],
   [ '$rule' => '#2' ],
);

sub new {
   my $self=&_new;
   my $top_object=$_[0];
   $top_object->transaction=$self;
   unless ($self->rule->flags & $Rule::is_any_precondition) {
      # is a production rule
      foreach my $item (@{$self->rule->output}) {
	 my ($obj, $prop)=Object::descend_and_create($top_object,$item);
	 my $pv=new PropertyValue($prop);
	 if (defined (my $content_index=$obj->dictionary->{$prop->key})) {
	    if (defined (my $pv_old=$obj->contents->[$content_index])) {
	       $obj->transaction->backup->{$content_index}=$pv_old;
	    }
	    $obj->contents->[$content_index]=$pv;
	 } else {
	    push @{$obj->contents}, $pv;
	    $obj->dictionary->{$prop->key}=$#{$obj->contents};
	    $self->changed=0;
	 }
      }
   }
   $self;
}

sub commit {
   my ($self, $object)=@_;
   if (defined $self->outer) {
      while (my ($index, $pv)=each %{$self->backup}) {
	 if ($index <= $self->outer->content_end) {
	    $self->outer->backup->{$index} ||= $pv;
	 }
      }
   } else {
      while (my ($index, $pv)=each %{$self->backup}) {
	 $object->contents->[$index]=$pv;
      }
   }
   if (@_==2 && defined (my $perm_deputy=$self->rule->with_permutation)) {
      # the rule just executed was the first one to create some sensitive properties:
      # record this now to avoid expensive search on the next scheduling
      # but only in the top-level transaction
      $perm_deputy->record_sensitivity($object);
   }
   &Transaction::commit;
}

####################################################################################
package Polymake::Core::RuleTransactionWithPerm;

use Polymake::Struct (
   [ '@ISA' => 'RuleTransaction' ],
);

sub sub_type { 'Polymake::Core::RuleTransaction' }

sub commit {
   my ($self, $object)=@_;
   my $prod_rule=$self->rule->rule;
   my $perm_object=$object->add_perm($self->rule->permutation);
   undef $perm_object->transaction;

   # transfer the sensitive properties created by prod_rule into the permutation subobjects
   foreach my $action (@{$self->rule->actions}) {
      my $output=$prod_rule->output->[$action->output];
      my ($base_obj, $sub_perm_obj, $prop);
      if ($action->depth) {
	 # must create an additional permutation object in the sub-object
	 ($base_obj)=$object->descend(@$output[0..$action->depth]);
	 if (defined (my $base_content_index=$base_obj->dictionary->{$prod_rule})) {
	    $sub_perm_obj=$base_obj->contents->[$base_content_index]->value;
	 } else {
	    $sub_perm_obj=$base_obj->add_perm($action->sub_permutation);
	    undef $sub_perm_obj->transaction;
	 }
	 ($base_obj)=$base_obj->descend(@$output[$action->depth..$#$output]);
	 ($sub_perm_obj, $prop)=$sub_perm_obj->descend_and_create(@$output[$action->depth..$#$output]);
      } else {
	 # the property is transferred into the base permutation object
	 ($base_obj)=$object->descend($output);
	 ($sub_perm_obj, $prop)=$perm_object->descend_and_create($output);
      }
      my $base_content_index=$base_obj->dictionary->{$prop->key};
      push @{$sub_perm_obj->contents}, $base_obj->contents->[$base_content_index];
      $sub_perm_obj->dictionary->{$prop->key}=$#{$sub_perm_obj->contents};
      $base_obj->contents->[$base_content_index]=delete $base_obj->transaction->backup->{$base_content_index};
   }

   &RuleTransaction::commit;
}

####################################################################################
package Polymake::Core::Object;

# The following new_XXX routines are registered for the overloaded construct method
# by the prototype (ObjectType) constructor.
# They may be never called directly.

sub new_empty : method {
   my $self=new((shift)->pkg);
   $self->name=name_of_ret_var();
   begin_transaction($self);
   $self;
}

sub new_named : method {
   my ($proto, $name)=@_;
   my $self=new($proto->pkg);
   $self->name=$name;
   begin_transaction($self);
   $self;
}

sub new_filled : method {
   my $proto=shift;
   if (ref($_[0])) {
      croak( "Can't convert ", UNIVERSAL::can($_[0],"type") ? $_[0]->type->full_name : ref($_[0]), " to ", $proto->full_name );
   }
   my $self=new($proto->pkg);
   $self->name= @_%2 ? shift : name_of_ret_var();
   fill_properties($self, $proto, @_);
}

sub new_with_auto_cast : method {
   my ($rule, $proto, $src)=@_;
   my $self=new($proto->pkg);
   copy_contents($src, $self);
   do_downcast($self, $rule);
   $self->name=$src->name;
   $self->description=$src->description;
   copy_attachments($self, $src);
   $self;
}

sub new_filled_with_auto_cast : method {
   my ($rule, $proto, $src)=splice @_, 0, 3;
   my $self=new_with_auto_cast($rule, $proto, $src);
   croak( "odd PROPERTY => VALUE list" ) if @_%2;
   fill_properties($self, $proto, @_);
}

sub new_copy : method {
   my ($proto, $src)=@_;
   my $self=new($proto->pkg);
   if ($proto->isa($src->type)) {
      # a direct heir
      copy_contents($src, $self);
   } else {
      my $prop;
      foreach my $pv (@{stable_contents($src)}) {
         if (defined($pv) && !$pv->is_temporary && $proto->isa(($prop=$pv->property->declared)->belongs_to)) {
            if ($prop->flags & $Property::is_multiple) {
               defined($_) && !$_->is_temporary && _add_multi($self, $prop, $_) for @{$pv->values};
            } else {
               _add($self, $prop, $pv->value);
            }
         }
      }
   }
   $self->name=$src->name;
   $self->description=$src->description;
   copy_attachments($self, $src);
   $self;
}

sub new_filled_copy : method {
   my ($proto, $src)=splice @_, 0, 2;
   my $self=new_copy($proto, $src);
   croak( "odd PROPERTY => VALUE list" ) if @_%2;
   fill_properties($self, $proto, @_);
}

# private:
sub fill_properties {
   my ($self, $proto)=splice @_, 0, 2;
   my $trans=begin_transaction($self);
   for (my ($i, $e)=(0, $#_); $i<$e; $i+=2) {
      my ($name, $value)=@_[$i, $i+1];
      my ($obj, $prop)= $name =~ /\./ ? descend_and_create($self, $proto->encode_request_element($name))
                                      : ($self, $proto->property($name));
      if ($prop->flags & $Property::is_multiple) {
         _add_multi($obj, $prop, $value);
      } else {
         _add($obj, $prop, $value);
      }
   }
   $trans->commit($self);
   $self
}

sub _add {
   my ($self, $prop, $value, $trusted)=@_;
   if (!$trusted && exists $self->dictionary->{$prop->key}) {
      croak( "multiple values for property ", $prop->name );
   }
   push @{$self->contents}, $prop->accept->($value,$self,$trusted);
   $self->dictionary->{$prop->key}=$#{$self->contents};
}

# private:
sub _add_multi {
   my ($self, $prop, $value, $temp)=@_;
   if (defined (my $content_index=$self->dictionary->{$prop->key})) {
      my $pv=$self->contents->[$content_index];
      $prop->accept->($value,$self,0,$temp);
      $value->parent_index=@{$pv->values};
      push @{$pv->values}, $value;
   } else {
      push @{$self->contents}, $prop->accept->($value,$self,0,$temp);
      $self->dictionary->{$prop->key}=$#{$self->contents};
   }
}

# protected:
sub _add_multis {
   my ($self, $prop, $values, $trusted)=@_;
   if (!$trusted && exists $self->dictionary->{$prop->key}) {
      croak( "multiple occurence of property ", $prop->name );
   }
   push @{$self->contents}, new PropertyMultipleValue($prop->concrete($self), $values);
   $self->dictionary->{$prop->key}=$#{$self->contents};
   $prop->accept->($_,$self,$trusted) for @$values;
}

# protected:
sub add_perm {
   my ($self, $prop)=@_;
   my $perm_object=$prop->accept->(new_named($self->type), $self, 1, $PropertyValue::is_temporary);
   if (defined (my $content_index=$self->dictionary->{$prop->key})) {
      $self->contents->[$content_index]=$perm_object;
   } else {
      push @{$self->contents}, $perm_object;
      $self->dictionary->{$prop->key}=$#{$self->contents};
   }
   assign_max($#{$self->transaction->temporaries},0);
   push @{$self->transaction->temporaries}, $prop;
   $perm_object;
}

sub add_perm_in_parent {
   my ($self, $up, $permutation)=@_;
   while (--$up >= 0) {
      $self=$self->parent or return;
   }
   add_perm($self, $permutation->super->[0]->parent_property);
}

sub begin_transaction {
   my $self=shift;
   $self->transaction=new Transaction($self);
}

sub print_me : method {
   my ($proto, $self)=@_;
   $proto->full_name . (length($self->name) ? ": ".$self->name : " anonymous object")
}
####################################################################################
sub load {
   my $self=&_new;
   my $ph=shift;
   ($self->persistent=is_object($ph) ? $ph : new XMLfile($ph))->load($self, @_);
   $self;
}

sub fromXMLstring {
   my $self=&_new;
   load XMLstring($self, @_);
   $self;
}

sub toXMLstring {
   save XMLstring(@_);
}

sub reset_to_empty {
   my $self=shift;
   bless $self;
   @{$self->contents}=();
   %{$self->dictionary}=();
   %{$self->attachments}=();
   %{$self->credits}=();
   $self->description="";
   undef $self->transaction;
}

sub isa { $_[0]->type->isa($_[1]) }
####################################################################################
sub copy {
   my ($self, $new_parent, $filter)=@_;
   if (@_==1) {
      my $type=$self->type;
      if (instanceof ObjectType::LocallyDerived($type)) {
	 # strip off local extensions
	 return $type->super->[1]->construct->($self);
      }
   }
   my $copy=new($self);
   $copy->name=$self->name;
   $copy->description=$self->description;
   if (defined $new_parent) {
      weak($copy->parent=$new_parent);
      $copy->property=$self->property;
      $new_parent->transaction->descend($copy) if defined($filter);
   } elsif (defined $filter) {
      begin_transaction($copy);
   }
   copy_contents($self,$copy,$filter);
   if (defined($new_parent) && !@{$copy->contents}) {
      delete $new_parent->transaction->subobjects->{$copy};
      undef
   } else {
      $copy
   }
}

# private:
# copy of an object made during an active production rule must be in a self-consistent state, that is, as at the rule start
sub stable_contents {
   my $self=shift;
   if (defined($self->transaction)) {
      if (defined($self->transaction->rule)) {
	 return [ map { $self->transaction->backup->{$_} || $self->contents->[$_] } 0..$self->transaction->content_end ];
      } else {
	 $self->commit;
      }
   }
   $self->contents;
}

# private:
sub copy_contents {
   my ($self, $dst, $filter)=@_;
   foreach my $pv (@{stable_contents($self)}) {
      if (defined($pv) && !$pv->is_temporary) {
	 my ($subobj, $pv_copy)= defined($filter) ? $filter->($dst, $pv) : ($dst, $pv->copy($dst));
	 if (defined $pv_copy) {
	    push @{$subobj->contents}, $pv_copy;
	    $subobj->dictionary->{$pv_copy->property->key}=$#{$subobj->contents};
	 }
      }
   }
}
####################################################################################
sub cast_me {
   my ($self, $target_proto)=@_;
   my $proto=$self->type;
   if ($target_proto->isa($proto)) {
      if (defined($self->transaction) && defined($self->transaction->rule)) {
	 croak( "production rule must not change the Object type" );
      }
      # downcast
      if ($target_proto != $proto) {
	 my $rule;
	 foreach ($proto, @{$proto->super}) {
	    if (defined ($rule=$_->auto_casts->{$target_proto})) {
	       $proto->auto_casts->{$target_proto}=$rule if $_ != $proto;
	       last;
	    }
	 }
	 if (defined $rule) {
	    do_downcast($self,$rule);
	 } else {
	    croak( "downcast from ", $proto->full_name, " to ", $target_proto->full_name, " is not allowed" );
	 }
      }
      return $self;
   }

   $proto->isa($target_proto)
      or croak( "invalid cast from ", $proto->full_name, " to ", $target_proto->full_name, "; use copy instead" );

   if (defined($self->property)) {
      if ($self->property->flags & $Property::is_locally_derived) {
	 if (!$self->property->type->super->[1]->isa($target_proto)) {
	    croak( "can't cast a subobject under ", $self->property->name, " to ", $target_proto->full_name );
	 }
	 $target_proto=$self->property->type->local_type($target_proto);
      } else {
	 if (!$self->property->type->isa($target_proto)) {
	    croak( "can't cast a subobject under ", $self->property->name, " to ", $target_proto->full_name );
	 }
      }
   }

   my $need_commit;
   if (defined($self->transaction)) {
      croak( "production rule may not change the Object type" ) if defined($self->transaction->rule);
   } else {
      $need_commit=1;
      begin_transaction($self);
   }
   # upcast: remove properties defined in the subtypes
   foreach my $pv (@{$self->contents}) {
      if (defined($pv) && !$target_proto->isa($pv->property->belongs_to)) {
	 assign_min($self->transaction->temporaries->[0], delete $self->dictionary->{$pv->property->key});
	 undef $pv;
      }
   }
   bless $self, $target_proto->pkg;
   $self->transaction->changed=1;
   $self->transaction->commit($self) if $need_commit;
   $self;
}
####################################################################################
my ($undef_underway);

# four different sorts of descending into subobjects,
# kept separately to optimize a little on the costs of extra branching

# protected:
sub descend {
   my $prop=pop;
   my ($self, @path)=@_;
   if (!is_object($prop)) {
      @path=@$prop;
      $prop=pop @path;
   }
   $undef_underway=0;
   foreach my $prop (@path) {
      if (defined (my $content_index=$self->dictionary->{$prop->key})) {
	 my $pv=$self->contents->[$content_index];
	 if (defined($pv) && defined($pv->value)) {
	    $self=$pv->value;
	    next;
	 }
	 $undef_underway=1;
      }
      return;
   }
   ($self, $prop);
}

# protected:
sub descend_partially {
   my $prop=pop;
   my ($self, $visited, @path)=@_;
   if (!is_object($prop)) {
      @path=@$prop;
      $prop=pop @path;
   }
   foreach my $prop (@path) {
      push @$visited, $self;
      if (defined (my $content_index=$self->dictionary->{$prop->key})) {
	 my $pv=$self->contents->[$content_index];
	 if (defined($pv) && defined($pv->value)) {
	    $self=$pv->value;
	    next;
	 }
      }
      return;
   }
   ($self, $prop);
}

# protected:
sub descend_with_transaction {
   my $prop=pop;
   my ($self, @path)=@_;
   my $trans=$self->transaction;
   if (!is_object($prop)) {
      @path=@$prop;
      $prop=pop @path;
   }
   foreach my $prop (@path) {
      if (defined (my $content_index=$self->dictionary->{$prop->key})) {
	 my $pv=$self->contents->[$content_index];
	 if (defined($pv) && defined($pv->value)) {
	    $trans=$trans->descend($pv->value);
	    $self=$pv->value;
	    next;
	 }
      }
      return;
   }
   ($self, $prop);
}

# protected:
sub descend_and_create {
   my $prop=pop;
   my ($self, @path)=@_;
   my $trans=$self->transaction;
   if (!is_object($prop)) {
      @path=@$prop;
      $prop=pop @path;
   }
   foreach my $prop (@path) {
      my $content_index=$self->dictionary->{$prop->key};
      if (defined $content_index) {
	 my $pv=$self->contents->[$content_index];
	 if (defined($pv) && defined($pv->value)) {
	    $trans=$trans->descend($pv->value);
	    $self=$pv->value;
	    next;
	 }
      }
      my $pv=$prop->create_subobject($self);
      if (defined $content_index) {
	 $self->contents->[$content_index]=$pv;
      } else {
	 push @{$self->contents}, $pv;
	 $self->dictionary->{$prop->key}=$#{$self->contents};
      }
      $self=$pv->value;
   }
   ($self, $prop);
}
####################################################################################
# protected:
sub create_undefs {
   my $self=shift;
   my $trans=begin_transaction($self);
   foreach my $item (@_) {
      my ($obj, $prop)=descend_and_create($self,$item);
      push @{$obj->contents}, new PropertyValue($prop);
      $obj->dictionary->{$prop->key}=$#{$obj->contents};
   }
   $trans->changed=1;
   $trans->commit($self);
}
####################################################################################
# protected:
sub _lookup_pv {
   my ($self, $req)=@_;
   my ($obj, $prop, $content_index, $pv);

   foreach my $req_item (@$req) {
      my (@path, @types);
      if (($obj, $prop)=descend_partially($self,\@path,$req_item)
	  and defined ($content_index=$obj->dictionary->{$prop->key})
	  and defined ($pv=$obj->contents->[$content_index])) {
	 if ($Application::plausibility_checks and
	     !defined($pv->value) && defined($obj->transaction) and
	     defined($obj->transaction->rule) and
	     $content_index > $obj->transaction->content_end || exists $obj->transaction->backup->{$content_index}) {
	    die "rule '", $obj->transaction->rule->header, "' attempts to read its output property ", $prop->name,
	        " before it is created\n";
	 }
	 return $pv;
      }

      # try to find a shortcut

      my $ascent_till=-1;
      if (is_object($req_item)) {
	 $path[0]=$self;
	 $types[0]=$self->type;
      } else {
	 @types=map { $_->type } @path;
	 # deduce the types of lacking subobjects
	 while ($#types < $#$req_item) {
	    my $prop_type=$req_item->[$#types]->type;
	    push @types, $prop_type->abstract ? $prop_type->concrete_type($types[-1]) : $prop_type;
	    --$ascent_till;
	 }
      }

      for (my $i=-1; $i>=$ascent_till; --$i) {
	 my $top=$self;
	 my $subobj_level;
	 if (is_object($req_item)) {
	    $subobj_level=0;
	 } else {
	    $prop=$req_item->[$i];
	    $subobj_level=@$req_item+$i;
	 }
	 my $prod_key=$prop->key;
	 my $skip_levels=$i-$ascent_till;
	 for (;;) {
	    # only look for shortcuts rooted in existing subobjects
	    if (--$skip_levels<0) {
	       my ($cur_obj, $cur_obj_type)= $subobj_level>=0 ? ($path[$subobj_level], $types[$subobj_level]) : ($top, $top->type);
	       my $shortcuts=$cur_obj_type->get_shortcuts_for($prop);
	       if ($i==-1) {
		  # consider all shortcuts delivering the requested property directly
		  foreach my $rule (@$shortcuts) {
		     if (defined ($pv=$rule->descend_to_source($cur_obj))) {
			return $pv;
		     }
		  }
	       } else {
		  # consider shorcuts for subobjects on the path to the requested property, look there for the rest of the path
		  foreach my $rule (@$shortcuts) {
		     if (defined ($pv=$rule->descend_to_source($cur_obj))
			 and defined ($pv=_lookup_pv($pv->value, [ [ @$req_item[$i+1..-1] ] ]))) {
			return $pv;
		     }
		  }
	       }
	    }
	    if (--$subobj_level>=0) {
	       $prop=$req_item->[$subobj_level];
	    } elsif (defined $top->parent) {
	       $prop=$top->property;
	       $top=$top->parent;
	    } else {
	       last;
	    }
	    last unless defined ($prod_key=$prod_key->{$prop->key});
	    $prop=$prod_key;
	 }
      }
   }
   undef;
}

sub lookup_pv {		# 'request' => PropertyValue or Object
   my ($self, $req)=@_;
   _lookup_pv($self, $self->type->encode_read_request($req,$self,1));
}
sub lookup {
   if (defined (my $pv=&lookup_pv)) {
      if (@_>2) {
         $pv->property->flags & $Property::is_multiple
           or croak( "property-based lookup can only be performed on sub-objects with `multiple' attribute" );
         $pv->find(@_[2..$#_]);
      } else {
         $pv->value;
      }
   } else {
      _expect_array_access() ? [ ] : undef;
   }
}
sub lookup_with_name {
   my $pv=&lookup_pv;
   defined($pv) ? ($pv->value, $pv->property->name) : ();
}
####################################################################################
# private:
sub _put_pv {
   my ($self, $prop, $pv)=@_;
   my $content_index=$self->dictionary->{$prop->key};
   if (defined $self->transaction->rule) {
      # creating a property in a rule
      defined($content_index)
         or croak( "attempt to create property '", $prop->name, "' which is not declared as a rule target" );
      $self->contents->[$content_index]=$pv;

   } elsif (defined $content_index) {
      # overwriting an existing property
      if ($self->transaction->content_end<0 || $prop->flags & ($Property::is_multiple | $Property::is_mutable)) {
	 $self->contents->[$content_index]=$pv;
      } else {
	 croak( "can't change the property ", $prop->name );
      }

   } else {
      # new property created outside of a production rule
      push @{$self->contents}, $pv;
      $self->dictionary->{$prop->key}=$content_index=$#{$self->contents};
   }
}
####################################################################################
sub put {
   my ($self, $temp, $prop, $value);
   if (@_==3) {
      ($self, $prop, $value)=@_;
   } else {
      ($self, $temp, $prop, $value)=@_;
   }
   my $need_commit;
   if (defined($self->transaction)) {
      $temp ||= $self->transaction->entirely_temp;
   } else {
      if ($prop->flags & ($Property::is_multiple | $Property::is_mutable)) {
	 $need_commit=1;
	 begin_transaction($self);
      } else {
	 croak( "can't add or change the property ", $prop->name );
      }
   }
   my $pv=$prop->accept->($value,$self,0,$temp);
   _put_pv($self,$prop,$pv);
   if ($temp) {
      assign_max($#{$self->transaction->temporaries},0);
      push @{$self->transaction->temporaries}, ($prop->flags & $Property::is_multiple ? [ $prop, 0 ] : $prop);
   } else {
      $self->transaction->changed=1;
   }
   $self->transaction->commit($self) if $need_commit;
   $pv->value if defined(wantarray);
}
####################################################################################
sub put_ref {
   my ($self, $prop, $value, $flags)=@_;
   _put_pv($self, $prop, new PropertyValue($prop, $value, $flags || (defined($value) && $PropertyValue::is_strong_ref)));
}
####################################################################################
sub add {
   my ($self, $prop_name, $value, $temp)=@_;
   my $need_commit;
   my $prop=$self->type->lookup_property($prop_name) ||
            try_auto_cast($self,$prop_name,0) || 
            croak( "unknown property ", $self->type->full_name, "::$prop_name" );
   if ($prop->flags & $Property::is_multiple) {
      if (defined($self->transaction)) {
	 if (!$temp) {
            if (defined($self->transaction->rule)) {
               croak( "Attempt to add a subobject in an unrelated rule" );
            }
            $temp=$self->transaction->entirely_temp;
	 }
      } else {
	 $need_commit=1;
	 begin_transaction($self);
      }
      _add_multi($self,$prop,$value,$temp);
      if ($temp) {
	 assign_max($#{$self->transaction->temporaries},0);
	 push @{$self->transaction->temporaries}, [ $prop, $value->parent_index ];
      } else {
	 $self->transaction->changed=1;
      }
      $self->transaction->commit($self) if $need_commit;
   } else {
      croak( "Object::add can only be used to attach subobjects declared as 'multiple'" );
   }
}

sub add_temp { add(@_,1) }
####################################################################################
sub take {
   my ($self, $prop_name, $value, $temp)=@_;
   my @req=$self->type->encode_request_element($prop_name);
   my $need_commit;
   if (!defined($self->transaction)) {
      if ($req[-1]->flags & ($Property::is_multiple & $Property::is_mutable)) {
	 $need_commit=1;
	 begin_transaction($self);
      } else {
	 croak( "can't add or change the property $prop_name" );
      }
   }
   my ($obj, $prop)=descend_and_create($self,@req);
   put($obj,$temp,$prop,$value);
   $self->transaction->commit($self) if $need_commit;
}

sub take_temp { take(@_,1) }
####################################################################################
sub remove {
   my ($self, $prop_name)=@_;
   my $need_commit;
   if (ref($prop_name)) {
      my $sub_obj=$prop_name;
      if (!($sub_obj->property->flags & $Property::is_multiple)) {
	 croak( "only multiple sub-objects can be removed by reference" );
      }
      if ($sub_obj->parent==$self) {
	 my $content_index=$self->dictionary->{$sub_obj->property->key};
	 my $sub_index=$sub_obj->parent_index;
	 my $pv;
	 if (defined($content_index)  and
	     ($pv=$self->contents->[$content_index], $pv->values->[$sub_index]==$sub_obj)) {
	    if (defined($self->transaction)) {
	       if (defined($self->transaction->rule)) {
		  croak( "attempt to remove a sub-object in a rule" );
	       }
	       if (defined($sub_obj->transaction)) {
		  $sub_obj->transaction->rollback->($sub_obj);
		  delete $self->transaction->subobjects->{$sub_obj};
	       }
	    } else {
	       $need_commit=1;
	       begin_transaction($self);
	    }
	    if ($sub_index == $#{$pv->values}) {
	       pop @{$pv->values};
	       if (!@{$pv->values}) {
		  delete $self->dictionary->{$sub_obj->property->key};
		  undef $self->contents->[$content_index];
		  assign_min($self->transaction->temporaries->[0], $content_index);
	       }
	    } else {
	       undef $pv->values->[$sub_index];
	       $pv->has_gaps=1;
	       if (!$sub_obj->is_temporary) {
		  assign_max($#{$self->transaction->temporaries},0);
		  push @{$self->transaction->temporaries}, [ $sub_obj->property, $sub_index ];
	       }
	    }
	    if (defined($sub_obj->transaction) && !$need_commit) {
	       delete $self->transaction->subobjects->{$sub_obj};
	    }
	    $self->transaction->changed=1;
	    $self->transaction->commit($self) if $need_commit;
	    undef $sub_obj->parent;
	    undef $sub_obj->property;
	    undef $sub_obj->parent_index;
	    undef $sub_obj->is_temporary;
	 } else {
	    croak( "internal inconsistency: sub-object list for property ", $subobj->property->name, " is corrupted" );
	 }
      } else {
	 croak( "only own sub-objects can be removed" );
      }

   } else {
      my ($obj, $prop);
      my $allowed=1;
      my @req=$self->type->encode_request_element($prop_name);
      if (!defined($self->transaction)) {
         $allowed= $req[-1]->flags & ($Property::is_multiple | $Property::is_mutable);
	 $need_commit=1;
	 begin_transaction($self);
      }
      if (($obj, $prop)=descend_with_transaction($self,@req) and
	  defined (my $content_index=delete $obj->dictionary->{$prop->key})) {
         $obj->transaction->backup->{$content_index} ||= $obj->contents->[$content_index];
	 undef $obj->contents->[$content_index];
	 assign_min($obj->transaction->temporaries->[0], $content_index);
	 $obj->transaction->changed=1;
         if ($allowed || can_reconstruct($self, @req)) {
            $self->transaction->commit($self) if $need_commit;
         } else {
            $self->rollback;
            croak( "can't remove the property $prop_name: it is neither multiple nor mutable, nor can be computed from the rest properties" );
         }
      } elsif (defined($self->transaction->rule)) {
	 croak( "attempt to remove the property $prop_name which is not declared as a rule source" );
      } else {
	 $self->rollback if $need_commit;
         croak( "property $prop_name does not exist in the given object" );
      }
   }
}
####################################################################################
sub commit {
   my ($self)=@_;
   $self->transaction->commit(@_);
}
sub rollback {
   my ($self)=@_;
   $self->transaction->rollback(@_);
}
####################################################################################
sub cleanup {
   my ($self, $data)=@_;
   my $deleted_index=shift @$data;
   my %squeeze_multi;
   foreach (@$data) {
      my ($content_index, $sub_index);
      if (!is_object($_) && is_integer($sub_index=$_->[1])) {
	 # via multiple sub-object (might be removed in the meanwhile)
	 defined($content_index=$self->dictionary->{$_->[0]->key}) or next;
	 my $pv=$self->contents->[$content_index];
	 my $sub_obj=$pv->values->[$sub_index];
	 if (!defined($sub_obj)) {
	    $pv->has_gaps or croak( "internal inconsistency: flag has_gaps for property ", $pv->property->name, " is not set although child $sub_index removed" );
	    $squeeze_multi{$pv}=$content_index;
	    next;
	 }
	 if ($#$_==2) {
	    cleanup($sub_obj,$_->[2]);
	    next if $#{$sub_obj->contents}>=0;
	 }
	 if ($sub_index==$#{$pv->values}) {
	    pop @{$pv->values};
	    next if @{$pv->values};
	 } else {
	    undef $pv->values->[$sub_index];
	    $squeeze_multi{$pv}=$content_index;
	    next;
	 }
	 delete $self->dictionary->{$_->[0]->key};

      } elsif (defined $sub_index) {
	 # via singular sub-object
	 defined($content_index=$self->dictionary->{$_->[0]->key}) or next;
	 my $sub_obj=$self->contents->[$content_index];
	 cleanup($sub_obj, $sub_index);
	 next if $#{$sub_obj->contents}>=0;
	 delete $self->dictionary->{$_->[0]->key};
      } else {
	 # atomic property
	 defined($content_index=delete $self->dictionary->{$_->key}) or next;
      }
      if ($content_index==$#{$self->contents}) {
	 pop @{$self->contents};
      } else {
	 undef $self->contents->[$content_index];
	 assign_min($deleted_index,$content_index);
      }
   }

   while (my ($pv, $content_index)=each %squeeze_multi) {
      if (!$pv->squeeze) {
	 delete $self->dictionary->{$pv->property->key};
	 if ($content_index==$#{$self->contents}) {
	    pop @{$self->contents};
	 } else {
	    undef $self->contents->[$content_index];
	    assign_min($deleted_index,$content_index);
	 }
      }
   }

   if (defined $deleted_index) {
      my ($gap, $last)=(1, $#{$self->contents});
      while (++$deleted_index<=$last) {
	 my $pv=$self->contents->[$deleted_index];
	 if (defined($pv)) {
	    $self->contents->[$deleted_index-$gap]=$pv;
	    $self->dictionary->{$pv->property->key}=$deleted_index-$gap;
	 } else {
	    ++$gap;
	 }
      }
      $#{$self->contents}-=$gap;
   }
   $self->has_cleanup=0;
}

sub cleanup_now {
   my $self=shift;
   cleanup($self, delete $Scope->cleanup->{$self});
}
####################################################################################
sub save : method {
   my $self=shift;
   if (defined($self->property)) {
      croak( "A sub-object can't be saved without its parent" );
   }
   if (defined($self->transaction)) {
      if (defined($self->transaction->rule)) {
	 croak( "Object::save called from within a rule" );
      }
      $self->transaction->commit($self);
   }
   cleanup_now($self) if $self->has_cleanup;
   $self->persistent->save($self);
   delete $save_at_end{$self};
   $self->changed=0;
}
####################################################################################
sub DESTROY {
   my $self=shift;
   if (defined($self->parent)) {
      if (defined($self->transaction) && defined (my $parent_trans=$self->parent->transaction)) {
	 delete $parent_trans->subobjects->{$self};
      }

      # If $Scope object does not exist, we are in the final object destruction phase;
      # the persistent objects have already been saved in the AtEnd action,
      # all others may be discarded without remorse.
   } elsif (defined($Scope) && !defined($self->property)) {
      if (defined($self->persistent) && $self->changed) {
	 if (defined($self->transaction)) {
	    $self->transaction->rollback($self);
	 }
	 if ($self->changed) {
	    if ($self->has_cleanup) {
	       cleanup($self, delete $Scope->cleanup->{$self});
	    }
	    $self->persistent->save($self);
	 } elsif ($self->has_cleanup) {
	    delete $Scope->cleanup->{$self};
	 }
	 delete $save_at_end{$self};
      } elsif ($self->has_cleanup) {
	 delete $Scope->cleanup->{$self};
      }
   }
}

sub dont_save {
   my $self=shift;
   if (!defined($self->property) && defined($Scope) && defined($self->persistent)) {
      if (defined($self->transaction)) {
	 $self->transaction->rollback($self);
      }
      if ($self->changed) {
	 if ($self->has_cleanup) {
	    cleanup($self, delete $Scope->cleanup->{$self});
	 }
	 $self->changed=0;
	 delete $save_at_end{$self};
      }
   }
}
####################################################################################
sub eval_input_list {	# [ PropertyPath, ... ] => true (ready) || false (not exist) || undef
   my ($self, $input_list, $allow_undefs)=@_;
   my ($content_index, $pv, $rc);
   foreach my $item (@$input_list) {
      if (my ($obj, $prop)=descend($self,$item)) {
	 if (defined ($content_index=$obj->dictionary->{$prop->key}) &&
	     defined ($pv=$obj->contents->[$content_index])) {
	    return $allow_undefs || defined($pv->value) || undef;
	 } else {
	    $rc=0;
	 }
      } elsif (!$undef_underway) {
	 $rc=0;
      }
   }
   $rc
}
####################################################################################
sub allow_undef_value {
   my ($self, $prop)=@_;
   if (defined($self->transaction) && defined($self->transaction->rule) &&
       !($self->transaction->rule->flags & $Rule::is_definedness_check)) {
      die "attempt to use a property ", is_object($prop) ? $prop->name : $prop, " with undefined value\n";
   }
   undef
}

sub give_pv {
   my ($self, $req_string)=@_;
   my $req=$self->type->encode_read_request($req_string,$self);
   _lookup_pv($self,$req)
   || do {
      if (defined($self->transaction)) {
	 if (defined($self->transaction->rule)) {
	    die "attempt to access ", ($#$req>0 ? "undefined properties " : "an undefined property "), $req_string, "\n";
	 }
	 $self->transaction->commit($self);
      }
      provide_request($self, [ $req ]);
      _lookup_pv($self,$req)
      or die( $#$req>0 ? "properties " : "property ", $req_string, " not created as expected" );
   }
}

sub give {
   if (@_==2) {
      &give_pv->value;
   } else {
      my ($self, $req_string)=splice @_, 0, 2;
      my $req=$self->type->encode_read_request($req_string,$self);
      if ($#$req>0) {
	 croak( "mixing alternatives with property-based lookup of multiple sub-objects is not allowed" );
      }
      if (my ($obj, $prop)=descend($self,$req->[0])) {
	 $prop->flags & $Property::is_multiple
	    or croak( "property-based lookup can only be performed on sub-objects with `multiple' attribute" );
	 get_multi($obj, @_, $prop);
      } else {
	 die "can't create any subobject on a non-existing path $req->[0]\n";
      }
   }
}

sub give_with_name {
   my $pv=&give_pv;
   ($pv->value, $pv->property->name);
}
####################################################################################
# protected:
sub provide_request {
   my ($self, $request)=@_;
   my ($success, $sched)=&Scheduler::resolve_request;
   return 1 if $success>0;
   my @lacking;
   foreach my $input_list (@$request) {
      eval_input_list($self,$input_list,1)
         or push @lacking, $input_list;
   }
   if ($success==0) {
      if ($Verbose::rules) {
	 my @failed_precond;
	 while (my ($rule, $rc)=each %{$sched->run}) {
	    if ($rc==$exec_failed && ($rule->flags & $Rule::is_precondition)) {
	       push @failed_precond, $rule->header."\n";
	    }
	 }
	 my $lacking=join(", ", map { "'".Scheduler::print_input_list($_)."'" } @lacking);
	 if (@failed_precond) {
	    warn_print("could not compute $lacking probably because of unsatisfied preconditions:\n", @failed_precond);
	 } else {
	    warn_print("available properties insufficient to compute $lacking");
	 }
      }
      create_undefs($self, map { @$_ } @lacking);
      0;
   } else {
      die "no more rules available to compute ", join(", ", map { "'".Scheduler::print_input_list($_)."'" } @lacking), "\n";
   }
}
####################################################################################
sub provide {
   my $self=shift;
   if (defined($self->transaction)) {
      if (defined($self->transaction->rule)) {
	 croak( "Object->provide not allowed within a rule" );
      } else {
	 commit($self);
      }
   }
   provide_request($self, [ map { $self->type->encode_read_request($_,$self) } @_ ]);
}
####################################################################################
sub get_schedule {
   my $self=shift;
   if (defined($self->transaction)) {
      if (defined($self->transaction->rule)) {
	 croak( "Object->get_schedule not allowed within a rule" );
      } else {
	 commit($self);
      }
   }
   my $for_auto_cast;
   my $sched=new Scheduler::InitRuleChain($self, create Rule('request', [ map { $self->type->encode_read_request($_,$self,\$for_auto_cast) } @_ ], 1));
   if (defined $for_auto_cast) {
      my $chain;
      if (@{$for_auto_cast->rules} &&
	  defined ($chain=$sched->gather_rules &&
		          $sched->resolve($self,!$Scheduler::dry_run))) {
	 unshift @{$chain->rules}, @{$for_auto_cast->rules};
      }
      $chain;
   } else {
      $sched->gather_rules &&
      $sched->resolve($self,!$Scheduler::dry_run);
   }
}
####################################################################################
# protected:
sub can_reconstruct {
   my ($self, @path)=@_;
   # if the Scheduler creates new properties for precondition evaluation, they shouldn't remain
   $self->transaction->entirely_temp=1;
   my $sched=new Scheduler::InitRuleChain($self, create Rule('request', [ [ @path>1 ? \@path : @path ] ], 1));
   $sched->gather_rules &&
   defined($sched->resolve($self,1));
}
####################################################################################
sub list_properties {
   my ($self, $rec)=@_;
   map {
      if (defined($_)) {
	 if (!$rec || instanceof PropertyValue($_)) {
	    $_->property->name
	 } elsif (instanceof Object($_)) {
	    my $prefix=$_->property->name;
	    map { "$prefix.$_" } list_properties($_,$rec)
	 } else {
	    my $prop=$_->property->name;
	    my $prefix;
	    map { $prefix="$prop\[".subobj_name($_)."]"; map { "$prefix.$_" } list_properties($_,$rec) } @{$_->defined_values}
	 }
      } else {
	 ()
      }
   } @{$self->contents};
}
####################################################################################
sub get {
   my ($self, $prop)=@_;
   my $content_index=$self->dictionary->{$prop->key};
   if (defined $content_index) {
      _get_alternatives();
   } else {
    TRY_ALT: {
	 my $subtype=$prop->type;
	 my $descend_path;
	 my @alt= instanceof ObjectType($subtype) ? _get_alternatives($descend_path) : _get_alternatives();

	 if (defined $descend_path) {

	    if (defined($self->transaction)) {
	       if (defined($self->transaction->rule)) {
		  die "attempt to access an undefined property ", $prop->name, "\n";
	       }
	       $self->transaction->commit($self);
	    }

	    my @req=($prop);
	    foreach (@$descend_path) {
	       if (defined (my $subprop=$subtype->lookup_property($_))) {
		  push @req, $subprop;
		  last unless instanceof ObjectType($subprop->type);
		  $subtype=$subprop->type;
	       } else {
		  last;
	       }
	    }

	    if (@alt && @$descend_path==$#req) {
	       provide_request($self, [ [ \@req,
					  map { [ (@req[0..$#req-1], $subtype->lookup_property($_) || croak( "unknown property $_" )) ]
					      } @alt ] ]);
	    } else {
	       provide_request($self, [ [ \@req ] ]);
	    }
	    $content_index=$self->dictionary->{$prop->key};

	 } else {

	    foreach my $alt_prop (@alt) {
	       $alt_prop=$self->type->lookup_property($alt_prop)
	                 || croak( "unknown property $alt_prop" );
	       last TRY_ALT if defined ($content_index=$self->dictionary->{$alt_prop->key});
	    }

	    if (defined($self->transaction)) {
	       if (defined($self->transaction->rule)) {
		  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";
		  }
	       }
	       $self->transaction->commit($self);
	    }

	    unshift @alt, $prop;
	    provide_request($self, [ \@alt ]);
	    foreach $prop (@alt) {
	       last if defined ($content_index=$self->dictionary->{$prop->key});
	    }
	 }
      }
      defined($content_index) or die "can't create property ", $prop->name, "\n";
   }
   defined($self->contents->[$content_index]->value || &allow_undef_value);
}
####################################################################################
sub get_multi {
   my $iterate;
   if (@_==2 && !($iterate=_expect_array_access())) {
      &get;
   } else {
      my $self=shift;
      my $prop=pop;
      my $content_index=$self->dictionary->{$prop->key};
      if ($iterate) {
	 return defined($content_index) ? $self->contents->[$content_index]->defined_values : [ ];
      }
      if (@_==1 && !ref($_[0])) {
	 # search by name
	 return defined($content_index) ? $self->contents->[$content_index]->find_by_name(@_) : undef;
      }
      if (!defined($content_index)) {
	 push @{$self->contents}, new PropertyMultipleValue($prop->concrete($self), [ ]);
	 $content_index=$self->dictionary->{$prop->key}=$#{$self->contents};
      }
      $self->contents->[$content_index]->find_or_create($self,@_);
   }
}
####################################################################################
sub put_multi {
   if (@_==3 or @_==4 && !ref($_[1])) {
      &put;
   } else {
      my $self=shift;
      my ($prop, $value)=splice @_, -2;
      my $need_commit;
      if (!defined($self->transaction)) {
	 $need_commit=1;
	 begin_transaction($self);
      }
      my $content_index=$self->dictionary->{$prop->key};
      if (defined $content_index) {
	 $self->contents->[$content_index]->replace_or_add($self,@_,$value);
      } else {
	 push @{$self->contents}, $prop->accept->($value,$self);
	 $self->dictionary->{$prop->key}=$#{$self->contents};
      }
      $self->transaction->changed=1;
      $self->transaction->commit($self) if $need_commit;
      $value;
   }
}
####################################################################################
sub subobj_name : method {
   my $self=shift;
   defined($self->name) ? $self->name : defined($self->parent) ? $self->parent_index : undef
}
####################################################################################
sub get_attachment {
   my ($self, $name)=@_;
   if (defined($self->transaction) && defined($self->transaction->rule)) {
      croak( "production rules may not access attachments" );
   }
   $self->attachments->{$name};
}

sub remove_attachment {
   my ($self, $name)=@_;
   if (defined($self->transaction)) {
      if (defined($self->transaction->rule)) {
	 croak( "porduction rules may not operate on attachments" );
      }
      $self->transaction->changed=1;
   } else {
      begin_transaction($self);
      $self->transaction->changed=1;
      $self->transaction->commit($self);
   }
   delete $self->attachments->{$name};
}

sub list_attachments {
   my $self=shift;
   keys %{$self->attachments};
}

sub attach {
   my ($self, $name, $data)=@_;
   if (ref($data)) {
      if (is_object($data) && defined (my $type=UNIVERSAL::can($data,"type"))) {
	 $type=$type->();
	 if (instanceof ObjectType($type)) {
	    croak( "can't attach a subobject of type ", $type->full_name, ": only atomic properties are allowed as attachments" );
	 }
      } else {
	 croak( "can't attach ", ref($data), ": it does not belong to any declared property type" );
      }
   }
   if (defined($self->transaction)) {
      if (defined($self->transaction->rule)) {
	 croak( "production rules may not operate on attachments" );
      }
      $self->transaction->changed=1;
   } else {
      begin_transaction($self);
      $self->transaction->changed=1;
      $self->transaction->commit($self);
   }
   $self->attachments->{$name}=$data;
}

sub copy_attachments {
   my ($self, $src)=@_;
   while (my ($name, $data)=each %{$src->attachments}) {
      if (is_object($data)) {
	 $data=$data->type->construct->($data);
      }
      $self->attachments->{$name}=$data;
   }
}
####################################################################################
# this method is called only as fallback,
# if no ObjectType in the type hierarchy has a specifix suffix
sub default_file_suffix : method {
   (shift)->type->application->default_file_suffix
}
####################################################################################
# protected:
sub do_cast {
   my ($self, $target_proto)=@_;
   if (defined($self->property) && $self->property->flags & $Property::is_locally_derived) {
      $target_proto=$self->property->type->local_type($target_proto);
   }
   bless $self, $target_proto->pkg;
}

# protected:
sub do_downcast {
   my ($self, $rule)=@_;
   if (@{$rule->preconditions}) {
      Scheduler::resolve_rule($self,$rule)>0
      or croak( "Can't perform a downcast to ", $rule->output->full_name, " due to unsatisfied preconditions" );
   }
   do_cast($self, $rule->output);
}

# protected:
#  mode==1: "dry run", only check if possible but don't change anything
#  mode==ARRAY: gather rules for a canned schedule
sub try_auto_cast {
   my ($self, $prop_name, $mode)=@_;
   if (my ($rule, $prop)=$self->type->lookup_auto_cast($prop_name)) {
      if (ref($mode)) {
	 if (defined (my $chain=Scheduler::resolve_rule($self,$rule,!$Scheduler::dry_run))) {
	    if ($Scheduler::dry_run) {
	       @{$chain->rules}=($rule);
	    } else {
	       do_cast($self,$rule->output);
	    }
	    $$mode=$chain;
	 } else {
	    $$mode=new Scheduler::RuleChain($self, undef);
	 }
      } elsif (!$mode) {
	 do_downcast($self,$rule);
      }
      ($rule->output, $prop)
   } else {
      ()
   }
}

sub AUTOLOAD {
   my $self=$_[0];
   my ($prop_name)=$AUTOLOAD=~/($id_re)$/xo;
   if (!$DeveloperMode || instanceof Object($self)) {
      if (my ($rule, $prop)=$self->type->lookup_auto_cast($prop_name)) {
	 do_downcast($self,$rule);
	 push @_, $prop;
	 $prop->flags & $Property::is_multiple ? &get_multi : &get;
      } else {
	 croak( "Object ", $self->type->full_name, " does not have a property or method $prop_name" );
      }
   } else {
      croak( "undefined subroutine $prop_name called" );
   }
}
####################################################################################
sub add_credit {
   my ($self, $credit)=@_;
   my $parent;
   while (defined ($parent=$self->parent)) { $self=$parent; }
   $self->credits->{$credit->product} ||= $credit;
   $credit->display if $Verbose::credits > $credit->shown;
}
####################################################################################
sub copy_permuted {
   my $self=shift;
   my $proto=$self->type;
   my (@descend_to_permuted, @perms);
   if ($_[0] eq "permutation") {
      $perms[0]=$proto->lookup_permutation($_[1]) || croak( "unknown permutation $_[1]" );
      splice @_, 0, 2;
   } else {
      my @path=$proto->encode_request_element($_[0]);
      @perms=grep { defined($_->type->find_sensitive_sub_property(@path)) } $proto->list_permutations;
      unless (@perms) {
	 my $subobj=$self;
	 my ($content_index, $pv);
	 for (my $i=0; $i<$#path; ++$i) {
	    if (defined ($content_index=$subobj->dictionary->{$path[$i]->key}) &&
		defined ($pv=$subobj->contents->[$content_index])) {
	       if (@perms=grep { defined($_->type->find_sensitive_sub_property(@path[$i+1..$#path])) } $pv->property->type->list_permutations) {
		  @descend_to_permuted=@path[0..$i];
		  last;
	       }
	       $subobj=$pv->value;
	    } else {
	       croak( "copy_permuted: ", join(".", map { $->name } @path[0..$i]), " does not exist in the object" );
	    }
	 }
	 @perms or croak( "copy_permuted: $_[0] is not affected by any permutation" );
      }
      for (my $i=2; $i<$#_; $i+=2) {
	 @path=$proto->encode_request_element($_[$i]);
	 if (@descend_to_permuted) {
	    splice @path, 0, scalar @descend_to_permuted;
	 }
	 @perms= grep { defined($_->type->find_sensitive_sub_property(@path)) } @perms
	    or croak( "copy_permuted: no permutation type known which would simultaneously affect ", join(", ", map { $_[$_*2] } 0..$i/2));
      }
      if (@perms!=1) {
         croak( "copy_permuted: permutation type can't be unambiguously chosen; permutations in question are ",
	        join(", ", map { $_->name } @perms) );
      }
   }
   my ($rule, $filter)=permuting Rule($proto, shift(@perms), @descend_to_permuted);
   my $copy=$self->copy(undef, $filter);
   for (my $i=0; $i<$#_; $i+=2) {
      take($copy, $_[$i], $_[$i+1]);
   }
   Scheduler::resolve_permutation($copy, $rule) > 0
     or croak( "couldn't permute all properties" );
   cleanup_now($copy);
   $copy;
}
####################################################################################
# private:
sub search_for_sensitive {
   my ($self, $prop_hash, $in_props)=@_;
   my ($content_index, $pv);
   while (my ($prop_key, $down)=each %$prop_hash) {
      if ($prop_key == $ObjectType::Permutation::sub_key) {
	 while (my ($prop_key, $sub_hash)=each %$down) {
	    if (defined ($content_index=$self->dictionary->{$prop_key}) &&
		defined ($pv=$self->contents->[$content_index]) &&
		defined ($pv->value)) {
	       if ($pv->property->flags & $Property::is_multiple) {
		  foreach (@{$pv->values}) {
		     if (search_for_sensitive($_,$sub_hash,$in_props)) {
			keys %$down; keys %$prop_hash;   # reset iterators
			return 1;
		     }
		  }
	       } elsif (search_for_sensitive($pv->value,$sub_hash,$in_props)) {
		  keys %$down; keys %$prop_hash;   # reset iterators
		  return 1;
	       }
	    }
	 }
      } else {
	 if (defined ($content_index=$self->dictionary->{$prop_key}) &&
	     defined ($pv=$self->contents->[$content_index]) &&
	     defined ($pv->value)) {
	    if ($in_props || search_for_sensitive($pv->value,$down->type->sensitive_props,1)) {
	       keys %$prop_hash;	# reset the iterator;
	       return 1;
	    }
	 }
      }
   }
   0
}

sub has_sensitive_to {
   my ($self, $perm_prop)=@_;
   defined( $self->sensitive_to->{$perm_prop->key} ||= search_for_sensitive($self,$perm_prop->type->sensitive_props,1)
					           || search_for_sensitive($self,$perm_prop->type->sub_permutations,0) );
}
####################################################################################
# PropertyValue1, PropertyValue2 => scalar context: >0 if not equal, undef if equal
#                                => list context:   (pv1, pv2) if not equal, () if equal
sub diff_properties {
   my ($self, $pv1, $pv2)=@_;
   if ($pv1->property->flags & $Property::is_multiple) {
      my $v2=instanceof PropertyMultipleValue($pv2) ? $pv2->values : $pv2;
      if ((my $l=$#{$pv1->values}) == $#$v2) {
	 if (wantarray) {
	    map { my $o1=$pv1->values->[$_]; map { $_->[2] ||= $o1; $_ } $o1->diff($v2->[$_]) } 0..$l;
	 } else {
	    $pv1->values->[$_]->diff($v2->[$_]) and return 1 for 0..$l;
	    ()
	 }
      } else {
	 !wantarray || [ $pv1, $pv2 ]
      }
   } else {
      my $v2=instanceof PropertyValue($pv2) ? $pv2->value : $pv2;
      if (defined($pv1->value) && defined($v2)) {
	 if (instanceof Object($pv1->value)) {
	    if (ref($pv1->value) eq ref($v2)) {
	       if (wantarray) {
		  map { $_->[2] ||= $pv1->value; $_ } $pv1->value->diff($v2);
	       } else {
		  $pv1->value->diff($v2);
	       }
	    } else {
	       !wantarray || [ $pv1, $pv2 ]
	    }
	 } else {
	    (defined($pv1->property->equal) ? select_method($pv1->property->equal,$self,1)
	     				    : $pv1->property->type->equal)
	    ->($pv1->value, $v2) ? () : !wantarray || [ $pv1, $pv2 ]
	 }
      } else {
	 defined($pv1->value) == (defined($v2)) ? () : !wantarray || [ $pv1, $pv2 ]
      }
   }
}

# Object1, Object2 => scalar context: >0 if not equal, 0 if equal
#                  => list context:   [ pv1, pv2, subobj ], ... if not equal
sub diff {
   my ($self, $other)=@_;
   my @diff;

   if (@{$self->contents} != @{$other->contents}) {
      if (wantarray) {
	 push @diff, map { [ undef, $_ ] } grep { defined($_) && !exists $self->dictionary->{$_->property->key} } @{$other->contents};
      } else {
	 return 1;
      }
   }

   foreach my $pv (@{$self->contents}) {
      my $other_index=$other->dictionary->{$pv->property->key};
      if (defined $other_index) {
	 if (wantarray) {
	    push @diff, diff_properties($self, $pv, $other->contents->[$other_index]);
	 } else {
	    diff_properties($self, $pv, $other->contents->[$other_index]) and return 1;
	 }
      } elsif (wantarray) {
	 push @diff, [ $pv, undef ];
      } else {
	 return 1;
      }
   }

   @diff
}
####################################################################################
package Polymake::Core::MethodAsRule;

sub add_control {
   my ($pkg, $list, $rule)=@_;
   if (!@$list) {
      bless $list, $pkg;
   }
   push @$list, $rule;
}

sub dup {
   my $list=shift;
   inherit_class([ @$list ], $list);
}

sub resolve {
   my ($self, $args)=@_;
   Scheduler::resolve_method($args->[0],$self)
      or croak( "could not provide all required input properties" );
}


1

# Local Variables:
# cperl-indent-level:3
# End:
