Rosetta Code

Stable marriage problem: Difference between revisions

Page Discussion

Stable marriage problem (view source)

Revision as of 13:40, 12 August 2016

762 bytes removed ,  7 years ago
→‎{{header|VBA}}
Line 6,801:
 
=={{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}}
<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>
 
Anonymous user
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/154419"