Stable marriage problem: Difference between revisions
Content added Content deleted
m (changed women->woman) |
|||
Line 6,792: | Line 6,792: | ||
{{omit from|GUISS}} |
{{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}}== |
=={{header|XSLT 2.0}}== |