How can I implement the Gale-Shapley stable marriage algorithm in Perl?

Question

Problem statement:

We have equal number of men and women. Each man has a preference score toward each woman. So do the woman for each man. Each of the men and women have certain interests. Based on the interest, we calculate the preference scores.

So initially, we have an input in a file having x columns. The first column is the person (man/woman) id. Ids are nothing but numbers from 0 ... n. (First half are men and next half women). The remaining x-1 columns will have the interests. These are integers too.

Now, using this n by x-1 matrix, we have come up with an n by n/2 matrix. The new matrix has all men and woman as their rows and scores for opposite sex in columns.

We have to sort the scores in descending order, also we need to know the id of person related to the scores after sorting.

So, here I wanted to use hash table.

Once we get the scores we need to make up pairs, for which we need to follow some rules.

My trouble is with the second matrix of n by n/2 that needs to give information of which man/woman has how much preference on a woman/man. I need these scores sorted so that I know who is the first preferred woman/man, 2nd preferred and so on for a man/woman.

I hope to get good suggestions on the data structures I use. I prefer PHP or Perl.

NB:

This is not homework. This is a little modified version of stable marriage algorithm. I have a working solution. I am only working on optimizing my code.

It is very similar to stable marriage problem but here we need to calculate the scores based on the interests they share. So, I have implemented it as the way you see in the wiki page http://en.wikipedia.org/wiki/Stable_marriage_problem.

My problem is not solving the problem. I solved it and can run it. I am just trying to have a better solution. So I am asking suggestions on the type of data structure to use.

Conceptually I tried using an array of hashes. where the array index give the person id and the hash in it gives the ids <=> scores in sorted manner. I initially start with an array of hashes. Now, I sort the hashes on values, but I could not store the sorted hashes back in an array. So just stored the keys after sorting and used these to get the values from my initial unsorted hashes.

Can we store the hashes after sorting? Can you suggest a better structure?

Answer 1

I think the following implements the Gale-Shapley algorithm where each person's preference ordering is given as an array of scores over the members of the opposite sex.

As an aside, I just found out that David Gale passed away (see his Wikipedia entry — he will be missed).

The code is wordy, I just quickly transcribed the algorithm as described on Wikipedia and did not check original sources, but it should give you an idea of how to use appropriate Perl data structures. If the dimensions of the problem grow, profile first before trying to optimize.

I am not going to try to address the specific issues in your problem. In particular, you did not fully flesh out the idea of computing a match score based on interests and trying to guess is bound to be frustrating.

#!/usr/bin/perl

use strict; use warnings;
use YAML;

my (%pref, %people, %proposed_by);

while ( my $line = <DATA> ) {
    my ($sex, $id, @pref) = split ' ', $line;
    last unless $sex and ($sex) =~ /^(m|w)\z/;
    $pref{$sex}{$id} = [ map 0 + $_, @pref ];
    $people{$sex}{$id} = undef;
}

while ( defined( my $man = bachelor($people{m}) ) ) {
    my @women = eligible_women($people{w}, $proposed_by{$man});
    next unless @women;

    my $woman = argmax($pref{m}{$man}, \@women);
    $proposed_by{$man}{$woman} = 1;

    if ( defined ( my $jilted = $people{w}{$woman}{m} ) ) {
        my $proposal_score =  $pref{w}{$woman}[$man];
        my $jilted_score = $pref{w}{$woman}[$jilted];
        next if $proposal_score < $jilted_score;
        $people{m}{$jilted}{w} = undef;
    }
    $people{m}{$man}{w} = $woman;
    $people{w}{$woman}{m} = $man;
}

print Dump \%people;

sub argmax {
    my ($pref, $candidates) = @_;
    my ($ret) = sort { $pref->[$b] <=> $pref->[$a] } @$candidates;
    return $ret;
}

sub bachelor {
    my ($men) = @_;
    my ($bachelor) = grep { not defined $men->{$_}{w} } keys %$men;
    return $bachelor;
}

sub eligible_women {
    my ($women, $proposed_to) = @_;
    return grep { not defined $proposed_to->{$_} } keys %$women;
}

__DATA__
m 0 10 20 30 40 50
m 1 50 30 40 20 10
m 2 30 40 50 10 20
m 3 10 10 10 10 10
m 4 50 40 30 20 10
w 0 50 40 30 20 10
w 1 40 30 20 10 50
w 2 30 20 10 50 40
w 3 20 10 50 40 30
w 4 10 50 40 30 20