monkfan has asked for the wisdom of the Perl Monks concerning the following question:

Hi,
Here I wanted to test if an array is of a _same order_ with another, left array is always be greater/superset or equal to the right one. Here is my current code.
#!/usr/bin/perl -w

# The original code here is constructed 
# thanks to ysth's suggestion  

use strict;
my @AR  = qw(a b c);   # First Case
my @ar  = qw(z a b c); # Second Case

my @ar2 = qw(b a);
my @ar3 = qw(a b);
my @ar4 = qw(a b c);
my @ar5 = qw(z a b c);

print "First case\n";
#                   L     R
print test_ordered(\@ar,\@ar2),"\n"; # Answer:False(0)
print test_ordered(\@ar,\@ar3),"\n"; # Answer:True(1)
print test_ordered(\@ar,\@ar4),"\n"; # Answer:True(1)
print test_ordered(\@ar,\@ar5),"\n"; # Answer:True(1)

print "Second case\n";
print test_ordered(\@AR,\@ar2),"\n"; # Answer: False(0)
print test_ordered(\@AR,\@ar3),"\n"; # Answer: True(1)
print test_ordered(\@AR,\@ar4),"\n"; # Answer: True(1)


sub test_ordered
{
    #test if two arrays are ordered in same way
    #assuming no duplicate and left array is always 
    #be greater/superset or equal to the right one

    #    L    R
    my ($ar1,$ar2)= @_;

    my %h;

    @h{@$ar1} = (0..$#{$ar1});
    my $decision = grep($h{$ar2[$_]} != $_, 0..$#{$ar2}) ? 0 : 1;

   return $decision;
}

[download]
Currently the code give correct answer for the Second Case. How can I modify it such that it's also correct for the First Case?
Now it prints: 
First Case:       Second Case:
0                 0
0                 1
0                 1
1

[download]
The desired answer is: 
First Case:       Second Case:
0                 0
1                 1
1                 1
1

[download]
Regards,
Edward

Replies are listed 'Best First'.
Re: Testing if Two Arrays are Ordered in a Same Way
by ikegami (Patriarch) on May 25, 2005 at 04:52 UTC

    This works

    sub test_ordered
{
    #test if two arrays are ordered in same way
    #assuming no duplicate and left array is always 
    #be greater/superset or equal to the right one

    #    L    R
    my ($ar1,$ar2)= @_;

    my %h;

    @h{@$ar1} = (0..$#{$ar1});

    my $last = -1;
    foreach (@h{@$ar2}) {
       return 0 unless $_ >= $last;
       $last = $_;
    }

    return 1;
}

    [download]
[reply]
[d/l]
Re: Testing if Two Arrays are Ordered in a Same Way
by BrowserUk (Patriarch) on May 25, 2005 at 04:42 UTC

    If all the elements of your arrays are single chars (as in your previous posts) then I think this would do the job. It does for the testcases provided: 

    #!/usr/bin/perl -w
use strict;
my @AR  = qw(a b c);   # First Case
my @ar  = qw(z a b c); # Second Case

my @ar2 = qw(b a);
my @ar3 = qw(a b);
my @ar4 = qw(a b c);
my @ar5 = qw(z a b c);

print "First case\n";
#                   L     R
print test_ordered(\@ar,\@ar2),"\n"; # Answer:False(0)
print test_ordered(\@ar,\@ar3),"\n"; # Answer:True(1)
print test_ordered(\@ar,\@ar4),"\n"; # Answer:True(1)
print test_ordered(\@ar,\@ar5),"\n"; # Answer:True(1)

print "Second case\n";
print test_ordered(\@AR,\@ar2),"\n"; # Answer: False(0)
print test_ordered(\@AR,\@ar3),"\n"; # Answer: True(1)
print test_ordered(\@AR,\@ar4),"\n"; # Answer: True(1)

sub test_ordered {
    my( $ar1, $ar2 ) = @_;
    my $re = join '.*?', @$ar2;
    $ar1 = join'', @$ar1;
    return $ar1 =~ $re ? 1 : 0;
}

__END__
P:\test>460234.pl
First case
0
1
1
1
Second case
0
1
1

    [download]
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    Lingua non convalesco, consenesco et abolesco. -- Rule 1 has a caveat! -- Who broke the cabal?
    "Science is about questioning the status quo. Questioning authority".
    The "good enough" maybe good enough for the now, and perfection maybe unobtainable, but that should not preclude us from striving for perfection, when time, circumstance or desire allow.
[reply]
[d/l]
Re: Testing if Two Arrays are Ordered in a Same Way
by tlm (Prior) on May 25, 2005 at 04:50 UTC 
    sub test_ordered {
  my ( $ref, $test ) = @_;

  # $i scans the indices of @$ref;
  # $matched keeps count of # of elements matched in @$test;
  my ( $i, $matched ) = ( 0, 0 );
OUTER: for ( @$test ) {
    while ( $i < @$ref or return 0 ) {
      if ( $ref->[ $i++ ] eq $_ ) {
        last OUTER if ++$matched == @$test;
        last;
      }
    }
  }
  return 1;
}

    [download]

    Updates: Minor tweaks. Fixed behavior for the empty @$test case (returns 1).

    the lowliest monk

[reply]
[d/l]
Re: Testing if Two Arrays are Ordered in a Same Way
by johnnywang (Priest) on May 25, 2005 at 05:29 UTC
    My algorithm: drop those element from the first array which are not in second, the resulting array should be the same as the second, which can be compared by joining the elements together. (not tested): 
    sub test_ordered{
 my ($ar1,$ar2)= @_;
 my %array2;
 @array2{@{$ar2}} = 1;

 # a more perlish way?
 my @array1 = ();
 foreach (@{$ar1}){
    push @array1, $_ if $array2{$_};
 }
 return join(",", @array1) eq join(",",@{$ar2});

}

    [download]
[reply]
[d/l]

Back to Seekers of Perl Wisdom