1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
| # sommaire6.pl
use strict;
use warnings;
use 5.010;
my %fmt = (
'1' => {
ntoa => sub { $_[0] + 1 },
aton => sub { $_[0] - 1 }
},
'a' => {
ntoa => sub { my ($n) = @_; my $s = ""; while ($n) {$s = chr(ord(q{a})+($n-1)%26) . $s, $n = int(($n-1)/26)} $s},
aton => sub { my $n = 0; $n += $n*25 + ord($_) - ord('a') + 1 for split '', $_[0]; $n}
},
'A' => {
ntoa => sub { my ($n) = @_; my $s = ""; while ($n) {$s = chr(ord(q{A})+($n-1)%26) . $s, $n = int(($n-1)/26)} $s},
aton => sub { my $n = 0; $n += $n*25 + ord($_) - ord('A') + 1 for split '', $_[0]; $n}
},
'i' => {
ntoa => sub { use Roman; roman($_[0]) },
aton => sub { use Roman; arabic($_[0]) },
},
'I' => {
ntoa => sub { use Roman; Roman($_[0]) },
aton => sub { use Roman; arabic($_[0]) },
},
);
sub build_compare {
my @t = @_;
return
sub {
my @a = split q{-}, $_[0];
my @b = split q{-}, $_[1];
my $i = 0;
loop: {
return ($i > $#b ? 0 : -1) if $i > $#a;
return 1 if $i > $#b;
my ($a, $b) = map { $fmt{$t[$i]}{aton}->($_) } $a[$i],$b[$i];
++$i and redo loop if $a == $b;
return $a <=> $b;
}
}
}
sub renumerote {
my $opts = shift if ref $_[0] eq 'HASH';
my $verbose = $opts->{verbose} if $opts;
my @rest = ();
@rest = @{ shift @_} if ref $_[0] eq 'ARRAY';
die "extra params to renumerote" if @rest and @_;
my (@d, @t, %k, %p);
$verbose && say $verbose "#",(q{ } x (2 * scalar(split q{-}))), "$_ (ex $p{$_})" for
map {
my @n = split q{-};
++$d[$#n];
$d[@n] = 0;
my $x = join q{-}, map { $fmt{$t[$_]}{ntoa}->($d[$_]) } 0 .. $#n;
$p{$x} = $_;
$x;
} grep {
my ($b, $p, $c, $m) = m/^((?:(.*)-)?(.*?))([*])?$/;
$t[y/-/-/] //= $c;
!$m and (!$p or $k{$p}) and ++$k{$b} and $b
} @rest, @_;
return wantarray ? (\%p, \@t, build_compare(@t)) : \%p;
}
my @sorted_sections = (
'I*', 'I-A', 'I-A-1', 'I-A-1-a', 'I-A-2', 'I-A-2-a', 'I-A-2-b', 'I-A-2-c',
'I-A-3', 'I-A-3-a', 'I-A-3-b', 'I-A-3-c', 'I-A-3-d', 'I-A-3-e', 'I-A-4', 'I-B',
'I-B-1', 'I-B-1-a', 'I-B-1-b', 'I-B-1-c', 'I-B-1-d', 'I-B-1-e', 'I-B-2', 'I-B-2-a',
'I-B-2-b', 'I-B-2-c', 'I-B-3', 'I-B-3-a', 'I-B-3-b', 'I-B-3-c', 'I-B-4', 'I-B-5',
'I-B-5-a', 'I-B-5-b', 'I-B-5-c', 'I-B-6', 'I-B-6-a', 'I-B-6-b', 'II*', 'II-A',
'II-A-1', 'II-A-2', 'II-A-3', 'II-A-3-a', 'II-A-3-b', 'II-A-3-c', 'II-A-3-d', 'II-A-4',
'II-A-5', 'II-A-6', 'II-A-7', 'II-A-8', 'II-B', 'II-B-1', 'II-B-1-a', 'II-B-1-b',
'II-B-1-c', 'II-B-1-d', 'II-B-2', 'II-B-2-a', 'II-B-2-b', 'II-B-2-c', 'II-B-2-d', 'II-B-2-e',
'II-B-3', 'II-B-3-a', 'II-B-3-b', 'II-B-3-c', 'II-B-3-d', 'II-B-3-e', 'II-B-4', 'II-B-4-a',
'II-B-4-b', 'II-B-4-c', 'II-C', 'II-C-1', 'II-C-1-a', 'II-C-1-b', 'II-C-2', 'II-C-2-a',
'II-C-2-b', 'II-C-2-c', 'II-C-2-d', 'II-C-3', 'II-C-4', 'II-C-4-a', 'II-C-4-b', 'II-C-4-c',
'II-D', 'II-D-1', 'II-D-1-a', 'II-D-1-b', 'II-D-1-c', 'II-D-2', 'II-D-2-a', 'II-D-2-b',
'II-D-2-c', 'II-D-2-d', 'II-D-2-e', 'II-D-2-f', 'II-D-2-g', 'II-D-3', 'II-D-3-a', 'II-D-3-b',
'II-D-3-c', 'II-D-4', 'II-D-4-a', 'II-D-4-b', 'II-D-4-c', 'II-D-4-d', 'III*', 'III-A',
'III-A-1', 'III-A-1-a', 'III-A-1-b', 'III-A-2', 'III-A-3', 'III-A-3-a', 'III-A-3-b', 'III-A-4',
'III-A-4-a', 'III-A-4-b', 'III-A-4-c', 'III-A-5', 'III-A-5-a', 'III-A-5-b', 'III-A-5-c', 'III-A-5-d',
'III-B', 'III-B-1', 'III-B-1-a', 'III-B-1-b', 'III-B-2', 'III-B-2-a', 'III-B-2-b', 'III-B-3',
'III-B-3-a', 'III-B-3-b', 'III-B-3-c', 'III-B-3-d', 'III-B-3-e', 'III-B-4', 'III-B-5', 'III-C',
'III-C-1', 'III-C-2', 'III-C-2-a', 'III-C-2-b', 'III-C-2-c', 'III-C-2-d', 'III-C-3', 'III-D',
'III-D-1', 'III-D-1-a', 'III-D-1-b', 'III-D-1-c', 'III-D-2', 'III-D-2-a', 'III-D-2-b', 'III-D-3',
'III-D-3-a', 'III-D-3-b', 'III-D-3-c', 'III-D-3-d', 'III-D-3-e', 'III-D-3-f', 'III-D-3-g', 'IV*',
'IV-A', 'IV-A-1', 'IV-A-1-a', 'IV-A-1-b', 'IV-A-1-c', 'IV-A-1-d', 'IV-A-2', 'IV-A-2-a',
'IV-A-2-b', 'IV-A-2-c', 'IV-A-2-d', 'IV-A-2-e', 'IV-A-2-f', 'IV-A-2-g', 'IV-A-3', 'IV-A-3-a',
'IV-A-3-b', 'IV-A-3-c', 'IV-A-4', 'IV-A-4-a', 'IV-A-4-b', 'IV-A-4-c', 'IV-A-4-d', 'IV-A-4-e',
'IV-A-4-f', 'IV-B', 'IV-B-1', 'IV-B-1-a', 'IV-B-1-b', 'IV-B-1-c', 'IV-B-1-d', 'IV-B-1-e',
'IV-B-2', 'IV-B-2-a', 'IV-B-2-b', 'IV-B-2-c', 'IV-B-2-d', 'IV-B-3', 'IV-B-3-a', 'IV-B-3-b',
'IV-C', 'IV-C-1', 'IV-C-2', 'IV-C-3', 'IV-C-4', 'IV-C-5', 'IV-C-6', 'IV-C-7',
'IV-C-7-a', 'IV-C-8', 'IV-C-8-a', 'IV-D', 'IV-D-1', 'IV-D-2', 'IV-D-3', 'IV-D-4',
'IV-D-5', 'IV-D-6', 'IV-D-6-a', 'IV-D-6-b', 'IV-D-6-c', 'IV-D-6-d', 'IV-E', 'IV-E-1',
'IV-E-2', 'IV-E-3', 'IV-E-4', 'IV-E-5', 'IV-E-6', 'IV-F', 'IV-F-1', 'IV-F-2',
'IV-F-3', 'IV-G', 'IV-G-1', 'IV-G-1-a', 'IV-G-1-b', 'IV-G-1-c', 'IV-G-1-d', 'IV-G-1-e',
'IV-G-1-f', 'IV-G-1-g', 'IV-G-2', 'IV-G-2-a', 'IV-G-2-b', 'IV-G-2-c', 'IV-G-2-d', 'IV-G-3',
'IV-G-3-a', 'IV-G-3-b', 'IV-G-3-c', 'IV-G-3-d', 'V*', 'V-A', 'V-A-1', 'V-A-2',
'V-A-3', 'V-B', 'V-B-1', 'V-B-2', 'V-B-2-a', 'V-B-2-b', 'V-B-3', 'V-B-4',
'V-B-4-a', 'V-B-4-b', 'V-B-4-c', 'V-B-4-d', 'V-B-5', 'V-B-6', 'V-B-7', 'V-C',
'V-C-1', 'V-C-1-a', 'V-C-1-b', 'V-C-1-c', 'V-C-1-d', 'V-C-1-e', 'V-C-1-f', 'V-C-2',
'V-C-2-a', 'V-C-2-b', 'V-C-2-c', 'V-C-2-d', 'V-C-2-e', 'V-C-2-f', 'V-D', 'V-D-1',
'V-D-1-a', 'V-D-1-b', 'V-D-1-c', 'V-D-2', 'V-D-2-a', 'V-D-2-b', 'V-D-2-c', 'V-E',
'V-E-1', 'V-E-2', 'V-E-3', 'V-F', 'VI', 'VI-A', 'VI-A-1', 'VI-A-1-a',
'VI-A-1-b', 'VI-A-1-c', 'VI-A-2', 'VI-A-2-a', 'VI-A-2-b', 'VI-A-2-c', 'VI-A-2-d', 'VI-A-2-e',
'VI-B', 'VI-B-1', 'VI-B-1-a', 'VI-B-1-b', 'VI-B-1-c', 'VI-B-1-d', 'VI-B-1-e', 'VI-B-2',
'VI-B-2-a', 'VI-B-2-b', 'VI-B-2-c', 'VI-B-2-d', 'VI-B-2-e', 'VI-B-3', 'VI-B-3-a', 'VI-B-4',
'VI-B-4-a', 'VI-B-4-b', 'VI-B-4-c', 'VI-B-4-d', 'VI-B-5', 'VI-B-5-a', 'VI-B-5-b', 'VI-B-5-c',
'VI-B-5-d', 'VI-B-5-e', 'VI-C', 'VI-C-1', 'VI-C-1-a', 'VI-C-1-b', 'VI-C-1-c', 'VI-C-1-d',
'VI-C-1-e', 'VI-C-2', 'VI-C-3', 'VI-C-4', 'VI-C-4-a', 'VI-C-4-b', 'VI-C-4-c', 'VI-C-4-d',
'VI-C-4-e', 'VII*'
);
# my ($hash, $types, $compare) = renumerote(@sorted_sections);
# my ($hash, $types, $compare) = renumerote({verbose => *STDERR}, \@sorted_sections);
my ($hash, $types, $compare) = renumerote(\@sorted_sections);
use Data::Dumper;
$Data::Dumper::Sortkeys = sub { my $h = shift; my @keys = sort { $compare->($a, $b) } keys %$h; \@keys};
print Data::Dumper->Dump([$types, $hash],[qw(types hash)]); |
Partager