|
fidda has asked for the wisdom of the Perl Monks concerning the following question:
Hi,
I have 2 sets of Arrays,
@A = qw ( H1 H2 H3 H4);
@B = qw (1 2 3 4 5 6 7 8 9 10);
I need a way to return a hash with @A elemets as keys and @B elements as values, with one condition that hash should look like this.
H1-> 1,8,9
H2-> 2,7,10
H3-> 3,6
H4-> 4,5
TIA |
Re: How to get this not the usual round robin looping
by kcott (Archbishop) on Oct 13, 2015 at 05:59 UTC
|
G'day fidda,
This does what you want:
#!/usr/bin/env perl
use strict;
use warnings;
use Data::Dump;
my @A = qw{H1 H2 H3 H4};
my @B = 1 .. 10;
my %result;
my $reverse = 0;
while (@B) {
build_hash(\%result, \@A, \@B, $reverse);
$reverse ^= 1;
}
dd \%result;
sub build_hash {
my ($result, $A, $B, $reverse) = @_;
my @keys = @$B >= @$A ? @$A : @$A[0 .. $#$B];
my @values;
if ($reverse) {
unshift @values, shift @$B for (0 .. $#keys);
}
else {
push @values, shift @$B for (0 .. $#keys);
}
push @{$result->{$keys[$_]}}, $values[$_] for 0 .. $#keys;
}
Output:
{ H1 => [1, 8, 9], H2 => [2, 7, 10], H3 => [3, 6], H4 => [4, 5] }
Note that this code destroys @B.
If you need to keep it, make a copy and use that in the while condition and when calling &build_hash:
my @B_copy = @B;
...
while (@B_copy) {
build_hash(\%result, \@A, \@B_copy, $reverse);
...
Furthermore, the subroutine &build_hash has no reliance on the initial values of either @A or @B.
For example, these initial values:
my @A = qw{H1 H2 H3 H4 H5};
my @B = 1 .. 23;
produce this output:
{
H1 => [1, 10, 11, 20, 21],
H2 => [2, 9, 12, 19, 22],
H3 => [3, 8, 13, 18, 23],
H4 => [4, 7, 14, 17],
H5 => [5, 6, 15, 16],
}
| [reply]
[d/l]
[select] |
|
|
#! perl
use strict;
use warnings;
use Data::Dump;
my @A = qw{H1 H2 H3 H4 H5};
my @B = 1 .. 23;
my %h;
while (@B)
{
push @{ $h{$_} }, shift @B // () for @A, reverse @A;
}
dd \%h;
Output:
16:10 >perl 1404_SoPW.pl
{
H1 => [1, 10, 11, 20, 21],
H2 => [2, 9, 12, 19, 22],
H3 => [3, 8, 13, 18, 23],
H4 => [4, 7, 14, 17],
H5 => [5, 6, 15, 16],
}
16:12 >
:-)
| [reply]
[d/l]
[select] |
|
|
"This is good, ..."
Thanks.
"... but can be considerably simplified"
Agreed.
I normally check an OP's home node before replying.
If it's a first post, I add a welcome greeting.
In this case, it was a second post.
The first post was stated to be homework.
On that basis, I intentionally went with a longer piece of code than I might do normally.
I had meant to add a comment that the code could be simplified: clearly, I forgot to do that.
Perhaps, fidda will tell us which was the more useful.
| [reply] |
|
|
You can also complicate it to avoid the loop (in fact, disguise it as a repetition) and the // operator:
push @{ $h{$_} }, shift @B for (@A, reverse @A) x (@B / @A / 2),
(@A, reverse @A)[ 0 .. @B % (2 * @A) -
+1 ];
Update: Another idea:
for my $i (0 .. $#A) {
$h{ $A[$i] } = [ @B[ grep { my $m = $_ % (2 * @A);
grep $_ == $m, $i, 2 * @A - $i - 1
} 0 .. $#B ] ];
}
TIMTOWTDI, an iterator:
my $iter = do {
my ($pos, $step) = ('0E0', 1);
sub {
my $r = $H{ $A[$pos] } ||= [];
if ($pos % $#A || $pos =~ /E/) {
$pos += $step;
} else {
$pos .= 'E0';
$step *= -1;
}
return $r
}
};
push @{ $iter->() }, $_ for @B;
| [reply]
[d/l]
[select] |
|
|
As already said in chat congratulation Athanasius for your Boustrophedon distribution function.I thought your crucial line was difficult to read and my hubris lead me think i could semplify it by playing with the index of @A..
..as always i endend with a hyper complicated and cryptic solution, even if my hubrys is partially satisfied: anyway TIMTOWTDI!!
#! perl
use strict;
use warnings;
use Data::Dump;
my @A = qw ( H1 H2 H3 H4); # original set
my @B = qw (1 2 3 4 5 6 7 8 9 10); # as per OP
my %h;
my $i = 0;
while (@B) {
push @{$h{$A[$i]}},shift @B;
$i == $#A ? $i = -1 : $i == -$#A-1 ? $i = 0 : $i < 0 ? $i-- : $i+
++;
}
dd %h;
L*
There are no rules, there are no thumbs..
Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
| [reply]
[d/l]
[select] |
|
|
oh yes the reverse if for sure the best trick, but you can eliminate entirely the while loop using map instead.
#! perl
use strict;
use warnings;
use Data::Dump;
my @A = qw ( H1 H2 H3 H4);
my @B = qw (1 2 3 4 5 6 7 8 9 10);
my %h;
map {push @{$h{ $_ }},grep {defined} shift @B} (@A, reverse @A) x int
+($#B / $#A) ;
dd %h;
L*
UPDATE: with help of choroba i realized i had no need of int nor of so much repetitons:
map {push @{$h{ $_ }}, shift @B} (@A, reverse @A) x ($#B / $#A /2)
+; ##No it is still not good..
L*
There are no rules, there are no thumbs..
Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
| [reply]
[d/l]
[select] |
|
|
This is good, but can be considerably simplified: H1 => [1, 10, 11, 20, 21],
hmm, OP has H1-> 1,8,9
Weird question :)( i need this sequence ... imagine the equation which I won't tell you )
| [reply]
[d/l]
[select] |
|
|
|
|
|
|
Re: How to get this not the usual round robin looping
by hdb (Monsignor) on Oct 13, 2015 at 08:22 UTC
|
use strict;
use warnings;
use Data::Dumper;
my @K = qw (H1 H2 H3 H4);
my @V = qw (1 2 3 4 5 6 7 8 9 10);
my %hash;
my $i = -1;
push @{ $hash{ $K[ ++$i&4 ? 3-$i%4 : $i%4 ] } }, $_ for @V;
print Dumper \%hash;
UPDATE: ...or...
push @{ $hash{ $K[ int 3.5*abs sin (0.19634954085+0.39269908170*++$i)
+] } }, $_ for @V;
| [reply]
[d/l]
[select] |
|
|
| [reply]
[d/l]
[select] |
|
|
Well spotted! Right now I cannot think of something as terse as this for the general solution. The $i&4 basically tells the ups and downs and would need to be replaced by something like int($i/@K)&1 (not tested). The line based on sin will not work for large arrays @K as sin is not linear enough for that...
Update: This should work:
push @{ $hash{ $K[ int(++$i/@K)&1 ? @K-1-$i%@K : $i%@K ] } }, $_ for @
+V;
| [reply]
[d/l]
[select] |
|
|
| [reply] |
|
|
| [reply] |
Re: How to get this not the usual round robin looping
by Anonymous Monk on Oct 13, 2015 at 12:21 UTC
|
Wow... homework never had it so easy. | [reply] |
|
|
| [reply]
[d/l] |
Re: How to get this not the usual round robin looping
by AnomalousMonk (Archbishop) on Oct 16, 2015 at 12:44 UTC
|
c:\@Work\Perl\monks\fidda>perl -wMstrict -le
"use List::MoreUtils qw(part);
;;
use constant KEYS => qw(H1 H2 H3 H4);
use constant ITEMS => 'A' .. 'O';
;;
my @steps = map { @$_, reverse @$_ } [ 0 .. KEYS-1 ];
;;
my $i = 0;
my @parts = part { $steps[ $i++ % @steps ] } ITEMS;
;;
my %h;
@h{ KEYS() } = @parts;
for my $k (KEYS) {
printf qq{$k };
printf qq{'$_' } for @{ $h{$k} };
print '';
}
"
H1 'A' 'H' 'I'
H2 'B' 'G' 'J' 'O'
H3 'C' 'F' 'K' 'N'
H4 'D' 'E' 'L' 'M'
If you don't like part(), you can use
my @parts;
push @{ $parts[ $steps[ $i++ % @steps ] ] }, $_ for ITEMS;
I kinda don't like the stray $i variable wandering through the code, but if you wrap this all up in a distributor function, this is no longer an issue.
Give a man a fish: <%-{-{-{-<
| [reply]
[d/l]
[select] |
|
|
