XP is just a number PerlMonks

### Testing if Two Arrays are Ordered in a Same Way

by monkfan (Curate)
 on May 25, 2005 at 04:13 UTC Need Help??
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 "Second case\n";

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;
}
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
```First Case:       Second Case:
0                 0
1                 1
1                 1
1
Regards,
Edward

Replies are listed 'Best First'.
Re: Testing if Two Arrays are Ordered in a Same Way
by ikegami (Pope) 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;
}
Re: Testing if Two Arrays are Ordered in a Same Way
by BrowserUk (Pope) 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 "Second case\n";

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

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.
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;
}

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

the lowliest monk

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});

}

Create A New User
Node Status?
node history
Node Type: perlquestion [id://460234]
Approved by BrowserUk
help
Chatterbox?
 [pryrt]: 1nickt, sprintf "%.16e", \$v will always give enough precision to see 1 ULP (the smallest fractional part) of a standard 64bit Perl NV* [pryrt]: (*: for systems where \$Config{nvsize}==8 ) [pryrt]: Thus, that's "enough precision" to tell the difference between 1.0 and 1.0+1ULP [pryrt]: But in what circumstance does your problem arise? When, in Perl, does the integer 1 not work identically to the floating-point NV 1.0000000000000000 e0?

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (15)
As of 2017-05-24 19:13 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
My favorite model of computation is ...

Results (186 votes). Check out past polls.