1#  Copyright (c) 1997-2021
2#  Ewgenij Gawrilow, Michael Joswig, and the polymake team
3#  Technische Universität Berlin, Germany
4#  https://polymake.org
5#
6#  This program is free software; you can redistribute it and/or modify it
7#  under the terms of the GNU General Public License as published by the
8#  Free Software Foundation; either version 2, or (at your option) any
9#  later version: http://www.gnu.org/licenses/gpl.txt.
10#
11#  This program is distributed in the hope that it will be useful,
12#  but WITHOUT ANY WARRANTY; without even the implied warranty of
13#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14#  GNU General Public License for more details.
15#-------------------------------------------------------------------------------
16
17use strict;
18use namespaces;
19use warnings qw(FATAL void syntax misc);
20use feature 'state';
21
22package Polymake::Core::BigObjectType;
23
24my $construct_node;
25sub construct_node : lvalue { $construct_node }
26
27# outer BigObjectType during rulefile loading
28declare $scope_owner;
29
30##############################################################################
31#  Collection of information common to all Objects of the same type
32#  (such as property names, rules, etc.)
33
34use Polymake::Struct (
35   [ new => '$$@' ],
36#
37#  Environmental data
38#
39   [ '$name' => '#1' ],                 # own name
40   [ '$application' => '#2' ],          # -> Application
41   [ '$extension' => '$Extension::loading' ],
42   '$pkg',                              # perl class
43   [ '$context_pkg' => 'undef' ],       # for abstract parameterized object types resulting from local derivation
44                                        #  as a property of another parameterized BigObjectType:
45                                        #  perl class of the enclosing BigObjectType (i.e. property owner)
46   [ '$params' => 'undef' ],            # for parameterized types: list of BigObjectType or PropertyType describing the parameters
47   '&abstract',
48   [ '&perform_typecheck' => '\&PropertyType::concrete_typecheck' ],
49   [ '&construct' => '\&PropertyType::construct_object' ],
50   [ '&parse' => '\&BigObject::new_named' ],
51   [ '&toString' => '\&BigObject::print_me' ],
52   [ '&JSONschema' => '\&Serializer::big_object_schema' ],
53#
54#  Derivation relations
55#
56   '@super',                       # ( BigObjectType ) base classes
57                                   #   For non-parametrized and generic types it exactly reflects the object type declaration.
58                                   #   For concrete instances of parametrized types the base classes follow in the order:
59                                   #     - named full specializations (restricted by preconditions)
60                                   #     - anonymous full specialization (w/o preconditions)
61                                   #     - concrete instances of matching partial specializations
62                                   #     - own generic type
63                                   #     - concrete instance(s) of base types
64   '@linear_isa',                  # transitive closure of @super in C3 resolution order
65   [ '$generic' => 'undef' ],      # BigObjectType of the own generic type;
66                                   #   for concrete instances of partial specialization: the parametrized specialization
67   [ '$full_spez' => 'undef' ],    # full specializations of parametrized types: concrete BigObjectType pkg or spez. name => Specialization
68#
69#  Own components
70#
71   '%properties',                  # 'name' => Property
72   '%permutations',                # 'name' => permutation Property
73   '%producers',                   # own rules producing a property: Property/Key => [ Rule, ... ]
74   '%all_producers',               # cached own and inherited rules: Property/Key => [ Rule, ... ]
75   '%shortcuts',                   # cached own and inherited shortcut rules
76   '%rules_by_label',              # own labeled producing rules: '*.label' => ControlList
77   '%all_rules_by_label',          # cached own and inherited labeled rules
78   '@production_rules',            # ( Rule ) all production rules directly applicable to this object type and descendants (for search by header)
79#
80   [ '$specializations' => 'undef' ],  # ( Specialization ) for parameterized types with partial specializations: the abstract objects
81   [ '$borrowed_from' => 'undef' ],    # other Specializations defining properties this Specialization or generic type refers to
82#
83   [ '$help' => 'undef' ],         # Help::Topic if loaded
84);
85
86####################################################################################
87#
88#  Constructor
89#
90#  new BigObjectType('name', Application, [ type params ], [ super BigObjectType, ... ]);
91#
92sub new {
93   my $self = &_new;
94   Struct::learn_package_retrieval($self, \&pkg);
95   my $tparams = splice @_, 0, 3;
96   my $self_sub = sub { $self };
97   my $generic_type;
98
99   unless ($construct_node) {
100      $construct_node = new_root Overload::Node;
101      Overload::add_instance("Polymake::Core::BigObject", ".construct", undef, \&BigObject::new_empty,
102                             [0, 0], undef, $construct_node);
103      $construct_node->add_fallback(\&BigObject::new_filled);
104   }
105
106   if (defined($self->application)) {
107      $self->pkg = $self->application->pkg."::".$self->name;
108      if (defined($tparams)) {
109         $self->abstract = \&type;
110         undef $self->perform_typecheck;
111         $self->params = PropertyParamedType::create_param_placeholders($self->pkg, $self->application, $tparams);
112      }
113      Overload::add_instance($self->pkg, ".construct", undef, \&BigObject::new_copy,
114                             [1, 1, $self->pkg ], undef, $construct_node);
115      Overload::add_instance($self->pkg, ".construct", undef, \&BigObject::new_filled_copy,
116                             [3, 3+Overload::SignatureFlags::has_trailing_list, $self->pkg, '$', '$'], undef, $construct_node);
117   } else {
118      # it is an instance of an abstract BigObject type
119      # the first super-BigObject is always the own abstract type
120      $generic_type = $_[0];
121      $self->application = $generic_type->application;
122      $self->extension = $generic_type->extension;
123      $self->pkg = $generic_type->pkg;
124      $self->params = $tparams;
125      PropertyParamedType::scan_params($self);
126      if ($self->abstract) {
127         if (defined($self->context_pkg)) {
128            push @{$self->super}, $generic_type;
129            push @{$self->linear_isa}, $generic_type, @{$generic_type->linear_isa};
130            $self->generic=$generic_type;
131         }
132         return $self;
133      }
134      define_function($self->pkg, "typeof", $self_sub, 1);
135   }
136
137   define_function($self->pkg, "type", $self_sub, 1);
138   if (!$self->abstract) {
139      define_function($self->pkg, ".type", $self_sub);
140   }
141   PropertyType::create_method_new($self);
142
143   # proceed with parent classes
144   if (@_) {
145      set_extension($self->extension, $_->extension) for @_;
146      modify_super($self, 0, 0, @_);
147      if (defined $generic_type) {
148         $self->generic=$generic_type;
149
150         my %required_spezs;
151         if (defined $generic_type->borrowed_from) {
152            $required_spezs{$_}=1 for keys %{$generic_type->borrowed_from};
153         }
154         if (defined $generic_type->specializations) {
155            my @matching_spezs=map { pick_specialization($_, $self) } @{$generic_type->specializations};
156
157            foreach my $spez (@matching_spezs) {
158               my $gen_spez=$spez->generic;
159               $required_spezs{$gen_spez} |= 2;
160               if (defined $gen_spez->borrowed_from) {
161                  $required_spezs{$_} |= 1 for keys %{$gen_spez->borrowed_from};
162               }
163            }
164
165            modify_super($self, 0, 0, @matching_spezs);
166         }
167
168         # verify correctness of inheritance relationship between specializations
169         while (my ($spez, $status)=each %required_spezs) {
170            if ($status == 1 && list_index($self->linear_isa, $spez)<0) {
171               my @bad=grep { defined($_->borrowed_from) && $_->borrowed_from->{$spez} } @{$self->super};
172               die "Invalid inheritance: ", join(", ", map { $_->full_name } @bad),
173                            "\n refer", @bad==1 && "s", " to properties defined in ", $spez->full_name,
174                            "\n which does not match the object type ", $self->full_name, "\n";
175            }
176         }
177      }
178   } else {
179      no strict 'refs';
180      push @{$self->pkg."::ISA"}, "Polymake::Core::BigObject";
181      mro::set_mro($self->pkg, "c3");
182   }
183
184   push @{$self->application->object_types}, $self;
185   $self;
186}
187
188####################################################################################
189sub pick_specialization {
190   my $spez=shift;
191   &{$spez->match_node->resolve(\@_) // return ()}
192}
193
194sub all_partial_specializations {
195   my ($self, $for_spez)=@_;
196   ( ($self != $for_spez && defined($self->specializations)
197      ? (grep { $_ != $for_spez } @{$self->specializations}) : () ),
198     map { defined($_->specializations) ? @{$_->specializations} : () } @{$self->linear_isa}
199   )
200}
201####################################################################################
202sub full_specialization {
203   my ($self, $concrete) = @_;
204   ($self->full_spez //= { })->{$concrete->pkg} //= new Specialization(undef, $concrete->pkg."::_Full_Spez", $concrete);
205}
206####################################################################################
207sub modify_super {
208   my ($self, $pos, $remove, @types) = @_;
209   mro::set_mro($self->pkg, "c3") unless @{$self->super};
210   splice @{$self->super}, $pos, $remove, @types;
211   my @pkgs = map { $_->pkg } @types;
212   namespaces::using($self->pkg, @pkgs);
213   no strict 'refs';
214   splice @{$self->pkg."::ISA"}, $pos, $remove, @pkgs;
215   update_inheritance($self);
216}
217
218sub update_inheritance {
219   my ($self) = @_;
220   my $linear_isa = mro::get_linear_isa($self->pkg);
221   # ignore the type itself and ubiquitous BigObject
222   @{$self->linear_isa} = map { $_->type } grep { !/^Polymake::Core::/ } @$linear_isa[1..$#$linear_isa];
223}
224
225sub concrete_instances {
226   my ($self) = @_;
227   grep { $_->generic == $self && !$_->abstract } &derived
228}
229
230sub concrete_super_instances {
231   my ($self) = @_;
232   my @list;
233   foreach my $super (reverse @{$self->super}) {
234      last if $super->abstract || $super->full_spez_for == $self;
235      push @list, $super;
236   }
237   reverse @list
238}
239####################################################################################
240sub isa {
241   my ($self, $other) = @_;
242   if (is_string($other)) {
243      $other = $self->application->eval_type($other, 1) or return;
244   }
245   return $self == $other || list_index($self->linear_isa, $other) >= 0;
246}
247####################################################################################
248sub deserialize : method {
249   my ($self, $src) = @_;
250   if (is_hash($src)) {
251      &BigObject::deserialize
252   } else {
253      croak( "wrong serialized representation of ", $self->full_name, " - anonymous hash expected" );
254   }
255}
256####################################################################################
257# for compatibility with PropertyType:
258
259*type=\&PropertyType::type;
260*mangled_name=\&PropertyParamedType::mangled_name;
261*full_name=\&PropertyParamedType::full_name;
262*typecheck=\&PropertyType::typecheck;
263*add_constructor=\&PropertyType::add_constructor;
264*performs_deduction=\&PropertyParamedType::performs_deduction;
265*set_extension=\&PropertyParamedType::set_extension;
266*type_param_index=\&PropertyType::type_param_index;
267*derived=\&PropertyType::derived;
268define_function(__PACKAGE__, ".type", \&type);
269
270sub qualified_name {
271   my ($self) = @_;
272   defined($self->params) && !$self->abstract ? &PropertyParamedType::qualified_name : &PropertyType::qualified_name
273}
274
275sub required_extensions {
276   my ($self) = @_;
277   defined($self->params) && !$self->abstract ? &PropertyParamedType::required_extensions : &PropertyType::required_extensions
278}
279
280sub concrete_type {
281   # undef context_pkg means we are in a generic parameterized object class, hence nothing to deduce
282   defined($_[0]->context_pkg) ? &PropertyParamedType::concrete_type : pop
283}
284
285sub descend_to_generic {
286   my ($self, $pkg)=@_;
287   if (@{$self->linear_isa}) {
288      return $self if defined($self->generic) && $self->generic->pkg eq $pkg;
289      foreach my $super_proto (@{$self->linear_isa}) {
290         return $super_proto if defined($super_proto->generic) && $super_proto->generic->pkg eq $pkg;
291      }
292   }
293   undef
294}
295####################################################################################
296sub find_super_type_param {
297   my ($self, $name) = @_;
298   my @result;
299   foreach my $super (@{$self->linear_isa}) {
300      if (!instanceof Augmented($super) and defined($super->params) and my ($param) = grep { $_->name eq $name } @{$super->params}) {
301         @result = ($super, $param);
302      }
303   }
304   @result;
305}
306####################################################################################
307# "property name" => Property or undef
308sub lookup_property {
309   my ($obj_type, $prop_name) = @_;
310   # full spezialization objects share all properties with full instances
311   my $self = $obj_type->full_spez_for // $obj_type;
312   # negative results are not cached
313   $self->properties->{$prop_name} // do {
314      my $prop;
315      foreach my $super (@{$self->linear_isa}) {
316         if (defined($prop = $super->properties->{$prop_name})) {
317            if ($prop->flags & Property::Flags::is_permutation) {
318               $prop = instantiate_permutation($self, $prop);
319            } elsif (!$self->abstract && ($prop->flags & Property::Flags::is_subobject || !($prop->flags & Property::Flags::is_concrete))) {
320               $prop = instantiate_property($self, $prop_name, $prop);
321            }
322            return $self->properties->{$prop_name} = $prop;
323         }
324      }
325      if ($self->abstract) {
326         foreach my $spez (($self->generic // $self)->all_partial_specializations($self)) {
327            if (defined($prop = $spez->properties->{$prop_name})) {
328               $spez = $prop->defined_for;
329               my ($borrower, $lender) = ($self->outer_object_type, $spez->outer_object_type);
330               ($borrower->borrowed_from //= { })->{$lender} ||= do {
331                  # verify the correctness of borrowing
332                  foreach my $proto ($borrower->concrete_instances) {
333                     if (list_index($proto->linear_isa, $lender) < 0) {
334                        die "Invalid inheritance: ", $self->full_name,
335                            "\n refers to property $prop_name defined in ", $spez->full_name,
336                            "\n which does not match the derived object type ", $proto->full_name, "\n";
337                     }
338                  }
339                  1
340               };
341               return $self->properties->{$prop_name} = $prop;
342            }
343         }
344      }
345      undef
346   }
347}
348
349sub instantiate_property {
350   my ($self, $prop_name, $prop) = @_;
351   if ($prop->name ne $prop_name) {
352      # found an overridden property in one of the ancestors:
353      # take the overriding instance
354      if ($prop->overrides ne $prop_name) {
355         die "internal error: property ", $prop->name, " cached under the name '$prop_name'\n";
356      }
357      return lookup_property($self, $prop->name);
358   }
359   my $owner = $prop->belongs_to;
360   if (defined(my $gen_proto = $owner->generic)) {
361      # move from a specialization to the abstract type
362      $owner = $gen_proto;
363   }
364   if ($owner == $self->generic) {
365      unless ($prop->flags & Property::Flags::is_concrete) {
366         $prop = $prop->clone_for_owner($self);
367         create_prop_method($self, $prop);
368      }
369      $prop
370   } else {
371      if ($prop->flags & Property::Flags::is_subobject) {
372         # instantiate the property for each of the concrete ancestors; they are dwelling at the end of the base class list
373         # augmented instances might need to be mixed in the case of multiple inheritance
374         if (my @instances = collect_augmented_super_instances($self, $prop_name)) {
375            if (@instances > 1) {
376               $prop = $prop->clone_for_augmented(new Augmented($prop, $self, map { $_->type } @instances));
377               create_prop_method($self, $prop);
378               return $prop;
379            } else {
380               return $instances[0];
381            }
382         } elsif ($prop->flags & Property::Flags::is_concrete) {
383            return $prop;
384         }
385      }
386
387      # instantiate the property at its birthplace
388      foreach my $super (@{$self->linear_isa}) {
389         # the concrete object type must appear before all specializations and generic types
390         if ($super->generic == $owner) {
391            # if $self is a parametrized augmented type, we might have found the abstract property instance cached in the generic augmented type
392            # because it precedes the pure types in the inheritance list, thus in fact the concrete property instance might already exist
393            return $super->properties->{$prop_name} //= do {
394               $prop = $prop->clone_for_owner($super);
395               create_prop_method($super, $prop);
396               $prop
397            };
398         }
399      }
400      croak( "internal error: could not find the concrete instance of ", $owner->full_name, " among ancestors of ", $self->full_name,
401                   " (", join(", ", map { $_->full_name } @{$self->super}), ") while instantiating property ", $prop->name );
402   }
403}
404
405sub instantiate_permutation {
406   my ($self, $prop) = @_;
407   # only a dependent abstract type may inherit the permutation instance from its generic type,
408   # all other types might introduce own properties and therefore need personalized permutation instances
409   if ($self->abstract && defined($self->context_pkg)) {
410      if ($prop->belongs_to != $self->generic) {
411         $prop = lookup_property($self->generic, $prop->name);
412      }
413   } else {
414      $prop = $prop->clone_for_owner($self);
415      create_prop_method($self, $prop);
416   }
417   $prop
418}
419
420sub lookup_overridden_property {
421   my ($self, $prop) = @_;
422   foreach my $super (@{$self->linear_isa}) {
423      if ($super->full_spez_for != $self && !$super->isa($prop->overrides_for) && $super->isa($prop->defined_for)) {
424         return lookup_property($super, $prop->overrides);
425      }
426   }
427   undef
428}
429
430sub property {
431   my ($self, $prop_name) = @_;
432   lookup_property($self, $prop_name) or croak( "unknown property ", $self->full_name, "::$prop_name" );
433}
434
435sub init_pseudo_prop {
436   state $prop = _new Property(".initial", undef, undef);
437}
438
439sub collect_augmented_super_instances {
440   my ($self, $prop_name) = @_;
441   my @list;
442   foreach my $super ($self->concrete_super_instances) {
443      if (defined(my $found_prop = lookup_property($super, $prop_name))) {
444         if ($found_prop->flags & Property::Flags::is_augmented) {
445            if (@list == 1 && !($list[0]->flags & Property::Flags::is_augmented)) {
446               $list[0] = $found_prop;
447            } elsif (!@list || list_index(\@list, $found_prop) < 0) {
448               push @list, $found_prop;
449            }
450         } elsif (!@list) {
451            push @list, $found_prop;
452         }
453      }
454   }
455   @list
456}
457
458sub help_ref_to_prop {
459   my ($self, $from_app, $prop_name)=@_;
460   ($self->application != $from_app && $self->application->name."::").$self->name."::$prop_name";
461}
462####################################################################################
463# "property name" => bool
464# Returns TRUE if the property is overridden for this object type or one of its ancestors.
465# Returns undef if the property is not known at all.
466sub is_overridden {
467   my ($self, $prop_name) = @_;
468   if (defined(my $prop = lookup_property($self, $prop_name))) {
469      $prop->name ne $prop_name;
470   } else {
471      undef
472   }
473}
474####################################################################################
475# Property => "name"
476# Returns the name of the overriding property if appropriate.
477sub property_name {
478   my ($self, $prop) = @_;
479   lookup_property($self, $prop->property_name)->name
480}
481####################################################################################
482sub list_permutations {
483   my ($self) = @_;
484   (values %{$self->permutations}), (map { values %{$_->permutations} } @{$self->linear_isa})
485}
486####################################################################################
487# private:
488sub create_prop_method {
489   my ($self, $prop)=@_;
490   define_function($self->pkg, $prop->name,
491                   create_prop_accessor($prop->flags & Property::Flags::is_multiple
492                                        ? [ $prop, \&BigObject::get_multi, \&BigObject::put_multi ]
493                                        : [ $prop, \&BigObject::get,       \&BigObject::put       ],
494                                        $self->pkg));
495}
496
497# private:
498sub add_property {      # => Property
499   my ($self, $prop) = @_;
500   if ($enable_plausibility_checks && defined(my $old_prop = lookup_property($self, $prop->name))) {
501      croak( $old_prop->belongs_to == $self
502             ? "multiple definition of property '".$prop->name."'"
503             : "redefinition of inherited property '".$prop->name."' not allowed" );
504   }
505   &create_prop_method;
506   $self->properties->{$prop->name} = $prop;
507}
508
509sub add_permutation {
510   my ($self, $name, $pure_prop) = @_;
511   if ($enable_plausibility_checks && defined(my $old_prop = lookup_property($self, $name))) {
512      croak( $old_prop->flags & Property::Flags::is_permutation
513             ? ( $old_prop->belongs_to == $self
514                 ? "multiple definition of permutation '$name'"
515                 : "redefinition of inherited permutation '$name' not allowed" )
516             : "permutation $name conflicts with property ".$old_prop->defined_for->full_name."::$name" );
517   }
518   my $perm = new Permutation($name, $self->augment($pure_prop), $self);
519   create_prop_method($self, $perm);
520   $pure_prop->name .= ".pure";
521   $pure_prop->flags |= Property::Flags::is_non_storable;
522   $self->properties->{$pure_prop->name} = $pure_prop;
523   $self->permutations->{$name} =
524   $self->properties->{$name} = $perm;
525}
526####################################################################################
527# private:
528sub find_overridden_property {
529   my ($self, $prop_name) = @_;
530   my $prop;
531   foreach my $super (@{$self->linear_isa}) {
532      # only properties inherited from other types or from other enclosing types may be overridden
533      if ($super != $self->generic && $super->outer_object_type != $scope_owner) {
534         defined($prop = lookup_property($super, $prop_name))
535           and return $prop;
536      }
537   }
538   # this will croak if $prop_name is unknown
539   $prop = property($self, $prop_name);
540   croak( "Can't override a property $prop_name defined in the same class family ", $prop_name->defined_for->full_name );
541}
542####################################################################################
543sub override_property {        # "new name", "old name", Help => Property
544   my ($self, $prop_name, $old_prop_name, $new_type, $help) = @_;
545   if ($enable_plausibility_checks) {
546      if (defined($old_prop_name)) {
547         if (instanceof Specialization($scope_owner) && !$scope_owner->is_anon_full_spez) {
548            croak( "A property can't be overridden in a partial or conditional specialization" );
549         }
550      } else {
551         if (instanceof Specialization($self) || instanceof Augmented($self)) {
552            croak( "Property type can only be overridden in a derived object type" );
553         }
554      }
555   }
556   my $old_prop = find_overridden_property($self, $old_prop_name // $prop_name);
557
558   if ($enable_plausibility_checks && defined($new_type)) {
559      $old_prop->flags & Property::Flags::is_subobject
560        or croak( "invalid type override for an atomic property ", $old_prop_name // $prop_name );
561      if ($old_prop->flags & Property::Flags::is_twin and $new_type != $self) {
562         croak( "Twin property $prop_name automatically inherits the enclosing object type, the override definition must end with ': self'" );
563      }
564      if ($new_type->pkg eq $old_prop->type->pkg) {
565         croak( "invalid property type override: new type is identical to the overridden one" );
566      }
567      ($new_type->generic // $new_type)->isa($old_prop->type->pure_type->generic // $old_prop->type->pure_type)
568        or croak( "invalid property type override: ", $new_type->full_name, " is not derived from ", $old_prop->type->pure_type->full_name );
569   }
570
571   my $prop=$old_prop->override_by($prop_name, $self, $new_type);
572
573   if (defined($new_type) and $old_prop->flags & Property::Flags::is_augmented) {
574      $prop->change_to_augmented(new Augmented($prop, $self));
575   }
576
577   if (defined($old_prop_name)) {
578      $self->properties->{$old_prop_name} = add_property($self, $prop);
579      define_function($self->pkg, $old_prop_name, UNIVERSAL::can($self->pkg, $prop_name));
580
581      if (defined($help)) {
582         $help->annex->{header} = "property $prop_name : ".$prop->type->full_name."\n";
583         weak($help->annex->{property} = $prop);
584         $help->text =~ s/UNDOCUMENTED\n//;
585         $help->text .= " Alias for property [[" . $old_prop->defined_for->help_ref_to_prop($self->application, $old_prop_name) . "]].\n";
586      }
587   } else {
588      $self->properties->{$prop_name} = $prop;
589      create_prop_method($self, $prop);
590
591      # derived classes might have cached the original property or its concrete instances
592      foreach my $derived ($self->derived) {
593         my $cached_prop = $derived->properties->{$prop_name} or next;
594         if ($cached_prop == $old_prop) {
595            $derived->properties->{$prop_name} = $prop;
596         } elsif ($cached_prop->flags & Property::Flags::is_concrete && $self->isa($cached_prop->belongs_to->generic // $cached_prop->belongs_to)) {
597            delete $derived->properties->{$prop_name};
598         }
599      }
600   }
601   $prop;
602}
603####################################################################################
604# protected:
605sub invalidate_prod_cache {
606   my ($self, $key) = @_;
607   if (defined(delete $self->all_producers->{$key})) {
608      delete $self->shortcuts->{$key};
609      invalidate_prod_cache($_, $key) for $self->derived;
610   }
611}
612
613
614sub rule_is_applicable {
615   my ($self, $rule) = @_;
616   if (defined(my $overridden_in = $rule->overridden_in)) {
617      foreach my $other (@$overridden_in) {
618         return 0 if $self == $other || list_index($self->linear_isa, $other) >= 0;
619      }
620   }
621   1
622}
623
624sub add_producers_of {
625   my ($self, $key) = splice @_, 0, 2;
626   push @{$self->producers->{$key}}, @_;
627   invalidate_prod_cache($self, $key);
628}
629
630sub get_producers_of {
631   my ($self, $prop, $stop_after) = @_;
632   my $key = $prop->key;
633   $self->all_producers->{$key} ||= do {
634      my @list;
635      if (defined(my $own_prod = $self->producers->{$key})) {
636         @list = @$own_prod;
637      }
638      if (!defined($stop_after) && defined($prop->defined_for)) {
639         $stop_after = $prop->defined_for->pure_type;
640         if (defined($stop_after->generic)) {
641            $stop_after = $stop_after->generic;
642         } elsif (!defined($stop_after->abstract)) {
643            # this is not an abstract super type so we need to find the last
644            # matching specialization to check all of them for rules
645            my @siblings = grep {defined($_->full_spez_for) && $_->full_spez_for->pure_type == $stop_after} @{$stop_after->linear_isa};
646            if (@siblings > 0) {
647               $stop_after = $siblings[-1];
648            }
649         }
650      }
651      if ($stop_after != $self) {
652         foreach my $super_proto (@{$self->linear_isa}) {
653            $super_proto->all_producers->{$key} //= 0;   # mark for cache invalidation
654            if (defined(my $super_prod = $super_proto->producers->{$key})) {
655               push @list, grep { rule_is_applicable($self, $_) } @$super_prod;
656            }
657            last if $stop_after == $super_proto;
658         }
659      }
660      \@list
661   };
662}
663
664# only shortcuts directly creating the property asked for are stored here
665sub get_shortcuts_for {
666   my ($self, $prop) = @_;
667   $self->shortcuts->{$prop->key} //=
668      [ grep { instanceof Rule::Shortcut($_) and
669               $_->output->[0]->[-1]->key == $prop->property_key
670        } @{ $self->get_producers_of($prop) }
671      ]
672}
673####################################################################################
674# protected:
675sub invalidate_label_cache {
676   my ($self, $wildcard) = @_;
677   if (defined(delete $self->all_rules_by_label->{$wildcard})) {
678      invalidate_label_cache($_, $wildcard) for $self->derived;
679   }
680}
681
682sub get_rules_by_label {
683   my ($self, $wildcard) = @_;
684   $self->all_rules_by_label->{$wildcard} ||= do {
685      # signal for invalidate_label_cache should it happen later
686      $_->all_rules_by_label->{$wildcard} //= 0 for @{$self->linear_isa};
687      Preference::merge_controls(grep { defined($_) } map { $_->rules_by_label->{$wildcard} } $self, @{$self->linear_isa})
688   };
689}
690
691####################################################################################
692# protected:
693sub add_rule_labels {
694   my ($self, $rule, $labels)=@_;
695   foreach my $label (@$labels) {
696      my $wildcard = $label->wildcard_name;
697      my $ctl_list;
698      if (defined ($ctl_list = $self->rules_by_label->{$wildcard})) {
699         invalidate_label_cache($self, $wildcard);
700      } else {
701         $self->rules_by_label->{$wildcard} = $ctl_list = [ ];
702      }
703      $label->add_control($ctl_list, $rule);
704   }
705}
706####################################################################################
707# protected:
708# "NAME.NAME" => (Property)
709sub encode_descending_path {
710   my ($self, $string) = @_;
711   my $prop;
712   map {
713      $self = $prop->type if $prop;
714      $prop = property($self, $_);
715   } split /\./, $string;
716}
717
718# "parent.<...>.PROP_NAME.<...> => Property::Path
719# Leading "parents" may also be expressed as "ancestor(TYPE)"
720sub encode_property_path {
721   my ($self, $string)=@_;
722   my $up=0;
723   while ($string =~ s/^parent\.//) {
724      if (instanceof Augmented($self)) {
725         ++$up;
726         $self=$self->parent_property->belongs_to;
727      } else {
728         croak("can't refer to parents of a non-augmented object type ", $self->full_name);
729      }
730   }
731   if (!$up && $string =~ s/^ancestor\(($balanced_re)\)\.//) {
732      my $parent_type=eval "typeof $1";
733      croak("invalid parent type $1: $@") if $@;
734      for (;;) {
735         if (instanceof Augmented($self)) {
736            ++$up;
737            $self=$self->parent_property->belongs_to;
738            if ($self->isa($parent_type)) {
739               last;
740            }
741         } elsif ($up) {
742            croak($_[0]->full_name, " has no ascendants of type ", $parent_type->full_name);
743         } else {
744            croak("can't refer to parents of a non-augmented object type ", $self->full_name);
745         }
746      }
747   }
748   new Property::Path($up, encode_descending_path($self, $string));
749}
750
751# 'NAME.NAME | ...' => [ [ Property, ... ] ]
752# flags(RETVAL)==Property::Flags::is_permutation if the paths descend into a permutation subobject
753sub encode_read_request {
754   my ($self, $req)=@_;
755   my $perm_seen;
756   my @alternatives=map {
757      my @path=encode_descending_path($self, $_);
758      $perm_seen ||= Property::find_first_in_path(\@path, Property::Flags::is_permutation)>=0;
759      \@path
760   } split /\s*\|\s*/, $req;
761   if ($perm_seen) {
762      set_array_flags(\@alternatives, Property::Flags::is_permutation);
763   }
764   \@alternatives
765}
766####################################################################################
767# for compatibility with Augmented types, e.g. when only derived owner types define some additional properties
768*pure_type=\&type;
769sub final_type { pop }
770sub outer_object_type { shift }
771sub parent_property { undef }
772sub enclosed_in_restricted_spez { 0 }
773
774# for compatibility with Specialization
775sub preconditions { undef }
776sub full_spez_for { undef }
777sub is_anon_full_spez { 0 }
778####################################################################################
779sub override_rule {
780   my ($self, $super, $label)=@_;
781   my $matched;
782   foreach my $rule ($label->list_all_rules) {
783      if (is_object($super)) {
784         next if !$super->isa($rule->defined_for);
785      } else {
786         next if $self==$rule->defined_for || list_index($self->linear_isa, $rule->defined_for)<0;
787      }
788      $matched=1;
789      if (defined($rule->overridden_in)) {
790         push @{$rule->overridden_in}, $self if list_index($rule->overridden_in, $self)<0;
791      } else {
792         $rule->overridden_in=[ $self ];
793      }
794   }
795   if ($enable_plausibility_checks && !$matched) {
796      warn_print( "\"$_[3]\", line $_[4]: override declaration does not match any inherited rules" );
797   }
798}
799####################################################################################
800sub find_rule_label {
801   my ($self, $pattern)=@_;
802   $self->application->prefs->find_label($pattern)
803}
804
805sub find_rules_by_pattern {
806   my ($self, $pattern)=@_;
807   if ($pattern =~ /^ $hier_id_re $/xo) {
808      # specified by label
809      my $label=$self->find_rule_label($pattern)
810        or die "unknown label \"$pattern\"\n";
811      grep { $self->isa($_->defined_for) } $label->list_all_rules
812
813   } elsif ($pattern =~ /:/) {
814      # specified by header:
815      Rule::header_search_pattern($pattern);
816      grep { $_->header =~ $pattern } map { @{$_->production_rules} } $self, @{$self->linear_isa}
817
818   } else {
819      die "invalid rule search pattern: expected a label or a complete header in the form \"OUTPUT : INPUT\"\n";
820   }
821}
822
823sub disable_rules {
824   my @rules=&find_rules_by_pattern
825     or die "no matching rules found\n";
826   Scheduler::temp_disable_rules(@rules);
827}
828####################################################################################
829sub add_method_rule {
830   my ($self, $header, $code, $name)=@_;
831   my $rule = special Rule($header, $code, $self);
832   $rule->flags = Rule::Flags::is_function;
833   substr($rule->header, 0, 0) = "user_method ";
834   $rule->analyze_spez_preconditions;
835   if (defined($name)) {
836      # non-polymorphic method, no call redirection via overload resolution
837      my $rules = [ $rule ];
838      define_function($self->pkg, $name,
839                      sub : method {
840                         &{ (Scheduler::resolve_rules($_[0], $rules) // croak("could not provide all required input properties") )->code };
841                      });
842   }
843   $rule;
844}
845####################################################################################
846sub augment {
847   my ($self, $prop)=@_;
848   my ($augm, $augm_super, $cloned_prop, $update_caches);
849
850   if ($prop->flags & Property::Flags::is_permutation) {
851      my $pure_prop = $prop->type->pure_property;
852      $augm = $self->augment($pure_prop);
853      $prop->change_to_augmented($augm);
854      # TODO: reactivate if needed, or delete, together with Permutation::update_pure_type
855      if (false) {
856         # update permuted types in every derived class to use the augmented base "pure" type
857         foreach my $derived (grep { $_ != $self->full_spez_for && !defined($_->full_spez_for) } $self->derived) {
858            my $cached_prop = $derived->properties->{$prop->name} or next;
859            $cached_prop != $prop
860              or croak( "internal error: permutation ", $prop->name, " instance shared between different types ",
861                        $derived->full_name, " and ", $self->full_name );
862            $cached_prop->update_pure_type(property($derived, $pure_prop->name)->type);
863         }
864      }
865
866   } elsif ($prop->belongs_to == $self) {
867      if ($prop->flags & Property::Flags::is_augmented  and
868          !defined($prop->overrides) || $prop->type->parent_property == $prop) {
869         return $prop->type;
870      }
871      $augm = new Augmented($prop, $self);
872      $prop->change_to_augmented($augm);
873      $update_caches = !($prop->flags & Property::Flags::is_concrete);
874
875   } elsif ($prop->belongs_to == $self->full_spez_for) {
876      return Specialization::augment_in_full_spez($self, $prop);
877
878   } else {
879      ($augm, $augm_super, $update_caches) = $self->create_augmentation($prop);
880      $cloned_prop = $self->properties->{$prop->name} = $prop->clone_for_augmented($augm, $self);
881      create_prop_method($self, $cloned_prop);
882   }
883
884   if ($update_caches) {
885      # derived classes might have cached the original property; update or delete the cache entries
886      foreach my $derived ($self->derived) {
887         my $cached_prop = $derived->properties->{$prop->name} or next;
888         if ($cached_prop == $prop) {
889            if (defined($cloned_prop)) {
890               # the derived class has inherited the original property, now it is shadowed by the cloned one
891               if ($cloned_prop->flags & Property::Flags::is_concrete || $derived->abstract) {
892                  $derived->properties->{$prop->name} = $cloned_prop;
893               } else {
894                  # augmentation is parametrized, the concrete instance will be created later on demand
895                  delete $derived->properties->{$prop->name};
896               }
897            } elsif (!($prop->flags & Property::Flags::is_concrete || $derived->abstract) || $prop->flags & Property::Flags::is_permutation) {
898               # augmentation is parametrized, the concrete instance will be created later on demand
899               delete $derived->properties->{$prop->name};
900            }
901
902         } elsif (defined($augm_super)) {
903            # other augmentations downstream have already been treated by the new augmentation itself;
904            # only handle classes which inherited a concrete instance of augm_super
905            if ($augm_super == $cached_prop->type->generic) {
906               if ($derived->generic == ($self->generic // $self)) {
907                  # clone the property for this concrete instance;
908                  # the augmentation will propagate itself to all concrete descendants
909                  my $cloned_concrete_prop =
910                    $derived->properties->{$prop->name} =
911                    $prop->clone_for_augmented($augm->concrete_type($derived, $cached_prop->type), $derived);
912                  create_prop_method($derived, $cloned_concrete_prop);
913               } else {
914                  # it's an intermediate class without own augmentations
915                  delete $derived->properties->{$prop->name};
916               }
917            }
918         } elsif ($cached_prop->flags & Property::Flags::is_augmented) {
919            # this augmentation was at the root of the hierarchy, now it has to absorb the new one
920            if ($cached_prop->type->super->[0] == $cached_prop->type->pure_type) {
921               $cached_prop->type->inject_inheritance($augm);
922            }
923
924         } else {
925            # cached_prop must be a concrete instance of the generic original property
926            ($cached_prop->flags & Property::Flags::is_concrete) > ($prop->flags & Property::Flags::is_concrete)
927              or croak( "internal error: unexpected property instance of ", $cached_prop->name,
928                        " found in ", $derived->full_name );
929            if (defined($cloned_prop) || $derived->generic != ($self->generic // $self)) {
930               # the derived class has inherited a concrete instance of the original property;
931               # a new concrete instance will be created or fetched later on demand
932               delete $derived->properties->{$prop->name};
933            } else {
934               # we can't delete the property because it's stored in the accessor methods;
935               # this will create a new concrete augmentation which won't have any descendants yet
936               $cached_prop->change_to_augmented($augm->concrete_type($derived));
937            }
938         }
939      }
940   }
941
942   $augm
943}
944
945sub create_augmentation {
946   my ($self, $prop)=@_;
947   my @augm_super= $prop->flags & Property::Flags::is_augmented ? ($prop->type) : ();
948   my $augm=new Augmented($prop, $self, @augm_super);
949   ($augm, $augm_super[0], 1);
950}
951####################################################################################
952sub help_topic {
953   my $self=shift;
954   $self->help // ($self->application // return)->help->find_type_topic($self, "objects", @_);
955}
956####################################################################################
957sub override_help {
958   my ($self, $group, $item, $text)=@_;
959   my ($inherited_topic)=map { $_->help_topic(1)->find($group, $item) } @{$self->linear_isa}
960     or croak( "help topic $group/$item not found anywhere in base types of ", $self->full_name );
961   if ($inherited_topic->parent->category) {
962      $text='# @category ' . $inherited_topic->parent->name . "\n" . $text;
963   }
964   my $topic=$self->help_topic(1)->add([ $group, $item ], $text);
965   foreach (qw(spez property header)) {
966      if (defined (my $ref=$inherited_topic->annex->{$_})) {
967         if (ref($ref)) {
968            weak($topic->annex->{$_}=$ref);
969         } else {
970            $topic->annex->{$_}=$ref;
971         }
972      }
973   }
974   $topic
975}
976####################################################################################
977sub set_file_suffix {
978   my ($self, $suffix) = @_;
979   define_function($self->pkg, "default_file_suffix", sub : method { $suffix });
980   push @{$self->application->file_suffixes}, $suffix;
981}
982####################################################################################
983sub reopen_subobject {
984   my ($self, $path) = @_;
985   foreach my $prop_name (split /\./, $path) {
986      my $prop = property($self, $prop_name);
987      if (($prop->flags & (Property::Flags::is_subobject | Property::Flags::is_twin)) == Property::Flags::is_subobject) {
988         $self = $self->augment($prop);
989      } elsif ($prop->flags & Property::Flags::is_twin) {
990         croak( "a twin property cannot be augmented" );
991      } else {
992         croak( "an atomic property definition cannot be augmented" );
993      }
994   }
995   $self
996}
997####################################################################################
998package Polymake::Core::BigObjectType::RuleLikeMethodNode;
999
1000use Polymake::Struct(
1001   [ '@ISA' => 'Overload::Node' ],
1002);
1003
1004# instead of single sub references, every code slot contains a list of rule-like methods
1005
1006sub store_code {
1007   my ($self, $i, $rule)=@_;
1008   push @{$self->code->[$i] //= [ ]}, $rule;
1009}
1010
1011sub store_ellipsis_code {
1012   my ($self, $rule)=@_;
1013   push @{$self->ellipsis_code //= [ ]}, $rule;
1014}
1015
1016sub dup_ellipsis_code {
1017   my ($self, $upto)=@_;
1018   push @{$self->code}, map { [ @{$self->ellipsis_code} ] } @{$self->code}..$upto;
1019}
1020
1021sub push_code {
1022   my ($self, $n, $rule)=@_;
1023   push @{$self->code}, map { [ $rule ] } 1..$n;
1024}
1025
1026sub resolve {
1027   my ($self, $args)=@_;
1028   if (defined (my $rulelist=&Overload::Node::resolve)) {
1029      (Scheduler::resolve_rules($args->[0], $rulelist) // croak( "could not provide all required input properties" ))->code;
1030   } else {
1031      undef
1032   }
1033}
1034
1035####################################################################################
1036package Polymake::Core::BigObjectType::Augmented;
1037
1038use Polymake::Struct (
1039   [ '@ISA' => 'BigObjectType' ],
1040   [ new => '$$@' ],
1041   [ '$name' => '#2->name ."__". #1->name ."__augmented"' ],
1042   [ '$application' => '#2->application' ],
1043   [ '$parent_property' => 'undef' ],
1044   [ '$outer_object_type' => 'undef' ],
1045   [ '$pure_type' => '#1->type->pure_type' ],
1046   [ '$enclosed_in_restricted_spez' => '#2->enclosed_in_restricted_spez || defined(#2->preconditions)' ],
1047   [ '$full_spez_for' => 'undef' ],
1048   '$is_anon_full_spez',
1049   '%inst_cache',             # for abstract types: owner BigObjectType => concrete instance
1050                              # for concrete types: autonomous BigObjectType => Augmented
1051);
1052
1053# constructor: (parent) Property, (owner) BigObjectType, super Augmented =>
1054sub new {
1055   my $self = &_new;
1056   my ($prop, $owner, @super) = @_;
1057
1058   $self->pkg = $owner->pkg."::_prop_".$prop->name =~ s/\.pure$//r;
1059   define_function($self->pkg, "type", sub { $self }, 1);
1060   RuleFilter::create_self_method_for_object($self);
1061
1062   weak($self->outer_object_type = $owner->outer_object_type);
1063
1064   if ($self->outer_object_type->abstract) {
1065      $self->context_pkg = $self->outer_object_type->context_pkg;
1066      $self->abstract = \&type;
1067   } elsif ($self->pure_type->abstract) {
1068      $self->pure_type = $self->pure_type->concrete_type($self->outer_object_type);
1069   }
1070
1071   my $inherit_pure_type;
1072   if (!@super && defined($prop->overrides)) {
1073      my $overridden = $owner->lookup_overridden_property($prop);
1074      if ($overridden->flags & Property::Flags::is_augmented) {
1075         push @super, $overridden->type;
1076         $inherit_pure_type = $overridden->type->pure_type != $self->pure_type;
1077      }
1078   }
1079   modify_super($self, 0, 0, @super, $inherit_pure_type || !@super ? $self->pure_type : ());
1080
1081   if (instanceof Specialization($scope_owner)) {
1082      if ($self->abstract) {
1083         my $augm_generic = $super[0];
1084         if (instanceof Specialization($augm_generic->outer_object_type)) {
1085            # derived augmentation of a property introduced in a partial specialization
1086         } else {
1087            # introduced a new augmentation in a partial specialization:
1088            # inject it into all matching concrete instances
1089            weak($self->generic = $augm_generic);
1090            push @{$augm_generic->specializations //= [ ]}, $self;
1091
1092            while (my ($concrete_owner, $concrete_augm) = each %{$augm_generic->inst_cache}) {
1093               if ($concrete_owner->isa($owner)) {
1094                  (my $pos = list_index($concrete_augm->super, $augm_generic)) >= 0
1095                    or croak( "internal error: super(", $concrete_augm->full_name, ") does not contain the generic augmentation ", $augm_generic->full_name);
1096                  modify_super($concrete_augm, $pos, 0, $self);
1097                  $_->update_inheritance for $concrete_augm->derived;
1098               }
1099            }
1100         }
1101      }
1102      # augmentations in full specializations are included into the concrete instance directly in augment()
1103
1104   } elsif (@super) {
1105      propagate_inheritance($self, $owner, @super);
1106   }
1107
1108   $self;
1109}
1110####################################################################################
1111use Polymake::Struct (
1112   [ 'alt.constructor' => 'new_concrete' ],
1113   [ new => '$' ],
1114   [ '$name' => '#1->name' ],
1115   [ '$application' => '#1->application' ],
1116   [ '$extension' => '#1->extension' ],
1117   [ '$context_pkg' => '#1->context_pkg' ],
1118   [ '$generic' => 'weak(#1)' ],
1119   [ '$pure_type' => 'undef' ],
1120   [ '$enclosed_in_restricted_spez' => '0' ],
1121);
1122
1123sub concrete_type {
1124   my ($src, $owner, @concrete_super) = @_;
1125   $src->abstract
1126     or croak( "internal error: attempt to construct a concrete instance of non-abstract augmentation ", $src->full_name );
1127   if (defined(my $augm_generic = $src->generic)) {
1128      $src = $augm_generic;
1129   }
1130
1131   $src->inst_cache->{$owner} //= do {
1132      my $self = new_concrete($src, $src);
1133      my $prop_name = $src->parent_property->name;
1134      if ($owner->pkg =~ /::_Full_Spez\b/) {
1135         croak("internal error: Augmented::concrete_type called from a wrong context");
1136      }
1137      $self->pkg = $owner->pkg . "::_prop_" . ($prop_name =~ s/\.pure$//r);
1138      define_function($self->pkg, "type", sub { $self }, 1);
1139
1140      weak($self->outer_object_type = $owner->outer_object_type);
1141      if (!@concrete_super) {
1142         @concrete_super = map { $_->type } grep { $_->flags & Property::Flags::is_augmented } $owner->collect_augmented_super_instances($prop_name);
1143      }
1144      $self->pure_type = @concrete_super
1145                         ? $concrete_super[0]->pure_type :
1146                         $src->pure_type->abstract
1147                         ? $src->pure_type->concrete_type($self->outer_object_type)
1148                         : $src->pure_type;
1149      modify_super($self, 0, 0, $src->matching_specializations($owner, $self->pure_type), $src,
1150                   @concrete_super || $self->pure_type == $src->pure_type ? @concrete_super : $self->pure_type);
1151      propagate_inheritance($self, $owner, @concrete_super);
1152      $self;
1153   };
1154}
1155
1156sub concrete_specialization {
1157   my ($src, $owner, $pure_type)=@_;
1158   $src->abstract
1159     or croak( "internal error: attempt to construct a concrete instance of non-abstract augmentation ", $src->full_name );
1160
1161   # find the concrete instance of the enclosing specialization
1162   my $owner_spez;
1163   my $gen_spez=$src->parent_property->belongs_to;
1164   foreach (@{$owner->linear_isa}) {
1165      if ($_->generic == $gen_spez) {
1166         $owner_spez=$_;
1167         last;
1168      }
1169   }
1170
1171   $owner_spez
1172     or croak( "internal error: could not find a concrete instance of augmentation ", $gen_spez->full_name, " among ancestors of ", $owner->full_name );
1173
1174   $src->inst_cache->{$owner_spez} //= do {
1175      my $self=new_concrete($src, $src);
1176      my $prop_name=$src->parent_property->name;
1177      $self->pkg=$owner_spez->pkg."::_prop_${prop_name}";
1178      define_function($self->pkg, "type", sub { $self }, 1);
1179      $self->pure_type=$pure_type;
1180      weak($self->outer_object_type=$owner_spez->outer_object_type);
1181      if ($src->generic) {
1182         # property defined in the generic enclosing type
1183         modify_super($self, 0, 0, $src);
1184      } else {
1185         # property borrowed from another specialization
1186         modify_super($self, 0, 0, $src, concrete_specialization($src->super->[0], $owner, $pure_type));
1187      }
1188      $self;
1189   };
1190}
1191
1192sub matching_specializations {
1193   my ($self, $owner, $pure_type)=@_;
1194   if ($self->specializations) {
1195      map { concrete_specialization($_, $owner, $pure_type) } grep { $owner->isa($_->parent_property->belongs_to) } @{$self->specializations};
1196   } else {
1197      ()
1198   }
1199}
1200
1201sub inject_inheritance {
1202   my ($self, $augm_super)=@_;
1203   $self->super->[0]=$augm_super;
1204   namespaces::using($self->pkg, $augm_super->pkg);
1205   {  no strict 'refs';
1206      ${$self->pkg."::ISA"}[0]=$augm_super->pkg;
1207   }
1208   if ($augm_super->abstract && $self->abstract) {
1209      my $super_generic=$augm_super->parent_property->belongs_to;
1210      while (my ($concrete_owner, $concrete_augm)=each %{$self->inst_cache}) {
1211         foreach my $super_concrete ($concrete_owner->concrete_super_instances) {
1212            if ($super_concrete->isa($super_generic)) {
1213               # the concrete augmentation can't have any concrete super classes so far
1214               modify_super($concrete_augm, -1, 0, $augm_super->concrete_type($super_concrete->descend_to_generic($super_generic->pkg)));
1215               last;
1216            }
1217         }
1218      }
1219   }
1220   $_->update_inheritance for $self, $self->derived;
1221}
1222
1223sub propagate_inheritance {
1224   my ($self, $owner, @override)=@_;
1225   my %overridden;
1226   @overridden{@override}=();
1227
1228   foreach my $derived (map { $_->derived } @override) {
1229      if ($derived != $self &&
1230          ($derived->abstract || !$self->abstract) &&
1231          $derived->parent_property->belongs_to->isa($owner)) {
1232         my $replaced=0;
1233         for (my $i=0; $i<=$#{$derived->super}; ) {
1234            if (exists $overridden{$derived->super->[$i]}) {
1235               if ($replaced) {
1236                  splice @{$derived->super}, $i, 1;
1237                  no strict 'refs';
1238                  splice @{$derived->pkg."::ISA"}, $i, 1;
1239               } else {
1240                  namespaces::using($derived->pkg, $self->pkg);
1241                  $derived->super->[$i]=$self;
1242                  no strict 'refs';
1243                  ${$derived->pkg."::ISA"}[$i]=$self->pkg;
1244                  ++$i;
1245                  $replaced=1;
1246               }
1247            } else {
1248               ++$i;
1249            }
1250         }
1251         if ($replaced) {
1252            $_->update_inheritance for $derived, $derived->derived;
1253         }
1254      }
1255   }
1256}
1257
1258####################################################################################
1259sub final_type {
1260   my ($self, $given_type)=@_;
1261   $self->abstract || $given_type->abstract
1262     and croak( "internal error: attempt to construct a concrete augmented type from ",
1263                ($self->abstract && "abstract base "), $self->full_name,
1264                " and ", ($autonomous_type->abstract && "abstract autonomous type "), $autonomous_type->full_name );
1265   my $autonomous_type=$given_type->pure_type;
1266   if ($autonomous_type == $self->pure_type) {
1267      $self
1268   } else {
1269      $self->inst_cache->{$autonomous_type} //= create_derived($self, $self->parent_property, $autonomous_type);
1270   }
1271}
1272####################################################################################
1273sub full_name {
1274   my ($self)=@_;
1275   (@_==1 && $self->pure_type->full_name . " as ") . $self->parent_property->belongs_to->full_name(0) . "::" . $self->parent_property->name;
1276}
1277
1278sub descend_to_generic {
1279   $_[0]->outer_object_type->descend_to_generic($_[1]) // $_[0]->pure_type->descend_to_generic($_[1]);
1280}
1281
1282sub concrete_super_instances {
1283   my ($self)=@_;
1284   $self->super->[0] == $self->pure_type ? () : &BigObjectType::concrete_super_instances;
1285}
1286####################################################################################
1287sub augmentation_path {
1288   my ($self)=@_;
1289   my ($parent_prop, @path);
1290   while (defined ($parent_prop=$self->parent_property)) {
1291      push @path, $parent_prop;
1292      $self=$parent_prop->belongs_to;
1293   }
1294   reverse @path;
1295}
1296
1297sub create_augmentation {
1298   my ($self, $prop) = @_;
1299   if (instanceof Specialization($scope_owner)) {
1300      &Specialization::create_augmentation;
1301   } else {
1302      my ($augm, @augm_super);
1303      my @owner_augm_path = augmentation_path($self);
1304      my @prop_augm_path = augmentation_path($prop->belongs_to);
1305      if (@prop_augm_path == @owner_augm_path) {
1306         # there is already another augmentation on the same nesting level
1307         push @augm_super, $prop->type;
1308      } else {
1309         # try to find or establish an augmentation with one or more outer enclosing object types stripped off
1310       STRIP_OFF:
1311         while (@owner_augm_path) {
1312            my $outer = shift(@owner_augm_path)->type->pure_type;
1313            if ($outer->abstract && defined($outer->generic)) {
1314               # pass through dependent abstract types
1315               $outer = $outer->generic;
1316            }
1317            foreach (@owner_augm_path, $prop) {
1318               if ($outer->isa($_->defined_for)) {
1319                  my $sub_prop = $outer->property($_->name);
1320                  $outer = $outer->augment($sub_prop);
1321               } else {
1322                  next STRIP_OFF;
1323               }
1324            }
1325            push @augm_super, $outer;
1326            last;
1327         }
1328      }
1329      $augm = new Augmented($prop, $self, @augm_super);
1330      ($augm, $augm_super[0], 1);
1331   }
1332}
1333####################################################################################
1334sub find_rule_label {
1335   &BigObjectType::find_rule_label // do {
1336      my $pure_type_app=$_[0]->pure_type->application;
1337      if ($pure_type_app != $_[0]->application) {
1338         $pure_type_app->prefs->find_label($_[1])
1339      } else {
1340         undef
1341      }
1342   }
1343}
1344####################################################################################
1345# private:
1346sub provide_help_topic {
1347   my ($owner, $force, @descend) = @_;
1348   my $topic = $owner->help_topic($force) or return;
1349   foreach my $prop (@descend) {
1350      my $help_group = $prop->flags & Property::Flags::is_permutation ? "permutations" : "properties";
1351      $topic = $topic->find("!rel", $help_group, $prop->name) // do {
1352         $force or return;
1353         my $text = "";
1354         my $refer_to = $prop->defined_for;
1355         if ($owner != $refer_to) {
1356            if (my $prop_topic = $prop->belongs_to->help_topic->find($help_group, $prop->name)) {
1357               if ($prop_topic->parent->category) {
1358                  $text='# @category ' . $prop_topic->parent->name . "\n";
1359               }
1360            }
1361            $text .= "Augmented subobject " . $refer_to->full_name . "::" . $prop->name . "\n"
1362                   . "# \@display noshow\n";
1363         }
1364         $topic = $topic->add([ $help_group, $prop->name ], $text);
1365         $topic->annex->{property}=$prop;
1366         $topic
1367      };
1368      $owner = $prop->belongs_to;
1369   }
1370   $topic
1371}
1372
1373sub help_topic {
1374   my ($self, $force) = @_;
1375   $self->help //= do {
1376      if ($scope_owner) {
1377         # need a help node during rulefile loading
1378         my @descend = augmentation_path($self);
1379         if (instanceof Specialization($scope_owner)) {
1380            my $gen_topic = provide_help_topic($scope_owner->generic // $scope_owner->full_spez_for, $force, @descend) or return;
1381            ($self->generic // $self->full_spez_for)->help //= $gen_topic;
1382            $gen_topic->new_specialization($scope_owner);
1383         } elsif ($scope_owner != $descend[0]->belongs_to) {
1384            $force and die "internal error: augmentation path does not match the compilation scope\n";
1385            return;
1386         } else {
1387            my $topic = provide_help_topic($scope_owner, $force, @descend) or return;
1388            push @{$topic->related}, uniq( map { ($_, @{$_->related}) } grep { defined($_) && ref($_) !~ /\bSpecialization$/ }
1389                                           map { $_->help_topic } @{$self->linear_isa} );
1390            foreach my $other ($self->derived) {
1391               if (defined($other->help)) {
1392                  push @{$other->help->related}, $topic;
1393               }
1394            }
1395            $topic
1396         }
1397      } else {
1398         $self->pure_type->help_topic;
1399      }
1400   };
1401}
1402
1403sub help_ref_to_prop {
1404   my ($self, $for_app, $prop_name) = @_;
1405   $self->outer_object_type->help_ref_to_prop($for_app, join(".", (map { $_->name } augmentation_path($self)), $prop_name));
1406}
1407####################################################################################
1408use Polymake::Struct (
1409   [ 'alt.constructor' => 'new_derived' ],
1410   [ new => '$$$' ],
1411   [ '$name' => '#1->name' ],
1412   [ '$application' => '#1->application' ],
1413   [ '$extension' => '#1->extension' ],
1414   [ '$parent_property' => 'weak(#2)' ],
1415   [ '$outer_object_type' => '#1->outer_object_type' ],
1416   [ '$pure_type' => '#3' ],
1417   [ '$enclosed_in_restricted_spez' => '#1->enclosed_in_restricted_spez' ],
1418   [ '$inst_cache' => 'undef' ],
1419);
1420
1421sub create_derived {
1422   my ($src, $prop, $autonomous_type) = @_;
1423   my $self = new_derived($prop->flags & Property::Flags::is_permutation ? "Polymake::Core::BigObjectType::Permuted" : __PACKAGE__, @_);
1424   $self->pkg = $autonomous_type->pkg."::__as__".$src->pkg;
1425   define_function($self->pkg, "type", sub { $self }, 1);
1426   modify_super($self, 0, 0, $src, $autonomous_type);
1427   set_extension($self->extension, $autonomous_type->extension);
1428   if ($autonomous_type->abstract) {
1429      $self->abstract = \&type;
1430   }
1431   $self;
1432}
1433####################################################################################
1434package Polymake::Core::BigObjectType::Permuted;
1435
1436use Polymake::Struct (
1437   [ '@ISA' => 'Augmented' ],
1438);
1439
1440sub get_producers_of {
1441   my ($self)=@_;
1442   # No production rules should be inherited from the non-permuted type, otherwise the scheduler would drive crazy.
1443   # Therefore the collection should stop in the pure permutation type.
1444   BigObjectType::get_producers_of(@_, $self->super->[0]->pure_type);
1445}
1446
1447sub pure_property { $_[0]->super->[0]->parent_property }
1448
1449sub concrete_type {
1450   my ($self, $owner) = @_;
1451   create_derived($owner->property(&pure_property->name)->type, $self->parent_property, $owner);
1452}
1453
1454sub full_name {
1455   my ($self)=@_;
1456   $self->pure_type->full_name . "::" . $self->parent_property->name
1457}
1458####################################################################################
1459package Polymake::Core::BigObjectType::Specialization;
1460
1461use Polymake::Struct (
1462   [ '@ISA' => 'BigObjectType' ],
1463   [ new => '$$$;$' ],
1464   [ '$application' => '#3->application' ],
1465   [ '$match_node' => 'undef' ],
1466   [ '$preconditions' => 'undef' ],
1467   [ '$full_spez_for' => 'undef' ],
1468   '$is_anon_full_spez',
1469);
1470
1471# Constructor: new Specialization('name', 'pkg', generic_ObjectType | generic_Specialization | concrete_ObjectType, [ type params ] )
1472sub new {
1473   my $self = &_new;
1474   my (undef, $pkg, $gen_proto, $tparams) = @_;
1475   my $concrete_proto;
1476
1477   if (defined($pkg)) {
1478      $self->pkg = $pkg;
1479      if ($tparams) {
1480         # new abstract specialization
1481         $self->abstract = \&type;
1482         undef $self->perform_typecheck;
1483         my $param_index = -1;
1484         $self->params = [ map { new ClassTypeParam($_, $pkg, $self->application, ++$param_index) } @$tparams ];
1485         $self->name //= do {
1486            my (undef, $file, $line) = caller;
1487            $def_line -= 2;       # accounting for code inserted in RuleFilter
1488            $gen_proto->name." defined at $file, line $line"
1489         };
1490         $self->match_node = new_root Overload::Node;
1491         push @{$gen_proto->specializations //= [ ]}, $self;
1492      } else {
1493         # new full specialization
1494         $concrete_proto = $gen_proto;
1495         $gen_proto = $concrete_proto->generic;
1496         if (defined($self->name)) {
1497            (($gen_proto // $concrete_proto)->full_spez //= { })->{$self->name} = $self;
1498         } else {
1499            $self->is_anon_full_spez = true;
1500            $self->name = $concrete_proto->full_name;
1501         }
1502         $self->params = $concrete_proto->params;
1503      }
1504   } else {
1505      # a concrete instance of a specialization
1506      $self->name = $gen_proto->name;
1507      $self->extension = $gen_proto->extension;
1508      $self->pkg = $gen_proto->pkg;
1509      $self->params = $tparams;
1510      PropertyParamedType::scan_params($self);
1511   }
1512   my $self_sub = define_function($self->pkg, "type", sub { $self }, 1);
1513   $self->generic = $gen_proto;
1514   if (defined($concrete_proto)) {
1515      RuleFilter::create_self_method_for_object($self);
1516
1517      weak($self->full_spez_for = $concrete_proto);
1518
1519      # inherit all the same as the concrete type but restricted full specializations
1520      my ($anon_pos, $pos) = positions_of_full_spez($concrete_proto);
1521      modify_super($self, 0, 0, @{$concrete_proto->super}[$pos..$#{$concrete_proto->super}]);
1522      if ($self->is_anon_full_spez) {
1523         if (defined($anon_pos)) {
1524            croak( "internal error: created duplicate instance for full specialization ",
1525                   $concrete_proto->super->[$anon_pos]->full_name, " (", $concrete_proto->super->[$anon_pos]->pkg,
1526                   ") and ", $self->full_name, " (", $self->pkg, ")" );
1527         }
1528         # inject it in restricted specializations too, if any
1529         modify_super($_, 0, 0, $self) for @{$concrete_proto->super}[0..$pos-1];
1530      }
1531      modify_super($concrete_proto, $pos, 0, $self);
1532      $_->update_inheritance for $concrete_proto->derived;
1533
1534   } else {
1535      modify_super($self, 0, 0, $gen_proto);
1536   }
1537   $self;
1538}
1539
1540# inject concrete instances of this specialization into all matching object types
1541sub apply_to_existing_types {
1542   my ($self) = @_;
1543   my $gen_proto = $self->generic;
1544   my @concrete_types = grep { !$_->abstract } $gen_proto->derived;
1545   # first update the ISA lists of matching instances of the same generic type
1546   foreach my $concrete (@concrete_types) {
1547      if ($concrete->generic == $gen_proto
1548            and
1549          my ($spez) = pick_specialization($self, $concrete)) {
1550         # all partial specializations go in front of the generic type
1551         modify_super($concrete, list_index($concrete->super, $gen_proto), 0, $spez);
1552      }
1553   }
1554   # then regenerate the super lists of all derived types
1555   $_->update_inheritance for @concrete_types;
1556}
1557
1558# concrete BigObjectType -> indexes into its super list
1559sub positions_of_full_spez {
1560   my ($self) = @_;
1561   my $pos = 0;
1562   foreach my $spez (@{$self->super}) {
1563      last if $spez->full_spez_for != $self;
1564      return ($pos, $pos) if $spez->is_anon_full_spez;
1565      ++$pos;
1566   }
1567   (undef, $pos)
1568}
1569####################################################################################
1570sub augment_in_full_spez {
1571   my ($self, $prop) = @_;
1572   my ($augm, $augm_generic, $augm_concrete);
1573
1574   if ($prop->flags & Property::Flags::is_augmented) {
1575      $augm_concrete = $prop->type;
1576      $augm_generic = $augm_concrete->generic;
1577   } elsif (defined(my $gen_proto = $self->full_spez_for->generic)) {
1578      $augm_generic = $gen_proto->augment($gen_proto->property($prop->name));
1579      # $prop must be updated here
1580      $prop->flags & Property::Flags::is_augmented
1581        or croak( "internal error: property instance ", $prop->name, " for ", $prop->belongs_to->full_name,
1582                  " not updated after augment(", $gen_proto->full_name, ")" );
1583      $augm_concrete = $prop->type;
1584   } else {
1585      $augm_concrete = $self->full_spez_for->augment($prop);
1586      $prop->flags & Property::Flags::is_augmented
1587        or croak( "internal error: property instance ", $prop->name, " for ", $prop->belongs_to->full_name,
1588                  " not updated after augment(", $self->full_spez_for->full_name, ")" );
1589   }
1590
1591   my ($anon_pos, $pos) = positions_of_full_spez($augm_concrete);
1592   if ($scope_owner->is_anon_full_spez) {
1593      if (defined($anon_pos)) {
1594         # already there?
1595         return $augm_concrete->super->[$anon_pos];
1596      }
1597   } elsif ($pos > 0) {
1598      # seen augmentations from some full specializations: maybe the desired one already exists?
1599      foreach my $spez (@{$augm_concrete->super}[0..$pos-1]) {
1600         if ($spez->parent_property->belongs_to == $self) {
1601            return $spez;
1602         }
1603      }
1604   }
1605
1606   # need a separate augmentation for this specialization
1607   # inherit all the same as the concrete type but other restricted full specializations
1608   $augm = new Augmented($prop, $self, @{$augm_concrete->super}[$pos..$#{$augm_concrete->super}]);
1609   if ($scope_owner->is_anon_full_spez) {
1610      $augm->is_anon_full_spez = true;
1611      weak($augm->parent_property = $prop);
1612      $self->properties->{$prop->name} = $prop;
1613      # inject it into inheritance lists of augmentations for restricted specializations, if any
1614      modify_super($_, 0, 0, $augm) for @{$augm_concrete->super}[0..$pos-1];
1615   } else {
1616      $self->properties->{$prop->name} = $prop->clone_for_augmented($augm, $self);
1617   }
1618   $augm->generic = $augm_generic;
1619   weak($augm->full_spez_for = $augm_concrete);
1620   if ($augm_generic) {
1621      $augm_generic->inst_cache->{$self} = $augm;
1622   }
1623   modify_super($augm_concrete, $pos, 0, $augm);
1624
1625   $augm
1626}
1627
1628sub create_augmentation {
1629   my ($self, $prop) = @_;
1630   if (my $concrete_proto = $scope_owner->full_spez_for) {
1631      if ($concrete_proto != $self->full_spez_for) {
1632         # it's a nested augmentation; redirected here from Augmented::
1633         $concrete_proto = $self->full_spez_for // $self;
1634      }
1635      if ($concrete_proto->generic) {
1636         local $scope_owner = $concrete_proto->generic->outer_object_type;
1637         $concrete_proto->generic->augment($concrete_proto->generic->property($prop->name));
1638         $prop = $concrete_proto->property($prop->name);
1639      } else {
1640         $prop = $concrete_proto->augment($prop)->parent_property;
1641      }
1642      augment_in_full_spez($self, $prop);
1643
1644   } elsif (instanceof Specialization($prop->belongs_to->outer_object_type) && $prop->belongs_to->abstract) {
1645      # The property must have been introduced in another specialization (borrowed from).
1646      my $augm_super = $prop->belongs_to->augment($prop);
1647      (new Augmented($augm_super->parent_property, $self, $augm_super), $augm_super, 1);
1648
1649   } else {
1650      # The property is introduced in or inherited by the generic part of the object type:
1651      # always make sure there is a generic augmentation for it, even if not explicitly declared in the rules.
1652      my $augm_gen = do {
1653         # prevent endless recursion when redirected here from Augmented::
1654         local $scope_owner = $self->generic->outer_object_type;
1655         $self->generic->augment($prop);
1656      };
1657      new Augmented($augm_gen->parent_property, $self, $augm_gen);
1658   }
1659}
1660####################################################################################
1661sub append_precondition {
1662   my ($self, $header, $code, $checks_definedness) = @_;
1663   my $precond = special Rule($header, $code, $self);
1664   $precond->flags = ($checks_definedness ? Rule::Flags::is_precondition | Rule::Flags::is_definedness_check : Rule::Flags::is_precondition) | Rule::Flags::is_spez_precondition;
1665   $precond->header = "precondition " . $precond->header . " ( specialization " . $self->name . " )";
1666   push @{$self->preconditions //= [ ]}, $precond;
1667}
1668
1669sub add_permutation {
1670   croak( "A type specialization can't have own permutation types; consider introducing a derived `big' object type for this" );
1671}
1672####################################################################################
1673sub full_name {
1674   my ($self)=@_;
1675   if (defined $self->full_spez_for) {
1676      # full specialization
1677      $self->name . " (specialization)"
1678   } elsif ($self->name =~ / defined at /) {
1679      # unnamed partial specialization
1680      "$`<" . join(",", map { $_->full_name } @{$self->params}) . ">$&$'"
1681   } else {
1682      # named partial specialization
1683      &PropertyParamedType::full_name
1684   }
1685}
1686
1687sub help_ref_to_prop {
1688   my $self=shift;
1689   ($self->full_spez_for // $self->generic)->help_ref_to_prop(@_)
1690}
1691
1692sub help_topic {
1693   my ($self, $force)=@_;
1694   $self->help // do {
1695      if ($force) {
1696         if ($enable_plausibility_checks && $self->name =~ / defined at /) {
1697            croak( "For the sake of better documentation, specializations introducing user-visible features (properties, methods, etc.) must be named" );
1698         }
1699         $self->help=($self->generic // $self->full_spez_for)->help_topic($force)->new_specialization($self);
1700      } else {
1701         undef
1702      }
1703   }
1704}
1705
1706sub pure_type {
1707   my ($proto)=@_;
1708   if (defined $proto->full_spez_for) {
1709      $proto=$proto->full_spez_for;
1710   }
1711   while (defined $proto->generic) {
1712      $proto=$proto->generic;
1713   }
1714   $proto
1715}
1716####################################################################################
1717# special prototype objects for Array<BigObject>
1718
1719package Polymake::Core::BigObjectArray;
1720
1721use Polymake::Struct (
1722   [ '@ISA' => 'PropertyType' ],
1723   [ new => '' ],
1724   [ '$name' => '"BigObjectArray"' ],
1725   [ '$pkg' => '__PACKAGE__' ],
1726   [ '$application' => 'undef' ],
1727   [ '$extension' => 'undef' ],
1728   [ '$dimension' => '1' ],
1729   [ '&serialize' => '\&serialize_func' ],
1730   [ '&deserialize' => '\&deserialize_meth' ],
1731   [ '&equal' => '\&equal_sub' ],
1732   [ '&isa' => '\&isa_meth' ],
1733);
1734
1735sub serialize_func {
1736   my ($arr, $options) = @_;
1737   [ map { $_->serialize($options) } @$arr ]
1738}
1739
1740sub deserialize_meth : method {
1741   my ($self, $src, @options) = @_;
1742   if (is_array($src)) {
1743      my $obj_proto = $self->params->[0];
1744      bless [ map { BigObject::deserialize($obj_proto, $_, @options) } @$src ], $self->pkg
1745   } else {
1746      croak( "wrong serialized representation of ", $self->full_name, " - anonymous array expected" );
1747   }
1748}
1749
1750Struct::pass_original_object(\&deserialize_meth);
1751
1752sub equal_sub {
1753   my ($arr1, $arr2) = @_;
1754   my $e = $#$arr1;
1755   return 0 if $e != $#$arr2;
1756   for (my $i = 0; $i <= $e; ++$i) {
1757      return 0 if $arr1->[$i]->diff($arr2->[$i]);
1758   }
1759   1
1760}
1761
1762sub isa_meth : method {
1763   my ($self, $arr) = @_;
1764   UNIVERSAL::isa($arr, __PACKAGE__) && $arr->type->params->[0]->isa($self->params->[0]);
1765}
1766
1767Struct::pass_original_object(\&isa_meth);
1768
1769sub construct_from_list : method {
1770   my ($self, $list) = @_;
1771   # the contained Objects have already been checked during overload resolution
1772   bless $list, $self->pkg;
1773}
1774
1775sub construct_with_size : method {
1776   my ($self, $n) = @_;
1777   my $elem_type = $self->params->[0];
1778   bless [ map { BigObject::new_named($elem_type, $_) } 0..$n-1 ], $self->pkg;
1779}
1780
1781sub resize {
1782   my ($self, $n) = @_;
1783   my $old_size = @$self;
1784   if ($n < $old_size) {
1785      $#$self = $n-1;
1786   } else {
1787      my $elem_type = $self->type->params->[0];
1788      push @$self, map { BigObject::new_named($elem_type, $_) } $old_size..$n-1;
1789   }
1790}
1791
1792sub copy {
1793   my ($self) = @_;
1794   inherit_class([ map { $_->copy } @$self ], $self);
1795}
1796
1797# For the exotic case of size passed in string form.
1798# Everything else will lead to an exception.
1799sub construct_with_size_str : method {
1800   construct_with_size($_[0], extract_integer($_[1]));
1801}
1802
1803sub new_generic {
1804   my $self = &_new;
1805   $self->construct_node = new_root Overload::Node;
1806   Overload::add_instance(__PACKAGE__, ".construct", undef, \&construct_with_size,
1807                          [ 1, 1, Overload::integer_package() ], undef, $self->construct_node);
1808   $self;
1809}
1810
1811sub typeof { state $me = &new_generic; }
1812
1813sub init_constructor : method {
1814   my ($super, $self) = @_;
1815   $self->construct_node = $super->construct_node;
1816   Overload::add_instance($self->pkg, ".construct", undef, \&construct_from_list,
1817                          [ 1, 1+Overload::SignatureFlags::has_repeated, [ $self->params->[0]->pkg, "+" ] ], undef, $self->construct_node);
1818
1819   $self->parse = \&construct_with_size_str;
1820   overload::OVERLOAD($self->pkg, '""' => ($self->toString = sub { "BigObjectArray" }));
1821
1822   # put BigObjectArray in front of generic Array as to inherit the correct constructors
1823   # TODO: find a more elegant/generic way of achieving this, e.g. by specializing the generic types in the rules.
1824   no strict 'refs';
1825   @{$self->pkg."::ISA"} = (__PACKAGE__, $self->generic->pkg);
1826}
1827
18281
1829
1830# Local Variables:
1831# cperl-indent-level:3
1832# indent-tabs-mode:nil
1833# End:
1834