Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

Puzzle: Given an array of integers, find the best sequence of pop / shift...

by TedPride (Priest)
on Mar 20, 2006 at 02:26 UTC ( #537857=perlquestion: print w/ replies, xml ) Need Help??
TedPride has asked for the wisdom of the Perl Monks concerning the following question:

You are given a random, even number of integers (for testing purposes, let's say the following):

16 2 10 2 9 17 5 8 15 14 20 19 19 11 10 11 9 13 7 13

You and some other player take turns choosing either the leftmost element (shift) or the rightmost element (pop). You go first. The objective is to achieve the highest total score: your choices minus the other player's choices. For instance, if you were given the following:

2 8 4 5

The best sequence of moves would be:

pop 5 shift 2 shift 8 ? 4 Best score: 7
You assume of course that the other player also picks his best move each time.

The big question is, can you write a script that will give you the best moves for the first sequence of numbers above, for a total score of 10? The same script must also be able to generate the sequence of best moves for an array of 1000 numbers without taking more than a minute or running you out of memory. My script produces the following:
shift 16 pop 13 pop 7 pop 13 pop 9 pop 11 pop 10 pop 11 pop 19 pop 19 pop 20 pop 14 pop 15 pop 8 pop 5 pop 17 pop 9 shift 2 shift 10 ? 2 Best score: 10
With the following code:
use strict; use warnings; my (@n, @s, $n, $i, $flip, $l, $total); #for (1..1000) { # push @n, (int rand 20) + 1; #} @n = split / /, '16 2 10 2 9 17 5 8 15 14 20 19 19 11 10 11 9 13 7 13' +; print "@n\n\n"; for (0..($#n-1)) { if ($n[$_] > $n[$_+1]) { push @{$s[0]}, ['L', $n[$_] - $n[$_+1]]; } else { push @{$s[0]}, ['R', $n[$_+1] - $n[$_]]; } } for ($i = 0; $i < ($#n-1); $i++) { for (0..($#n-($i+2))) { if ($s[$i][$_][1] - $n[$_+($i+2)] < $s[$i][$_+1][1] - $n[$_]) +{ push @{$s[($i+1)]}, ['R', $s[$i][$_][1] - $n[$_+($i+2)]]; } else { push @{$s[($i+1)]}, ['L', $s[$i][$_+1][1] - $n[$_]]; } } $i++; for (0..($#n-($i+2))) { if ($s[$i][$_][1] + $n[$_+($i+2)] > $s[$i][$_+1][1] + $n[$_]) +{ push @{$s[($i+1)]}, ['R', $s[$i][$_][1] + $n[$_+($i+2)]]; } else { push @{$s[($i+1)]}, ['L', $s[$i][$_+1][1] + $n[$_]]; } } } $flip = 1; $l = 0; for (reverse 0..($#n-1)) { if ($s[$_][$l][0] eq 'L') { print "shift "; $n = shift @n; $l++; } else { print "pop "; $n = pop @n; } print "$n\n"; $total += $n * $flip; $flip *= -1; } $n = pop @n; $total += $n * $flip; print "? $n\n\n"; print "Best score: $total\n";
I'm pretty sure my code produces the best results, but I'm not 100% sure, and as you can see, the code is somewhat of a hack job. I'd like to get some more submissions so I can check my results :)

No, this is not homework. This is just for personal enjoyment.

Comment on Puzzle: Given an array of integers, find the best sequence of pop / shift...
Select or Download Code
Re: Puzzle: Given an array of integers, find the best sequence of pop / shift...
by McDarren (Abbot) on Mar 20, 2006 at 03:20 UTC
    Unless I'm missing something, I reckon your solution is a lot more complex than it needs to be.

    Given that "the other player also picks his best move", then all you need to do is determine which produces the higher score - a pop-first, or a shift-first.

    This is my go at it:

    #!/usr/bin/perl -wl use strict; my @numbers = qw(16 2 10 2 9 17 5 8 15 14 20 19 19 11 10 11 9 13 7 13) +; my $shiftscore = checkscore("shift"); @numbers = qw(16 2 10 2 9 17 5 8 15 14 20 19 19 11 10 11 9 13 7 13); my $popscore = checkscore("pop"); my $bestscore = $popscore > $shiftscore ? $popscore : $shiftscore; print "POP:$popscore:SHIFT:$shiftscore"; print "Best Score:$bestscore"; sub checkscore { my $first_turn = shift; my ($player, $opponent); $player = $first_turn eq "pop" ? pop(@numbers) : shift(@numbers); while (@numbers) { $opponent += $numbers[0] > $numbers[-1] ? shift(@numbers) : pop(@numbers); last if !@numbers; $player += $numbers[0] > $numbers[-1] ? shift(@numbers) : pop(@numbers); } return ($player - $opponent); }
    Which gives:
    POP:4:SHIFT:10 Best Score:10

    Update: To test how long it takes with 1000 numbers I added the following lines:.

    use List::Util qw(shuffle); my @numbers = shuffle(1 .. 1000); print join(" ", @numbers); my @copy = @numbers; my $shiftscore = checkscore("shift"); @numbers = @copy; my $popscore = checkscore("pop");
    And I get something like this:
    POP:4354:SHIFT:7452 Best Score:7452 real 0m0.049s user 0m0.030s sys 0m0.000s
    PS: Like the OP, I'm not 100% sure that I'm getting correct results - and I'm not sure how to verify it for very large ranges, I guess I'll just wait for some more responses :)

    Update 2: - as tilly has pointed out, my solution is wrong. I kindof suspected that it would be - because it seemed too simple. And although I acknowledged further down in the thread that it was wrong, I forgot to add an update here.

    Cheers,
    Darren :)

      Because most people are not following this discussion they may not have noticed that Darren's solution is wrong.

      What he's written is to make the best choice at every turn based on the assumption that both players will thereafter play by a greedy strategy. However the greedy solution is suboptimal play, and the smart opponent will not do that.

      As an example for the game 38 67 63 43 83 66, Darren's solution says that if you pop, you'll get a final score of 4, versus -26 if you shift, so you should pop. In fact by shifting you can get a score of 8, while with pop you can be forced to a score of -8.

Re: Puzzle: Given an array of integers, find the best sequence of pop / shift...
by TedPride (Priest) on Mar 20, 2006 at 05:34 UTC
    First of all, you have to give the sequence of moves. You can't just say how many of each and then give a total - that would be far too easy. Secondly, it is not nearly as simple a problem as it appears. Take, for instance, the following:

    4 10 3 1

    The 4 is largest, so you take it, right? But wait! This leaves the enemy with the ability to take 10. We can't have that. So we instead take 1, thus forcing the enemy to take 4 or 3 (they pick 4), leaving us with the 10 and them with the 3. Our total score is now 4, vs the -4 we would have had if we'd picked the 4 at the beginning.

    My point is that making any choice involves knowing what the best scores are for the two branches, each of which needs to know what the best scores are for the two branches further down, etc. etc. You can do this with recursion (2^n), but it's inefficient since you end up doing a lot of the calculations multiple times, so the best approach is bottom up, starting with all the pairs, then moving to triples, quadruples, etc. until you have only one set. This is (n^2)/2, which is much better.

    For instance:

    4 10 3 1
    R6 L7 L2
    L3 L-8 (enemy subtracts and picks smallest)
    R4

    So the best choices are pop (1), shift (4), shift (10), ? (3).

      but it's inefficient since you end up doing a lot of the calculations multiple times,

      use Memoize;
        Memoize only reduces the work, it doesn't eliminate checking to see if it's already done.

        For N=1000, 2^n ~~ 1e301, while n^2/2 ~~ 1e5. The first will never finish in the lifetime of the universe, the second in a blink of an eye.

        -QM
        --
        Quantum Mechanics: The dreams stuff is made of

        Memoize will work, but it's not magic. The simplest way to write the function is as follows:
        sub get_move_score { my @numbers = @_ or return("end", "", 0); return "shift", $numbers[0], $numbers[0] if 1 == @numbers; my $shift = shift @numbers; my $pop = pop @numbers; my $score_shift = $shift - (get_move_score(@numbers, $pop))[2]; my $score_pop = $pop - (get_move_score($shift, @numbers))[2]; if ($score_pop > $score_shift) { return "pop", $pop, $score_pop; } else { return "shift", $shift, $score_shift; } }
        Now if you memoize that and try to run it for a list of n numbers, the memory requirements are O(n**3). (You wind up calling it for O(n) starting points, with O(n) ending points, with an argument list of length O(n) passed in.) For a list of 1000 numbers, that means that you'll need to store order of a billion or so numbers. (Less a factor of 6 or so, I could work it out.) Given how Perl hogs memory, and what most PCs are capable of, your implementation will probably fail on account of running out of memory.

        You can fix that by having @numbers be in a global array, and then only pass in the start and end points of the list. But now if you want to play more than one game, you're hosed. (Unless you read the documentation for Memoize, and correctly call memoize/unmemoize in pairs.)

        Which means that in this case it is better to understand what the program is supposed to do, and explicitly build up your own data structure.

Re: Puzzle: Given an array of integers, find the best sequence of pop / shift...
by Anonymous Monk on Mar 20, 2006 at 09:26 UTC
    Notice that if the first person takes a number which is at an odd index, the first person can only choose an even index number and vice versa. This strategy can be maintained through out the game by the first person so by summing the odd and even numbers and picking accordingly the first person can garantue a tie, but most likely win.

      What the 4377 are you talking about? They have no choice about indexes. They can only take from one end of the list or the other. Theoretically, both players can choose to always shift, which means they're both doing even indexes all the time. But that means nothing.

      Anyway, your "strategy" is too simple to work, because any successful strategy doesn't ignore the actual values of the numbers in the list. :-)

      But maybe you have some other meaning for the word "index" in mind.

      We're building the house of the future together.
        Nope, he's spot on. The decision player one gets to make is at the beginning.

        imagine a 6 element list...

        The beginning, bottom row is the number, top row is odds/evens flag. 1 0 1 0 1 0 5 1 3 4 5 3 player 1 totals the odds and the evens, decides to go for odds, and takes from the left 1 0 1 0 1 0 1 3 4 5 3 player 2 has to take an even element, lets say from the right 1 0 1 0 1 0 1 3 4 5 player 1 is after odds, so takes from the right 1 0 1 0 1 0 1 3 4 hmmm, player two is left with the evens again. 1 0 1 0 1 0 1 3 player 1 sticks with odds 1 0 1 0 1 0 1 player two takes the last even element, and loses

        If you try this strategy on the example numbers the OP gave, you win by ten, which is as good as strategy in the OP's example code.

        ---
        my name's not Keith, and I'm not reasonable.
      You can tie or win with this strategy, but you don't get the best possible score. So it doesn't solve the puzzle.
Re: Puzzle: Given an array of integers, find the best sequence of pop / shift...
by tilly (Archbishop) on Mar 20, 2006 at 17:55 UTC
    #! /usr/bin/perl -w use strict; my @numbers = @ARGV ? @ARGV : qw(2 8 4 5); # Scores is a 2-dim array, $scores[$i][$j] is the best score # that you can get given a string of $j numbers starting at # $numbers[$i]. my @scores; for (0..$#numbers) { $scores[$_][1] = $numbers[$_]; } for my $j (2..@numbers) { for my $i (0..(@numbers - $j)) { my $a = $numbers[$i] - $scores[$i+1][$j-1]; my $b = $numbers[$i+$j-1] - $scores[$i][$j-1]; $scores[$i][$j] = ($a > $b) ? $a : $b; } } my $i = 0; for my $j (reverse 1..$#numbers) { if ($numbers[$i] - $scores[$i+1][$j] > $numbers[$i+$j] - $scores[$i] +[$j]) { print "shift $numbers[$i]\n"; $i++; } else { print "pop $numbers[$i+$j]\n"; } } print "shift $numbers[$i]\n\n"; print "Best score: $scores[0][scalar @numbers]\n";
    UPDATE: Corrected conditional in the print so I print out the solution I calculated.
Re: Puzzle: Given an array of integers, find the best sequence of pop / shift...
by Roy Johnson (Monsignor) on Mar 20, 2006 at 18:26 UTC
    It seems to me that the best strategy is to always take the element that is best in relation to its neighbor. So if you have a list a b ... c d, you shift if a-b > d-c, and pop if the reverse is true. If the differences are equal, then you should probably resort to lookahead, but it's not clear to me what lookahead strategy should be.

    Update: Tilly shot a hole in that strategy, so I'll try again here rather than proliferating response nodes. If the number of nodes is fewer than 6, the above strategy should hold. For > 6, a b c ... d e f, calculate the differences a-b, b-c, e-d, and f-e. Call the "current score" of the field a-b + f-e. Depending on whether you shift or pop, the "new score" would be a-b + e-d or b-c + f-e. Choose whichever makes the bigger negative difference (changing the game the most to your opponent's disadvantage).

    Update 2: But it still doesn't get the best result for the example data. :-(


    Caution: Contents may have been coded under pressure.
      Your strategy fails with 3 1 2 100 5 4. (a - b = 2 is greater than 4 - 5 = -1, but you want to pop first.)

      Update: The reason why you want to pop first is because then the game goes:

      1: pop 4
      2: shift 3
      1: shift 1
      2: pop 5
      1: pop 100
      2: shift 2
      
      and your score is 95. If you shift first then the game goes:
      1: shift 3
      2: pop 4
      1: shift 3
      2: shift 1
      1: pop 5
      2: pop 100
      1: shift 2
      
      and your score is 90.

      UPDATE 2: I had the scores right but the sequence of moves wrong. Sorry.

      I believe that no strategy of that type can possibly work. Here's an example where a number 10 in changes whether it is better to pop or shift first:
      0.631752274168395 0.502325774658843 0.0553136679912676 0.696650395168113 0.904058789590099 0.83366887317402 0.676563261504992 0.620510190454731 0.835401306610937 0.331025798953092 100 0.460845097973213 0.0150072228842113 0.0863915966693014 0.252652201491809 0.0344964741543734 0.277799160386071 0.358041640281542 0.984148718850204 0.846530682637557
      (With the 100 there, you should shift, remove it and you should pop.)

      Here is the program that I wrote to find that strategy:

      #! /usr/bin/perl -w use strict; my $n = shift || 4; my $tries = shift || 4**$n; for (1..$tries) { my @num = map rand, 1..$n, 1..$n; $num[$n] = 0; my $iter = get_move_iter(@num); my ($move) = $iter->(); $num[$n] = 100; $iter = get_move_iter(@num); my ($move2) = $iter->(); if ($move eq $move2) { print "Try $_ was same\n"; } else { print "Got $move vs $move2:\n@num\n"; last; } } # Scores is a 2-dim array, $scores[$i][$j] is the best score # that you can get given a string of $j numbers starting at # $numbers[$i]. sub get_scores { my @numbers = @_; my @scores; for (0..$#numbers) { $scores[$_] = [0, $numbers[$_]]; } for my $j (2..@numbers) { for my $i (0..(@numbers - $j)) { my $a = $numbers[$i] - $scores[$i+1][$j-1]; my $b = $numbers[$i+$j-1] - $scores[$i][$j-1]; $scores[$i][$j] = ($a > $b) ? $a : $b; } } return @scores; } sub get_move_iter { my @n = @_; my @scores = get_scores(@n); my $i = 0; my $j = $#n; return sub { if ($j < 0) { return; } elsif ($n[$i] - $scores[$i+1][$j] > $n[$i+$j] - $scores[$i][$j]) { $j--; return "shift", $n[$i++]; } else { return "pop", $n[$i + $j--]; } }; }
Re: Puzzle: Given an array of integers, find the best sequence of pop / shift...
by TedPride (Priest) on Mar 20, 2006 at 18:37 UTC
    Yay, tilly seems to have a correct (and prettier than mine) solution! I knew there was a way to make the basic algorithm neater. For those of you doing the pairs method, can you come up with a solution with a best score of 65 for the following 100 numbers?
    16 16 9 5 12 14 18 10 12 20 20 10 10 20 11 18 5 7 19 11 2 6 15 5 20 5 +6 18 2 6 20 4 4 18 8 12 7 14 10 10 9 12 12 8 7 11 19 3 12 12 2 20 13 +18 15 12 2 8 3 19 20 20 1 15 14 19 17 13 9 15 20 13 5 3 19 2 8 14 15 +7 11 11 7 11 9 3 2 7 14 12 20 20 1 17 5 5 11 4 15 15
    My order is:

    shift 16, shift 16, shift 9, pop 15, pop 15, pop 4, shift 5, shift 12, pop 11, pop 5, shift 14, shift 18, shift 10, shift 12, shift 20, shift 20, shift 10, shift 10, shift 20, shift 11, shift 18, shift 5, shift 7, shift 19, shift 11, shift 2, pop 5, pop 17, pop 1, pop 20, pop 20, pop 12, pop 14, pop 7, pop 2, pop 3, pop 9, pop 11, pop 7, pop 11, pop 11, pop 7, pop 15, pop 14, pop 8, pop 2, pop 19, pop 3, shift 6, shift 15, shift 5, shift 20, shift 5, shift 6, shift 18, shift 2, shift 6, shift 20, shift 4, shift 4, shift 18, shift 8, shift 12, shift 7, shift 14, shift 10, shift 10, shift 9, shift 12, shift 12, shift 8, shift 7, shift 11, shift 19, shift 3, shift 12, shift 12, shift 2, shift 20, shift 13, shift 18, shift 15, shift 12, shift 2, shift 8, shift 3, shift 19, shift 20, shift 20, shift 1, shift 15, shift 14, shift 19, shift 17, shift 13, shift 9, shift 15, shift 20, shift 13, ? 5

    tilly's order is:

    pop 15, pop 15, shift 16, pop 4, shift 16, pop 11, shift 9, pop 5, shift 5, pop 5, pop 17, shift 12, pop 1, shift 14, shift 18, shift 10, shift 12, pop 20, pop 20, pop 12, pop 14, pop 7, pop 2, pop 3, pop 9, pop 11, pop 7, pop 11, pop 11, pop 7, pop 15, pop 14, pop 8, shift 20, pop 2, shift 20, pop 19, shift 10, pop 3, pop 5, pop 13, shift 10, pop 20, shift 20, pop 15, pop 9, pop 13, shift 11, shift 18, shift 5, shift 7, pop 17, pop 19, shift 19, shift 11, shift 2, shift 6, pop 14, pop 15, pop 1, pop 20, shift 15, shift 5, pop 20, shift 20, pop 19, shift 5, pop 3, pop 8, pop 2, pop 12, shift 6, shift 18, shift 2, shift 6, pop 15, shift 20, pop 18, shift 4, shift 4, shift 18, shift 8, shift 12, shift 7, pop 13, pop 20, pop 2, shift 14, shift 10, shift 10, shift 9, pop 12, pop 12, pop 3, pop 19, pop 11, pop 7, pop 8, pop 12, shift 12

    I'm still trying to figure out why our solutions are different, while still arriving at the same solution.

      My solution was correct. But the printing of my solution was incorrect. Here is the corrected solution.
      #! /usr/bin/perl -w use strict; my @numbers = @ARGV ? @ARGV : qw(2 8 4 5); # Scores is a 2-dim array, $scores[$i][$j] is the best score # that you can get given a string of $j numbers starting at # $numbers[$i]. my @scores; for (0..$#numbers) { $scores[$_][1] = $numbers[$_]; } for my $j (2..@numbers) { for my $i (0..(@numbers - $j)) { my $a = $numbers[$i] - $scores[$i+1][$j-1]; my $b = $numbers[$i+$j-1] - $scores[$i][$j-1]; $scores[$i][$j] = ($a > $b) ? $a : $b; } } my $i = 0; my $score = 0; for my $j (reverse 1..$#numbers) { # print "@numbers[$i..($i+$j)]\n"; if ($numbers[$i] - $scores[$i+1][$j] > $numbers[$i+$j] - $scores[$i] +[$j]) { print "shift $numbers[$i]\n"; $score = $numbers[$i] - $score; $i++; } else { print "pop $numbers[$i+$j]\n"; $score = $numbers[$i+$j] - $score; } } print "shift $numbers[$i]\n\n"; $score = $numbers[$i] - $score; $score *= -1; print "Score: $score\n"; print "Best score: $scores[0][scalar @numbers]\n";

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://537857]
Approved by GrandFather
Front-paged by sulfericacid
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (9)
As of 2014-07-30 02:00 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (229 votes), past polls