I am trying to write a simple recursive Perl routine to generate all of the permutations of an array. I don't have any of the modules that provide routines for doing this and I can't install them either. Here is the code I have so far:
sub permute
{
my #array = #_;
if (#array == 0)
{
return;
}
else
{
my $accum = "";
my $result = permute_with_accumulator($accum, #array);
return $result;
}
}
sub permute_with_accumulator
{
my ($accum, #array) = #_;
if (#array == 1)
{
my $element = $array[0];
$accum .= "$element,";
}
else
{
my $i;
for ($i = 0; $i <= $#array; $i++)
{
$accum .= "$array[$i] ";
my #new_array = ();
if ($i == 0)
{
#new_array = #array[1..$#array];
}
elsif ($i == $#array)
{
#new_array = #array[0..$#array-1];
}
else
{
my $lower = $i - 1;
my $upper = $i + 1;
#new_array = #array[1..$lower, $upper..$#array];
}
permute_with_accumulator($accum, #new_array);
}
}
return $accum;
}
But when I do #array = qw(e1 e2 e3 e4 e5) and run:
my $perms = permute(#array);
print ("$perms\n");
the output is just
e1 e2 e3 e4 e5
Any advice is appreciated.
Regards.
Actually, this could be found in the FAQ:
How do I permute N elements of a list?
Along with some nifty code for pasting:
#!/usr/bin/perl -n
# Fischer-Krause ordered permutation generator
sub permute (&#) {
my $code = shift;
my #idx = 0..$#_;
while ( $code->(#_[#idx]) ) {
my $p = $#idx;
--$p while $idx[$p-1] > $idx[$p];
my $q = $p or return;
push #idx, reverse splice #idx, $p;
++$q while $idx[$p-1] > $idx[$q];
#idx[$p-1,$q]=#idx[$q,$p-1];
}
}
permute { print "#_\n" } split;
This code is supposed to be used as a standalone script, but you can just use the sub directly with
sub permute (&#); # predeclare sub, paste sub at bottom
my #a;
permute { push #a, "#_" } #some_array;
There is a nice lecture on YouTube in the Stanford programming paradigms series about doing permutation with recursion and double mapping in Scheme. In Perl, I came up with the following implementation for the algorithm:
#!/usr/bin/perl
use strict;
use warnings;
my #array = qw(e1 e2 e3);
sub permute {
return ([]) unless (#_);
return map {
my #cdr = #_;
my $car = splice #cdr, $_, 1;
map { [$car, #$_]; } &permute(#cdr);
} 0 .. $#_;
}
print "#$_\n" foreach (&permute (#array));
Might be very inefficient, but I thought it was fun & elegant :)
Related
Consider:
string1 = "AAABBBBBCCCCCDDDDD"
string2 = "AEABBBBBCCECCDDDDD"
output. Where the mismatch (in this case E) will be replaced with HTML tags around E that color it.
A**E**ABBBBBCC**E**CCDDDDD
What I tried so far: XOR, diff and substr. First I need to find the indices then replace those indices with the pattern.
my #x = split '', "AAABBBBBCCCCCDDDDD";
my #y = split '', "AEABBBBBCCECCDDDDD";
my $result = join '',
map { $x[$_] eq $y[$_] ? $y[$_] : "**$y[$_]**" }
0 .. $#y;
Use:
use strict;
use warnings;
my $string1 = 'AAABBBBBCCCCCDDDDD';
my $string2 = 'AEABBBBBCCECCDDDDD';
my $result = '';
for(0 .. length($string1)) {
my $char = substr($string2, $_, 1);
if($char ne substr($string1, $_, 1)) {
$result .= "**$char**";
} else {
$result .= $char;
}
}
print $result;
It prints A**E**ABBBBBCC**E**CCDDDDD and was tested somewhat, but it may contain errors.
use warnings;
use strict;
my ($s1, $s2, $o1, $o2) = ("AAABBBBBCCCCCDDDDD", "AEABBBBBCCECCDDDDD");
my #s1 = split(//, $s1);
my #s2 = split(//, $s2);
my $eq_state = 1;
while (#s1 and #s2) {
if (($s1[0] eq $s2[0]) != $eq_state) {
$o1 .= (!$eq_state) ? "</b>" : "<b>";
$o2 .= (!$eq_state) ? "</b>" : "<b>";
}
$eq_state = $s1[0] eq $s2[0];
$o1.=shift #s1;
$o2.=shift #s2;
}
print "$o1\n$o2\n";
Output
A<b>A</b>ABBBBBCC<b>C</b>CCDDDDD
A<b>E</b>ABBBBBCC<b>E</b>CCDDDDD
A simpler one that only prints out the second string:
use warnings;
use strict;
my ($s1, $s2, $was_eq) = ("AAABBBBBCCCCCDDDDD", "AEABBBBBCCECCDDDDD", 1);
my #s1 = split(//, $s1);
my #s2 = split(//, $s2);
for my $idx (0 .. #s2 -1) {
my $is_eq = $s1[$idx] eq $s2[$idx];
print $is_eq ? "</b>" : "<b>" if ( $was_eq != $is_eq);
$was_eq = $is_eq;
print $s2[$idx];
}
Outout
</b>A<b>E</b>ABBBBBCC<b>E</b>CCDDDDD
This might be memory intensive, for large strings:
use strict;
use warnings;
my $a = "aabbcc";
my $b = "aabdcc";
my #a = split //, $a;
my #b = split //, $b;
my $new_b = '';
for(my $i = 0; $i < scalar(#a); $i++) {
$new_b .= $a[$i] eq $b[$i] ? $b[$i] : "**$b[$i]**";
}
Output
$ test.pl
new_b: aab**d**cc
There are several ways to accomplish this. Below is a possible way to solve this.
my $str1="ABCDEA";
my $str2="AECDEB";
my #old1=split("",$str1);
my #old2=split("",$str2);
my #new;
for my $i (0..$#old1) {
if ($old1[$i] eq $old2[$i] ) {
push (#new, $old2[$i]);
}
else
{
my $elem = "**".$old2[$i]."**";
push (#new , $elem);
}
}
print #new;
The output is:
A**E**CDE**B**
Aligning columns and using the bitwise string operator, "^":
my $a = "aabbccP";
my $b = "aabdccEE";
$_ = $a ^ $b;
s/./ord $& ? "^" : " "/ge;
print "$_\n" for $a, $b, $_;
gives:
aabbccP
aabdccEE
^ ^^
I have two arrays:
#array1 = (A,B,C,D,E,F);
#array2 = (A,C,H,D,E,G);
The arrays could be of different size. I want to find how many mismatches are there between the arrays. The indexes should be the same. In this case there are three mismatch :b->c,c->h and F->G.(i.e , The 'C' in $array[2] should not be considered a match to 'C' in $array[1]) I would like to get the number of mismatches as well as the mismatch.
foreach my $a1 ( 0 .. $#array1) {
foreach my $a2( 0 .. $#array2)
if($array1[$a1] ne $array2[$a2]) {
}
}
}
my %array_one = map {$_, 1} #array1;
my #difference = grep {!$array_one {$_}} #array1;
print "#difference\n";
Ans: gives me H, G but not C.
with my little Perl knowledge I tried this, with no result. Could you suggest me how I should deal this? Your suggestions and pointers would be very helpful.
You shouldn't have nested loops. You only need to go through the indexes once.
use List::Util qw( max );
my #mismatches;
for my $i (0..max($#array1, $#array2)) {
push #mismatches, $i
if $i >= #array1
|| $i >= #array2
|| $array1[$i] ne $array2[$i];
}
}
say "There are " . (0+#mismatches) . " mismatches";
for my $i (#mismatches) {
...
}
Since you mentioned grep, this is how you'd replace the for with grep:
use List::Util qw( max );
my #mismatches =
grep { $_ >= #array1
|| $_ >= #array2
|| array1[$_] ne $array2[$_] }
0 .. max($#array1, $#array2);
say "There are " . (0+#mismatches) . " mismatches";
for my $i (#mismatches) {
...
}
Here's an example using each_arrayref from List::MoreUtils.
sub diff_array{
use List::MoreUtils qw'each_arrayref';
return unless #_ && defined wantarray;
my #out;
my $iter = each_arrayref(#_);
my $index = 0;
while( my #current = $iter->() ){
next if all_same(#current);
unshift #current, $index;
push #out, \#current;
}continue{ ++$index }
return #out;
}
This version should be faster if you are going to use this for determining the number of differences often. The output is exactly the same. It just doesn't have to work as hard when returning a number.
Read about wantarray for more information.
sub diff_array{
use List::MoreUtils qw'each_arrayref';
return unless #_ && defined wantarray;
my $iter = each_arrayref(#_);
if( wantarray ){
# return structure
my #out;
my $index = 0;
while( my #current = $iter->() ){
next if all_same(#current);
unshift #current, $index;
push #out, \#current;
}continue{ ++$index }
return #out;
}else{
# only return a count of differences
my $out = 0;
while( my #current = $iter->() ){
++$out unless all_same #current;
}
return $out;
}
}
diff_array uses the subroutine all_same to determine if all of the current list of elements are the same.
sub all_same{
my $head = shift;
return undef unless #_; # not enough arguments
for( #_ ){
return 0 if $_ ne $head; # at least one mismatch
}
return 1; # all are the same
}
To get just the number of differences:
print scalar diff_array \#array1, \#array2;
my $count = diff_array \#array1, \#array2;
To get a list of differences:
my #list = diff_array \#array1, \#array2;
To get both:
my $count = my #list = diff_array \#array1, \#array2;
The output for the input you provided:
(
[ 1, 'B', 'C' ],
[ 2, 'C', 'H' ],
[ 5, 'F', 'G' ]
)
Example usage
my #a1 = qw'A B C D E F';
my #a2 = qw'A C H D E G';
my $count = my #list = diff_array \#a1, \#a2;
print "There were $count differences\n\n";
for my $group (#list){
my $index = shift #$group;
print " At index $index\n";
print " $_\n" for #$group;
print "\n";
}
You're iterating over both arrays when you don't want to be doing so.
#array1 = ("A","B","C","D","E","F");
#array2 = ("A","C","H","D","E","G");
foreach my $index (0 .. $#array1) {
if ($array1[$index] ne $array2[$index]) {
print "Arrays differ at index $index: $array1[$index] and $array2[$index]\n";
}
}
Output:
Arrays differ at index 1: B and C
Arrays differ at index 2: C and H
Arrays differ at index 5: F and G
Well, first, you're going to want to go over each element of one of the arrays, and compare it to the same element of the other array. List::MoreUtils provides an easy way to do this:
use v5.14;
use List::MoreUtils qw(each_array);
my #a = qw(a b c d);
my #b = qw(1 2 3);
my $ea = each_array #a, #b;
while ( my ($a, $b) = $ea->() ) {
say "a = $a, b = $b, idx = ", $ea->('index');
}
You can extend that to find where there is a non-match by checking inside that while loop (note: this assumes your arrays don't have undefs at the end, or that if they do, undef is the same as having a shorter array):
my #mismatch;
my $ea = each_array #a, #b;
while ( my ($a, $b) = $ea->() ) {
if (defined $a != defined $b || $a ne $b) {
push #mismatch, $ea->('index');
}
}
and then:
say "Mismatched count = ", scalar(#mismatch), " items are: ", join(q{, }, #mismatch);
The following code builds a list of mismatched pairs, then prints them out.
#a1 = (A,B,C,D,E,F);
#a2 = (A,C,H,D,E,G);
#diff = map { [$a1[$_] => $a2[$_]] }
grep { $a1[$_] ne $a2[$_] }
(0..($#a1 < $#a2 ? $#a1 : $#a2));
print "$_->[0]->$_->[1]\n" for #diff
You have the right idea, but you only need a single loop, since you are looking at each index and comparing entries between the arrays:
foreach my $a1 ( 0 .. $#array1) {
if($array1[$a1] ne $array2[$a1]) {
print "$a1: $array1[$a1] <-> $array2[$a1]\n";
}
}
I am trying to do work on a hash of files and the work has to be done in a specific order. Most would say the list can be ordered like so:
for my $k (sort keys %my_hash)
{
print "$k=>$my_hash{$k}, ";
}
However, I need nonalphabetical order, in fact the keys start with a word then _ and they go G to digits to L to any of M,P,R,T or D (eg. word_G.txt,word_2.txt,...,word_P.txt). Is there any way to sort by custom order?
Is there any way to sort by custom order?
Yes. See sort.
For example:
#!/usr/bin/env perl
use warnings; use strict;
my #order = qw(G 1 2 3 L M P R T D);
my %order_map = map { $order[$_] => $_ } 0 .. $#order;
my $pat = join '|', #order;
my #input = qw(word_P.txt word_2.txt word_G.txt);
my #sorted = sort {
my ($x, $y) = map /^word_($pat)[.]txt\z/, $a, $b;
$order_map{$x} <=> $order_map{$y}
} #input;
print "#sorted\n";
use 5.014;
sub rank {
my ($word) = #_;
$word =~ s{\A \w+ _}{}msx;
return do {
given ($word) {
0 when /\A G/msx;
1 when /\A [0-9]/msx;
2 when /\A L/msx;
3 when /\A [MPRTD]/msx;
default { 1000 };
}
};
}
say for sort { rank($a) <=> rank($b) } qw(word_P.txt word_2.txt word_G.txt);
Output:
word_G.txt
word_2.txt
word_P.txt
Edit: Before Perl 5.14, use a temporary variable.
use 5.010;
⋮
return do {
my $dummy;
given ($word) {
$dummy = 0 when /\A G/msx;
$dummy = 1 when /\A [0-9]/msx;
$dummy = 2 when /\A L/msx;
$dummy = 3 when /\A [MPRTD]/msx;
default { $dummy = 1000 };
}
$dummy;
};
I had a specific use case where I wanted to sort with certain values first, other values last, then everything else alphabetically in the middle.
Here's my solution:
my #sorted = sort {
my #order = qw(Mike Dave - Tom Joe);
my ($x,$y) = (undef,undef);
for (my $i = 0; $i <= $#order; $i++) {
my $token = $order[$i];
$x = $i if ($token eq $a or (not defined $x and $token eq "-"));
$y = $i if ($token eq $b or (not defined $y and $token eq "-"));
}
$x <=> $y or
$a cmp $b
} #ARGV;
Output:
$ perl customsort.pl Tom Z Mike A Joe X Dave G
Mike Dave A G X Z Tom Joe
I'm building a count matrix in Perl using AoA: my #aoa = () then call $aoa[$i][$j]++ whenever I need to increment a specific cell. Since some cells are not incremented at all, they are left undef (these are equivalent to 0 counts).
I would like to print some lines from the matrix, but I get errors for undef cells (which I would simply like to print as zeros). what should I do?
Use defined with a conditional operator (?:).
#!/usr/bin/perl
use strict;
use warnings;
my #matrix;
for my $i (0 .. 3) {
for my $j (0 .. 3) {
if (rand > .5) {
$matrix[$i][$j]++;
}
}
}
for my $aref (#matrix) {
print join(", ", map { defined() ? $_ : 0 } #{$aref}[0 .. 3]), "\n"
}
If you are using Perl 5.10 or later, you can use the defined-or operator (//).
#!/usr/bin/perl
use 5.012;
use warnings;
my #matrix;
for my $i (0 .. 3) {
for my $j (0 .. 3) {
if (rand > .5) {
$matrix[$i][$j]++;
}
}
}
for my $aref (#matrix) {
print join(", ", map { $_ // 0 } #{$aref}[0 .. 3]), "\n"
}
Classically:
print defined $aoa[$i][$j] ? $aoa[$i][$j] : 0;
Modern Perl (5.10 or later):
print $aoa[$i][$j] // 0;
That is a lot more succinct and Perlish, it has to be said.
Alternatively, run through the matrix before printing, replacing undef with 0.
use strict;
use warnings;
my #aoa = ();
$aoa[1][1] = 1;
$aoa[0][2] = 1;
$aoa[2][1] = 1;
for my $i (0..2)
{
print join ",", map { $_ // 0 } #{$aoa[$i]}[0..2], "\n";
}
Just an example, please modify the code to your requirements.
use strict;
use warnings;
my #aoa;
$aoa[1][3]++;
foreach my $i (1 .. 3){
foreach my $j (1 .. 3){
defined $aoa[$i][$j] ? print $aoa[$i][$j] : print "0";
print "\t";
}
print "\n";
}
I have two arrays, #a and #b. I want to do a compare among the elements of the two arrays.
my #a = qw"abc def efg ghy klm ghn";
my #b = qw"def ghy jgk lom com klm";
If any element matches then set a flag. Is there any simple way to do this?
First of all, your 2 arrays need to be written correctly.
#a = ("abc","def","efg","ghy","klm","ghn");
#b = ("def","efg","ghy","klm","ghn","klm");
Second of all, for arbitrary arrays (e.g. arrays whose elements may be references to other data structures) you can use Data::Compare.
For arrays whose elements are scalar, you can do comparison using List::MoreUtils pairwise BLOCK ARRAY1 ARRAY2, where BLOCK is your comparison subroutine. You can emulate pairwise (if you don't have List::MoreUtils access) via:
if (#a != #b) {
$equals = 0;
} else {
$equals = 1;
foreach (my $i = 0; $i < #a; $i++) {
# Ideally, check for undef/value comparison here as well
if ($a[$i] != $b[$i]) { # use "ne" if elements are strings, not numbers
# Or you can use generic sub comparing 2 values
$equals = 0;
last;
}
}
}
P.S. I am not sure but List::Compare may always sort the lists. I'm not sure if it can do pairwise comparisons.
List::Compare
if ( scalar List::Compare->new(\#a, \#b)->get_intersection ) {
…
}
Check to create an intersect function, which will return a list of items that are present in both lists. Then your return value is dependent on the number of items in the intersected list.
You can easily find on the web the best implementation of intersect for Perl. I remember looking for it a few years ago.
Here's what I found :
my #array1 = (1, 2, 3);
my #array2 = (2, 3, 4);
my %original = ();
my #isect = ();
map { $original{$_} = 1 } #array1;
#isect = grep { $original{$_} } #array2;
This is one way:
use warnings;
use strict;
my #a = split /,/, "abc,def,efg,ghy,klm,ghn";
my #b = split /,/, "def,ghy,jgk,lom,com,klm";
my $flag = 0;
my %a;
#a{#a} = (1) x #a;
for (#b) {
if ($a{$_}) {
$flag = 1;
last;
}
}
print "$flag\n";
From the requirement that 'if any element matches', use the intersection of sets:
sub set{
my %set = map { $_, undef }, #_;
return sort keys %set;
}
sub compare{
my ($listA,$listB) = #_;
return ( (set(#$listA)-set(#$listB)) > 0)
}
my #a = qw' abc def efg ghy klm ghn ';
my #b = qw' def ghy jgk lom com klm ';
my $flag;
foreach my $item(#a) {
$flag = #b~~$item ? 0 : 1;
last if !$flag;
}
Note that you will need Perl 5.10, or later, to use the smart match operator (~~) .
Brute force should do the trick for small a n:
my $flag = 0;
foreach my $i (#a) {
foreach my $k (#b) {
if ($i eq $k) {
$flag = 1;
last;
}
}
}
For a large n, use a hash table:
my $flag = 0;
my %aa = ();
$aa{$_} = 1 foreach (#a);
foreach my $i (#b) {
if ($aa{$i}) {
$flag = 1;
last;
}
}
Where a large n is |#a| + |#b| > ~1000 items
IMHO, you should use List::MoreUtils::pairwise. However, if for some reason you cannot, then the following sub would return a 1 for every index where the value in the first array compares equal to the value in the second array. You can generalize this method as much as you want and pass your own comparator if you want to, but at that point, just installing List::MoreUtils would be a more productive use of your time.
use strict; use warnings;
my #a = qw(abc def ghi jkl);
my #b = qw(abc dgh dlkfj jkl kjj lkm);
my $map = which_ones_equal(\#a, \#b);
print join(', ', #$map), "\n";
sub which_ones_equal {
my ($x, $y, $compare) = #_;
my $last = $#$x > $#$y ? $#$x : $#$y;
no warnings 'uninitialized';
return [ map { 0 + ($x->[$_] eq $y->[$_]) } $[ .. $last ];
}
This is Perl. The 'obvious' solution:
my #a = qw"abc def efg ghy klm ghn";
my #b = qw"def ghy jgk lom com klm";
print "arrays equal\n"
if #a == #b and join("\0", #a) eq join("\0", #b);
given "\0" not being in #a.
But thanks for confirming that there is no other generic solution than rolling your own.
my #a1 = qw|a b c d|;
my #a2 = qw|b c d e|;
for my $i (0..$#a1) {
say "element $i of array 1 was not found in array 2"
unless grep {$_ eq $a1[$i]} #a2
}
If you would consider the arrays with different order to be different, you may use Array::Diff
if (Array::Diff->diff(\#a, \#b)->count) {
# not_same
} else {
# same
}
This question still could mean two things where it states "If any element matches then set a flag":
Elements at the same position, i.e $a[2] eq $b[2]
Values at any position, i.e. $a[3] eq $b[5]
For case 1, you might do this:
# iterate over all positions, and compare values at that position
my #matches = grep { $a[$_] eq $b[$_] } 0 .. $#a;
# set flag if there's any match at the same position
my $flag = 1 if #matches;
For case 2, you might do that:
# make a hash of #a and check if any #b are in there
my %a = map { $_ => 1 } #a;
my #matches = grep { $a{$_} } #b;
# set flag if there's matches at any position
my $flag = 1 if #matches;
Note that in the first case, #matches holds the indexes of where there are matching elements, and in the second case #matches holds the matching values in the order in which they appear in #b.