Clusterize (group) array of strings

user_1441592 0
Viewed 88

I need to group array of strings following way (merge same strings nearby)

Input          | Output
---------------+--------------------
[              | [
    'a'        |    'a (x3)',
    'a'        |    'b',
    'a'        |    'c (x2)'
    'b'        |    'd'
    'c'        |    'c'
    'c'        |    'x'
    'd'        | ]
    'c'        |
    'x'        |
]              |
---------------+--------------------

How to do that ?

I wrote this code

sub str_minus_multiplier {
    my ( $str ) = @_;
    $str =~ s/\(x(\d+)\)//;
    return $str;
}

sub str_add_multiplier {
    my ( $str, $num ) = @_;
    $num = 1 if !defined $num;
    if ( my $n = str_has_multiplier($str) ) {
        $str = str_minus_multiplier($str);
        my $new_m = $n+$num;
        $str.= '(x'.$new_m.')';
    } else {
        $str.= ' (x2)';
    }
    return $str;
}

sub fold_list {
    my ( @x ) = @_;
    for my $i (0 .. $#x-1) {

        my $j = 1;
        while ( str_minus_multiplier($x[$i]) eq $x[$i+$j] ) {
            $x[$i] = str_add_multiplier($x[$i]);
            $j++;
        }
        splice(@x, $i+1, $j-1) if ( $j > 1 );
    }
    return @x;
}

But it's not working as expected, output of fold_list() is 

[
          'a (x2)',
          'a',
          'b',
          'c (x2)',
          'd',
          'c',
          'x',
          ' (x2)'
        ];

I guess that problem is in str_minus_multiplier($x[$i]) eq $x[$i+$j] comparision, after splice one value in comparision is undef. How to avoid that ?

perl
4 Answers

You may be overcomplicating the problem. Essentially, this is a variant of run-length encoding.

The idea is to walk through the list and increment a counter at each character to compute how long the "run" is, or how many subsequent characters are equal to the current character. Once you've found the length, add it to the result in the appropriate format and skip all of the elements you just squashed together.

use strict;
use warnings;
use Data::Dumper;

my @a = split //, "aaabccdcx";
my @rle;

for (my $i = 0; $i < @a;) {
    my $j = 1;

    while ($i + $j < @a && $a[$i+$j] eq $a[$i]) {
        $j++;
    }

    push @rle, $a[$i] . ($j > 1 ? " (x$j)" : "");
    $i += $j;
}

print Dumper \@rle;

Output:

$VAR1 = [
          'a (x3)',
          'b',
          'c (x2)',
          'd',
          'c',
          'x'
        ];
user_62433520

Lots of ways of doing this, I have:

$ cat file1
'a'
'a'
'a'
'b'
'c'
'c'
'd'
'x'

$ perl -ne 'END{for(sort keys %count){if($count{$_}>1){ print "$_ \(x$count{$_}\)\n";} else{print "$_\n";}}} chomp; $count{$_}++;' file1
'a' (x3)
'b'
'c' (x2)
'd'
'x'
user_34989620

This seems to do what you want. It's longer than the other answers but (hopefully) less cryptic.

#!/usr/bin/perl

use strict;
use warnings;

use Data::Dumper;

my $string = 'aaabccdcx';

my $prev = '';
my $count;
my @out;

for (split //, $string) {
  if ($_ eq $prev) {
    $count++;
  } else {
    push @out, $prev . ($count > 1 ? " (x$count)" : '') if $count;
    $count = 1;
    $prev = $_;
  }
}

push @out, $prev . ($count > 1 ? " (x$count)" : '');

print Dumper \@out;
user_72310

Another Perl - using backreference

$ echo "aaabccdcx"| perl -nle ' while( /(.)(\1*)/g ) { $t=length("$1$2"); print "$1 -> ",$t> 1? "x(".$t.")" : "" } '
a -> x(3)
b ->
c -> x(2)
d ->
c ->
x ->
$

standalone

$  perl -le ' $str="aaabccdcx"; while($str=~/(.)(\1*)/g ) { $t=length("$1$2"); print "$1 -> ",$t> 1? "x(".$t.")" : "" } '
a -> x(3)
b ->
c -> x(2)
d ->
c ->
x ->
$
user_68670480
Related