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::UpgradeGroup;
23
24use Polymake::Struct (
25   [ new => '$$' ],
26   [ '$to_version' => '#1' ],
27   [ '$to_v' => '#2' ],
28   '@rules',
29   [ '$big_objects' => 'undef' ],
30   '%rules_by_type',
31   '%subobjects_by_type',
32);
33
34sub prepare {
35   my ($self) = @_;
36
37   # for each type, collect rules from all its super types
38   my (%by_type, %derived);
39   foreach my $rule (@{$self->rules}) {
40      push @{$by_type{$rule->type}}, $rule;
41   }
42   %{$self->rules_by_type} = %by_type;
43   my $all_super = $self->big_objects->{super};
44   while (my ($type, $super) = each %$all_super) {
45      push @{$derived{$_}}, $type for @$super;
46      if (my @inherit_from = grep { defined } @by_type{@$super}) {
47         push @{$self->rules_by_type->{$type} //= [ ]}, map { @$_ } @inherit_from;
48      }
49   }
50
51   # mark "interesting" types, that is, having subobjects with applicable rules
52   # this may require several rounds of search
53   my (%interesting, $repeat);
54   my $is_interesting_subobject = sub {
55      my ($type) = @_;
56      exists($self->rules_by_type->{ANY_DATA_TYPE}) || exists($self->rules_by_type->{$type}) || $interesting{$type}
57   };
58   my $all_descends = $self->big_objects->{descend};
59   do {
60      $repeat = false;
61      while (my ($type, $descends) = each %$all_descends) {
62         $interesting{$type} ||= has_targets_among_subobjects($descends, $is_interesting_subobject) && do {
63            if (defined(my $derived = $derived{$type})) {
64               $interesting{$_} = true for @$derived;
65            }
66            $repeat = true;
67         }
68      }
69   } while ($repeat);
70
71   # filter out uninteresting subobjects and merge the subtrees from super types
72   %by_type = ();
73   while (my ($type, $descends) = each %$all_descends) {
74      if (defined(my $filtered = filter_interesting_subobjects($descends, $is_interesting_subobject))) {
75         $by_type{$type} = $filtered;
76      }
77   }
78   %{$self->subobjects_by_type} = %by_type;
79   while (my ($type, $super) = each %$all_super) {
80      merge_subobjects($self->subobjects_by_type->{$type} //= { }, $_) for grep { defined } @by_type{@$super};
81   }
82}
83
84sub has_targets_among_subobjects {
85   my ($descends, $is_interesting_subobject) = @_;
86   foreach my $descend (values %$descends) {
87      if (is_array($descend)) {
88         if ($is_interesting_subobject->($descend->[0]) ||
89             has_targets_among_subobjects($descend->[1], $is_interesting_subobject)) {
90            keys %$descends;
91            return true;
92         }
93      } elsif ($is_interesting_subobject->($descend)) {
94         keys %$descends;
95         return true;
96      }
97   }
98   false
99}
100
101sub filter_interesting_subobjects {
102   my ($descends, $is_interesting_subobject) = @_;
103   my %filtered;
104   while (my ($prop_name, $descend) = each %$descends) {
105      if (is_array($descend)) {
106         if (defined(my $next_level = filter_interesting_subobjects($descend->[1], $is_interesting_subobject))) {
107            $filtered{$prop_name} = [ $descend->[0], $next_level ];
108         } elsif ($is_interesting_subobject->($descend->[0])) {
109            $filtered{$prop_name} = $descend->[0];
110         }
111      } elsif ($is_interesting_subobject->($descend)) {
112         $filtered{$prop_name} = $descend;
113      }
114   }
115   keys(%filtered) ? \%filtered : undef
116}
117
118sub merge_subobjects {
119   my ($subobjects, $descends) = @_;
120   while (my ($prop_name, $descend) = each %$descends) {
121      if (is_array($subobjects->{$prop_name})) {
122         if (is_array($descend)) {
123            if ($subobjects->{$prop_name}->[0] ne $descend->[0]) {
124               die "contradicting subobject types for property $prop_name in big object inventory\n";
125            }
126            if (refcnt($subobjects->{$prop_name}) > 1) {
127               $subobjects->{$prop_name} = deep_copy_list($subobjects->{$prop_name});
128            }
129            merge_subobjects($subobjects->{$prop_name}->[1], $descend->[1]);
130         } elsif ($subobjects->{$prop_name}->[0] ne $descend) {
131            die "contradicting subobject types for property $prop_name in big object inventory\n";
132         }
133      } else {
134         $subobjects->{$prop_name} = $descend;
135      }
136   }
137}
138
139sub apply {
140   my ($self, $obj, $default_type, $descends) = @_;
141   # strip off type parameters, if any
142   my $type = is_hash($obj) && $obj->{_type} =~ s/^$qual_id_re\K.*//r || $default_type;
143   defined($type)
144     or die "can't determine the object type\n";
145
146   my $cnt = 0;
147   if (!defined($default_type) && defined(my $data = $obj->{data})) {
148      foreach my $type_tag ($type, "ANY_DATA_TYPE") {
149         if (defined(my $rules = $self->rules_by_type->{$type_tag})) {
150            $cnt += $_->apply($data, $obj) for @$rules;
151         }
152      }
153      return $cnt;
154   }
155   if (defined(my $rules = $self->rules_by_type->{$type})) {
156      $cnt += $_->apply($obj) for @$rules;
157   }
158   # this is still necessary because of a hack in Serializer::upgrade_data
159   return $cnt unless is_hash($obj);
160
161   my $subobjects = $self->subobjects_by_type->{$type};
162   if (defined($descends)) {
163      if (defined($subobjects)) {
164         if (refcnt($subobjects) > 2) {
165            $subobjects = deep_copy_hash($subobjects);
166         }
167         merge_subobjects($subobjects, $descends);
168      } else {
169         $subobjects = $descends;
170      }
171   }
172
173   # convert attachments and small data properties with explicit types
174
175   if (defined(my $attrs = $obj->{_attrs})) {
176      my $any_data_rules = $self->rules_by_type->{ANY_DATA_TYPE};
177      while (my ($prop_name, $prop_attrs) = each %$attrs) {
178         if (defined($type = $prop_attrs->{_type}) and
179             $prop_attrs->{attachment} ||
180             defined($any_data_rules) && !exists $subobjects->{$prop_name}) {
181            $type =~ s/^$qual_id_re\K.*//;
182            if (defined(my $rules = $self->rules_by_type->{$type})) {
183               $cnt += $_->apply($obj->{$prop_name}, $prop_attrs) for @$rules;
184            }
185            if (defined($any_data_rules)) {
186               $cnt += $_->apply($obj->{$prop_name}, $prop_attrs) for @$any_data_rules;
187            }
188         }
189      }
190   }
191
192   if (defined($subobjects)) {
193      # can't use each %$subobjects here because we might re-enter the same place recursively,
194      # while one hash iterator can't be shared between two scopes (perl is a catastrophe)
195      foreach my $prop_name (keys %$subobjects) {
196         if (defined(my $child = $obj->{$prop_name})) {
197            my $descend = $subobjects->{$prop_name};
198            if (is_array($child)) {
199               foreach my $instance (@$child) {
200                  $cnt += apply($self, $instance, is_array($descend) ? @$descend : $descend);
201               }
202            } else {
203               $cnt += apply($self, $child, is_array($descend) ? @$descend : $descend);
204            }
205         }
206      }
207   }
208
209   $cnt
210}
211
2121
213
214# Local Variables:
215# cperl-indent-level:3
216# indent-tabs-mode:nil
217# End:
218