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