Stable marriage problem: Difference between revisions

=={{header|Perl}}==

<lang Perl>

#!/usr/bin/env perl

use strict;

use warnings;

use feature qw/say/;

use List::Util qw(first);

my %Likes = (

M => {

abe => [qw/ abi eve cath ivy jan dee fay bea hope gay /],

bob => [qw/ cath hope abi dee eve fay bea jan ivy gay /],

col => [qw/ hope eve abi dee bea fay ivy gay cath jan /],

dan => [qw/ ivy fay dee gay hope eve jan bea cath abi /],

ed => [qw/ jan dee bea cath fay eve abi ivy hope gay /],

fred => [qw/ bea abi dee gay eve ivy cath jan hope fay /],

gav => [qw/ gay eve ivy bea cath abi dee hope jan fay /],

hal => [qw/ abi eve hope fay ivy cath jan bea gay dee /],

ian => [qw/ hope cath dee gay bea abi fay ivy jan eve /],

jon => [qw/ abi fay jan gay eve bea dee cath ivy hope /],

},

W => {

abi => [qw/ bob fred jon gav ian abe dan ed col hal /],

bea => [qw/ bob abe col fred gav dan ian ed jon hal /],

cath => [qw/ fred bob ed gav hal col ian abe dan jon /],

dee => [qw/ fred jon col abe ian hal gav dan bob ed /],

eve => [qw/ jon hal fred dan abe gav col ed ian bob /],

fay => [qw/ bob abe ed ian jon dan fred gav col hal /],

gay => [qw/ jon gav hal fred bob abe col ed dan ian /],

hope => [qw/ gav jon bob abe ian dan hal ed col fred /],

ivy => [qw/ ian col hal gav fred bob abe ed jon dan /],

jan => [qw/ ed hal gav abe bob jon col ian fred dan /],

},

);

my %Engaged;

my %Proposed;

match_them();

check_stability();

perturb();

check_stability();

sub match_them {

say 'Matchmaking:';

while(my $man = unmatched_man()) {

my $woman = preferred_choice($man);

$Proposed{$man}{$woman} = 1;

if(! $Engaged{W}{$woman}) {

engage($man, $woman);

say "\t$woman and $man";

}

else {

if(woman_prefers($woman, $man)) {

my $engaged_man = $Engaged{W}{$woman};

engage($man, $woman);

undef $Engaged{M}{$engaged_man};

say "\t$woman dumped $engaged_man for $man";

}

}

}

}

sub check_stability {

say 'Stablility:';

my $stable = 1;

foreach my $m (men()) {

foreach my $w (women()) {

if(man_prefers($m, $w) && woman_prefers($w, $m)) {

say "\t$w prefers $m to $Engaged{W}{$w} and $m prefers $w to $Engaged{M}{$m}";

$stable = 0;

}

}

}

if($stable) {

say "\t(all marriages stable)";

}

}

sub unmatched_man {

return first { ! $Engaged{M}{$_} } men();

}

sub preferred_choice {

my $man = shift;

return first { ! $Proposed{$man}{$_} } @{ $Likes{M}{$man} };

}

sub engage {

my ($man, $woman) = @_;

$Engaged{W}{$woman} = $man;

$Engaged{M}{$man} = $woman;

}

sub prefers {

my $sex = shift;

return sub {

my ($person, $prospect) = @_;

my $choices = join ' ', @{ $Likes{$sex}{$person} };

return index($choices, $prospect) < index($choices, $Engaged{$sex}{$person});

}

}

BEGIN {

*woman_prefers = prefers('W');

*man_prefers = prefers('M');

}

sub perturb {

say 'Perturb:';

say "\tengage abi with fred and bea with jon";

engage('fred' => 'abi');

engage('jon' => 'bea');

}

sub men { keys %{ $Likes{M} } }

sub women { keys %{ $Likes{W} } }

</lang>

Output:

<pre>

Matchmaking:

abi and abe

ivy and dan

abi dumped abe for jon

eve and abe

eve dumped abe for hal

cath and abe

gay and gav

jan and ed

hope and ian

dee and col

cath dumped abe for bob

ivy dumped dan for abe

fay and dan

bea and fred

Stablility:

(all marriages stable)

Perturb:

engage abi with fred and bea with jon

Stablility:

eve prefers jon to hal and jon prefers eve to bea

gay prefers jon to gav and jon prefers gay to bea

fay prefers jon to dan and jon prefers fay to bea

bea prefers fred to jon and fred prefers bea to abi

</pre>