Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

Re: Golf/Perlish solution to this problem?

by kyle (Abbot)
on Jan 31, 2008 at 03:22 UTC ( #665273=note: print w/replies, xml ) Need Help??


in reply to Golf/Perlish solution to this problem?

I had a working solution by the time the second one was posted, but I've been sitting here watching the thread and pasting all the solutions into the test framework I made. Here's what I came up with:

sub kyle { my @array = @_; my @other_array = ( map( $_ % 2 ? ( $array[ -$_ ], $array[ $_ - 1 ] ) : ( $array[ $_ - 1 ], $array[ -$_ ] ), 1 .. @array / 2 ), ( $array[ @array / 2 ] ) x !!( @array % 2 ) ); return "@other_array"; }

Note that the silly x!! business after the map is there to handle an odd number of elements that I didn't know would never be an input. The formatting is by perltidy because mine was ugly.

Anyway, here's the test framework and all the code posted so far in one steaming package:

#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Exception; my @solutions = ( 'Cody_Pendant', \&Cody_Pendant, 'kyle', \&kyle, 'GrandFather1', \&GrandFather1, 'GrandFather2', \&GrandFather2, 'rjray', \&rjray, 'lidden', \&lidden, 'jwkrahn', \&jwkrahn, 'hipowls', \&hipowls, 'ikegami1', \&ikegami1, 'ikegami2', \&ikegami2, 'tye', \&tye, 'BrowserUk', \&BrowserUk, ); my @tests = ( [ 1 .. 8 ], [ 1 .. 16 ], ); plan 'tests' => scalar @tests * scalar @solutions; # Cody_Pendant's results are the definition of 'correct' my @correct = map { Cody_Pendant( @$_ ) } @tests; # this loop does the actual testing. while ( @solutions ) { my ( $name, $s ) = ( shift @solutions, shift @solutions ); foreach my $n ( 0 .. $#tests ) { my $test = $tests[$n]; my $test_name = sprintf '%s( %d .. %d )', $name, $test->[0], $test->[-1] +; my $lives = lives_ok( sub { $s->( @{$test} ) }, "$test_name executes and survives" ); SKIP: { skip "$test_name died", 1 if ! $lives; is( $s->( @{$test} ), $correct[$n], "$test_name" ); } } } ### solutions follow ### sub kyle { my @array = @_; my @other_array = ( map( $_ % 2 ? ( $array[ -$_ ], $array[ $_ - 1 ] ) : ( $array[ $_ - 1 ], $array[ -$_ ] ), 1 .. @array / 2 ), ( $array[ @array / 2 ] ) x !!( @array % 2 ) ); return "@other_array"; } sub Cody_Pendant { my @array = @_; my @other_array = (); while (@array) { if ( $array[0] % 2 ) { push( @other_array, pop(@array), shift(@array) ); } else { push( @other_array, shift(@array), pop(@array) ); } } return "@other_array"; } sub rjray { my @array = @_; my @other = (); while ((@array % 4) == 0) { push(@other, $array[$#array], @array[0, 1], $array[$#array - 1 +]); splice(@array, 0, 2); splice(@array, -2); } return "@other"; } sub GrandFather1 { my @array = @_; my @other; while (@array) { push @other, @array[-1, 0, 1, -2]; splice @array, 0, 2; splice @array, -2, 2; } return "@other"; } sub GrandFather2 { my @array = @_; my @other; push @other, @array[-$_ * 2 - 1, $_ * 2, $_ * 2 + 1, -$_ * 2 -2] for 0 .. $#array / 4; return "@other"; } sub lidden { my @array = @_; my @other_array; @other_array = pop @array; while (@array > 3) { push @other_array, splice @array, 0, 2; push @other_array, reverse splice @array, -2; } push @other_array, splice @array, 0, 2 if @array > 1; push @other_array, shift @array if @array; return "@other_array"; } sub jwkrahn { my @array = @_; my @other_array; for ( 0 .. @array / 2 ) { my ( $lower, $upper ) = ( shift @array, pop @array ); push @other_array, $lower % 2 ? ( $upper, $lower ) : ( $lower, + $upper ); } return "@other_array"; } sub hipowls { my @array = @_; # I don't think I understood hipowls's solution my $n = @array; my @other_array = map { $n + 1 - $_, $_ } 1 .. $n / 2; return "@other_array"; } sub ikegami_a { @_<2 ? @_ : ((pop),(shift),&ikegami_b) } sub ikegami_b { @_<2 ? @_ : ((shift),(pop),&ikegami_a) } sub ikegami1 { my @array = @_; my @other_array = ikegami_a(@array); return "@other_array"; } sub ikegami2a { @_ ? (@_[-1,0,1,-2],ikegami2a(@_[3..$#_-3])) : () } sub ikegami2 { my @array = @_; my @other_array = ikegami2a(@array); return "@other_array"; } sub tye { my @array = @_; my $hi = $array[-1]; my $lo = 1; my @other_array = map $_ & 2 ? $lo++ : $hi--, 1..$hi; return "@other_array"; } sub BrowserUk { my @array = @_; my @other_array = sub{map{pop,shift,shift,pop}1..@_/4}->(@array); return "@other_array"; } sub example { my @array = @_; my @other_array; return "@other_array"; }

I found testing these almost as interesting as the problem itself, so I'm going to blab a bit now about the testing.

  • It's fairly data-driven, so interested monks should have no problem having it focus only on a particular solution or any input cases they want.
  • Some of the solutions actually crash ("Modification of non-creatable array value attempted, subscript -2"), so I had to add Test::Exception to the testing. This was especially important when I was tossing in tests like [ 3 .. 11 ].
  • Some of these toss out a bunch of warnings. I haven't considered it significant, but it would be interesting to add tests for it (probably using $SIG{__WARN__}).

Update: Added the solution from BrowserUk.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://665273]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others lurking in the Monastery: (7)
As of 2021-01-15 20:52 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Notices?