#  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: ObjectType.pm 9783 2010-09-01 21:45:27Z gawrilow $

use strict;
use namespaces;

package Polymake::Core::ObjectType;
@ISA=( 'Polymake::Core::HasType4Deduction' );

##############################################################################
#  Collection of information common to all Objects of the same type
#  (such as property names, rules, etc.)

use Polymake::Struct (
   [ new => '$$@' ],
#
#  Environmental data
#
   [ '$name | generic_name' => '#1' ], 	# own name
   [ '$application' => '#2' ],	# -> Application
   [ '$extension' => '$Application::extension' ],
   '$pkg',			# perl object type
   [ '$context_pkg' => 'undef' ],	# for abstract parameterized object types
   [ '$param' => 'undef' ],	# for type templates
   '&abstract',
   '&construct',
   [ '&parse_string' => '\&Object::new_named' ],
   [ '&toString' => '\&Object::print_me' ],
#
#  Derivation relations
#
   '@super',			# ( ObjectType )  super classes: transitive closure in DSF order
   '@derived',			# ( ObjectType )  derived classes
   '%auto_casts',		# derived ObjectType => Rule::AutoCast
#
#  Own components
#
   '%properties',		# 'name' => Property
   '%permutations',		# 'name' => permutation Property
   '%producers',		# own rules producing a property: Property/Key => [ Rule, ... ]
   '%all_producers',		# cached own and inherited rules: Property/Key => [ Rule, ... ]
   '%shortcuts',		# cached own and inherited shortcut rules
   '%rules_by_label',		# own labeled producing rules: '*.label' => ControlList
   '%all_rules_by_label',	# cached own and inherited labeled rules
#
   [ '$help' => 'undef' ],      # InteractiveHelp (in interactive mode, when comments are supplied for properties, user methods, etc.)
);

####################################################################################
#
#  Constructor
#
#  new ObjectType('name', Application, [ template params ], [ super ObjectType, ... ]);
#
sub new {
   my $self=&_new;
   my $tparams=splice @_, 0, 3;
   my $proto_sub=sub { $self };

   if (defined($self->application)) {
      $self->pkg=$self->application->pkg."::".$self->name;
      my $symtab=get_pkg($self->pkg,1);
      if ($tparams) {
	 $self->abstract=sub { 1 };
	 $self->param=$#$tparams;	# the first element is n_defaults
	 new_generic PropertyParamedType($self->name, $self->pkg, $self->application, $tparams, "objects");
      } else {
	 define_function($symtab, "new", sub { shift; PropertyType::new_object($self,@_) }, 1);
	 no strict 'refs';
	 *{$self->application->pkg."::objects::".$self->name."::"}=$symtab;
      }
      Overload::_add($self->pkg, "construct", "", \&Object::new_empty);
      Overload::_add($self->pkg, "construct", $self->pkg, \&Object::new_copy);
      Overload::_add($self->pkg, "construct", $self->pkg.',$$;@', \&Object::new_filled_copy);
      Overload::add_fallback($self->pkg, "construct", \&Object::new_filled);
      $self->construct=\&{*{$symtab->{construct}}};
   } else {
      # it is an instance of an abstract Object type
      # the first super-Object is always the own abstract type
      $self->application=$_[0]->application;
      $self->extension=$_[0]->extension;
      $self->pkg=$_[0]->pkg;
      $self->construct=$_[0]->construct;
      PropertyParamedType::init_params($self,$tparams);
      if ($self->abstract) {
	 if (defined($self->context_pkg)) {
	    push @{$self->super}, $_[0], @{$_[0]->super};
	 }
	 return $self;
      }
   }
   define_function($self->pkg, "self",	# for the rule parser
		   sub {
		      # complain if called not from my own scope
		      shift or croak( "This declaration is only allowed in the top-level (application) scope" );
		      $self
		   }, 1);

   if (!$self->abstract) {
      # abstract object types get never instantiated, therefore don't deserve a prototype() method
      define_function($self->pkg, "type", $proto_sub);
      define_function($self->pkg, "prototype", $proto_sub);
      define_function($self->pkg, "typeof", $proto_sub);
   }

   # proceed with parent classes
   if (@_) {
      my (%super_seen, @isa);
      foreach my $super_proto (@_) {
	 if (! $super_seen{$super_proto}++) {
	    push @{$self->super}, $super_proto, grep { !$super_seen{$_}++ } @{$super_proto->super};
	    push @{$super_proto->derived}, $self;
	    push @isa, $super_proto->pkg;
	 }
         PropertyParamedType::set_extension($self->extension, $super_proto->extension) if $super_proto->extension;
      }
      namespaces::using($self->pkg, @isa);
      no strict 'refs';
      push @{$self->pkg."::ISA"}, @isa;
   } else {
      define_function($self->pkg, "top_type", $proto_sub);
      no strict 'refs';
      push @{$self->pkg."::ISA"}, "Polymake::Core::Object";
   }

   push @{$self->application->object_types}, $self;
   $self;
}

####################################################################################
# for compatibility with PropertyType:

*mangled_name=\&PropertyParamedType::mangled_name;
*full_name=\&PropertyParamedType::full_name;
*XML_name=\&PropertyParamedType::full_name;
*match_type=\&PropertyParamedType::match_type;
*complain_source_conflict=\&PropertyParamedType::complain_source_conflict;

sub concrete_type {
   # undef context_pkg means we are in a generic parameterized object class, hence nothing to deduce
   defined($_[0]->context_pkg) ? &PropertyParamedType::concrete_type : pop
}

*resolve_abstract=\&PropertyParamedType::resolve_abstract;

sub descend_to_generic {
   my ($self, $pkg)=@_;
   if (@{$self->super}) {
      return $self if $self->super->[0]->pkg eq $pkg;
      foreach my $super_proto (@{$self->super}) {
	 return $super_proto if !$super_proto->abstract && @{$super_proto->super} && $super_proto->super->[0]->pkg eq $pkg;
      }
   }
   undef
}
####################################################################################
sub isa {
   my ($self, $other)=@_;
   if (is_string($other)) {
      if ($other =~ /^$qual_id_re$/o) {
	 my $pkg=namespaces::lookup_class($self->pkg, $other, $self->application->pkg)
	 or croak( "Unknown type $other" );
	 $other=$pkg->self;
      } else {
	 $other=$self->application->eval_type($other);
      }
   }
   return $self==$other || list_index($self->super, $other)>=0;
}

sub is_one_of {
   my ($self, $others)=@_;
   foreach my $other (@$others) {
      return 1 if $self==$other || list_index($self->super, $other)>=0;
   }
   0
}
####################################################################################
sub lookup_property {
   my ($self, $prop_name, $allow_autocast)=@_;
   defined ($self->properties->{$prop_name} ||= do {
      my $prop;
      foreach (@{$self->super}) {
	 last if defined ($prop=$_->properties->{$prop_name});
      }
      if (!defined($prop) && $allow_autocast) {
	 foreach (keys %{$self->auto_casts}) {
	    if (defined ($prop=$_->properties->{$prop_name})) {
	       keys %{$self->auto_casts};       # reset the iterator!
	       return $prop;			# don't cache
	    }
	 }
      }
      $prop
   })
}

sub property {
   &lookup_property or croak( "unknown property ", $_[0]->full_name, "::$_[1]" );
}
####################################################################################
sub list_permutations {
   my $self=shift;
   (values %{$self->permutations}), (map { values %{$_->permutations} } @{$self->super})
}
####################################################################################
sub lookup_auto_cast {
   my ($self, $prop_name)=@_;
   while (my ($target_proto, $rule)=each %{$self->auto_casts}) {
      if (defined (my $prop=$target_proto->lookup_property($prop_name))) {
	 keys %{$self->auto_casts};		# reset the iterator!
	 return ($rule, $prop);
      }
   }
   foreach (@{$self->super}) {
      while (my ($target_proto, $rule)=each %{$_->auto_casts}) {
	 if (defined (my $prop=$target_proto->lookup_property($prop_name)) and
	     # the current object type and the target object type may be two fork ends with a common ancestor,
	     # in which case the auto_cast is not allowed
	     isa($target_proto, $_)) {
	    $self->auto_casts->{$target_proto}=$rule;
	    keys %{$_->auto_casts};		# reset the iterator!
	    return ($rule, $prop);
	 }
      }
   }
   ()
}
####################################################################################
# private:
sub add_property {	# => Property
   my ($self, $prop)=@_;
   if ($Application::plausibility_checks && defined (my $old_prop=$self->lookup_property($prop->name))) {
      croak( $old_prop->belongs_to == $self
	     ? "multiple definition of property '".$prop->name."'"
	     : "redefinition of inherited property '".$prop->name."' not allowed" );
   }

   define_function($self->pkg, $prop->name,
		   create_prop_accessor($prop->flags & $Property::is_multiple
					? [ $prop, \&Object::get_multi, \&Object::put_multi ]
					: [ $prop, \&Object::get,       \&Object::put       ],
					$self->pkg));

   $self->application->EXPORT->{$prop->name}="prop";
   $self->properties->{$prop->name}=$prop;
}
####################################################################################
sub add_property_definition {
   my $self=$_[0];
   add_property($self, new Property(@_));
}

sub add_property_alias {	# "new name", "old name", override => Property
   my ($self, $prop_name, $old_prop_name, $override)=@_;
   my $old_prop=$self->lookup_property($old_prop_name)
      or croak( "unknown property ", $self->name, "::$old_prop_name" );
   my $new_prop=add_property($self, $old_prop->create_alias($prop_name));
   if ($override) {
      if ($Application::plausibility_checks and
          $old_prop->belongs_to == $self ||
          @{$self->super} && $self->super->[0]->abstract && $self->super->[0]->name eq $self->name) {
         croak( "only properties inherited from other object types can be overriden" );
      }
      $self->properties->{$old_prop_name}=$new_prop;
      define_function($self->pkg, $old_prop_name, UNIVERSAL::can($self->pkg, $prop_name));
   }
   $new_prop;
}
####################################################################################
sub add_permutation {
   my ($self, $name)=@_;
   my $prop=add_property($self, new Property(@_, $self, "", undef));
   delete $self->application->EXPORT->{$name}; 
   $prop->type=new Permutation($self, new PermutationMixin($prop,$self->application));
   $prop->flags |= $Property::is_locally_derived | $Property::is_permutation;
   $self->permutations->{$name}=$prop;
}

# create a temporary permutation type ostensibly working on an ancestor
# of the object to be really permuted
sub create_permutation_for_ancestor {
   my ($self, $perm, @descend)=@_;
   my $prop=new Property($self, 'PermuteAncestor', $self, "", undef);
   $prop->type=new Permutation($self,  PermutationMixin->_new($prop,$self->application));
   $prop->flags |= $Property::is_locally_derived | $Property::is_permutation;
   $prop->type->add_sub_permutation(@descend, $perm);
   $prop
}
####################################################################################
# private:
sub fill_prod_cache {
   my ($self, $prop, $list)=@_;
   if (defined (my $own_prod=$self->producers->{$prop->key})) {
      push @$list, @$own_prod;
   }
   if ($prop->belongs_to != $self) {
      foreach my $super_proto (@{$self->super}) {
	 if ($super_proto->isa($prop->belongs_to)) {
	    get_producers_of($super_proto, $prop);
	    if (defined (my $own_prod=$super_proto->producers->{$prop->key})) {
	       push @$list, grep { !defined($_->overriden_in) || !is_one_of($self,$_->overriden_in) } @$own_prod;
	    }
	 }
      }
   }
   $list
}

# protected:
sub invalidate_prod_cache {
   my ($self, $prop)=@_;
   if (defined (delete $self->all_producers->{$prop->key})) {
      delete $self->shortcuts->{$prop->key};
      invalidate_prod_cache($_,$prop) for @{$self->derived};
   }
}

sub get_producers_of {
   my ($self, $prop)=@_;
   $self->all_producers->{$prop->key} ||= fill_prod_cache(@_,[ ]);
}

# only shortcuts directly creating the property asked for are stored here
sub get_shortcuts_for {
   my ($self, $prop)=@_;
   $self->shortcuts->{$prop->key} ||=
      [ grep { instanceof Rule::Shortcut($_) and
	       do { my $target=$_->output->[0];
		    is_object($target) || $target->[-1]->key == $prop->property_key
	       }
	} @{ $self->get_producers_of($prop) }
      ]
}
####################################################################################
# private:
sub fill_label_cache {
   my ($self, $wildcard)=@_;
   my $list=$self->rules_by_label->{$wildcard};
   my $copied=0;
   foreach my $super_proto (@{$self->super}) {
      get_rules_by_label($super_proto, $wildcard);
      if (defined (my $list2=$super_proto->rules_by_label->{$wildcard})) {
	 if ($copied) {
	    $list->merge($list2);
	 } elsif (defined $list) {
	    $list=$list->dup;
	    $list->merge($list2);
	    $copied=1;
	 } else {
	    $list=$list2;
	 }
      }
   }
   if ($copied && $self->application->temp_prefs) {
      $Scope->begin_locals;
      local $self->all_rules_by_label->{$wildcard}=$list;
      $Scope->end_locals;
      $list
   } else {
      $self->all_rules_by_label->{$wildcard}= $list || 1;
   }
}

# protected:
sub invalidate_label_cache {
   my ($self, $wildcard)=@_;
   if (defined (delete $self->all_rules_by_label->{$wildcard})) {
      invalidate_label_cache($_,$wildcard) for @{$self->derived};
   }
}

sub get_rules_by_label {
   my ($self, $wildcard)=@_;
   $self->all_rules_by_label->{$wildcard} || &fill_label_cache;
}

####################################################################################
# protected:
sub add_rule_labels {
   my ($self, $rule, $labels)=@_;
   foreach my $label (@$labels) {
      my $wildcard=$label->wildcard_name;
      my $ctl_list;
      if (defined ($ctl_list=$self->rules_by_label->{$wildcard})) {
	 invalidate_label_cache($self, $wildcard);
      } else {
	 $self->rules_by_label->{$wildcard}=$ctl_list=[ ];
      }
      $label->add_control($ctl_list, $rule);
   }
}
####################################################################################
# protected:
#  mode = set of flags, see Object::try_auto_cast
sub encode_request_element {
   my ($self, $req, $obj, $mode)=@_;
   my ($prop, $casted);
   map {
      my $perm_parent;
      if (defined($prop)) {
	 if ($Application::plausibility_checks && !instanceof ObjectType($prop->type)) {
	    croak( $prop->name, " is an atomic property\n" );
	 }
	 # the concrete type of permutation subobject will be adjusted according to the parent's type,
	 # hence it may contain properties from derived object types
	 $perm_parent=$self if $prop->flags & $Property::is_permutation;
	 $self=$prop->type;
      }
      croak( "invalid property name '$_'\n" ) if $Application::plausibility_checks && /\W/;
      $prop=$self->lookup_property($_) || defined($perm_parent) && $perm_parent->lookup_property($_)
      or do {
	 if (defined($obj) and
	     ($casted, $prop)=$obj->try_auto_cast($_,$mode)) {
	    undef $obj;		# disable auto-cast in subobjects, they may be even absent
	    $self=$casted;
	    $prop
	 } else {
	    croak( "unknown property ", $self->full_name, "::$_" );
	 }
      };
   } split /\./, $req;
}

# 'NAME | NAME ...' => [ PropertyPath, ... ]
# flags(RETVAL)==$Property::is_{multiple,permutation} if the path descends into a subobject property declared as such
sub encode_read_request {
   my ($self, $req, $obj, $mode)=@_;
   my $mult_path;
   my $flag=0;
   my $result=[
      map {
	 my @path=encode_request_element($self,$_,$obj,$mode);
	 if (@path>1) {
	    if ($flag) {
	       foreach (0..$#$mult_path) {
		  $path[$_]==$mult_path->[$_]
		     or croak( "mixing ", $flag==$Property::is_multiple ? "multiple" : "permutation", " subobject ",
			       join(".", map { $_->name } @$mult_path),
			       " with other properties in one request is not allowed" );
	       }
	    } else {
	       foreach (0..@path-2) {
		  if (my $flag_here=$path[$_]->flags & ($Property::is_multiple | $Property::is_permutation)) {
		     $flag=$flag_here;
		     $mult_path=[ @path[0..$_] ];
		     last;
		  }
	       }
	    }
	    \@path
	 } else {
	    @path
	 }
      } split /\s*\|\s*/, $req
   ];
   set_array_flags($result, $flag) if $flag;
   $result;
}
####################################################################################
sub type : method { shift }
*prototype=\&type;

sub check_consistency {
   my ($self, $tparams)=@_;
   my $conflict;
   if (defined $tparams) {
      if ($self->abstract) {
	 my $cnt=0;
	 ++$cnt while $tparams =~ m/$type_param_re/go;
	 if ($cnt != $self->param) {
	    $conflict="different number of template parameters";
	 }
      } else {
	 $conflict="unexpected template parameters";
      }
   } else {
      if ($self->abstract) {
	 $conflict="lacking template parameters";
      }
   }
   $conflict && do {
      if (instanceof ForwardDecl($self)) {
	 "Conflict with forward declaration at ".$self->location.": $conflict";
      } else {
	 "Conflict with main declaration:  $conflict";
      }
   }
}

####################################################################################
sub add_production_rule {
   my ($self, $header, $code, $credit)=@_;
   push @{$self->application->rules}, new Rule($header,$code,$self,$credit);
}

sub append_rule_precondition {
   my ($self, $header, $code, $checks_definedness)=@_;
   $self->application->rules->[-1]->append_precondition(special Rule($header,$code,$self), $checks_definedness);
}

sub append_rule_weight {
   my ($self, $major, $minor, $header, $code)=@_;
   $self->application->rules->[-1]->append_weight($major, $minor, $code && special Rule($header,$code,$self));
}

sub append_overriden_rule {
   my ($self, $super, $label)=@_;
   if ($Application::plausibility_checks && is_object($super)) {
      isa($self,$super) or croak( "Invalid override: ", $self->full_name, " is not derived from ", $super->full_name );
   }
   $label=$self->application->prefs->find_label($label)
          || croak( "Unknown label $label" );
   push @{$self->application->rules->[-1]->overriden_in ||= [ ]}, [ $super, $label, $Application::plausibility_checks ? (caller)[1,2] : () ];
}

sub append_rule_permutation {
   my ($self, $perm_name)=@_;
   my $perm=&property;
   unless ($perm->flags & $Property::is_permutation) {
      croak( "$perm_name is not declared as a permutation" );
   }
   $self->application->rules->[-1]->append_permutation($perm);
}

sub override_rule {
   my ($self, $super, $label)=@_;
   my $matched;
   foreach my $rule ($label->list_all_rules) {
      if (is_object($super)) {
	 next if $super!=$rule->defined_for;
      } else {
	 next if $self==$rule->defined_for || list_index($self->super,$rule->defined_for)<0;
      }
      $matched=1;
      if (defined($rule->overriden_in)) {
	 push @{$rule->overriden_in}, $self if list_index($rule->overriden_in,$self)<0;
      } else {
	 $rule->overriden_in=[ $self ];
      }
   }
   if ($Application::plausibility_checks && !$matched) {
      warn_print( "\"$_[3]\", line $_[4]: override declaration does not match any inherited rules" );
   }
}
####################################################################################
sub add_auto_cast {
   my ($self, $proto)=@_;
   if ($Application::plausibility_checks) {
      isa($proto,$self) or croak( "Invalid cast declaration: ", $proto->full_name, " is not derived from ", $self->full_name );
      exists $self->auto_casts->{$proto} and croak( "duplicate auto_cast declaration" );
   }
   $self->auto_casts->{$proto}=my $rule=new Rule::AutoCast("auto_cast ".$self->full_name." => ".$proto->full_name, $proto, $self);
   push @{$self->application->rules}, $rule;
   Overload::_add($proto->pkg, "construct", $self->pkg, sub : method { Object::new_with_auto_cast($rule, @_) });
   Overload::_add($proto->pkg, "construct", $self->pkg.',$$;@', sub : method { Object::new_filled_with_auto_cast($rule, @_) });
}
####################################################################################
sub add_method_rule {
   my ($self, $header, $code, $name)=@_;
   my $rule=special Rule($header, $code, $self);
   $rule->flags=$Rule::is_function;
   push @{$self->application->rules}, $rule;
   substr($rule->header,0,0)="user_method ";
   if (defined($name)) {
      define_function($self->pkg, $name,
		      sub : method {
			 &{ Scheduler::resolve_method($_[0], [ $rule ]) ||
			    croak("failed providing input properties") };
		      });
   } else {
      $rule;
   }
}
####################################################################################
sub help_topic {
   my $self=shift;
   $self->help ||= PropertyType::locate_own_help_topic($self, "objects", @_);
}
####################################################################################
sub set_file_suffix {
   my ($self, $suffix)=@_;
   define_function($self->pkg, "default_file_suffix", sub : method { $suffix });
   push @{$self->application->file_suffixes}, $suffix;
}
####################################################################################
package Polymake::Core::ObjectType::LocalDerivationMixin;

use Polymake::Struct (
   [ '@ISA' => 'ObjectType' ],
   [ '$name' => 'undef' ],
   [ '$parent_property' => 'weak( #1 )' ],
   '%inst_cache',			# base ObjectType => LocallyDerived
);

sub new {
   my $self=&_new;
   my $parent=$self->parent_property->belongs_to;
   $self->pkg=$parent->pkg."::_props::".$self->parent_property->name;
   define_function($self->pkg, "type", sub { $self });
   define_function($self->pkg, "self",	# for the rule parser
		   sub {
		      # complain if called not from my own scope
		      shift or croak( "This declaration is only allowed in the top-level (application) scope" );
		      $self
		   }, 1);
   $self->name=$parent->name."__".$self->parent_property->name."__mix_in";
   $self;
}

sub lookup_property {
   my ($self, $prop_name)=@_;
   $self->properties->{$prop_name} || $self->parent_property->type->lookup_property($prop_name);
}

sub property {
   my ($self, $prop_name)=@_;
   $self->properties->{$prop_name} || $self->parent_property->type->property($prop_name);
}

sub full_name {
   my $self=shift;
   $self->parent_property->belongs_to->full_name . "::" . $self->parent_property->name;
}

sub help_topic {
   my $self=shift;
   $self->help ||= $self->parent_property->help_topic(@_);
}

####################################################################################
package Polymake::Core::ObjectType::LocallyDerived;

use Polymake::Struct (
   [ '@ISA' => 'ObjectType', 'HasType4Deduction' ],
   [ new => '$$' ],
   [ '$name' => '#1 ->name' ],
   [ '$application' => '#2 ->application' ],
   [ '$super' => '[ #2, #1 ]' ],
);

sub new {
   my $self=&_new;
   my ($mix_in, $orig_type)=@{$self->super};
   push @{$self->super}, @{$orig_type->super};
   my $parent=$mix_in->parent_property->belongs_to;
   $self->pkg=$orig_type->pkg."::__as__".$parent->name."__".$mix_in->parent_property->name;
   if ($orig_type->abstract) {
      $self->context_pkg=$orig_type->context_pkg;
      $self->abstract=sub : method { (shift)->super->[1]->abstract->(@_) };
   } else {
      my $proto_sub=sub { $self };
      define_function($self->pkg, "type", $proto_sub, 1);
      define_function($self->pkg, "prototype", $proto_sub);
      define_function($self->pkg, "typeof", $proto_sub);
   }
   $self->extension=$self->super->[0]->extension;
   PropertyParamedType::set_extension($self->extension, $self->super->[1]->extension) if $self->super->[1]->extension;
   no strict 'refs';
   push @{$self->pkg."::ISA"}, $mix_in->pkg, $orig_type->pkg;
   namespaces::using($self->pkg, $mix_in->pkg, $orig_type->pkg);
   $self;
}

sub full_name {
   my $self=shift;
   $self->super->[1]->full_name . " as " . $self->super->[0]->full_name;
}

sub XML_name {
   (shift)->super->[1]->XML_name;
}

sub concrete_type {
   my $self=shift;
   local_type($self, $self->super->[1]->concrete_type(@_));
}

sub local_type {
   my ($self, $proto)=@_;
   if ($proto==$self->super->[1]) {
      $self
   } else {
      my $mixin=$self->super->[0];
      $mixin->inst_cache->{$proto} ||= new($self,$proto,$mixin);
   }
}

sub type4deduction { (shift)->parent->type }

####################################################################################
package Polymake::Core::ExpectingLocalDerivation;
@ISA=('Polymake::Core::Property::Finalizer');

sub new {
   my $self=pop;
   define_function($self->pkg, "self",	# for the rule parser
		   sub {
		      # complain if called not from my own scope
		      shift or croak( "This declaration is only allowed in the top-level (application) scope" );
		      $self
		   });
   bless $self;
}

my (%forward_methods, %activate_methods, %forbidden_methods);
@forward_methods{qw( name pkg )}=();
@activate_methods{qw( help_topic add_property_definition add_property_alias add_production_rule add_method_rule )}=();
@forbidden_methods{qw( add_auto_cast )}=();

sub AUTOLOAD {
   my $self=$_[0];
   my ($method)=$AUTOLOAD=~/($id_re)$/;
   if (exists $forward_methods{$method}) {
      $self->property->type->$method();
   } elsif (exists $activate_methods{$method}) {
      my $mixin=new ObjectType::LocalDerivationMixin($self->property,$self->property->belongs_to->application);
      $self->property->type=new ObjectType::LocallyDerived($self->property->type, $mixin);
      $self->property->flags |= $Property::is_locally_derived;
      undef $self->pkg;
      $_[0]=$mixin;
      shift;
      $mixin->$method(@_);
   } elsif (exists $forbidden_methods{$method}) {
      croak( "$method is forbidden for locally extended object types" );
   } else {
      croak( "Unknown method ObjectType::$method" );
   }
}

sub DESTROY {
   my $self=shift;
   if (defined $self->pkg) {
      no strict 'refs';
      undef &{$self->pkg."::self"};
   }
}

####################################################################################
package Polymake::Core::ObjectType::ForwardDecl;
use Polymake::Struct (
   [ new => '$$$$' ],
   [ '$name' => '#1' ],
   [ '$application' => '#2' ],
   '$pkg',
   [ '$context_pkg' => 'undef' ],
   [ '$param' => '#3' ],
   '&abstract',
   [ '$location' => '#4' ],
);

@ISA=qw( Polymake::Core::ObjectType );	# must appear as a real ObjectType during signature parsing of C++ functions

# ... but the rest members of the ObjectType must be hidden
sub super { return [ ] }
*derived=\&super;
sub properties { return { } }
*producers=\&properties;
*all_producers=\&properties;
*rules_by_label=\&properties;
*all_rules_by_label=\&properties;

sub construct { croak( "Can't create an object of an incomplete type ".$_[0]->application->name."::".$_[0]->name ) }
*parse_string=\&construct;
sub toString { "incomplete object type ".$_[0]->application->name."::".$_[0]->name }

sub new {
   my $self=&_new;
   if (defined($self->application)) {
      $self->pkg=$self->application->pkg."::".$self->name;
      if ($self->param) {
	 $self->abstract=sub { 1 };
	 define_function($self->pkg, "generic_type",
			 sub {
			    shift unless is_object($_[0]);
			    croak( "wrong number of type parameters for ", $self->pkg ) if @_ != $self->param;
			    new ForwardDecl($self->name, undef, \@_, $self);
			 }, 1);
      }
      $self->location=(caller)[1].", line ".$self->location;
   } else {
      my $super=$self->location;
      $self->location=$super->location;
      $self->application=$super->application;
      $self->pkg=$super->pkg;
      PropertyParamedType::init_params($self,$self->param);
   }
   define_function($self->pkg, "self",	# for the rule parser
		   sub {
		      if (shift) {
			 if (wantarray) {
			    $self
			 } else {
			    croak( "Properties, methods, etc. can't be declared for an incomplete object type" );
			 }
		      } else {
			 croak( "This declaration is only allowed in the top-level (application) scope" );
		      }
		   }, 1);
   $self;
}

####################################################################################
package Polymake::Core::ObjectType::PermutationMixin;

use Polymake::Struct (
   [ '@ISA' => 'LocalDerivationMixin' ],
   '%sensitive_props',			# Property->key => [ Rule ]  or  { $sub_key }->{ Property }-> ... ->[ Rule ]
					# rules transferring Property from the permuted subobject back into the basis
   '%sub_permutations',			# Property->key (subobject) => Property (permutation)
);

# when used as a precondition in a canned RuleChain:

sub header { "sensitivity check for " . (shift)->parent_property->name }
sub flags { $Rule::is_function }
sub weight { $Rule::zero_weight }
sub preconditions { [ ] }
sub with_permutation { undef }
sub copy4schedule { }

sub execute {
   my ($self, $object)=@_;
   dbg_print("performing ", $self->header) if $Verbose::rules>2;
   $object->has_sensitive_to($self->parent_property) ? $Rule::exec_failed : $Rule::exec_OK
}

package Polymake::Core::ObjectType::Permutation;

@ISA=('Polymake::Core::ObjectType::LocallyDerived');

sub get_producers_of {
   my ($self, $prop)=@_;
   # don't inherit any production rule from the basis type, otherwise the scheduler would drive crazy
   $self->super->[0]->producers->{$prop->key} || [ ];
}

declare $sub_key=\(1);

sub sensitive_props { (shift)->super->[0]->sensitive_props }
sub sub_permutations { (shift)->super->[0]->sub_permutations }

sub add_sensitive_sub_property {
   my $rule=pop;
   my $prop=pop;
   my $hash=(shift)->super->[0]->sensitive_props;
   foreach $prop (@_) {
      $hash=($hash->{$sub_key} ||= { });
      $hash=($hash->{$prop->key} ||= { });
   }
   if ($rule->code==\&Rule::nonexistent) {
      if ($Application::plausibility_checks && ref($hash->{$prop->key})) {
         croak( "regenerating of property ", $prop->name, " was enabled prior to this rule definition" );
      }
      $hash->{$prop->key}=[ ];
   } else {
      if ($Application::plausibility_checks && exists($hash->{$prop->key}) && @{$hash->{$prop->key}}==0) {
         croak( "regenerating of property ", $prop->name, " was disabled prior to this rule definition" );
      }
      push @{$hash->{$prop->key}}, $rule;
   }
}

sub find_sensitive_sub_property {
   my $prop=pop;
   my $hash=(shift)->super->[0]->sensitive_props;
   foreach $prop (@_) {
      defined( $hash=$hash->{$sub_key} ) or return;
      defined( $hash=$hash->{$prop->key} ) or return;
   }
   $hash->{$prop->key}
}

sub add_sub_permutation {
   my $perm_prop=pop;
   my $prop=pop;
   my $hash=(shift)->super->[0]->sub_permutations;
   foreach $prop (@_) {
      $hash=($hash->{$sub_key} ||= { });
      $hash=($hash->{$prop->key} ||= { });
   }
   if (exists $hash->{$prop->key}) {
      $hash->{$prop->key}==$perm_prop or
      croak( "ambiguous permutation propagation into ", join(".", map { $_->name } @_,$prop), " : ",
	     $perm_prop->name, " vs. ", $hash->{$prop->key}->name );
   } else {
      $hash->{$prop->key}=$perm_prop;
      # provide for transitive closure
      my $sub_perm=$perm_prop->type->super->[0]->sub_permutations;
      if (keys %$sub_perm) {
	 $hash=($hash->{$sub_key} ||= { });
	 $hash->{$prop->key}=$sub_perm;
      }
   }
}

sub find_sub_permutation {
   my $prop=pop;
   my $hash=(shift)->super->[0]->sub_permutations;
   foreach $prop (@_) {
      defined( $hash=$hash->{$sub_key} ) or return;
      defined( $hash=$hash->{$prop->key} ) or return;
   }
   $hash->{$prop->key}
}


1

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