Perl: як зрабіць кампактнае імя з пранумараваных паслядоўнасці

[Perl 5.8.8]

У мяне ёсць паслядоўнасць імёнаў рэчаў, як:

names='foobar1304,foobar1305,foobar1306,foobar1307'  

дзе імёны адрозніваюцца толькі прылеглай радком лічбаў недзе ў назве. Радкі лічбаў у любой паслядоўнасці ўсё тыя ж даўжыні, а лічба радок ўтварае бесперапынную лічбавую паслядоўнасць без якіх-небудзь пропускаў, напрыклад, <�Код> 003004005 .

Я хачу, каб кампактнае паданне, як:

compact_name='foobar1304-7'

(The compact form is just a name, so it's exact form is negotiable.) There will usually only be <10 things, though some sets might span a decade, e.g.

'foobaz2205-11'

Ці ёсць які-небудзь кароткі спосаб зрабіць гэта ў Perl? Я не вялікі Perl хакера, так што трохі далікатнага ...

Бонусныя балы для апрацоўкі ўбудаваных паслядоўнасцяў, як:

names='foobar33-pqq,foobar34-pqq,foobar35-pqq'

Ідэальны сцэнар будзе акуратна падаць назад «firstname2301-lastname9922» у выпадку, калі ён не можа вызначыць паслядоўнасць у назвах.

3
Гэтае пытанне знаходзіцца пад зададзеным. Вам трэба прыдумаць набор правілаў, які апрацоўвае ўсе магчымыя ўваходы. Для вашага апошняга прыкладу, маецца на ўвазе спрашчэнне foobar33-35-PQQ можа апынуцца неадназначнай ў кантэксце. Асноўная ідэя здабывання колькасці і згортвання паслядоўнасці даволі проста улічваючы рэгулярныя выразы capabilites Perl, але ваша вялікая праблема заключаецца ў вызначэнні таго, што вы на самай справе хочаце зрабіць.
дададзена аўтар Jim Garrison, крыніца
Я думаю, што вы хочаце, каб разбіць радок у масіў ( @list = раскол ( »," $ імёны) ці нешта падобнае), то знайсці longest агульны прэфікс гэтых слоў у масіве. Бонусныя балы для знаходжання найбольшага агульнага суфікса. Такім чынам, вы падзеліце слова ў прэфікс зменнай часткі, і суфікс. Тады ваш адказ «прэфікс $ $ varFirst». "-". "$ VarLast $ Суфікс". Ці значыць гэта гук правільна?
дададзена аўтар Markku K., крыніца
Я думаю, што вы хочаце, каб разбіць радок у масіў ( @list = раскол ( »," $ імёны) ці нешта падобнае), то знайсці longest агульны прэфікс гэтых слоў у масіве. Бонусныя балы для знаходжання найбольшага агульнага суфікса. Такім чынам, вы падзеліце слова ў прэфікс зменнай часткі, і суфікс. Тады ваш адказ «прэфікс $ $ varFirst». "-". "$ VarLast $ Суфікс". Ці значыць гэта гук правільна?
дададзена аўтар Markku K., крыніца
Я думаю, што вы хочаце, каб разбіць радок у масіў ( @list = раскол ( »," $ імёны) ці нешта падобнае), то знайсці longest агульны прэфікс гэтых слоў у масіве. Бонусныя балы для знаходжання найбольшага агульнага суфікса. Такім чынам, вы падзеліце слова ў прэфікс зменнай часткі, і суфікс. Тады ваш адказ «прэфікс $ $ varFirst». "-". "$ VarLast $ Суфікс". Ці значыць гэта гук правільна?
дададзена аўтар Markku K., крыніца
фіксавана, я думаю. Я не бачу неадназначнасць foobar33-35-Pqq . Звярніце ўвагу, я ўказаў адрозненне <�Ь> а бесперапыннай радкі лічбаў ". Калі ёсць больш чым адзін радок лічбаў у імя, то я буду толькі пад заклад.
дададзена аўтар George Young, крыніца
фіксавана, я думаю. Я не бачу неадназначнасць foobar33-35-Pqq . Звярніце ўвагу, я ўказаў адрозненне <�Ь> а бесперапыннай радкі лічбаў ". Калі ёсць больш чым адзін радок лічбаў у імя, то я буду толькі пад заклад.
дададзена аўтар George Young, крыніца
фіксавана, я думаю. Я не бачу неадназначнасць foobar33-35-Pqq . Звярніце ўвагу, я ўказаў адрозненне <�Ь> а бесперапыннай радкі лічбаў ". Калі ёсць больш чым адзін радок лічбаў у імя, то я буду толькі пад заклад.
дададзена аўтар George Young, крыніца

8 адказы

Я не ўпэўнены, што я атрымаў вашу спецыфікацыю, але працуе як-то:

#!/usr/bin/perl
use warnings;
use strict;

use Test::More;

sub compact {
    my $string = shift;
    my ($name, $value) = split /=/, $string;

    $name =~ s/s$// or die "Cannot create compact name for $name.\n";  #/ SO hilite bug
    $name = 'compact_' . $name;

    $value =~ s/^'|'$//g;                                              #/ SO hilite bug
    my @values = split /,/, $value;                                    #/ SO hilite bug
    my ($prefix, $first, $suffix) = $values[0] =~ /^(.+?)([0-9]+)(.*)$/;

    my $last = $first + $#values;
    my $same = 0;
    $same++ while substr($first, 0, $same) eq substr($last, 0, $same);
    $last = substr $last, $same - 1;

    for my $i ($first .. $first + $#values) {
        $values[$i - $first] eq ($prefix . $i . $suffix) 
            or die "Invalid sequence at $values[$i-$first].\n";
    }
    return "$name='$prefix$first-$last$suffix'";
}


is( compact("names='foobar1304,foobar1305,foobar1306,foobar1307'"),
    "compact_name='foobar1304-7'");

is( compact("names='foobaz2205,foobaz2206,foobaz2207,foobaz2208,foobaz2209,foobaz2210,foobaz2211'"),
    "compact_name='foobaz2205-11'");

is( compact("names='foobar33-pqq,foobar34-pqq,foobar35-pqq'"),
    "compact_name='foobar33-5-pqq'");

done_testing();
2
дададзена

Я не ўпэўнены, што я атрымаў вашу спецыфікацыю, але працуе як-то:

#!/usr/bin/perl
use warnings;
use strict;

use Test::More;

sub compact {
    my $string = shift;
    my ($name, $value) = split /=/, $string;

    $name =~ s/s$// or die "Cannot create compact name for $name.\n";  #/ SO hilite bug
    $name = 'compact_' . $name;

    $value =~ s/^'|'$//g;                                              #/ SO hilite bug
    my @values = split /,/, $value;                                    #/ SO hilite bug
    my ($prefix, $first, $suffix) = $values[0] =~ /^(.+?)([0-9]+)(.*)$/;

    my $last = $first + $#values;
    my $same = 0;
    $same++ while substr($first, 0, $same) eq substr($last, 0, $same);
    $last = substr $last, $same - 1;

    for my $i ($first .. $first + $#values) {
        $values[$i - $first] eq ($prefix . $i . $suffix) 
            or die "Invalid sequence at $values[$i-$first].\n";
    }
    return "$name='$prefix$first-$last$suffix'";
}


is( compact("names='foobar1304,foobar1305,foobar1306,foobar1307'"),
    "compact_name='foobar1304-7'");

is( compact("names='foobaz2205,foobaz2206,foobaz2207,foobaz2208,foobaz2209,foobaz2210,foobaz2211'"),
    "compact_name='foobaz2205-11'");

is( compact("names='foobar33-pqq,foobar34-pqq,foobar35-pqq'"),
    "compact_name='foobar33-5-pqq'");

done_testing();
2
дададзена

Я не ўпэўнены, што я атрымаў вашу спецыфікацыю, але працуе як-то:

#!/usr/bin/perl
use warnings;
use strict;

use Test::More;

sub compact {
    my $string = shift;
    my ($name, $value) = split /=/, $string;

    $name =~ s/s$// or die "Cannot create compact name for $name.\n";  #/ SO hilite bug
    $name = 'compact_' . $name;

    $value =~ s/^'|'$//g;                                              #/ SO hilite bug
    my @values = split /,/, $value;                                    #/ SO hilite bug
    my ($prefix, $first, $suffix) = $values[0] =~ /^(.+?)([0-9]+)(.*)$/;

    my $last = $first + $#values;
    my $same = 0;
    $same++ while substr($first, 0, $same) eq substr($last, 0, $same);
    $last = substr $last, $same - 1;

    for my $i ($first .. $first + $#values) {
        $values[$i - $first] eq ($prefix . $i . $suffix) 
            or die "Invalid sequence at $values[$i-$first].\n";
    }
    return "$name='$prefix$first-$last$suffix'";
}


is( compact("names='foobar1304,foobar1305,foobar1306,foobar1307'"),
    "compact_name='foobar1304-7'");

is( compact("names='foobaz2205,foobaz2206,foobaz2207,foobaz2208,foobaz2209,foobaz2210,foobaz2211'"),
    "compact_name='foobaz2205-11'");

is( compact("names='foobar33-pqq,foobar34-pqq,foobar35-pqq'"),
    "compact_name='foobar33-5-pqq'");

done_testing();
2
дададзена

Я не ўпэўнены, што я атрымаў вашу спецыфікацыю, але працуе як-то:

#!/usr/bin/perl
use warnings;
use strict;

use Test::More;

sub compact {
    my $string = shift;
    my ($name, $value) = split /=/, $string;

    $name =~ s/s$// or die "Cannot create compact name for $name.\n";  #/ SO hilite bug
    $name = 'compact_' . $name;

    $value =~ s/^'|'$//g;                                              #/ SO hilite bug
    my @values = split /,/, $value;                                    #/ SO hilite bug
    my ($prefix, $first, $suffix) = $values[0] =~ /^(.+?)([0-9]+)(.*)$/;

    my $last = $first + $#values;
    my $same = 0;
    $same++ while substr($first, 0, $same) eq substr($last, 0, $same);
    $last = substr $last, $same - 1;

    for my $i ($first .. $first + $#values) {
        $values[$i - $first] eq ($prefix . $i . $suffix) 
            or die "Invalid sequence at $values[$i-$first].\n";
    }
    return "$name='$prefix$first-$last$suffix'";
}


is( compact("names='foobar1304,foobar1305,foobar1306,foobar1307'"),
    "compact_name='foobar1304-7'");

is( compact("names='foobaz2205,foobaz2206,foobaz2207,foobaz2208,foobaz2209,foobaz2210,foobaz2211'"),
    "compact_name='foobaz2205-11'");

is( compact("names='foobar33-pqq,foobar34-pqq,foobar35-pqq'"),
    "compact_name='foobar33-5-pqq'");

done_testing();
2
дададзена

Хтосьці ўпэўнена, размесціць больш элегантнае рашэнне, але ў наступным

use strict;
use warnings;

my $names='foobar1308-xy,foobar1309-xy,foobar1310-xy,foobar1311-xy';
my @names = split /,/,$names;

my $pfx = lcp(@names);

my @nums = map { m/$pfx(\d*)/; $1 } @names;
my $first=shift @nums;
my $last = pop @nums;
my $suf=$names[0];
$suf =~ s/$pfx\d*//;

print "$pfx\{$first-$last}$suf\n";

#https://gist.github.com/3309172
sub lcp {
    my $match = shift;
    substr($match, (($match ^ $_) =~ /^\0*/, $+[0])) = '' for @_;
    $match;
}

друкуе:

foobar13{08-11}-xy
1
дададзена

Хтосьці ўпэўнена, размесціць больш элегантнае рашэнне, але ў наступным

use strict;
use warnings;

my $names='foobar1308-xy,foobar1309-xy,foobar1310-xy,foobar1311-xy';
my @names = split /,/,$names;

my $pfx = lcp(@names);

my @nums = map { m/$pfx(\d*)/; $1 } @names;
my $first=shift @nums;
my $last = pop @nums;
my $suf=$names[0];
$suf =~ s/$pfx\d*//;

print "$pfx\{$first-$last}$suf\n";

#https://gist.github.com/3309172
sub lcp {
    my $match = shift;
    substr($match, (($match ^ $_) =~ /^\0*/, $+[0])) = '' for @_;
    $match;
}

друкуе:

foobar13{08-11}-xy
1
дададзена

Хтосьці ўпэўнена, размесціць больш элегантнае рашэнне, але ў наступным

use strict;
use warnings;

my $names='foobar1308-xy,foobar1309-xy,foobar1310-xy,foobar1311-xy';
my @names = split /,/,$names;

my $pfx = lcp(@names);

my @nums = map { m/$pfx(\d*)/; $1 } @names;
my $first=shift @nums;
my $last = pop @nums;
my $suf=$names[0];
$suf =~ s/$pfx\d*//;

print "$pfx\{$first-$last}$suf\n";

#https://gist.github.com/3309172
sub lcp {
    my $match = shift;
    substr($match, (($match ^ $_) =~ /^\0*/, $+[0])) = '' for @_;
    $match;
}

друкуе:

foobar13{08-11}-xy
1
дададзена

Хтосьці ўпэўнена, размесціць больш элегантнае рашэнне, але ў наступным

use strict;
use warnings;

my $names='foobar1308-xy,foobar1309-xy,foobar1310-xy,foobar1311-xy';
my @names = split /,/,$names;

my $pfx = lcp(@names);

my @nums = map { m/$pfx(\d*)/; $1 } @names;
my $first=shift @nums;
my $last = pop @nums;
my $suf=$names[0];
$suf =~ s/$pfx\d*//;

print "$pfx\{$first-$last}$suf\n";

#https://gist.github.com/3309172
sub lcp {
    my $match = shift;
    substr($match, (($match ^ $_) =~ /^\0*/, $+[0])) = '' for @_;
    $match;
}

друкуе:

foobar13{08-11}-xy
1
дададзена