Find common preamble of a list of strings

Question

Think of a set of text lines starting with a common string, e.g. indented code.

my $preamble = reduce {
    my $len = min(length $a, length $b);
    --$len while substr($a, 0, $len) ne substr($b, 0, $len);
    return substr($a, 0, $len);
} @lines;

Note that after the first invocation chances are high that $a already has the final result.

I'm wondering if there is a better approach in comparing the two strings in the reduce block. The while loop does not seem to be the best approach. It's also less readable since it does not convey the intent of the code (find common preamble of $a and $b).

Update: After feedback from amon here is an alternative:

my $preamble = reduce {
    my $len = min(length $a, length $b);
    my ($current_prefix, $string) = (substr($a, 0, $len), substr($b, 0, $len));

    while($current_prefix ne $string) {
        chop $current_prefix;
        chop $string;
    }

    return $current_prefix;
} @lines;

I think this is an improvement in both performance and readability.

Answer 1

First of all, I think it is very good that you used reduce, as it clearly shows how the algorithm works. At least, to a reader who understands functional idioms.

One problem in your code is that you keep using $a and $b. These two names do not convey any meaning. We could do instead:

my $prefix = reduce {
  my ($current_prefix, $string) = ($a, $b);
  ...

Then, I would shorten the $current_prefix until it is at the beginning of the other $string:

until (0 == index $string, $current_prefix) {
  chop $current_prefix;
}

I did not use the statement modifier form of until or while – I don't believe that they make code much easier to read the way a postfix if or for can do. Note that the empty string occurs at the beginning of any string, so the termination condition of that loop is safe.

If you do not like index or chop, you could equivalently use the less efficient

until ($string =~ /\A\Q$current_prefix/) {
  $current_prefix =~ s/.\z//s;
}

Either way, the concept of shortening the prefix by removing one character at a time until it fits should be easier to read than all the substringing you used.

Cutting the prefix to the length of the string would just be an optimization:

$current_prefix = substr $current_prefix, 0, length $string;

Put together, we would get the following code:

my $prefix = reduce {
  my ($current_prefix, $string) = ($a, $b);

  # the prefix cannot be longer than the string
  $current_prefix = substr $current_prefix, 0, length $string;

  # remove characters from the prefix until it occurs at the beginning.
  # "" is always a prefix, so the loop properly terminates.
  until (0 == index $string, $current_prefix) {
    chop $current_prefix;
  }

  return $current_prefix;
} @strings;

The code might be easier to understand for people who don't know reduce if you express it in the imperative form:

my ($prefix, @strings) = @original_strings;
for my $string (@strings) {
  # the prefix cannot be longer than the string
  $prefix = substr $prefix, 0, length $string;

  # remove characters from the prefix until it occurs at the beginning.
  # "" is always a prefix, so the loop properly terminates.
  until (0 == index $string, $prefix) {
    chop $prefix;
  }
}
# now $prefix is the prefix of all @original_strings

Oh look, it's shorter too!

Answer 2

For me, a better approach often means finding out if there's an existing module that does what I need so I don't have to reinvent the wheel. And, indeed, looking on CPAN, I found String::CommonPrefix¹.

#!/usr/bin/env perl
use v5.36;
use String::CommonPrefix;

...
my $preamble = common_prefix(@lines);
...

---

¹ It looks like it was originally released in 2014, after this question was asked.

Answer 3

"Better approach" is subjective. It is often faster to combine complex operations which would be wasteful in a compiled language, but turn out to be cheaper in Perl because it reduces the interpreter overhead. However, the resulting code may not be intuitive or readable.

You can (ab)use bitstrings for this. If you XOR two strings(!), the resulting string will have NUL characters wherever the characters are the same in both strings. So for example, "catty" ^ "catch" is "\0\0\0\27\21". It also works when the strings have different lengths as the shorter string is NUL-padded.

Similar bit-twiddling tricks are also used in highly-optimised SIMD algorithms in compiled languages.

From here, you can use a regex to match the leading NULs, and then count them. Use substr to extract the actual prefix. Here's the function I use for a very similar problem (where I want the length, not the prefix):

sub prefix_len($a, $b) {
    my ($nuls) = ("$a" ^ "$b") =~ /^(\0*)/;
    return length $nuls;
}

There is an edge case though. Because of the NUL-padding of the shorter string, this can give the wrong result if the longer string contains trailing NULs. For example, "cat" ^ "cat\0" is "\0\0\0\0", and so counting the NULs will say that the common prefix is four characters. There is a simple fix for this, which is left as an exercise.