稳定婚姻的求解程序——Ada应用实例之一

稳定婚姻的求解程序——Ada应用实例之一

一网友用C编写了稳定婚姻的求解程序，详见：
http://topic.csdn.net/u/20090904/07/c2aae375-c195-4ee1-b547-409688a520a4.html）。
该程序的求解思路是对的，但可惜没有正确处理数组下标，因此不能产生预期结果。

如果使用Ada，只要适当地定义了数组分量和下标的类型，那么在编译期间就可以发现和解决下标问题。
对于稳定婚姻的求解，我们定义如下数据类型：

MAX_COUPLE_NUMBER : constant := 4; --配偶数量
type boy_id_type is new Natural range 0 .. MAX_COUPLE_NUMBER;
--男孩编号，0是空号，有效编号从1开始
type girl_id_type is new Positive range 1 .. MAX_COUPLE_NUMBER;
--女孩编号，从1开始
type favorite_index_type is new Positive range 1 .. MAX_COUPLE_NUMBER;
type boy_favorite_list_type is array --男孩所喜欢的女孩
(boy_id_type range 1 .. boy_id_type'Last,
favorite_index_type) of girl_id_type;
type girl_favorite_list_type is array --女孩所喜欢的男孩
(girl_id_type, favorite_index_type) of boy_id_type;
type boy_spouse_list_type is array --男孩所配对的女孩
(boy_id_type range 1 .. boy_id_type'Last) of girl_id_type;

这里boy_favorite_list_type是一个二维数组类型，它的两个下标的类型分别是boy_id_type和favorite_index_type，它的分量类型是girl_id_type。因此，该数组用于存放每个男孩所喜欢的女孩。

boy_id_type、girl_id_type和favorite_index_type是三个不同的类型，虽然后两个都是从Positive导出的，但这三个类型不能混用（除非进行强制类型转换）。例如，不能把类型为girl_id_type的变量用作类型为boy_favorite_list_type的数组的下标。同样，也不能把类型为boy_id_type的变量赋给类型为boy_favorite_list_type的数组的分量。

以下是整个求解程序，由三个Ada程序文件组成。

文件1：stable_marrige.adb（主程序）
with Ada.Text_IO;
use Ada.Text_IO;
with stable_marrige_match;
use stable_marrige_match;

procedure stable_marrige is
boy_favorite_list : constant boy_favorite_list_type :=
((2, 4, 1, 3), (3, 1, 4, 2), (2, 3, 1, 4), (4, 1, 3, 2));
girl_favorite_list : constant girl_favorite_list_type :=
((2, 1, 4, 3), (4, 3, 1, 2), (1, 4, 3, 2), (2, 1, 4, 3));
match_list : boy_spouse_list_type;
begin
search_stable_marrige (
boy_favorite_list, girl_favorite_list, match_list);
for i in match_list'Range loop
Put_Line (boy_id_type'Image (i) & " " &
girl_id_type'Image (match_list (i)));
end loop;
end stable_marrige;

文件2：stable_marrige_match.ads （包规范）
package stable_marrige_match is
MAX_COUPLE_NUMBER : constant := 4;
type boy_id_type is new Natural range 0 .. MAX_COUPLE_NUMBER;
type girl_id_type is new Positive range 1 .. MAX_COUPLE_NUMBER;
type favorite_index_type is new Positive range 1 .. MAX_COUPLE_NUMBER;
type boy_favorite_list_type is array
(boy_id_type range 1 .. boy_id_type'Last,
favorite_index_type) of girl_id_type;
type girl_favorite_list_type is array
(girl_id_type, favorite_index_type) of boy_id_type;
type boy_spouse_list_type is array
(boy_id_type range 1 .. boy_id_type'Last) of girl_id_type;

procedure search_stable_marrige
(boy_favorite_list : boy_favorite_list_type;
girl_favorite_list : girl_favorite_list_type;
match_list : out boy_spouse_list_type
);

private
type girl_spouse_list_type is array (girl_id_type) of boy_id_type;

procedure push_boy_stack (boy_id : boy_id_type);
function pop_boy_stack return boy_id_type;
function get_favorite_index_of_boy
(boy_id : boy_id_type;
girl_id : girl_id_type;
girl_favorite_list : girl_favorite_list_type
) return favorite_index_type;
end stable_marrige_match;

文件3：stable_marrige_match.adb （包体）
with Ada.Text_IO;
use Ada.Text_IO;

package body stable_marrige_match is
DUMMY_BOY_ID : constant boy_id_type := 0;
MAX_BOY_STACK : constant Positive := 100;
type boy_stack_type is array
(Positive range 1 .. MAX_BOY_STACK) of boy_id_type;

boy_stack : boy_stack_type;
boy_stack_index : Positive := boy_stack'First;
boy_stack_overflow : exception;

procedure push_boy_stack (boy_id : boy_id_type) is
begin
boy_stack (boy_stack_index) := boy_id;
if boy_stack_index < boy_stack'Last then
boy_stack_index := boy_stack_index + 1;
else
raise boy_stack_overflow;
end if;
end push_boy_stack;

function pop_boy_stack return boy_id_type is
boy_id : boy_id_type;
begin
if boy_stack_index > boy_stack'First then
boy_stack_index := boy_stack_index - 1;
boy_id := boy_stack (boy_stack_index);
else
boy_id := DUMMY_BOY_ID;
end if;
return boy_id;
end pop_boy_stack;

function get_favorite_index_of_boy
(boy_id : boy_id_type;
girl_id : girl_id_type;
girl_favorite_list : girl_favorite_list_type
) return favorite_index_type is
favorite_index : favorite_index_type;
begin
for i in favorite_index_type'Range loop
if girl_favorite_list (girl_id, i) = boy_id then
favorite_index := i;
exit;
end if;
end loop;
return favorite_index;
end get_favorite_index_of_boy;

procedure search_stable_marrige
(boy_favorite_list : boy_favorite_list_type;
girl_favorite_list : girl_favorite_list_type;
match_list : out boy_spouse_list_type) is

boy_spouse_list : boy_spouse_list_type;
girl_spouse_list : girl_spouse_list_type;
boy_id : boy_id_type;
ex_boy_id : boy_id_type;
favorite_girl_id : girl_id_type;

begin
for i in girl_spouse_list'Range loop
girl_spouse_list (i) := DUMMY_BOY_ID;
end loop;

for i in 1 .. boy_id_type'Last loop
push_boy_stack (i);
end loop;

loop
boy_id := pop_boy_stack;
if boy_id = DUMMY_BOY_ID then
exit;
end if;
push_boy_stack (boy_id);
for favorite_index in favorite_index_type'Range loop
favorite_girl_id := boy_favorite_list (boy_id, favorite_index);
ex_boy_id := girl_spouse_list (favorite_girl_id);
if ex_boy_id = DUMMY_BOY_ID then
girl_spouse_list (favorite_girl_id) := boy_id;
boy_spouse_list (boy_id) := favorite_girl_id;
boy_id := pop_boy_stack;
exit;
elsif get_favorite_index_of_boy (boy_id,
favorite_girl_id,
girl_favorite_list) <
get_favorite_index_of_boy (ex_boy_id,
favorite_girl_id,
girl_favorite_list) then
boy_id := pop_boy_stack;
push_boy_stack (ex_boy_id);
girl_spouse_list (favorite_girl_id) := boy_id;
boy_spouse_list (boy_id) := favorite_girl_id;
exit;
end if;
end loop;
end loop;
match_list := boy_spouse_list;
end search_stable_marrige;

begin
null;
exception
when boy_stack_overflow =>
Put_Line ("MAX_BOY_STACK = 100 is not enough");
when others =>
Put_Line ("stable_marrige_match internal error");
end stable_marrige_match;