The magic is in the module Algorithm::Diff, which implements the Largest Common Subsequence (LCS), which is a more accurate name of the problem you describe (a set has no order).

perl -MHTTP::Daemon -MHTTP::Response -MLWP::Simple -e ' ;    # The  
$d = new HTTP::Daemon and fork and getprint $d->url and exit;#spider
($c = $d->accept())->get_request(); $c->send_response( new   #in the
HTTP::Response(200,$_,$_,qq(Just another Perl hacker\n))); ' #  web
[download]

Close but no banana, unfortunately. Quoting from the manual:

...you want to find a new sequence S which can be obtained from the first sequence by deleting some items, and from the secend sequence by deleting other items.

What I need instead is to generate a new sequence S which can be obtained from the first list by deleting some items, and from the second list by deleting other items, but only deleting items before the first element of S or after the last element of S.

For example, given this code:

use Algorithm::Diff qw(LCS);
@seq1 = qw(a b c d f g h j q z);
@seq2 = qw(a b c d e f g i j k r x y z);
@lcs = LCS(\@seq1, \@seq2);
[download]

What is produced is the list qw(a b c d f g j z). It did this by removing letters from the "inside" of S, for example 'e' and 'h'. Instead, I'd want qw(a b c d).

This is still unclear. To which part(s) of the sentence does "but only deleting items before the first element of S or after the last element of S" refer? To the entire preceding part of the sentence, or only to the part after "deleting some items"? More to the point, given the following two sequences:

@seq1 = qw(a b c d e f g h);
@seq2 = qw(a b c e f x g h);
[download]

is the answer  a b c  or  a b c e f ?

Not exactly vastly mystical but this should do the trick (although it hasn't been thoroughly tested)

use strict;

my @a = qw/ fred bob joe jim mary elaine /;
my @b = qw/ frank joe jim mary bob /;

print "LCS[anjiro] - ", join($", get_lcs(\@a, \@b)), $/;

@a = qw/ a b c /;
@b = qw/ a b x c /;

print "LCS[zby]    - ", join($", get_lcs(\@a, \@b)), $/;

sub get_lcs {
  my @a = @{ +shift };
  my @b = @{ +shift };

  my %map = map { $b[$_] => $_ } 0 .. $#b;

  my(@lcs, @tmp);
  for(0 .. $#a) {
    next unless exists $map{$a[$_]}
                or $a[$_ + 1] eq $b[$map{$a[$_]} + 1];

    push @tmp, $a[$_] if $a[$_] eq $b[$map{$a[$_]}];

    if($a[$_ + 1] ne $b[$map{$a[$_]} + 1]) {
      @lcs = @tmp if @tmp > @lcs;
      @tmp = ();
    }
  }
  @lcs = @tmp if @tmp > @lcs;

  return @lcs;
}

__output__

LCS[anjiro] - joe jim mary
LCS[zby]    - a b
[download]

_________
broquaint

With use warnings it gives a Use of uninitialized value in string eq at... warning. Small off-by-one error.

Replacing

   push @tmp, $a[$_]
      if ( $a[$_ + 1]) eq ( $b[$map{$a[$_]} + 1] )
         or @tmp >= 1;
[download]

with

    push @tmp, $a[$_]
      if ($a[$_ + 1] and $b[$map{$a[$_]} + 1]
          and ( $a[$_ + 1]) eq ( $b[$map{$a[$_]} + 1] )
          or @tmp >= 1);
[download]

makes Perl happy again.

Arjen

I just felt it was too simple. For @a = qw(a b c); @b = qw(a b x c) it prints LCS - a b c.

The updated code does not work for  @a = qw(a b c d); @b = qw(a b x b c d). It prints a b c d. The output is suprising for me - I created the inputs to catch another kind of mistake. I believe you can't do it in one sweep.

The output is due to the fact that 'b' is repeated in @b so the offset in %map is for the second 'b'. I think I'll leave the code as it is for the time being and just add a caveat that it won't work when there are duplicates in @b. Thanks once again :)

_________
broquaint

sub find_flccos {
  my @a = @{$_[0]};
  my @b = @{$_[1]};
  my (%map,@curchk,@longest);
  
  foreach my $i (0 .. $#a) {
    # I decided to store this map so we don't repeat this 
    # O(n) step if we come across the same letter again
    $map{$a[$i]} = [ grep $b[$_] eq $a[$i], (0 .. $#b) ] unless define
+d $map{$a[$i]};
    # ok, these are the indices in b where we should 
    #start matching from
    foreach my $j (@{$map{$a[$i]}}) { 
      @curchk = ();
      # make temporary indices
      my ($ti,$tj) = ($i,$j);
      # fill @curchk with the longest current match
      while ($ti < @a && $tj < @b && $a[$ti] eq $b[$tj]) {
        push @curchk, $a[$ti];
        $ti++;
        $tj++;
      }
      # change the longest array if it is longer 
      #than the one found previously
      @longest = @curchk if ($#curchk > $#longest);
    }
  }
  return @longest;
}


__DATA__

my (@a,@b,@c,@d,@e,@f);
@a = qw( a a a a b c d );
@b = qw( a b c b a b a c a d );

@c = qw(fred bob joe jim mary elaine);
@d = qw(frank joe jim mary bob);

@e = @f = ();

print join ",", find_flccos(\@a,\@b);
print $/;

print join ",", find_flccos(\@d,\@c);
print $/;

print join ",", find_flccos(\@e,\@f);
print $/;

OUTPUT:
> perl flccos.pl
a,b,c
joe,jim,mary

>
[download]

antirice    
The first rule of Perl club is - use Perl
The ith rule of Perl club is - follow rule i - 1 for i > 1

You, sir, are the winner. I can't seem to break your code. I'd just like to say, this is the best website ever!

Update DO NOT USE! THIS IS A TERMINALLY BROKEN ALGORITHM THAT GET THE RIGHT ANSWER SOMETIMES ALMOST BY LUCK. I DOUBT IT CAN BE EASILY FIXED.

Must test more! Must test more!

Whether this is 'cleaner' is doubtful, given this is the first time ever I've felt the need to use redo, but if your big set is very big, is should result in less total memory use and less comparisons. Ie. It should be faster, I think.

The basic premise to first locate all the subsets of @a that contain only values that exist in @b, and then use join and index to verify if the subset actually exists in @b.

#! perl -slw
use strict;

# gen some test data (often generates warnings too)
#my @a = map{ int rand 100 } 1 .. 100; print "@a";
#my @b; push @b, @a[ ($_ = rand(100)) .. ($_ + rand(10)) ] for 1 .. 10
+; print "@b";

my @a = qw(fred bob joe jim mary elaine);
my @b = qw(frank joe jim mary bob);

my %b; @b{ @b } = ();
my $b = join ',', @b ;

my @subsets;
my $start = 0;

OUTER: {
    for( $start .. $#a ) {
        next if exists $b{ $a[$_] };
        if( $_ > $start+1 ) {
            my $a = join ',', @a[ $start .. ($_-1) ];
            push @subsets, [ ($_ - 1 - $start), $start, $_ -1 ] if 1+i
+ndex( $b, $a );
        }
        $start++;
        redo OUTER;
    }
}

my $longest = [0];
$_->[0] > $longest->[0] and $longest = $_ for @subsets;


print "@a[ $longest->[1] .. $longest->[2] ]";
[download]

It finds the apppropriate subset of your sample data, and works quite quickly for various datasets I generated randomly. Full testing is left to you.

It handles duplicates in either set (collection:), and could probably be more efficient if this isn't a requirement.

Caveats:

The usual one about elements that could contain your chosen seperator which you are probably aware of.

As is, it will only find the first, longest common subset. If two or more, equally long, subsets exist and you want them all, you have a little work left to do:)

A somewhat non-standard approach, just for the fun of it:

my @a = qw( fred bob joe jim mary elaine );
my @b = qw( frank joe jim mary bob );

my $str = join(" ", @a) . "&" . join(" ", @b);

if ($str =~ /(?:\b\w+\b\s*)+?
             ((?:\b\w+\b\s*)+)
             (?:\s*\b\w+\b\s*)+?
             &
             (?:\b\w+\b\s*)+?
             \1
             (?:\s*\b\w+\b)+?/x) {
    my $result = $1;
    $result =~ s/\s*$//;
    print "found '$result'\n";
}
[download]

Note: it works on the example given, I didn't test it extensively.

Just my 2 cents, -gjb-

It won't work on general data. It will find the first subsequence of @a that is in @b and be content with it. But it was an interesting attempt.

Update: For @a = qw(a b c); @b = qw(a b c) it prints b. For two element lists it does not work at all.

Update: Changed the code to:

my $str = join(" ", @a) . "&" . join(" ", @b);

if ($str =~ /(?:\b\w+\b\s*)*?
             ((?:\b\w+\b\s*)+)
             (?:\s*\b\w+\b\s*)*?
             &
             (?:\b\w+\b\s*)*?
             \1
             (?:\s*\b\w+\b)*?/x) {
    my $result = $1;
    $result =~ s/\s*$//;
    print "found '$result'\n";
}
[download]

It does not have the problem with cutting the first and last elements of the list, but still for @a = qw(a b c); @b = qw(a x b c) it prints a.

I also went the route of creating a regular expression, and here is what I came up with. This RE most likely has abysmal exponential performance, as it backtracks extensively. It also does not work with duplicate elements in the input stream, as a (Perl) regular expression will be content with the leftmost match - had Perl a POSIX RE engine, that engine should match the longest match from what I remember...

Anyway, the code "simply" constructs a regular expression of one list that matches all possible subsequences in order, and then matches that list against the other list as a string. Spaces are used as the delimiters between the elements.

#!/usr/bin/perl -w
use strict;
use Test::More tests => 3;

sub lcos {
  my ($list1,$list2) = @_;
  my @list1 = @$list1;
  my @list2 = @$list2;
  
  # Assume that neither list1 nor list2 contain elements 
  # that stringify to the same value, that is, neither
  # list1 nor list2 contain both "" and undef.
  # Also, a blank is chosen as a delimiting character which
  # shall appear in no element of list1 or list2
  
  $list2 = " " . join(" ", @list2) . " ";
  my $matcher = lcos_match(@list1);
  #print $matcher,"\n";
  my @result;
  @result = split " ", $1 
    if $list2 =~ $matcher;
  @result;
};

sub lcos_match {
  my $match = '(';
  while (@_) {
    $match .= match_sequence(@_);
    shift;
    @_ and $match .= "|";
  };
  $match .= ')';
  $match;
};

sub match_sequence {
  my $result = "";
  my $element;
  while (defined ($element = pop)) {
    $result = $result ? qr{ \Q$element\E$result?} : qr{ \Q$element\E }
+;
  };
  $result;
};

while (<DATA>) {
  my ($l1,$l2,$expected) = split /\s*\|\s*/;
  my @l1 = split /\s*/, $l1;
  my @l2 = split /\s*/, $l2;
  my @expected = split /\s*/, $expected;
  
  $" = ",";
  $, = ",";
  is_deeply( [ lcos(\@l1,\@l2)], \@expected, "@l1 | @l2");
};

__DATA__
a b c d f g h j q z | a b c d e f g i j k r x y z | a b c d
a b c | a b x c | a b
a b c d | a b x b c d | b c d
[download]

use strict;

my @a = qw( fred bob joe jim mary elaine );
my @b = qw( frank joe jim mary bob );
my @result;

while (@a and @a > @result) {
    my $start = 0;
    while (@b - $start > @result) {
        my $end = 0;
        my @maybe = ();
        $end++ while (exists($a[$end]) and $a[$end] eq $b[$start+$end]
+);
        if (--$end > @result) {
            @result = @a[0..$end];
        }
        $start++;
    }
    shift(@a);
}

print "@result\n";
[download]

Jenda
Always code as if the guy who ends up maintaining your code will be a violent psychopath who knows where you live.
   -- Rick Osborne

Edit by castaway: Closed small tag in signature

So close! It works almost all the time, but this test case fails:

my @a = qw( a b c d e f g h i j k l m n o p q r s t u v w x y z );
my @b = qw( a b c X f g h X l m n X j k a b c d );
[download]

Running on this, I get a b c as the result instead of a b c d. I'm looking to see if I can figure out why now, but I figured I'd post in case someone's faster than me (likely).

I'm stupid, stupid, stupid. There should be:

....
        if ($end > @result) {
            @result = @a[0..$end-1];
        }
...
[download]

instead of

...
        if (--$end > @result) {
            @result = @a[0..$end];
        }
...
[download]

The way I have it I'd only update the @result if the newly found list was longer by at least 2 items. The usual off-by-one error :-(

Jenda
Always code as if the guy who ends up maintaining your code will be a violent psychopath who knows where you live.
   -- Rick Osborne

Edit by castaway: Closed small tag in signature

Also if the lists are huge and a lot of the items only appear on one of the lists it may be better to filter out those "unique" elements before you start looking for matches. Of course you can't remove them completely, you have to keep a "marker" there that's not equal to any other element nor marker.

use strict;
my @a = qw(fred bob joe jim ethfgh mary elaine foo bar bob foo too);
my @b = qw(frank joe jim dfkjhgdkjfg mary bob srere dfhgerg wet sdfwer
+ mary);

my (%seenA, %seenB);
{
    my $i = 0;
    @seenA{@a}=undef;
    @seenB{@b}=undef;
    my $last = -1;
    @a = map {exists $seenB{$_} ? ($last = $_) : (defined($last) ? ($l
+ast = undef) : ())} @a;
    my $last = -1;
    @b = map {exists $seenA{$_} ? ($last = $_) : (defined($last) ? ($l
+ast = undef) : ())} @b;
}

print "@a\n";
print "@b\n\n";

shift(@a) unless defined $a[0];
shift(@b) unless defined $b[0];
pop(@a) unless defined $a[-1];
pop(@b) unless defined $b[-1];

print "@a\n";
print "@b\n\n";

my @result;

while (@a and @a > @result) {
    my $start = 0;
    while (@b - $start > @result) {
        my $end = 0;
        my @maybe = ();
        $end++ while (defined($a[$end]) and defined($b[$start+$end]) a
+nd $a[$end] eq $b[$start+$end]);
        if (--$end > @result) {
            @result = @a[0..$end];
        }
        $start++;
    }
    shift(@a);
}

print "@result\n";
[download]

I assume the lists did not contain any undefs!

Jenda
Always code as if the guy who ends up maintaining your code will be a violent psychopath who knows where you live.
   -- Rick Osborne

Edit by castaway: Closed small tag in signature

####################################
sub LCCOS {
####################################
 my ($array1,$array2) =  @_;
 my $current_largest = [];
 my $current_size;

 if ( @$array1 > @$array2 ) {
   ($array1,$array2) = ($array2,$array1)
 };

 my $count = 0;

 my %elements_in_longer;
  
 #create an HoA holding the locations of all elements
 #in the larger array so we only start at those places
 push @{$elements_in_longer{$_}},
    $count++ for @$array1;

 for my $pos_in_small ( 0 .. $#array2 ) {
   my $current_letter = $array2->[$pos_in_small];

   for my $possible_start(@{$elements_in_longer{$current_letter}}) {
     my $curr_pos_in_small = $pos_in_small;
     my $curr_pos_in_large = $possible_start;
     my @curr_matching_sequence;

     while ( defined $array1->[$curr_pos_in_large] 
             and 
             defined $array2->[$curr_pos_in_small] ) {
       if ($array1->[$curr_pos_in_large] 
           eq 
           $array2->[$curr_pos_in_small]) {
         push @curr_matching_sequence, 
           $array2->[$curr_pos_in_small];

         $curr_pos_in_large++;
         $curr_pos_in_small++;
       } else  { last; }
     }
     if ( @curr_matching_sequence > @{$current_largest} ) {
         $current_largest = \@curr_matching_sequence;
         $current_size = @curr_matching_sequence;
      }
    }

    #if the $current_size is longer that what is left to
    #check in the smaller array, then we are done.
    last if  $current_size > $#array2 - $pos_in_small;
  }
  return $current_largest;
}   ##LCCOS
[download]

-enlil

The algorithm below is a bit like edit distance for strings +"edit distance" +"dynamic programming" with scores instead of costs and maxima searched for at any point.

#!/usr/bin/perl -w
use strict;
my @arr1 = qw( 123 a4 b c david e f g 8 h f g 8 X i j k l george );
my @arr2 = qw( c ¤¤ a4 b c d e f g 8 X l m k a4 b c david george );

print "array1: @arr1\n";
print "array2: @arr2\n";
my($longest, $longest_inds) = find_lccs(\@arr1, \@arr2);
print
    scalar @$longest_inds,
    " instance(s) of subsequence of length $longest, starting at index
+ ",
    (join ', ' => @$longest_inds), ":\n";
    
foreach (@$longest_inds) {
    print "@arr1[$_ .. $_ + $longest - 1]\n";
}


sub find_lccs {
    my ($arr1, $arr2) = @_;
    my %inds;
    my $longest = 0;
    my @longest_inds = ();

    for (my $i = 0; $i < @$arr1; $i++) {
        $inds{$arr1->[$i]}->{$i} = 0;
    }

    for (my $i = $#$arr2; $i >= 0; $i--) {
        foreach (keys %{ $inds{$arr2->[$i]} } ) {
            if (defined $arr2->[$i+1] && exists $inds{$arr2->[$i+1]}->
+{$_ + 1}) {
                $inds{$arr2->[$i]}->{$_} = $inds{$arr2->[$i+1]}->{$_ +
+ 1} + 1;
            } else {
                $inds{$arr2->[$i]}->{$_} =  1;
            }
            if ($inds{$arr2->[$i]}->{$_} > $longest ) {
                $longest = $inds{$arr2->[$i]}->{$_};
                @longest_inds = ($_);
            } elsif ($inds{$arr2->[$i]}->{$_} == $longest ) {
                push @longest_inds, $_;
            }
        }
    }

    @longest_inds = sort {$a <=> $b} @longest_inds;
    return ($longest, \@longest_inds);
}
[download]