G'day tel2,

Here's my offering. It just uses length and substr. There's no: concatenation; splitting strings into lists; regexes; or modules to load.

#!/usr/bin/env perl -l

use strict;
use warnings;

print zip("ABCDEFGHIJ", "abcde");

sub zip {
    my ($str1, $str2) = @_;

    for (0 .. length $str2) {
        substr $str1, $_ * 2 + 1, 0, substr $str2, $_, 1;
    }

    return $str1;
}
[download]

Output:

AaBbCcDdEeFGHIJ
[download]

G'day mate.

Awesome work from across the ditch!

Thanks.

sub zip($$){ 
   my( $n, $a, $b ) = ( 1, @_ ); 
   substr( $a, $n, 0, $_), $n += 2 for split '', $b; 
   return $a;
};;

print zip( 'ABCDEFGHIJ', 'abcde' );;
AaBbCcDdEeFGHIJ
[download]

Thanks BrowserUk!

Nice.

Unfortunately, the following fails with this code:

   zip( 'abcde', 'ABCDEFGHIJ' );
[download]

This is a good example of why a CPAN module is usually the right choice. :-)

This is a good example of why a CPAN module is usually the right choice

Unless the programmer actually read the spec. From the OP "i.e. 1 char from each string until the 2nd string (which will be always shorter)".

Had that not been specified, or if you'd read on a little, you'd have found Re^3: Merge 2 strings like a zip [benchmark] which contains:

sub zipD($$) {
    my( $a, $b ) =  length( $_[0] ) < length( $_[1] ) ? @_[ 1, 0 ] : @
+_[ 0, 1 ];
    substr( $a, $_*2+1, 0, substr( $b, $_, 1 ) ) for 0 .. length( $b )
+ -1;
    return $a;
}
[download]

BTW, if you think all the code on CPAN is correct, you have a very rude awaking coming.

And if you feel you'll never be a better programmer than the average on CPAN; keep on using it, instead of your own brain; and you'll be right.

---

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

I'm with torvalds on this Agile (and TDD) debunked I told'em LLVM was the way to go. But did they listen!

Use a CPAN module! Preferably one that has a method that does what you want, and is called what you imagine it should be :-)

#!/usr/bin/env perl
use strict;
use warnings;
use List::MoreUtils qw/ zip /;

my @a1 = split('', 'ABCDEFGHIJ');
my @a2 = split('', 'abcde');

no warnings qw/ uninitialized /;

print zip @a1, @a2;

use warnings;

__END__
[download]

Hm.

#! perl -slw
use strict;
use Benchmark qw[ cmpthese ];
use List::MoreUtils qw[ zip ];

sub zipA {
    my( $str1, $str2 ) = @_;
    $str1 =~ s/.\K/ substr $str2, 0, 1, ''/gesr;
}

sub zipB {
    no warnings qw/ uninitialized /;
    my( $a, $b ) = @_;
    my @a1 = split( '', $a );
    my @a2 = split( '', $b );
    return join'', zip @a1, @a2;
}

sub zipC($$){
   my( $n, $a, $b ) = ( 1, @_ );
   substr( $a, $n, 0, $_), $n += 2 for split '', $b;
   return $a;
};;

our $A = 'ABCDEFGHIJ';
our $B = 'abcde';

cmpthese -1, {
    A => q[ my $zipped = zipA( $A, $B ); ],
    B => q[ my $zipped = zipB( $A, $B ); ],
    C => q[ my $zipped = zipC( $A, $B ); ],
};

__END__
C:\test>\perl5.18\perl\bin\perl.exe 1133857.pl
      Rate    B    A    C
B  43932/s   -- -48% -72%
A  84167/s  92%   -- -47%
C 159444/s 263%  89%   --
[download]

---

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

I'm with torvalds on this Agile (and TDD) debunked I told'em LLVM was the way to go. But did they listen!

"substr( $a, $n, 0, $_), $n += 2 for split '', $b;"

Excellent use of substr

The race is not always to the swift, my friend.

Remember: Ne dederis in spiritu molere illegitimi!

Hello 1nickt,

As a cleaner alternative to:

no warnings qw/ uninitialized /;

print zip @a1, @a2;

use warnings;
[download]

you can just filter the list returned by zip:

print grep { defined } zip @a1, @a2;
[download]

Hope that helps,

Athanasius <°(((>< contra mundum

Iustus alius egestas vitae, eros Piratica,

Thanks 1nickt.

While I didn't think it would be worth the overhead of a module for something so small/simple, I do appreciate your input, and I wasn't aware of that module or function.

I didn't think it would be worth the overhead of a module for something so small/simple,

• Personally I don't like the overhead of writing code that I don't need to.
• Small/simple things have a way of growing.
• There is more than one way to do it :-)
Remember: Ne dederis in spiritu molere illegitimi!

Latest benchmark:

#!/usr/bin/env perl -slw

use strict;
use Benchmark qw[ cmpthese ];
use List::MoreUtils qw[ zip ];

sub zipA {
    my( $str1, $str2 ) = @_;
    $str1 =~ s/.\K/ substr $str2, 0, 1, ''/gesr;
}

sub zipB {
    no warnings qw/ uninitialized /;
    my( $a, $b ) = @_;
    my @a1 = split( '', $a );
    my @a2 = split( '', $b );
    return join'', zip @a1, @a2;
}

sub zipC($$){
   my( $n, $a, $b ) = ( 1, @_ );
   substr( $a, $n, 0, $_), $n += 2 for split '', $b;
   return $a;
};;

sub zipD {
    my ($str1, $str2) = @_;
    for (0 .. length $str2) {
        substr $str1, $_ * 2 + 1, 0, substr $str2, $_, 1;
    }
    return $str1;
}

our $A = 'ABCDEFGHIJ';
our $B = 'abcde';

cmpthese -1, {
    A => q[ my $zipped = zipA( $A, $B ); ],
    B => q[ my $zipped = zipB( $A, $B ); ],
    C => q[ my $zipped = zipC( $A, $B ); ],
    D => q[ my $zipped = zipD( $A, $B ); ],
};
[download]

I ran it five times. This seems to be the most representative:

      Rate    B    A    C    D
B  91995/s   -- -39% -66% -72%
A 151837/s  65%   -- -45% -54%
C 274373/s 198%  81%   -- -17%
D 330831/s 260% 118%  21%   --
[download]

While the OP specified that the second string is always the shortest, I wanted one that worked without that restriction:

#! perl -slw
use strict;
use Benchmark qw[ cmpthese ];
use List::MoreUtils qw[ zip ];

sub zipA {
    my( $str1, $str2 ) = @_;
    $str1 =~ s/.\K/ substr $str2, 0, 1, ''/gesr;
}

sub zipB {
    no warnings qw/ uninitialized /;
    my( $a, $b ) = @_;
    my @a1 = split( '', $a );
    my @a2 = split( '', $b );
    return join'', zip @a1, @a2;
}

sub zipC($$){
   my( $n, $a, $b ) = ( 1, @_ );
   substr( $a, $n, 0, $_), $n += 2 for split '', $b;
   return $a;
};;

sub zipR {
    my ($s1, $s2) = @_;
    my ($ls1, $ls2, $l, $tmp) = (length($s1), length($s2));
    $l = $ls1<$ls2 ? $ls1 : $ls2;
    $tmp = join("", map{substr($s1,$_,1), substr($s2,$_,1)} 0 .. $l-1)
         . substr($l==$ls2 ? $s1 : $s2,$l);
    return $tmp;
}


sub zipD {
    my ($str1, $str2) = @_;
    for (0 .. length $str2) {
        substr $str1, $_ * 2 + 1, 0, substr $str2, $_, 1;
    }
    return $str1;
}

our $A = 'ABCDEFGHIJ';
our $B = 'abcde';

my (%tests,%results);
for my $T (qw(A B C D R)) {
    $tests{$T.'a'} = "my \$z = zip$T( \$A, \$B )";
    $tests{$T.'b'} = "my \$z = zip$T( \$B, \$A )";
    my $a = eval($tests{$T.'a'});
    my $b = eval($tests{$T.'b'});
}

my %R = ( a=>eval $tests{Ba}, b=>eval $tests{Bb} );
print "Expected: a=<$R{a}>, b=<$R{b}>";

for my $test (sort keys %tests) {
    no warnings 'uninitialized';
    my $S = eval $tests{$test};
    my $R = $R{substr($test,1,1)};
    if ($R ne $S) {
        print "test $test failed: <$S>";
        delete $tests{$test};
    }
}

cmpthese -1, \%tests;
__END__
$ perl 1133865.pl
Expected: a=<AaBbCcDdEeFGHIJ>, b=<aAbBcCdDeEFGHIJ>
test Ab failed: <aAbBcCdDeE>
test Cb failed: <>
test Db failed: <>
       Rate   Bb   Ba   Aa   Rb   Ra   Ca   Da
Bb 105326/s   --   0% -62% -69% -69% -81% -86%
Ba 105326/s   0%   -- -62% -69% -69% -81% -86%
Aa 276648/s 163% 163%   -- -18% -19% -50% -62%
Rb 336364/s 219% 219%  22%   --  -1% -39% -54%
Ra 339856/s 223% 223%  23%   1%   -- -39% -54%
Ca 553781/s 426% 426% 100%  65%  63%   -- -25%
Da 735965/s 599% 599% 166% 119% 117%  33%   --
[download]

So I have the fastest one that works without that restriction. (Prediction, someone else will hold that title within 20 minutes......)

...roboticus

When your only tool is a hammer, all problems look like your thumb.

#! perl -slw
use strict;
use Benchmark qw[ cmpthese ];
use List::MoreUtils qw[ zip ];

sub zipD($$) {
    my( $a, $b ) =  length( $_[0] ) < length( $_[1] ) ? @_[ 1, 0 ] : @
+_[ 0, 1 ];
    substr( $a, $_*2+1, 0, substr( $b, $_, 1 ) ) for 0 .. length( $b )
+ -1;
    return $a;
}

sub zipR {
    my ($s1, $s2) = @_;
    my ($ls1, $ls2, $l, $tmp) = (length($s1), length($s2));
    $l = $ls1<$ls2 ? $ls1 : $ls2;
    $tmp = join("", map{substr($s1,$_,1), substr($s2,$_,1)} 0 .. $l-1)
         . substr($l==$ls2 ? $s1 : $s2,$l);
    return $tmp;
}

our $A = 'ABCDEFGHIJ';
our $B = 'abcde';

print zipD( $A, $B ), zipD( $B, $A );
print zipR( $A, $B ), zipD( $B, $A );

cmpthese -1, {
    Dd => q[ my $zipped = zipD( $A, $B ); ],
    Rr => q[ my $zipped = zipR( $A, $B ); ],
    dD => q[ my $zipped = zipD( $B, $A ); ],
    rR => q[ my $zipped = zipR( $B, $A ); ],
};

__END__
C:\test>1133857.pl
AaBbCcDdEeFGHIJAaBbCcDdEeFGHIJ
AaBbCcDdEeFGHIJAaBbCcDdEeFGHIJ
       Rate   Rr   rR   dD   Dd
Rr  82878/s   --  -1% -43% -44%
rR  83720/s   1%   -- -42% -44%
dD 145211/s  75%  73%   --  -2%
Dd 148473/s  79%  77%   2%   --
[download]

---

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

I'm with torvalds on this Agile (and TDD) debunked I told'em LLVM was the way to go. But did they listen!

Impressive, Ken!

Oz leading the world.

#!/usr/bin/perl

# http://perlmonks.org/?node_id=1133857

use warnings;
use strict;

print zip("ABCDEFGHIJ", "abcde"), "\n";

sub zip
  {
  my ($str1, $str2) = @_;
  $str1 =~ s/.\K/ substr $str2, 0, 1, ''/gesr;
  }
[download]

Thanks for that, Anonymous Monk!

I don't fully understand it yet, but it looks beautiful. 8)

That's the first time I've seen /K and /r.  No problems with /K, but my webhost is still using v5.10.1 and I see that /r didn't come in until 5.14.  So how could I write that without the /r modifier?  I think I understand what /r is supposed to do, but I don't yet understand your code enough to replace it in this context.

I've added a 2nd (unzip) function request, below, which I'd appreciate your input on, if you have time.

Thanks again.

zip() without /r and unzip()

#!/usr/bin/perl

# http://perlmonks.org/?node_id=1133857

use warnings;
use strict;

print zip("ABCDEFGHIJ", "abcde"), "\n";

print "@{[ unzip('AaBbCcDdEeFGHIJ', 5) ]}\n";

sub zip # if no /r
  {
  my ($str1, $str2) = @_;
  $str1 =~ s/.\K/ substr $str2, 0, 1, ''/ges;
  $str1
  }

sub unzip
  {
  my ($input, $length2) = @_;
  return
    join('', unpack "(ax)$length2 a*", $input),
    join '', unpack "(xa)$length2", $input;
  }
[download]

Also, since posting my original question, I realised that I forgot to also ask for an unzip function which takes a zipped string and the length of $str2, and generates $str1 & $str2 from it.  I guess I could do it with a verbose style similar to my original function, but would love to see more elegant, concise & efficient options.  Any offers?

I would probably call it something like this:
   ($str1, $str2) = unzip('AaBbCcDdEeFGHIJ', 5);

Thanks again!

Based on my earlier zip(): this only uses substr.

#!/usr/bin/env perl -l

use strict;
use warnings;

print for unzip('AaBbCcDdEeFGHIJ', 5);

sub unzip {
    my ($str1, $len) = @_;

    my $str2 = '';

    for (0 .. $len - 1) {
        substr $str2, $_, 0, substr $str1, $_ + 1, 1, ''; 
    }

    return ($str1, $str2);
}
[download]

Output:

ABCDEFGHIJ
abcde
[download]

-- Ken

How dare you put us Kiwis to shame...again, Ken.

Thanks again and keep up the good work!

BTW, what's the 'for' for in:
   print for unzip...

I now realise my original code could have been simplified (and sped up) like this:

sub zip
{
  my ($str1, $str2) = @_;
  my $zip;
  for (0 .. length($str2)-1)
  { $zip .= substr($str1, $_, 1) . substr($str2, $_, 1) }
  $zip .= substr($str1, length($str2));
  return $zip;
}
[download]

Of course that only meets my original spec's (i.e. 2nd string must be the shortest) but it seems to be pretty fast (though I guess the concatenation would slow it down if my data was much longer).

"TIMTOWTDI"

My 2 ¢:

use warnings;
use strict;
use feature qw(say);
sub zip;

say zip 'ABCDEFGHIJ', 'abcde';

sub zip {
    join "", sort { lc $a cmp lc $b } split "", $_[0] . $_[1];
}

__END__
[download]

I guess it's slower than some of the examples above but it doesn't look bad ;-)

And i learned something. See Strange Observation [SOLVED] for details. Thanks to toolic, KurtSchwind, Athanasius and some unknown soldier.

Update: Same benchmark as used by BrowserUK:

karls-mac-mini:monks karl$ ./benchzip.pl 
         Rate    B Karl    A    C
B     98641/s   -- -17% -44% -68%
Karl 118153/s  20%   -- -33% -62%
A    176987/s  79%  50%   -- -43%
C    312785/s 217% 165%  77%   --
[download]

Regards, Karl

While in principle I would agree with the statement that there is no need to re-write existing functionality from modules (= re-inventing the wheel), I would argue strongly in favour of the striving for elegance in coding. Questions like this one have an immense value as they inspire the quest for a concise and elegant solution thus fostering an in-depth understanding of Perl's inner workings. Anyway, so much for the philosophical part of my post.

Here's my code solution now. It essentially achieves the zipping in one single line of code (if you are lenient enough not to count the conversion of one input string into a list). Lemme know what you think.



use strict;
use warnings;

my $a = "ABCDEFGHIJ";
my $b = "abcde";
my @b = split "", $b;

$a =~ s/(.)/$1.($b[length($`)] or "")/ge;

print $a;
[download]

You'll need a // operator there, otherwise it eats the 0's in $b...

An alternative:

$b = reverse $b;
$a =~ s{.\K}{chop $b}sge;
print $a;
[download]

Thanks for that, Karl.

It seems to work with my original sample data, but with this:
   say zip 'ABCDEFGH0J', 'a0cde';
it produces this:
   00AaBCcDdEeFGHJ
but should be producing this:
   AaB0CcDdEeFGH0J

New specs ;-)

First hint in a hurry: How do I do a natural sort on an array?

Regards, Karl

«The Crux of the Biscuit is the Apostrophe»

use strict;
use warnings;

my $a = "ABCDEFGHIJ";
my $b = "abcde";
my @b = split "", $b;

$a =~ s/(.)/$1.($b[length($`)] or "")/ge;

print $a;
[download]

In keeping with your philosophy, here's something completely different :)

#!/usr/bin/perl

# http://perlmonks.org/?node_id=1133857

use warnings;
use strict;

print zip("ABCDEFGHIJ", "abcde"), "\n";

sub zip
  {
  my ($str1, $str2) = @_;
  my $gap = length($str1) - 1;
  my $len2 = length $str2;

  join '', grep defined, "$str1$str2" =~ /(.)(?=.{$gap}(.)|.{$len2})/g
+s;
  }
[download]

hehehe

#!/usr/bin/perl

# http://perlmonks.org/?node_id=1133857

use warnings;
use strict;

print zip("ABCDEFGHIJ", "abcde"), "\n";

sub zip
  {
  my ($str1, $str2) = @_;
  my $len = length $str2;
  pack("(ax)$len (a)*", split //, $str1) | pack "(xa)$len", split //, 
+$str2
  }
[download]

Only one, but that doesn't stop the other 999 guys!

...roboticus

When your only tool is a hammer, all problems look like your thumb.

How many dumb pissants does it take to think the pursuit of excellence is vain?

Just to show the crowd that I can, in fact, whip-up a “one-liner” ...

perl -e 'use strict; use warnings; my $a="ABCDE"; my $b="xyz"; my $res
+ult=""; my $i; for ($i=0; $i<length($b); $i++) { $result .= substr($a
+, $i, 1) . substr($b, $i, 1) }; $result .= substr($a, $i); print "$re
+sult\n";'
[download]

If you really, really, know that one string is always shorter than the other, then this problem simply consists of taking a character from both strings until the shorter string is exhausted.   Then, you append the remainder of the first (longer) string.

But I wouldn’t make such an assumption.   I would allow either string to be longer:

use strict;
use warnings;

sub zip {
  my ($a, $b) = @_;
  my $result = "";

  my $max = ( length($a) > length($b) ) ? length($a) : length($b);

  my $i;
  for ($i = 0; $i < $max; $i++) {
    if ($i < length($a)) { $result .= substr($a, $i, 1); }
    if ($i < length($b)) { $result .= substr($b, $i, 1); }
  }
  print "$result\n";
}

zip("XYZZY", "ABC");
zip("ABC",   "XYZZY");
zip("XYZZY", "XYZZY");
zip("", "");

. . .

XAYBZCZY
AXBYCZZY
XXYYZZZZYY
[download]

“Elegant?”   “Not?”   My response is the same as Rhett Butler’s.   The algorithm can be demonstrated to work in every case, by accompanying tests, and it is easy to eyeball it.

And, yes ... if I had any other reason to install and use an existing CPAN module that can zip a string, I would use that module.   I probably would not install it, just to zip a string, since the alternative is trivial.

Elegance arises from the concise use of existing and suitable features to achieve the desired effect. Ideally, at least in my view, the solution to the problem can be stated in a declarative rather than a procedural fashion.
While I would concede that the former is not necessarily more concise, its implicit usage of features required to solve the problem will contribute to the elegance of the solution put forward. Solutions involving an explicit loop stepping through a string character-by-character hence certainly are transparent to inspection ... but way too procedural to be surprising or elegant.