#  Copyright (c) 1997-2006
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.de
#
#  This program is free software; you can redistribute it and/or modify it
#  under the terms of the GNU General Public License as published by the
#  Free Software Foundation; either version 2, or (at your option) any
#  later version: http://www.gnu.org/licenses/gpl.txt.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#----------------------------------------------------------------------------
#  $Project: polymake $$Id: Prototype.pm,v 1.14 2006/02/06 23:36:55 gawrilow Exp $

use strict;
use namespaces;

require Poly::Property;
require Poly::Rule;

package Poly::Prototype;

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

use Struct (
   [ new => '$$$@' ],
#
#  Environmental data
#
   [ '$name' => '#1' ],		# own name
   [ '$object_type' => '#2' ],	# perl object type
   [ '$application' => '#3' ],	# -> Application
#
#  Derivation relations
#
   '@super',			# ( Prototype )  super classes
   '@derived',			# ( Prototype )  derived classes
#
#  Own components
#
   '%properties',		# 'name' => Property
   '@rules',			# ( Rule )
#
#  '@upgrade',			# ( UpgradeProperty )
);

####################################################################################
#
#  Constructor
#
#  new Poly::Prototype('name', 'perl object type', Application, [ super Prototype, ... ]);
#
sub new {
   my $self=&_new;
   splice @_, 0, 3;
   my $proto_sub=sub { $self };
   define_function($self->object_type, "prototype", $proto_sub);
   define_function($self->object_type, "Prototype", $proto_sub);	# for the rulefile parser
   # proceed with parent classes
   if (@_) {
      foreach my $super (@_) {
	 if (! UNIVERSAL::isa($self->object_type, $super->object_type)) {
	    push @{$self->super}, $super;
	    push @{$super->derived}, $self;
	    no strict 'refs';
	    push @{$self->object_type."::ISA"}, $super->object_type;
	 }
      }
   } else {
      define_function($self->object_type, "top_prototype", $proto_sub);
   }
   if (! UNIVERSAL::isa($self->object_type, "Poly::Object")) {
      no strict 'refs';
      push @{$self->object_type."::ISA"}, "Poly::Object";
   }

   $self;
}
####################################################################################
sub lookup_property {
   my ($self, $prop_name)=@_;
   my $prop=$self->properties->{$prop_name};
   if (!defined $prop) {
      foreach my $super_proto (@{$self->super}) {
	 if (defined ($prop=lookup_property($super_proto, $prop_name))) {
	    $self->properties->{$prop_name}=$prop;
	    last;
	 }
      }
   }
   $prop
}
####################################################################################
# in list context allows to define new (undeclared) properties on the fly
sub property {
   my $prop=&lookup_property;
   return $prop if defined $prop;
   my ($self, $prop_name)=@_;
   die "unknown property ", $self->name, "::$prop_name\n" unless wantarray;
   $prop=add_property_description($self, $prop_name, "text", 0, undef, undef, undef, { }, "Undeclared property\n");
   ($prop, 1);
}
####################################################################################
sub add_property_description {	# => Property
   my ($self, $prop_name)=@_[0,1];
   my $help_text=pop @_;
   croak( "multiple declaration of property '$prop_name'" )
      if exists $self->properties->{$prop_name};

   my $prop=new Property(@_);
   $self->application->help->add([ 'objects', $self->name, 'properties', $prop_name ], $help_text);

   define_function($self->object_type, $prop_name, Poly::Object::create_prop_accessor($prop));
   my ($producer_list, $invalidate)=([], []);
   define_function($self->object_type, $prop->prod_method, sub { $producer_list });
   define_function($self->object_type, $prop->prod_method.".inval",
		   sub {
		      return $invalidate if defined wantarray;
		      @$_=() for @$invalidate;
		   });
   $self->application->EXPORT->{$prop_name}="prop";
   $self->properties->{$prop_name}=$prop;
}
####################################################################################
#
#  Bookkeeping of producing rules.
#
# In order to quickly obtain the list of rules capable of creating some given property
# they are stored in special methods. The method name is Property->prod_method
# and the package is Property->object_type. The method has no arguments and returns
# a reference to an array with the Rule objects.
#
# A derived prototype initially inherits the producer list methods from its super class.
# However, when it gets own rules delivering some inherited properties, the producer
# list is kept twice: once the own rule list, and the cumulated list of own and inherited
# rules.  The own list is always available via the method named "$method_name.own".
# The cumulated list is generated lazily, by the first call to the method.
# It can be invalidated (to enforce recomputation) by calling "$method_name.inval"
# in void context.
#
# private:
sub find_all_producers {
   my ($obj, $meth_name, $list)=@_;
   foreach my $super_proto (@{$obj->Prototype->super}) {
      if (defined (my $meth=$super_proto->object_type->can($meth_name))) {
	 push @$list, @{$meth->($super_proto->object_type)};
      }
   }
}
####################################################################################
# private:
sub add_producer {
   my ($self, $rule, $prop)=@_;
   my $object=$self->object_type;
   my $meth_name=$prop->prod_method;
   my ($method, $inval_method);

   my $producer_list=
      $prop->belongs_to == $self
	 ? $object->$meth_name()
      : defined ($method=do { no strict 'refs'; *{"$object\::$meth_name.own"}{CODE} })
         ? $method->()
      : do {
	 my ($own_list, $cumulated_list)=([], []);
	 define_function($object, "$meth_name.own", sub { $own_list } );
	 define_function($object, $meth_name,
			 sub {
			    if (!@$cumulated_list) {
			       @$cumulated_list=@$own_list;
			       find_all_producers(shift,$meth_name,$cumulated_list);
			    }
			    $cumulated_list
			 });
	 $inval_method=$object->can("$meth_name.inval");
	 push @{$inval_method->()}, $cumulated_list;
	 $own_list;
      };
   push @$producer_list, $rule;
   if (@{$self->derived}) {
      $inval_method ||= $object->can("$meth_name.inval");
      $inval_method->();
   }
   undef;
}
####################################################################################
# private:
sub find_all_rule_labels {
   my ($obj, $suffix, $list)=@_;
   foreach my $super_proto (@{$obj->Prototype->super}) {
      if (defined (my $meth=$super_proto->object_type->can($suffix))) {
	 Poly::Preference::Label::merge_controls($list, $meth->($super_proto->object_type));
      }
   }
}
####################################################################################
# private:
sub add_rule_label {
   my ($self, $rule, $label)=@_;
   my $object=$self->object_type;
   my $suffix=$label->wildcard_name;
   my $method=do { no strict 'refs'; *{"$object\::$suffix.own"}{CODE} };
   my $inval_method;
   my $ctl_list=
      defined($method)
      ? $method->()
      : do {
	   my ($own_list, $cumulated_list)=([], []);
	   define_function($object, "$suffix.own", sub { $own_list });
	   define_function($object, $suffix,
			   sub {
			      if (!@$cumulated_list) {
				 Poly::Preference::Label::copy_control($cumulated_list, $own_list);
				 find_all_rule_labels(shift,$suffix,$cumulated_list);
			      }
			      $cumulated_list
			   });
	   if (!defined ($inval_method=$object->can("$suffix.inval"))) {
	      my $invalidate=[ ];
	      $inval_method=sub {
		               return $invalidate if defined wantarray;
			       Poly::Preference::Label::forget_control($_), @$_=() for @$invalidate;
			    };
	      define_function($object->top_prototype->object_type, "$suffix.inval", $inval_method);
	   }
	   push @{$inval_method->()}, $cumulated_list;
	   $own_list;
      };
   $label->add_control($ctl_list, $rule);
   if (@{$self->derived}) {
      $inval_method ||= $object->can("$suffix.inval");
      $inval_method->();
   }
   undef;
}
####################################################################################
sub add_production_rule {
   my ($self, $rule)=@_;
   push @{$self->rules}, $rule;

   foreach my $output (@{$rule->output}) {
      if (is_object($output)) {
	 add_producer($self, $rule, $output);
      } else {
	 die "subobjects are not yet implemented";
      }
   }

   foreach my $label (@{$rule->labels}) {
      add_rule_label($self, $rule, $label);
   }
}
####################################################################################
sub encode_request_element {
   my ($self, $req)=@_;
   my @parts=split m{[./]}, $req;
   my @path;
   for (my $i=0; ; ++$i) {
      my $prop_name=$parts[$i];
      die "invalid property name '$prop_name'\n" if $prop_name =~ /\W/;
      my $prop=property($self, $prop_name);
      if (@parts>1) {
	 push @path, $prop;
	 if ($i < $#parts) {
	    my $obj=$prop->object_type
	       or die "property '", $self->name, "::$prop_name' is not of an Object type\n";
	    $self=$obj->prototype;
	 } else {
	    return \@path;
	 }
      } else {
	 return $prop;
      }
   }
}
####################################################################################
sub encode_read_request {		# 'NAME | NAME ...' => [ Property ]
   my ($self, $req)=@_;
   [ map { encode_request_element($self, $_) } split /\s*\|\s*/, $req ]
}
####################################################################################
sub encode_read_requests {		# 'request', ... => ( [ Property ] )
   my $self=shift;
   ( map { encode_read_request($self, $_) } @_ )
}
####################################################################################

# package Poly::UpgradeProperty;
# use Struct (
#    [ '$version' => '#1' ],
#    [ '$regex' => '#2' ],
#    [ '$code' => '#3' ],
# );

1

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