#  Copyright (c) 1997-2004
#  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: Property.pm 7470 2006-11-21 16:14:10Z gawrilow $

use strict;
use namespaces;

# for rulefile parser

package Poly::Property;

declare @decl_prologue;
@decl_prologue=split /(?<=\n)/, <<'_#_#_#_';
my ($type, $temporary, $diff, $accept, @upgrade, %apply_diff);
_#_#_#_

declare $decl_args='$type, $temporary && $Poly::Property::allow_temporary, $diff, $accept, @upgrade && \\@upgrade, \\%apply_diff';

declare $allow_temporary=1;

#  Constructor
#
#  new Poly::Property(Prototype, 'Name', $decl_args);

use Struct (
   [ 'new' => '$$$;$$$$$' ],
   [ '$name' => '#2' ],		# 'property name'
   [ '$belongs_to' => '#1' ],	# Prototype
   [ '$type' => '#3' ],		#
   '$dimension',		# 0: scalar, 1: one line, all others: empty or multiple lines
   '$allow_empty',		# FIXME: unless each 'type' has a real constructor/verifier

   [ '$temporary' => '#4' ],	# boolean: get rid of the prop. value as soon as possible

				# the following 3 fields contain \&sub or "method name",
				#   methods are called via the Poly::Object
   [ '$diff' => '#5' ],		# sub: old_data, new_data => diff or die('reason')
   [ '$accept' => '#6' ],	# sub: data => data or converted_data or die('reason')
   '%apply_diff',		# Property => sub: data, diff => converted_data

   '@diff_sensitive',		# ( Property )  having apply_diff{this property}
   [ '@upgrade' => '#7' ],	# ( version, \&sub, ... )

   [ '$prod_method' => '"prod." . #2' ],
   '@aliases',			# alias names (currently kept here for solely documentation purposes)
);

# FIXME: idem
my %scalar_types=map { $_ => 1 }
   qw(scalar boolean cardinal integer label word object);
my %numeric_types=map { $_ => 1 }
   qw(scalar boolean cardinal integer);
my %container_types=map { $_=> 1 }
   qw(vector array set list);
my %empty_container=map { $_=> 1 }
   qw(vector array);
my $simple_container_re=qr{^ (\w+) <\s* (\w+) \s*> $ }x;

sub new {
   my $self=&_new;

   croak( "missing property type declaration\n" ) unless $self->type;

   if (@_>6) {
      my $apply_diff=pop @_;
      while (my ($prop_name, $apply_diff_sub)=each %$apply_diff) {
	 my $prop=$self->belongs_to->lookup_property($prop_name)
            or croak( "unknown property ", $self->belongs_to->name, "::$prop_name" );
	 croak( "property ", $prop->belongs_to->name, "::$prop_name does not have diff subroutine" )
            unless defined $prop->diff;
	 push @{$prop->diff_sensitive}, $self;
	 $self->apply_diff->{$prop}=$apply_diff_sub;
      }
   }

   $self->dimension= $scalar_types{$self->type} ? 0
   		   : $container_types{$self->type} ? 1
		   : $self->type =~ $simple_container_re && $container_types{$1} && $scalar_types{$2} ? 1
		   : 2;
   $self->allow_empty= $self->dimension>=2 ||
                       $self->dimension==1 &&
			  ( $empty_container{$self->type} ||
			    $self->type =~ $simple_container_re && $empty_container{$1} );
   $self;
}

1