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;
}
[download]

Output:

{ H1 => [1, 8, 9], H2 => [2, 7, 10], H3 => [3, 6], H4 => [4, 5] }
[download]

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);
...
[download]

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;
[download]

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],
}
[download]

Hello kcott,

This is good, but can be considerably simplified:

#! 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;
[download]

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 >
[download]

:-)

Athanasius <°(((>< contra mundum

Iustus alius egestas vitae, eros Piratica,

"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.

— Ken

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 ];
[download]

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 ] ];
}
[download]

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;
[download]

لսႽ† ᥲᥒ⚪⟊Ⴙᘓᖇ Ꮅᘓᖇ⎱ Ⴙᥲ𝇋ƙᘓᖇ

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;
[download]



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.

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;
[download]



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..
[download]


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.

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 )

My humble solution:

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;
[download]

UPDATE: ...or...

push @{ $hash{ $K[ int 3.5*abs sin (0.19634954085+0.39269908170*++$i) 
+] } }, $_ for @V;
[download]

chapeau for your solutions, but while i was reading them to appreciate how bad i was to not studied math (quite at all), i realized that your two push lines work only for 0 to 3. has your math solution the possibility to abstract this and using the index of a variable @K?

thanks
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.

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;
[download]

"My humble solution"

I guess this a typical case of total underestimation.

Update: What a cool solution!

Best regards, Karl

«The Crux of the Biscuit is the Apostrophe»

You are exaggerating!

Here's a variation on hdb's (nice++) approach that uses List::MoreUtils::part():

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'
[download]

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.

Wow... homework never had it so easy.

if the OP understand half of given solutions is valid homework.
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.