Перловые экзерсисы

[recoder]

Для домашнего проекта поставил себе задачку: по форматной строке вида "Я [сразу|немедленно] [пошёл|поехал|пополз|попёрся] разбираться с [делами|братками]." сгенерировать полный список всех возможных вариантов такой строки. Посидел с карандашиком минут 20, наваял примерно такой код:

package Xtras::Mutator;

sub new {
    my ($class,$pattern) = @_;
    my $self = bless {}, $class;

    $self->parse( $pattern ) if $pattern;

    return $self;
}

sub parse {
    my( $self, $pattern ) = @_;
    
    $pattern =~ s/\%/%%/g;
    $self->{pattern} = $pattern;
    $self->{words} = [];

    while( $self->{pattern} =~ s/\[(.*?)\]/%s/ )
    {
        push @{$self->{words}}, [ split /\|/, $1 ];
    }

    return $self->{words};
}

sub permutations {
    return make_mutes( $_[0]->{pattern}, $_[0]->{words}, [] );
}

sub make_mutes {
    my( $pat, $dict, $dat ) = @_;

        return [ sprintf( $pat, @$dat ) ] unless scalar @$dict;

    my @mutes = ();

    my $words = shift @$dict;
    push @mutes, @{ make_mutes( $pat, $dict, [ @$dat, $_ ] ) } for @$words;
    unshift @$dict, $words;

    return [ @mutes ];
}

Добравшись до компа, втоптал. И - заработало всего после двух исправлений. Старею видать... Надо посидеть помедитировать - можно ли всё это проще или изящнее изобразить? Всё-таки люблю я perl.

Comments

[vlsergey.livejournal.com]

Навеяно code_wtf?
http://community.livejournal.com/code_wtf/73670.html

[greshnik.livejournal.com]

Ну, алгоритм подбора всех возможных перестановок - не бином ньютона. Так что неудивительно, что заработало.

[russuv.livejournal.com]

помню дет так с десять назад, лежал в больнице и за неимение компа......
накатал на бумажке ;-) на ассмеблере пару листов....
при загнании в комп - на удивление все заработало.
че писал уже непомню.... но листинг был по длине достойный ;-)

цветной код

[jerom.livejournal.com]

#!/usr/bin/perl -l

$pattern = "Я [сразу|немедленно] [пошёл|поехал|пополз|попёрся] разбираться с [делами|братками].";

print "$_" for(@{mutate($pattern)});

sub mutate {
    my (@m, $s, $w);

    while($s = pop@_) {
        if($s =~ /\[(.*?)\]/) {

            for$w(split '\|',$1) {
                $_ = $s;

                s/\[(.*?)\]/$w/;
                push @_,$_;

            }
        } else {
            push @m, $s;

        }
    }
    return \@m;
}