Anonymous user
Stable marriage problem: Difference between revisions
→{{header|VBA}}
m (changed women->woman) |
|||
Line 6,792:
{{omit from|GUISS}}
=={{header|VBA}}==
<lang VBA>
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
On Error GoTo Terminate
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
Debug.Print "Final Output:"
For i = 1 To lPeople
Debug.Print arrWomen(i, 1) & " is ENGAGED to " & arrWomen(i, lPartner)
Next i
Terminate:
If Err Then
Debug.Print "ERROR", Err.Number, Err.Description
Err.Clear
End If
Application.ScreenUpdating = True
End Sub
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
Function FindPerson(ByRef arrPeople() As Variant, ByVal vPerson As Variant) As Long
Dim lPerson As Long
For lPerson = LBound(arrPeople, 1) To UBound(arrPeople, 1)
If arrPeople(lPerson, 1) = vPerson Then
FindPerson = lPerson
Exit Function
End If
Next lPerson
End Function
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>
abi ACCEPTED abe
cath ACCEPTED bob
hope ACCEPTED col
ivy ACCEPTED dan
jan ACCEPTED ed
bea ACCEPTED fred
gay ACCEPTED gav
eve ACCEPTED hal
hope REJECTED col
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>
=={{header|XSLT 2.0}}==
| |||