About two years ago, Veritasium posted The Riddle That Seems Impossible Even If You Know The Answer on Youtube. Today i was rewatching that video, because after seeing it initially i had some doubts, and it was a bit of an itch i finally decided to scratch.

The basic riddle goes something like this (watch the video for a much more coherent explanation AND the solution):

  1. You have 100 prisoners, each with a number.
  2. There is a room with 100 (numbered) boxes, and every prisoner number is in one random box.
  3. Prisoners enter the room one by one
  4. Each prisoner can open 50 boxes and search for their prisoner number.
  5. Each prisoner has to leave the room exactly as he found it.
  6. If ALL prisoners find their own number, everyone goes free.
  7. If even a single prisoner fails to finds his number, everyone stays in jail.
  8. Prisoners can decide on a tactic BEFORE the event, but can't communicate in any way DURIN the event.

If prisoners just do random sampling, their chances are 0.5**100 = 0.0000000000000000000000000000008.

Is there a better tactic? (Rest of the post in spoiler tags if you want to have a go on the problem yourself).

According to Veritasium, the solution is this: Every prisoner picks the box with their number on top (=prisoner 42 picks box 42) to start with. He opens the box. If the box doesn't contain his number, he then picks the box with THAT number to open next, and so on. This improves the chances for the whole group to 0.31 (31%).

I'm not good at doing mathematics proves, or writing scientific papers. My one (and only) real talent is crunching data with software. But, wait. This IS a problem you can simulate! No math degree, no AI, just throw some raw CPU cycles at the problem and see if we can get a reasonable match to the results Veritasium posted.

#!/usr/bin/env perl
# https://www.youtube.com/watch?v=iSNsgj1OCLA

use v5.40;

use strict;
use warnings;
use diagnostics;

use Array::Contains;

my $PRISONERCOUNT = 100; # How many prisoners
my $OPENBOXES = $PRISONERCOUNT / 2; # Every prisoner can open half the
+ boxes
my $LOOPCOUNT = 10_000;
my $DEBUG = 0;
STDOUT->autoflush(1);

my @results = (0, 0);

for(my $l = 0; $l < $LOOPCOUNT; $l++) {
    if($DEBUG) {
        print "== SIMULATION $l ==\n";
    } elsif($l % 100 == 0) {
        print "== SIMULATION $l of $LOOPCOUNT ==\r"; # non-debug: over
+write the line without scrolling
    }
    $results[simulate()]++;
}

print "\n";
print "Success:   ", $results[1], "\n";
print "Fail:      ", $results[0], "\n";
print "Fail rate: ", $results[0] / ($results[0] + $results[1]) * 100, 
+"%\n";


sub simulate {
    my $boxes = generateBoxes();
    DumpBoxes($boxes) if($DEBUG);
    print "Checking prisoner " if($DEBUG);
    for(my $i = 0; $i < $PRISONERCOUNT; $i++) {
        print $i, " " if($DEBUG);
        if(!checkBoxes($boxes, $i, $OPENBOXES)) {
            print "Failed!\n" if($DEBUG);
            return 0;
        }
    }
    print "OK\n" if($DEBUG);
    return 1;
}

sub generateBoxes {
    print "Generating boxes...\n" if($DEBUG);
    my @boxes;

    while(scalar @boxes < $PRISONERCOUNT) {
        my $prisoner = int(rand($PRISONERCOUNT));
        if(!contains($prisoner, \@boxes)) {
            push @boxes, $prisoner;
        }
    }

    return \@boxes;
}

sub checkBoxes($boxes, $prisoner, $count) {
    my $currentbox = $prisoner;
    
    while($count) {
        my $val = $boxes->[$currentbox]; # Get content of current box
        if($val == $prisoner) {
            return 1;
        }
        $currentbox = $val;
        $count--;
    }

    return 0;
}

sub DumpBoxes($boxes) {
    print "---- BOXES -------------\n";
    for(my $i = 0; $i < $PRISONERCOUNT; $i++) {
        print $i, " =>  ", $boxes->[$i], "\n";
    }
    print "---- LOOPS -------------\n";

    my @seen;
    for(my $i = 0; $i < $PRISONERCOUNT; $i++) {
        my $currentbox = $i;
        my $count = 100;
        my $ok = 1;
        my @current;
        while($count) {
            if(contains($currentbox, \@seen)) {
                $ok = 0; # Part of already known loop
                last;
            }
            push @current, $currentbox;
            my $val = $boxes->[$currentbox];
            if($val == $i) {
                last; # Loop done
            }
            $currentbox = $val;
        }

        if($ok) {
            print join(' ', @current), "\n";
            push @seen, @current;
        }
    }
    print "------------------------\n";

    return;
}

[download]

And it seems to be a relatively good match:

$ perl simulate.pl 
== LOOP 99900 ==
Success:   31139
Fail:      68861
Fail rate: 68.861%

[download]

And if we activate $VERBOSE, we can get a simple view of those loops Veritasium was talking about:

---- LOOPS -------------
0 72 86 73 80
1 96 19 83 91 47 75 18 53 3 50 24 81 59 38 23 44 67 39 55 65
2 20 45 98 84 89 63 93 46 58 68 28 56 64 78 6 87 52 8 82 97 34 31 85 7
+9 12 41 48 70 66 37 5 49 33 51 15 57 54 69 90 26 43 14 94 76 9 88 40
4 42 25 99 27 77 16 10 74 36 22
7 13 71 61 62 11 95 21 17 30
29
32
35 60 92
------------------------

[download]

Frankly, even having programmed a full simulation of the solution myself, it still absolutely boggles my mind that this actually works at all. Maths is weird.

PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
Also check out my sisters artwork and my weekly webcomics

Replies are listed 'Best First'.
Re: Proving Veritasiums riddle using Perl
by pfaut (Priest) on Apr 30, 2025 at 20:19 UTC

    Very interesting problem and very interesting algorithm. Statistics are very often counter-intuitive.

    I think setting up the boxes might be easier and faster with something like Array::Shuffle.

    90% of every Perl application is already written. ⇒
    dragonchild
[reply]

      I think setting up the boxes might be easier and faster with something like Array::Shuffle.

      Yes. And it would be way faster. My randomizer as probably the least efficient version possible.

      The other variant would probably to just generate the array of numbers, then randomly select and splice.

      I just wanted to do a qick proof of concept without looking up anything and hand-rolled algos (without modules) so i can easily play with every part to see what happens. I do Perl 40 hours a week at work¹, this one was a just-for-fun little home project without any code quality and/or maintainability requirements ;-)

      ¹ all to do with Point-of-Sales stuff and financial data. I nearly never get to use rand() based stuff, so i'm a bit rusty in that regard

      PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
      Also check out my sisters artwork and my weekly webcomics
[reply]

        Cool program. It's much faster using a shuffle.

        Your code:

        % time perl prisoners-orig.pl
== SIMULATION 9900 of 10000 ==
Success:   3085
Fail:      6915
Fail rate: 69.15%
perl prisoners-orig.pl  13.09s user 0.01s system 99% cpu 13.101 total

        [download]

        Modified to use Array::Shuffle:

        % time perl prisoners.pl     
== SIMULATION 9900 of 10000 ==
Success:   3175
Fail:      6825
Fail rate: 68.25%
perl prisoners.pl  0.71s user 0.00s system 99% cpu 0.716 total

        [download]

        Diff:

        Read more... (1035 Bytes)
        90% of every Perl application is already written. ⇒
        dragonchild
[reply]
[d/l]
[select]
Re: Proving Veritasiums riddle using Perl
by jo37 (Curate) on May 03, 2025 at 19:40 UTC

    Neither did I reveal the spoiler, nor did look at the Youtube post.

    The arrangement of the prisoners' numbers in the boxes is a permutation of 100 numbers. Every permutation consists of a number of cycles. I believe that chances are not too high that any given permutation has a cycle that is larger than half of the number of its elements. When every prisoner follows the cycle starting with his own number, they will stay in prison only if there is a cycle larger than 50 in the given permutation.

    I don't want to claim this strategy would be optimal, but it looks like chances of getting free are around 0.31 with this approach. 

    #!/usr/bin/perl

use v5.16;
use warnings;
use List::Util 'shuffle';
use constant N => 100000;

sub doit {
    my @box = shuffle 0 .. 99;

    prisoner:
    for my $prisoner (0 .. 99) {
        my $box = $prisoner;
        for (0 .. 49) {
            my $found = $box[$box];
            next prisoner if $prisoner == $found;
            $box = $found;
        }
        return;
    }
    1;
}
my $success;
for (1..N) {
    $success++ if doit();
}

say $success / N;
__DATA__
0.31257

    [download]

    Greetings,
    🐻

    $gryYup$d0ylprbpriprrYpkJl2xyl~rzg??P~5lp2hyl0p$
[reply]
[d/l]
      > The arrangement of the prisoners' numbers in the boxes is a permutation of 100 numbers. Every permutation consists of a number of cycles

      That's impressive!,

      ... but I suppose you had former training in permutation groups and cycle notation?

      Like in algebra lessons at university? :)

      > don't want to claim this strategy would be optimal,

      Well no approach can be better than 0.5, so a > 0.3 chance is already damn good.

      > but it looks like chances of getting free are around 0.31 with this approach.

      Yes, no matter how many prisoners, the chances are never worse than 1 - ln 2 = 0.3068

      Cheers Rolf
      (addicted to the Perl Programming Language :)
      see Wikisyntax for the Monastery

[reply]
[d/l]
        ... but I suppose you had former training in permutation groups and cycle notation? Like in algebra lessons at university? :)

        Yes, I had.

        Greetings,
        🐻

        $gryYup$d0ylprbpriprrYpkJl2xyl~rzg??P~5lp2hyl0p$
[reply]
Re: Proving Veritasiums riddle using Perl (simulating "100 prisoners problem")
by LanX (Saint) on May 01, 2025 at 20:03 UTC
    > still absolutely boggles my mind that this actually works at all

    Without having read the solution.

    I think it's easy to see that there are strategies performing better that 0.5**N.

    Consider N=2 prisoners.

    A strategy where both prisoners choose the same box is doomed to fail, because the box can't hold both numbers. It will perform worse than on average.

    Hence the inverse strategy to always choose different boxes will perform better. And indeed it's easy to see that the success rate would be 50%. (Either both fail, or both succeed) ¹ That's far better than 0.5**2 = 25% of random picks. ²

    This could be generalized to bigger N by choosing a strategy where overlaps like in the failing strategy are minimized.

    Now I'll try watching the solution :)

    Updates

    See also 100 prisoners problem for references.

    ¹) in math lingo, the two experiments are not statistically independent anymore.

    ²) this gain is possible because there is extra information available to couple the experiments, because the boxes are ordered.

    Now imagine the warden would change the order of the boxes after each pick, and erase that information.

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    see Wikisyntax for the Monastery

[reply]

      I watched the video, and was very confused. Turns out the solution is right, but his explanation was - mildly phrased - flawed, when calculating the probability of cycles ("loops") of length N to N/2+1.

      I had to reconstruct the correct solution.

      But that's YouTube nowadays, trimmed to maximum emotional show effect for the sake of clicks

      FWIW: if you still struggle to understand the solution, try the case N=4. There are only 24 = 4! possible configurations of the boxes, this easily fits on a piece of paper.

      And you can see why there are exactly N!/C configurations with a cycle length C, for N >= C > N/2. In the case of N=4 there are

      • 6 cases with C=4 (6=4!/4)†
      • 8 cases with C=3 (8=4!/3)†

      Hence the survival rate is at 10/24.

      Cheers Rolf
      (addicted to the Perl Programming Language :)
      see Wikisyntax for the Monastery

      †) updated

[reply]
Re: Proving the 100 Prisoners Problem using Perl
by Anonymous Monk on May 04, 2025 at 05:00 UTC
    Proving Veritasiums riddle using Perl

    It's not Veritasium's. The 100 prisoners problem was first proposed by Anna Gál and Peter Bro Miltersen in 2003.

[reply]
      Neither is it "proving", it's a demonstration or simulation.

      Cheers Rolf
      (addicted to the Perl Programming Language :)
      see Wikisyntax for the Monastery

[reply]

        Yes, my phrasing was a bit poor. In my defense, i never went to Uni, so never received formal scientific training. I'm just a simple software developer.

        To be fair, in my usual use cases "works correctly to the forth digit after the comma in all cases" fullfills all my usual project requirements (as set by law). So in these circumstances simulating it to that degree is equivalent to "proof that the solution works".

        But yes, i totally agree that there is a big difference between actual mathematical proof and my 1970s-british-automotive-worker "that will do" attitude ;-)

        PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
        Also check out my sisters artwork and my weekly webcomics
[reply]

Back to Meditations