#! perl -slw
use strict;

my $n = <>;
my %counts;
++$counts{ $_ } for split ' ', do{ local $/, <> };
my @sorted = sort{ $counts{$b} <=> $counts{$a} }keys %counts;

my( $i, $min, $total ) = (0) x 3;
++$min while ( $total += $counts{ $sorted[ $i++ ] } ) < $n;
print $min+1;
print for @sorted[ 0 .. $min ];
[download]

Tests:

C:\test>SpotifyComp.pl
4
1009 2000
1009 2001
1002 2002
1003 2002
^Z
2
2002
1009

C:\test>SpotifyComp.pl
2
1009 2011
1017 2011
^Z
1
2011
[download]

Actual:


> SpotifyComp.pl
4
1009 2000
1008 2001
1002 2002
1003 2002
^D
3
2002
1002
1009
[download]


Expected:


3
2002
1008 or 2001
1009 or 2000
[download]

Cool. It's also a lot faster than my version.

[rml@box current]$ time perl BrowserUK.pl sample-input.txt
2
2002
1009

real    0m0.006s
user    0m0.002s
sys    0m0.004s
[rml@box current]$ time perl rml.pl sample-input.txt
2
1009
2002

real    0m0.028s
user    0m0.023s
sys    0m0.003s
[download]

-- C-x C-c

Cool. It's also a lot faster than my version.

Yes. But unfortunately, fatally flawed.

I should never try to assess the inherent complexity of a task when approaching my personal shutdown time :) Nor take example solutions as sufficient tests.

That said, the fix to the approach doesn't seem to be too complicated, though I haven't coded it yet, so that thought might come back to bite me. Maybe I'll get to it once I cleared the non-optional tasks of my day.

---

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.

Here's my second attempt:

#! perl -slw
use strict;

my $n = <>;
my %pairings;
push( @{ $pairings{ $_->[0] } }, $_->[1] ),
push( @{ $pairings{ $_->[1] } }, $_->[0] ),
    while @{ $_ = [ split ' ', <> ] };

my $total = 0;
my @guests;
while( $total < $n ) {
    my $next = (
        sort{
            @{ $pairings{ $b } } <=> @{ $pairings{ $a } }
        } keys %pairings
    )[ 0 ];
    push @guests, $next;
    $total += @{ $pairings{ $next } };
    delete $pairings{ $_ } for @{ delete $pairings{ $next } };
}
print scalar @guests;
print for @guests;
[download]

It is still incomplete in that it doesn't yet favour employee 1009 in the event of their being an equally valid choice. I'll think about how to do that whilst I try to find an example that breaks it. (Generating random datasets is quite easy; verifying the answers produced not so:( )

Update: Added code to favour 1009:

#! perl -slw
use strict;

my $n = <>;
my %pairings;
push( @{ $pairings{ $_->[0] } }, $_->[1] ),
push( @{ $pairings{ $_->[1] } }, $_->[0] ),
    while @{ $_ = [split ' ', <> ] };

my $total = 0;
my @guests;
while( $total < $n ) {
    my( $best, $next ) = (
        sort{
            @{ $pairings{ $b } } <=> @{ $pairings{ $a } }
        } keys %pairings
    )[ 0, 1 ];

    $best = $next
        if $next == 1009
        and @{ $pairings{ $best } } == @{ $pairings{ $next } };

    push @guests, $best;
    $total += @{ $pairings{ $best } };
    delete $pairings{ $_ } for @{ delete $pairings{ $best } };
}
print scalar @guests;
print for @guests;
[download]

20
1001 2000
1002 2000
1009 2000
1011 2010
1012 2010
1013 2010
1021 2020
1022 2020
1023 2020
1031 2030
1032 2030
1033 2030
1041 2040
1042 2040
1043 2040
1100 2000
1100 2010
1100 2020
1100 2030
1100 2040
[download]

Attempt 3:

#! perl -slw
use strict;
use Algorithm::Combinatorics qw[ combinations ];

my $favourite = 1009;
my $n = <>;
my %pairings;
push( @{ $pairings{ $_->[0] } }, $_->[1] ),
push( @{ $pairings{ $_->[1] } }, $_->[0] ),
    while @{ $_ = [split ' ', <> ] };

my @ids = keys %pairings;

my %idPos; @idPos{ @ids } = 0 .. @ids;
my %posId; @posId{ values %idPos } = keys %idPos;

my @masks;
for my $id ( @ids ) {
    $masks[ $idPos{ $id } ] = '';
    vec( $masks[ $idPos{ $id } ], $idPos{ $id }, 1 ) = 1;
    vec( $masks[ $idPos{ $id } ], $idPos{ $_  }, 1 ) = 1
        for @{ $pairings{ $id } };
}

my @hits;
for my $k ( 1 .. $n ) {
    my $iter = combinations( [0 .. $#ids], $k );
    while( my $c = $iter->next ) {
        my $ored = '';
        $ored |= $masks[ $_ ] for @$c;
        my $count = unpack '%32b*', $ored;
        push @hits, [ $k, @$c ] if $count >= @ids;
    }
    last if @hits;
}

if( @hits > 1 ) {
    @hits = sort{ $a->[0] <=> $b->[0] } @hits;
    my $min = $hits[0][0];
    my $i = $#hits;
    --$i while $hits[ $i ][0] > $min;
    $#hits = $i;
    if( @hits > 1 ) {
        my $first = $hits[ 0 ];
        @hits = grep {
            scalar grep{
                $posId{ $_ } == $favourite;
            } @$_[ 0 .. $#{ $_ } ];
        } @hits;
        @hits = @hits >= 1 ? $hits[ 0 ] : $first;
    }
}

print @{ $hits[0] } -1;
print $posId{ $_ } for @{ $hits[0] }[ 1 .. $#{ $hits[ 0 ] } ];
[download]

A run:

C:\test>Bilateral2.pl
20
1001 2000
1002 2000
1009 2000
1011 2010
1012 2010
1013 2010
1021 2020
1022 2020
1023 2020
1031 2030
1032 2030
1033 2030
1041 2040
1042 2040
1043 2040
1100 2000
1100 2010
1100 2020
1100 2030
1100 2040
^Z
5
2020
2030
2000
2010
2040
[download]

---

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.

Actual:


> Bilateral2.pl
7
71 34
71 1001
72 1002
73 1003
1001 2000
1002 2000
1003 2000
^D
3
1002
71
1003
[download]


Expected:


4
1001
1002
1003
71 or 34
[download]

Nice example!

---

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.

You're right, thanks. Rewriting...

-- C-x C-c

use List::Util qw(reduce);

my (@teams, %emp);
my $n = <>;

for my $i (0 .. $n - 1)
{
    my ($e1, $e2) = (split ' ', scalar <>);
    push @{ $emp{$e1} }, $i;
    push @{ $emp{$e2} }, $i;
    $teams[$i] = 1;
}

my @picks;
sub pick {
    my $pick = shift;
    push @picks, $pick;
    $teams[$_] = 0 for @{ $emp{$pick} };
    delete $emp{$pick};
}

my @favorites = (1002, 2001);
$emp{$_} and pick($_) for @favorites;

while (1)
{
    my $max =
      reduce { $a->[1] > $b->[1] ? $a : $b }
      map [ $_ => scalar(grep $teams[$_], @{ $emp{$_} }) ],
      keys %emp;

    my ($winner, $cnt) = @{ $max };
    last if $cnt == 0;
    pick($winner);
}

local $\ = "\n";
print scalar(@picks);
print for @picks;
[download]

I think you're over favouring. Fed this set:

10
1001 2002
1003 2002
1003 2005
1003 2005
1005 2002
1005 2002
1008 2002
1009 2005
1010 2002
1010 2002
[download]

Yours outputs:

3
1009
2002
1003
[download]

where this is possible and (to my interpretation of the rules) therefore better:

2
2002
2005
[download]

Mine's broken in the reverse way in that it ignores (actually, doesn't even consider), equally valid solutions that would use the favoured employee.

---

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.

Thanks :) I attempted again given what you said, also considering the eye-opener that argggh pointed out. I tried hard using some comparison heuristic approach before resigning to the fact that this is really a combinatorial problem.

use List::Util qw(first);

sub nck {
    my $end_cond   = shift;
    my $nextk_cond = shift;
    my $k          = shift;

    my $end = $end_cond->($k, @_);
    return () unless defined($end); # force early exit
    return [ ] if $end; # start recursive grouping

    # keep looking for a partner
    my @groups;
    my @leftover;
    while (@_)
    {
        my $pick = shift;
        push @groups,
          map {
              unshift @{ $_ }, $pick;
              $_;
          }
          &nck($end_cond, $nextk_cond, $nextk_cond->($k, $pick), @_);
    }

    return @groups;
}

my (%emp, %mates);
my $n = <>;

for my $i (0 .. $n - 1)
{
    my ($e1, $e2) = (split ' ', scalar <>);
    push @{ $emp{$e1} }, $i;
    push @{ $emp{$e2} }, $i;
    push @{ $mates{$e1} }, $e2;
    push @{ $mates{$e2} }, $e1;
}

my @emps;
my $fav = 1009;
my %must_include = ($fav => 1);

# optimize away single entries
for my $e (keys %mates)
{
    my @t = @{ $mates{$e} };

    if (@t == 1 && !$must_include{$e})
    {
        $must_include{$t[0]} = 1;
    }
    else
    {
        push(@emps, $e);
    }
}

my ($saw_fav, $found_fav);
my $min = $n + 1;

my $end_cb = sub {
    my @k = @{ $_[0] };
    return undef if @k > $min;

    my %seen;
    my $coverage =
      grep !$seen{$_}++,
      map @{ $emp{$_} },
      @k;

    return 0 if $coverage < $n;
    return undef if @k == $min && $found_fav;

    $min = @k if @k < $min;
    $found_fav = first { $_ == $fav } @k;
    $saw_fav = 1 if $found_fav;

    return 1;
};

my @picks =
  grep { @{ $_ } == $min }
  nck($end_cb, sub { [ @{ $_[0] }, $_[1] ] }, [ ], @emps);

my $picks_fav;
$picks_fav = first { first { $_ == $fav } @{ $_ } } @picks
  if $saw_fav;

my @winner = @{ $picks_fav ? $picks_fav : $picks[0] };

local $\ = "\n";
print scalar(@winner);
print for @winner;
[download]