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

use strict;
use namespaces;

package Polymake::Core::Property::_defs;
# for rulefile parser

sub canonical;
sub equal;

####################################################################################
package Polymake::Core::Property;

#  Constructor
#
#  new Property(ObjectType, 'Name', $type, $decl_args);

use Polymake::Struct (
   [ 'new' => '$$$$$' ],
   [ '$name' => '#2' ],		# 'property name'
   [ '$belongs_to' => '#1' ],	# ObjectType
   [ '$extension' => '$Application::extension' ],
   [ '$type' => '#3' ],		# PropertyType | ObjectType
   [ '$flags' => '0' ],
				# the following fields contain \&sub or "method name",
				#   methods are called via the Object
   '&canonical',		# sub: data =>
   '&equal',

   '&accept',			# value, object, trusted_flag =>
   '&copy',			# value, object =>

   [ '$inst_cache' => 'undef' ],
   [ '$up' => '0' ],		# how many parent objects to travel upwards in order to get a proper type context

   '%key | property_key',	# The address of the hash itself serves as a search key in the objects' dictionaries,
		                # production rule lists, permutation sensitivity lists, etc. - all kinds of lists where
		                # all properties being concrete type instances or aliases of the same root property have
		                # to be matched to the same data.
		                # Contained is a hierarchy of further hashes: the keys belong to subobject properties, and
		                # the values serve again as search keys in the lists of producers.
		                # For example, if the object type O has a rule R = A.B : X,
		                # then there is a hash $H=$Property_B->key->{$Property_A->key}
		                # such that the list $ObjectType_O->producers->{$H} contains $Rule_R.

   [ '$cloned_from' => 'undef' ],
   [ '$help' => 'undef' ],	# InteractiveHelp (in interactive mode)
);

# Property->flags
use Polymake::Enum qw( is: mutable=1 locally_derived=2 multiple=4 produced_as_whole=8 permutation=16 );

# Constructor: ObjectType, 'name', Type, attributes, open_scope =>

sub new {
   my $self=&_new;
   my $with_scope=pop;
   my $attrs=pop;
   if ($attrs =~ s/:\s*mutable\b//) {
      $self->flags|=$is_mutable;
   }
   if ($attrs =~ s/:\s*multiple\b//) {
      if ($Application::plausibility_checks && !instanceof ObjectType($self->type)) {
	 croak( "an atomic property may not be declared as multiple" );
      }
      $self->flags|=$is_multiple;
   }
   if ($attrs =~ /\S/) {
      croak( "unknown property attributes $attrs" );
   }
   if ($self->type->abstract) {
      $self->inst_cache={ };
      if (defined $self->type->context_pkg) {
	 my $obj_proto=$self->belongs_to;
	 while ($obj_proto->pkg ne $self->type->context_pkg  and  ! defined($obj_proto->descend_to_generic($self->type->context_pkg))) {
	    $obj_proto=$obj_proto->parent_property->belongs_to;
	    $self->up++;
	 }
      }
      $self->accept=sub : method {
	 my $self=shift;
	 ($self->clone($_[1]))->accept->(@_);
      };
   } else {
      ($self->accept, $self->copy)=choose_methods($self);
   }

   $self;
}
####################################################################################
sub create_alias {
   my ($src, $alias_name)=@_;
   my $self=inherit_class([ @$src ], $src);
   $self->name=$alias_name;
   $self;
}
####################################################################################
sub clone {
   my ($src, $obj)=@_;
   my $up=$src->up;
   while ($up>0) { $obj=$obj->parent; --$up }
   my $obj_proto=$obj->type;
   $src->inst_cache->{$obj_proto} ||= do {
      my $self=inherit_class([ @$src ], $src);
      $self->cloned_from=$src;
      $self->type=$src->type->concrete_type($obj_proto);
      ($self->accept, $self->copy)=choose_methods($self);
      $self;
   }
}

sub concrete {
   my ($self, $obj)=@_;
   $self->type->abstract ? $self->clone($obj) : $self
}

sub declared {
   my $self=shift;
   $self->cloned_from || $self
}
####################################################################################
sub choose_methods {
   my ($self)=@_;
   instanceof ObjectType($self->type)
   ? (\&accept_subobject, undef) :
   $self->type->cppoptions && !$self->type->cppoptions->default_constructor
   ? (\&accept_special_constructed, \&copy_special_constructed) :
   $self->type->construct
   ? (\&accept_composite, \&copy_composite)
   : (\&accept_atomic, \&copy_atomic);
}
####################################################################################
sub accept_subobject : method {
   my ($self, $value, $obj, $trusted, $temp)=@_;
   unless (defined $value) {
      if (!$trusted and $self->flags & $is_multiple) {
	 croak( "undefined value not allowed for the multiple subobject property ", $self->name );
      }
      return new PropertyValue($self, $value);
   }

   unless ($trusted) {
      is_object($value) or croak( "property ", $self->name, " needs an Object\n" );
      my $expected= $self->flags & $is_locally_derived ? $self->type->super->[1] : $self->type;
      unless (UNIVERSAL::isa($value, $expected->pkg)) {
	 # if the source object can't be converted to our type, it will croak():
	 $value=$expected->construct->($value);
      }
   }

   if (defined($value->parent) || defined($value->persistent)) {
      if ($value->type==$self->type) {
	 $value=$value->copy(undef);
      } elsif ($self->flags & $is_locally_derived) {
	 # create the autonomous external type, get rid of potentially dangerous foreign extensions
	 $value=$self->type->super->[1]->construct->($value);
      } else {
	 $value=$self->type->construct->($value);
      }
      defined(wantarray) or $_[1]=$value;	# replace the subobject in the caller
   }
   if ($self->flags & $is_locally_derived) {
      my $orig_type=$value->type;
      if ($orig_type != $self->type) {
	 bless $value, $self->type->local_type($orig_type)->pkg;
      }
   }
   weak($value->parent=$obj);
   $value->property=$self;
   $value->is_temporary= $temp || defined($obj->parent) && $obj->is_temporary;
   if (defined($value->transaction)) {
      if ($value->has_cleanup) {
	 Transaction::merge_temporaries($value->transaction->temporaries, delete $Scope->cleanup->{$value});
	 $value->has_cleanup=0;
      }
      if (defined($obj->transaction)) {
	 $obj->transaction->descend($value) unless ($temp && defined($obj->transaction->rule));
      } else {
	 $value->transaction->commit($value);
      }
   } elsif (defined($obj->transaction)) {
      $obj->transaction->descend($value) unless ($temp && defined($obj->transaction->rule));
      if ($value->has_cleanup) {
	 $value->transaction->temporaries=delete $Scope->cleanup->{$value};
	 $value->has_cleanup=0;
      }
   }
   if (!$trusted && defined($self->canonical)) {
      select_method($self->canonical,$obj,1)->($value);
   }
   defined(wantarray) and $self->flags & $is_multiple ? new PropertyMultipleValue($self, [ $value ]) : $value;
}

sub create_subobject : method {
   my $self=&concrete;
   accept_subobject($self, Object::new($self->type->pkg), $_[1], 1);
}
####################################################################################
sub accept_composite : method {
   my ($self, $value, $obj, $trusted, $temp)=@_;
   if (defined $value) {
      my $needs_canonicalization=!$trusted && defined($self->canonical);
      my ($is_object, $type_mismatch);
      if (is_string($value)) {
	 local $PropertyType::trusted_value=$trusted;
	 $value=$self->type->parse_string->($value);
      } elsif (!($is_object=is_object($value)) or
	       $type_mismatch=!$self->type->isa->($value) or
	       $self->type->cppoptions && !$self->type->cppoptions->builtin &&
	       CPlusPlus::must_be_copied($value,$temp,$needs_canonicalization)) {
	 my $target_type= $type_mismatch
	                  ? $self->cloned_from &&
	                    eval { $value->rebind_type($self->cloned_from->type)->concrete_type($obj->type) }
			  : $is_object &&
			    $value->type;
	 local $PropertyType::trusted_value=$trusted;
	 $value=($target_type || $self->type)->construct->($value);
      }
      if ($needs_canonicalization) {
	 select_method($self->canonical,$obj,1)->($value);
      }
   }
   new PropertyValue($self, $value, $temp);
}

sub copy_composite : method {
   my ($self, $value)=@_;
   new PropertyValue($self, $self->type->construct->($value));
}
####################################################################################
sub accept_special_constructed : method {
   my ($self, $value, $obj, $trusted, $temp)=@_;
   if (defined($value)) {
      my $needs_canonicalization=!$trusted && defined($self->canonical);
      if (!is_object($value) or
	  !$self->type->isa->($value) or
	  CPlusPlus::must_be_copied($value,$temp,$needs_canonicalization)) {
	 local $PropertyType::trusted_value=$trusted;
	 $value=$self->type->construct->($obj,$value);
      }
      if ($needs_canonicalization) {
	 select_method($self->canonical,$obj,1)->($value);
      }
   }
   new PropertyValue($self, $value, $temp);
}

sub copy_special_constructed : method {
   my ($self, $value, $obj)=@_;
   new PropertyValue($self, $self->type->construct->($obj,$value));
}
####################################################################################
sub accept_atomic : method {
   my ($self, $value, $obj, $trusted, $temp)=@_;
   if (defined $value) {
      if (is_string($value)) {
	 $value=$self->type->parse_whole($value, $trusted);
      }
      if (!$trusted && defined($self->canonical)) {
	 select_method($self->canonical,$obj,1)->($value);
      }
   }
   new PropertyValue($self, $value, $temp);
}

sub copy_atomic : method {
   my ($self, $value)=@_;
   new PropertyValue($self, $value);
}
####################################################################################
# ancestor_prop, ... => last key
# arguments come in reverse (bottom-up) order!
sub get_prod_key {
   my $self=shift;
   my $hash=$self->key;
   my $perm_seen;
   foreach (@_) {
      $perm_seen ||= $_->flags & $Property::is_permutation;
      $hash=($hash->{$_->key} ||= new SubobjKey($self,$_,$perm_seen));
   }
   $hash
}
####################################################################################
sub help_topic {
   my ($self, $force)=@_;
   $self->help ||= do {
      my ($topic, $obj_topic);
      if ($topic=$self->belongs_to->help_topic($force) and
	  $topic=$topic->find("properties", $self->name) ||
	         $force && $topic->add(["properties", $self->name]) and
	  instanceof ObjectType($self->type) and
	  defined ($obj_topic=($self->flags & $is_locally_derived ? $self->type->super->[1] : $self->type)->help_topic)) {
	 push @{$topic->related}, $obj_topic, @{$obj_topic->related};
      }
      $topic
   };
}
####################################################################################
package Polymake::Core::Property::SubobjKey;
RefHash::allow(__PACKAGE__);

my $prop_key=\(1);
my $subobj_key=\(2);
my $perm_key=\(3);

sub new {
   my $self=bless { $prop_key => $_[1], $subobj_key => $_[2] }, $_[0];
   weak($_) for values %$self;
   $self->{$perm_key}=1 if $_[3];
   $self;
}

sub key { shift }
sub property { (shift)->{$prop_key} }
sub subobject_property { (shift)->{$subobj_key} }
sub property_key { (&property)->key }
sub belongs_to { (&subobject_property)->belongs_to }
sub on_permutation_path { (shift)->{$perm_key} }

####################################################################################
package Polymake::Core::Property::Finalizer;

use Polymake::Struct (
   [ new => '$;$' ],
   [ '$property' => '#1' ],
   [ '$pkg' => 'undef' ],
);

sub new {
   my $self=&_new;
   if (defined (my $proto=$_[1])) {
      if ($self->property->belongs_to != $proto) {
         croak( "Sorry, reopening subobject properties in derived object types is not implemented yet" );
      }
   }
   $self;
}

sub import {
   my ($self, $pkg)=@_;
   unless ($self->property->flags & $Property::is_locally_derived) {
      $self->pkg=$pkg;
      if (instanceof ObjectType($self->property->type)) {
         new ExpectingLocalDerivation($self);
      } else {
         namespaces::using($pkg, 'Polymake::Core::Property::_defs', $self->property->type->pkg);
      }
   }
}

sub DESTROY {
   unless ($@) {
      my $self=shift;
      defined($self->pkg) and PropertyType::Finalizer::store_methods(@$self, qw(canonical equal));
   }
}

1

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