如何在Perl中实现Gale-Shapley稳定婚姻算法?

时间:2010-03-26 19:17:59

标签: perl algorithm data-structures stable-marriage

问题陈述:

我们有相同数量的男女。每个男人对每个女人都有一个偏好分数。每个男人都是女人。每个男女都有一定的兴趣。根据兴趣,我们计算偏好分数。

所以最初,我们在一个包含x列的文件中有一个输入。第一列是人(男/女)身份证。 ID只是来自0 ... n的数字。 (上半部分是男性,下半部分是女性)。剩下的x-1列将有兴趣。这些也是整数。

现在,使用此n by x-1矩阵,我们提出了n by n/2矩阵。新矩阵将所有男人和女人作为他们的行和在列中的异性分数。

我们必须按降序对分数进行排序,我们还需要知道排序后与分数相关的人的ID。

所以,我想在这里使用哈希表。

一旦我们得到分数,我们需要组成对,我们需要遵循一些规则。

我的麻烦在于n by n/2的第二个矩阵需要提供哪些男人/女人对女人/男人有多少偏好的信息。我需要对这些分数进行排序,以便我知道谁是第一个首选的女性/男性,第二个首选的等等,对于一个男人/女人来说。

我希望对我使用的数据结构有很好的建议。我更喜欢PHP或Perl。

NB:

这不是作业。这是稳定婚姻算法的一个小修改版本。我有一个有效的解决方案。我只是在优化我的代码。

这与稳定的婚姻问题非常相似,但在这里我们需要根据他们分享的兴趣来计算分数。所以,我已经按照你在wiki页面http://en.wikipedia.org/wiki/Stable_marriage_problem中看到的方式实现了它。

我的问题不是解决问题。我解决了它,可以运行它。我只是想找到一个更好的解决方案。所以我在询问有关要使用的数据结构类型的建议。

从概念上讲,我尝试使用哈希数组。数组索引给出了person id,其中的hash给出了ids <=> scores的排序方式。我最初从一系列哈希开始。现在,我对值进行哈希排序,但是我无法将已排序的哈希值存储在数组中。因此,只需在排序后存储密钥,并使用它们从我最初未分类的哈希值中获取值。

我们可以在排序后存储哈希吗? 你能建议一个更好的结构吗?

1 个答案:

答案 0 :(得分:1)

我认为以下实现了Gale-Shapley algorithm,其中每个人的偏好排序是作为一组分数给出的异性成员。

顺便说一句,我发现David Gale去世了(见Wikipedia entry - 他会被遗忘)。

代码很冗长,我只是快速转录维基百科上描述的算法并没有检查原始资源,但它应该让您了解如何使用适当的Perl数据结构。如果问题的维度增加,请在尝试优化之前先进行配置。

我不会尝试解决您问题中的具体问题。特别是,你没有完全充实根据兴趣计算匹配分数的想法,并且试图猜测肯定会令人沮丧。

#!/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