File Coverage

blib/lib/LCS.pm

Criterion	Covered	Total	%
statement	165	165	100.0
branch	39	40	97.5
condition	17	18	100.0
subroutine	19	19	100.0
pod	13	13	100.0
total	253	255	99.6

package LCS;

use strict;
use warnings;

use 5.006;
our $VERSION = '0.11';

use Data::Dumper;

sub new {
  my $class = shift;
  # uncoverable condition false
  bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
}

sub align {
  my ($self, $X, $Y) = @_;

  return $self->lcs2align(
    $X, $Y, $self->LCS($X,$Y)
  );
}

sub lcs2align {
  my ($self, $X, $Y, $LCS) = @_;

  my $hunks = [];

  my $Xcurrent = -1;
  my $Ycurrent = -1;
  my $Xtemp;
  my $Ytemp;

  for my $hunk (@$LCS) {
    while ( ($Xcurrent+1 < $hunk->[0] ||  $Ycurrent+1 < $hunk->[1]) ) {
      $Xtemp = '';
      $Ytemp = '';
      if ($Xcurrent+1 < $hunk->[0]) {
        $Xcurrent++;
        $Xtemp = $X->[$Xcurrent];
      }
      if ($Ycurrent+1 < $hunk->[1]) {
        $Ycurrent++;
        $Ytemp = $Y->[$Ycurrent];
      }
      push @$hunks,[$Xtemp,$Ytemp];
    }

    $Xcurrent = $hunk->[0];
    $Ycurrent = $hunk->[1];
    push @$hunks,[$X->[$Xcurrent],$Y->[$Ycurrent]]; # elements
  }
  while ( ($Xcurrent+1 <= $#$X ||  $Ycurrent+1 <= $#$Y) ) {
    $Xtemp = '';
    $Ytemp = '';
    if ($Xcurrent+1 <= $#$X) {
      $Xcurrent++;
      $Xtemp = $X->[$Xcurrent];
    }
    if ($Ycurrent+1 <= $#$Y) {
      $Ycurrent++;
      $Ytemp = $Y->[$Ycurrent];
    }
    push @$hunks,[$Xtemp,$Ytemp];
  }
  return $hunks;
}

sub sequences2hunks {
  my ($self, $a, $b) = @_;
  return [ map { [ $a->[$_], $b->[$_] ] } 0..$#$a ];
}

sub clcs2lcs {
  my ($self, $clcs) = @_;
  my $lcs = [];
  for my $entry (@$clcs) {
    for (my $i = 0; $i < $entry->[2];$i++) {
      push @$lcs,[$entry->[0]+$i,$entry->[1]+$i];
    }
  }
  return $lcs;
}

sub lcs2clcs {
  my ($self, $lcs) = @_;
  my $clcs = [];
  for my $entry (@$lcs) {
    if (@$clcs && $clcs->[-1]->[0] + $clcs->[-1]->[2] == $entry->[0]) {
      $clcs->[-1]->[2]++;
    }
    else {
      push @$clcs,[$entry->[0],$entry->[1],1];
    }
  }
  return $clcs;
}

sub hunks2sequences {
  my ($self, $hunks) = @_;

  my $a = [];
  my $b = [];

  for my $hunk (@$hunks) {
    push @$a, $hunk->[0];
    push @$b, $hunk->[1];
  }
  return ($a,$b);
}

sub align2strings {
  my ($self, $hunks,$gap) = @_;
  #$gap //= '_';
  $gap = (defined $gap) ? $gap : '_';

  my $a = '';
  my $b = '';

  for my $hunk (@$hunks) {
    my ($ae,$be) = $self->fill_strings($hunk->[0],$hunk->[1],$gap);
    $a .=  $ae;
    $b .=  $be;
  }
  return ($a,$b);
}

sub fill_strings {
  my ($self, $string1,$string2, $gap) = @_;
  #$gap //= '_';
  $gap = (defined $gap) ? $gap : '_';

  my @m = $string1 =~ m/(\X)/g;
  my @n = $string2 =~ m/(\X)/g;
  my $max = max(scalar(@m),scalar(@n));
  if ($max - scalar(@m) > 0) {
    for (1..$max-scalar(@m)) {
      $string1 .= $gap;
    }
  }
  if ($max - scalar(@n) > 0) {
    for (1..$max-scalar(@n)) {
      $string2 .= $gap;
    }
  }
  return ($string1,$string2);
}

sub LLCS {
  my ($self,$X,$Y) = @_;

  my $m = scalar @$X;
  my $n = scalar @$Y;

  my $c = [];

  for my $i (0..1) {
    for my $j (0..$n) {
      $c->[$i][$j]=0;
    }
  }

  my ($i,$j);

  for ($i=1; $i <= $m; $i++) {
    for ($j=1; $j <= $n; $j++) {
      if ($X->[$i-1] eq $Y->[$j-1]) {
        $c->[1][$j] = $c->[0][$j-1]+1;
      }
      else {
        $c->[1][$j] = max($c->[1][$j-1],$c->[0][$j]);
      }
    }
    for ($j = 1; $j <= $n; $j++) {
      $c->[0][$j] = $c->[1][$j];
    }
  }
  return ($c->[1][$n]);
}


sub LCS {
  my ($self,$X,$Y) = @_;

  my $m = scalar @$X;
  my $n = scalar @$Y;

  my $c = [];
  my ($i,$j);
  for ($i=0;$i<=$m;$i++) {
    for ($j=0;$j<=$n;$j++) {
      $c->[$i][$j]=0;
    }
  }
  for ($i=1;$i<=$m;$i++) {
    for ($j=1;$j<=$n;$j++) {
      if ($X->[$i-1] eq $Y->[$j-1]) {
        $c->[$i][$j] = $c->[$i-1][$j-1]+1;
      }
      else {
        $c->[$i][$j] = max($c->[$i][$j-1], $c->[$i-1][$j]);
      }
    }
  }
  my $path = $self->_lcs($X,$Y,$c,$m,$n,[]);

  return $path;
}


sub max {
  ($_[0] > $_[1]) ? $_[0] : $_[1];
}


sub _lcs {
  my ($self,$X,$Y,$c,$i,$j,$L) = @_;

  while ($i > 0 && $j > 0) {
    if ($X->[$i-1] eq $Y->[$j-1]) {
      unshift @{$L},[$i-1,$j-1];
      $i--;
      $j--;
    }
    elsif ($c->[$i][$j] == $c->[$i-1][$j]) {
      $i--;
    }
    else {
      $j--;
    }
  }
  return $L;
}


sub _all_lcs {
  my ($self,$ranks,$rank,$max) = @_;

  my $R = [[]];

  while ($rank <= $max) {
    my @temp;
    for my $path (@$R) {
      for my $hunk (@{$ranks->{$rank}}) {
        if (scalar @{$path} == 0) {
          push @temp,[$hunk];
        }
        elsif (($path->[-1][0] < $hunk->[0]) && ($path->[-1][1] < $hunk->[1])) {
          push @temp,[@$path,$hunk];
        }
      }
    }
    @$R = @temp;
    $rank++;
  }
  return $R;
}

# get all LCS of two arrays
# records the matches by rank
sub allLCS {
  my ($self,$X,$Y) = @_;

  my $m = scalar @$X;
  my $n = scalar @$Y;

  my $ranks = {}; # e.g. '4' => [[3,6],[4,5]]
  my $c = [];
  my ($i,$j);

  for (0..$m) {$c->[$_][0]=0;}
  for (0..$n) {$c->[0][$_]=0;}
  for ($i=1;$i<=$m;$i++) {
    for ($j=1;$j<=$n;$j++) {
      if ($X->[$i-1] eq $Y->[$j-1]) {
        $c->[$i][$j] = $c->[$i-1][$j-1]+1;
        push @{$ranks->{$c->[$i][$j]}},[$i-1,$j-1];
      }
      else {
        $c->[$i][$j] =
          ($c->[$i][$j-1] > $c->[$i-1][$j])
            ? $c->[$i][$j-1]
            : $c->[$i-1][$j];
      }
    }
  }
  my $max = scalar keys %$ranks;
  return $self->_all_lcs($ranks,1,$max);
}

1;
__END__