Stable marriage problem: Difference between revisions
Content added Content deleted
m (→{{header|VBA}}) |
|||
Line 6,801: | Line 6,801: | ||
=={{header|VBA}}== |
=={{header|VBA}}== |
||
<lang vb> |
|||
Sub GaleShapleyRosetta() |
|||
Dim arrMenList() As String |
|||
Dim arrMen() As Variant |
|||
Dim vMan As Variant |
|||
Dim lMan As Long |
|||
Dim lManPref As Long |
|||
Dim lManDown As Long |
|||
Dim arrWomenList() As String |
|||
Dim arrWomen() As Variant |
|||
Dim vWoman As Variant |
|||
Dim lWoman As Long |
|||
Dim i As Integer |
|||
Dim j As Integer |
|||
Dim lPeople As Long |
|||
Dim lPartner As Long |
|||
<pre>2 methods will be shown here: |
|||
On Error GoTo Terminate |
|||
1 - using basic VBA-features for strings |
|||
2 - using the scripting.dictionary library</pre> |
|||
lPeople = 10 |
|||
lPartner = lPeople + 2 |
|||
ReDim arrMenList(1 To lPeople) |
|||
ReDim arrWomenList(1 To lPeople) |
|||
ReDim arrMen(1 To lPeople, 1 To lPartner) |
|||
ReDim arrWomen(1 To lPeople, 1 To lPartner) |
|||
arrMenList(1) = "abe,abi,eve,cath,ivy,jan,dee,fay,bea,hope,gay" |
|||
arrMenList(2) = "bob,cath,hope,abi,dee,eve,fay,bea,jan,ivy,gay" |
|||
arrMenList(3) = "col,hope,eve,abi,dee,bea,fay,ivy,gay,cath,jan" |
|||
arrMenList(4) = "dan,ivy,fay,dee,gay,hope,eve,jan,bea,cath,abi" |
|||
arrMenList(5) = "ed,jan,dee,bea,cath,fay,eve,abi,ivy,hope,gay" |
|||
arrMenList(6) = "fred,bea,abi,dee,gay,eve,ivy,cath,jan,hope,fay" |
|||
arrMenList(7) = "gav,gay,eve,ivy,bea,cath,abi,dee,hope,jan,fay" |
|||
arrMenList(8) = "hal,abi,eve,hope,fay,ivy,cath,jan,bea,gay,dee" |
|||
arrMenList(9) = "ian,hope,cath,dee,gay,bea,abi,fay,ivy,jan,eve" |
|||
arrMenList(10) = "jon,abi,fay,jan,gay,eve,bea,dee,cath,ivy,hope" |
|||
arrWomenList(1) = "abi,bob,fred,jon,gav,ian,abe,dan,ed,col,hal" |
|||
arrWomenList(2) = "bea,bob,abe,col,fred,gav,dan,ian,ed,jon,hal" |
|||
arrWomenList(3) = "cath,fred,bob,ed,gav,hal,col,ian,abe,dan,jon" |
|||
arrWomenList(4) = "dee,fred,jon,col,abe,ian,hal,gav,dan,bob,ed" |
|||
arrWomenList(5) = "eve,jon,hal,fred,dan,abe,gav,col,ed,ian,bob" |
|||
arrWomenList(6) = "fay,bob,abe,ed,ian,jon,dan,fred,gav,col,hal" |
|||
arrWomenList(7) = "gay,jon,gav,hal,fred,bob,abe,col,ed,dan,ian" |
|||
arrWomenList(8) = "hope,gav,jon,bob,abe,ian,dan,hal,ed,col,fred" |
|||
arrWomenList(9) = "ivy,ian,col,hal,gav,fred,bob,abe,ed,jon,dan" |
|||
arrWomenList(10) = "jan,ed,hal,gav,abe,bob,jon,col,ian,fred,dan" |
|||
For i = 1 To lPeople |
|||
For j = 1 To lPeople + 1 |
|||
arrMen(i, j) = Split(arrMenList(i), ",")(j - 1) |
|||
arrWomen(i, j) = Split(arrWomenList(i), ",")(j - 1) |
|||
Next j |
|||
Next i |
|||
Do Until UnmatchedMen(arrMen, lPartner) = 0 |
|||
For lMan = LBound(arrMen, 1) To UBound(arrMen, 1) |
|||
vMan = arrMen(lMan, 1) |
|||
If arrMen(lMan, lPartner) = 0 Then |
|||
'Man has no partner |
|||
For lManPref = 2 To lPartner - 1 |
|||
vWoman = arrMen(lMan, lManPref) |
|||
lWoman = FindPerson(arrWomen, vWoman) |
|||
'Woman has no partner |
|||
If arrWomen(lWoman, lPartner) = 0 Then |
|||
arrWomen(lWoman, lPartner) = vMan |
|||
arrMen(lMan, lPartner) = vWoman |
|||
Debug.Print vWoman & " ACCEPTED " & vMan |
|||
GoTo NextMan |
|||
End If |
|||
'Woman has partner |
|||
lManDown = FindPerson(arrMen, arrWomen(lWoman, lPartner)) |
|||
If FindPersonPref(arrWomen, lWoman, vMan) < FindPersonPref(arrWomen, lWoman, arrWomen(lWoman, lPartner)) Then |
|||
'New man is preferred |
|||
arrMen(lManDown, lPartner) = 0 |
|||
Debug.Print vWoman & " REJECTED " & arrMen(lManDown, 1) |
|||
arrWomen(lWoman, lPartner) = vMan |
|||
arrMen(lMan, lPartner) = vWoman |
|||
Debug.Print vWoman & " ACCEPTED " & vMan |
|||
GoTo NextMan |
|||
End If |
|||
Next lManPref |
|||
End If |
|||
NextMan: |
|||
Next lMan |
|||
Loop |
|||
'''The string approach'''<br/> |
|||
Debug.Print "Final Output:" |
|||
<lang vb>Sub M_snb() |
|||
For i = 1 To lPeople |
|||
c00 = "_abe abi eve cath ivy jan dee fay bea hope gay " & _ |
|||
Debug.Print arrWomen(i, 1) & " is ENGAGED to " & arrWomen(i, lPartner) |
|||
"_bob cath hope abi dee eve fay bea jan ivy gay " & _ |
|||
Next i |
|||
"_col hope eve abi dee bea fay ivy gay cath jan " & _ |
|||
"_dan ivy fay dee gay hope eve jan bea cath abi " & _ |
|||
Terminate: |
|||
"_ed jan dee bea cath fay eve abi ivy hope gay " & _ |
|||
If Err Then |
|||
"_fred bea abi dee gay eve ivy cath jan hope fay " & _ |
|||
Debug.Print "ERROR", Err.Number, Err.Description |
|||
"_gav gay eve ivy bea cath abi dee hope jan fay " & _ |
|||
Err.Clear |
|||
"_hal abi eve hope fay ivy cath jan bea gay dee " & _ |
|||
End If |
|||
"_ian hope cath dee gay bea abi fay ivy jan eve " & _ |
|||
Application.ScreenUpdating = True |
|||
"_jon abi fay jan gay eve bea dee cath ivy hope " & _ |
|||
End Sub |
|||
"_abi bob fred jon gav ian abe dan ed col hal " & _ |
|||
"_bea bob abe col fred gav dan ian ed jon hal " & _ |
|||
"_cath fred bob ed gav hal col ian abe dan jon " & _ |
|||
"_dee fred jon col abe ian hal gav dan bob ed " & _ |
|||
"_eve jon hal fred dan abe gav col ed ian bob " & _ |
|||
"_fay bob abe ed ian jon dan fred gav col hal " & _ |
|||
"_gay jon gav hal fred bob abe col ed dan ian " & _ |
|||
"_hope gav jon bob abe ian dan hal ed col fred " & _ |
|||
"_ivy ian col hal gav fred bob abe ed jon dan " & _ |
|||
"_jan ed hal gav abe bob jon col ian fred dan " |
|||
sn = Filter(Filter(Split(c00), "_"), "-", 0) |
|||
Do |
|||
c01 = Mid(c00, InStr(c00, sn(0) & " ")) |
|||
st = Split(Left(c01, InStr(Mid(c01, 2), "_"))) |
|||
For j = 1 To UBound(st) - 1 |
|||
If InStr(c00, "_" & st(j) & " ") > 0 Then |
|||
c00 = Replace(Replace(c00, sn(0), sn(0) & "-" & st(j)), "_" & st(j), "_" & st(j) & "." & Mid(sn(0), 2)) |
|||
Exit For |
|||
Else |
|||
c02 = Filter(Split(c00, "_"), st(j) & ".")(0) |
|||
c03 = Split(Split(c02)(0), ".")(1) |
|||
If InStr(c02, " " & Mid(sn(0), 2) & " ") < InStr(c02, " " & c03 & " ") Then |
|||
c00 = Replace(Replace(Replace(c00, c03 & "-" & st(j), c03), sn(0), sn(0) & "-" & st(j)), "_" & st(j), "_" & st(j) & "." & Mid(sn(0), 2)) |
|||
Exit For |
|||
End If |
|||
End If |
|||
Next |
|||
sn = Filter(Filter(Filter(Split(c00), "_"), "-", 0), ".", 0) |
|||
Loop Until UBound(sn) = -1 |
|||
MsgBox Replace(Join(Filter(Split(c00), "-"), vbLf), "_", "") |
|||
End Sub</lang> |
|||
'''The Dictionary approach''' |
|||
Function UnmatchedMen(ByRef arrMen() As Variant, ByVal lColPartner As Variant) |
|||
Dim i As Integer |
|||
UnmatchedMen = 0 |
|||
For i = LBound(arrMen, 1) To UBound(arrMen, 1) |
|||
If arrMen(i, lColPartner) = 0 Then UnmatchedMen = UnmatchedMen + 1 |
|||
Next i |
|||
End Function |
|||
<lang vb>Sub M_snb() |
|||
Function FindPerson(ByRef arrPeople() As Variant, ByVal vPerson As Variant) As Long |
|||
Set d_00 = CreateObject("scripting.dictionary") |
|||
Dim lPerson As Long |
|||
Set d_01 = CreateObject("scripting.dictionary") |
|||
For lPerson = LBound(arrPeople, 1) To UBound(arrPeople, 1) |
|||
Set d_02 = CreateObject("scripting.dictionary") |
|||
If arrPeople(lPerson, 1) = vPerson Then |
|||
FindPerson = lPerson |
|||
sn = Split("abe abi eve cath ivy jan dee fay bea hope gay _" & _ |
|||
Exit Function |
|||
"bob cath hope abi dee eve fay bea jan ivy gay _" & _ |
|||
End If |
|||
"col hope eve abi dee bea fay ivy gay cath jan _" & _ |
|||
Next lPerson |
|||
"dan ivy fay dee gay hope eve jan bea cath abi _" & _ |
|||
End Function |
|||
"ed jan dee bea cath fay eve abi ivy hope gay _" & _ |
|||
"fred bea abi dee gay eve ivy cath jan hope fay _" & _ |
|||
"gav gay eve ivy bea cath abi dee hope jan fay _" & _ |
|||
"hal abi eve hope fay ivy cath jan bea gay dee _" & _ |
|||
"ian hope cath dee gay bea abi fay ivy jan eve _" & _ |
|||
"jon abi fay jan gay eve bea dee cath ivy hope ", "_") |
|||
sp = Split("abi bob fred jon gav ian abe dan ed col hal _" & _ |
|||
"bea bob abe col fred gav dan ian ed jon hal _" & _ |
|||
"cath fred bob ed gav hal col ian abe dan jon _" & _ |
|||
"dee fred jon col abe ian hal gav dan bob ed _" & _ |
|||
"eve jon hal fred dan abe gav col ed ian bob _" & _ |
|||
"fay bob abe ed ian jon dan fred gav col hal _" & _ |
|||
"gay jon gav hal fred bob abe col ed dan ian _" & _ |
|||
"hope gav jon bob abe ian dan hal ed col fred _" & _ |
|||
"ivy ian col hal gav fred bob abe ed jon dan _" & _ |
|||
"jan ed hal gav abe bob jon col ian fred dan ", "_") |
|||
For j = 0 To UBound(sn) |
|||
d_00(Split(sn(j))(0)) = "" |
|||
d_01(Split(sp(j))(0)) = "" |
|||
d_02(Split(sn(j))(0)) = sn(j) |
|||
d_02(Split(sp(j))(0)) = sp(j) |
|||
Next |
|||
Do |
|||
For Each it In d_00.keys |
|||
If d_00.Item(it) = "" Then |
|||
st = Split(d_02.Item(it)) |
|||
For jj = 1 To UBound(st) |
|||
If d_01(st(jj)) = "" Then |
|||
d_00(st(0)) = st(0) & vbTab & st(jj) |
|||
d_01(st(jj)) = st(0) |
|||
Exit For |
|||
ElseIf InStr(d_02.Item(st(jj)), " " & st(0) & " ") < InStr(d_02.Item(st(jj)), " " & d_01(st(jj)) & " ") Then |
|||
d_00(d_01(st(jj))) = "" |
|||
d_00(st(0)) = st(0) & vbTab & st(jj) |
|||
d_01(st(jj)) = st(0) |
|||
Exit For |
|||
End If |
|||
Next |
|||
End If |
|||
Next |
|||
Loop Until UBound(Filter(d_00.items, vbTab)) = d_00.Count - 1 |
|||
MsgBox Join(d_00.items, vbLf) |
|||
End Sub</lang> |
|||
Function FindPersonPref(ByRef arrPeople() As Variant, ByVal lPerson As Long, ByVal vPerson As Variant) As Long |
|||
Dim lPersonPref As Long |
|||
For lPersonPref = LBound(arrPeople, 2) To UBound(arrPeople, 2) |
|||
If arrPeople(lPerson, lPersonPref) = vPerson Then |
|||
FindPersonPref = lPersonPref |
|||
Exit Function |
|||
End If |
|||
Next lPersonPref |
|||
End Function |
|||
</lang> |
|||
{{out}} |
{{out}} |
||
<pre> |
<pre> |
||
abe - ivy |
|||
abi ACCEPTED abe |
|||
bob - cath |
|||
cath ACCEPTED bob |
|||
col - dee |
|||
hope ACCEPTED col |
|||
dan - fay |
|||
ivy ACCEPTED dan |
|||
ed - jan |
|||
jan ACCEPTED ed |
|||
fred - bea |
|||
bea ACCEPTED fred |
|||
gav - gay |
|||
gay ACCEPTED gav |
|||
hal - eve |
|||
eve ACCEPTED hal |
|||
ian - hope |
|||
hope REJECTED col |
|||
jan - abi |
|||
hope ACCEPTED ian |
|||
abi REJECTED abe |
|||
abi ACCEPTED jon |
|||
ivy REJECTED dan |
|||
ivy ACCEPTED abe |
|||
dee ACCEPTED col |
|||
fay ACCEPTED dan |
|||
Final Output: |
|||
abi is ENGAGED to jon |
|||
bea is ENGAGED to fred |
|||
cath is ENGAGED to bob |
|||
dee is ENGAGED to col |
|||
eve is ENGAGED to hal |
|||
fay is ENGAGED to dan |
|||
gay is ENGAGED to gav |
|||
hope is ENGAGED to ian |
|||
ivy is ENGAGED to abe |
|||
jan is ENGAGED to ed |
|||
</pre> |
</pre> |
||