1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
Preliminaries
=============
- Efficient finite maps
> import Data.Map (Map, (!))
> import qualified Data.Map as Map
- Efficient finite sets
> import Data.Set (Set)
> import qualified Data.Set as Set
- Some convenience functions for manipulating lists and endomorphisms
> import Control.Monad (guard, when)
> import Data.Monoid (Endo(..))
- An arbitrary representation of a person
> type Person = Integer
Utilities
---------
> (&!) :: a -> [a -> a] -> a
> -- ^ Reverse application of a list of endomorphisms
> x &! fs = foldMap Endo fs `appEndo` x
>
> infix 3 ==>
> -- | Logical implication
> (==>) :: Bool -> Bool -> Bool
> False ==> _ = True
> True ==> True = True
> True ==> False = False
<!--
> pPrint :: PreferenceTable -> IO ()
> pPrint = putStr . unlines . map (\(k, prefs) -> show k ++ ": " ++ unwords (map show prefs)) . Map.toList
>
> stepPhase1 :: PreferenceTable -> IO (Maybe PreferenceTable)
> stepPhase1 = phase1Iter Set.empty
> where
> phase1Iter :: Set Person -> PreferenceTable -> IO (Maybe PreferenceTable)
> -- ^ Call `phase1'` until no person is free
> phase1Iter engaged table = do
> let r = phase1' engaged table
> case r of
> Just (engaged', table') -> do
> when (table' /= table) $ do
> pPrint table'
> () <$ getLine
> if engaged' == Map.keysSet table'
> then return (Just table')
> else phase1Iter engaged' table'
> Nothing -> return Nothing
-->
Definitions
===========
\begin{def*}
A \emph{preference table} is a finite set of persons, each associated with a list of other persons, ordered by preference.
\end{def*}
> type PreferenceTable = Map Person [Person]
\begin{def*}
We call a pair ${a, b}$ \emph{embedded} in a preference table if $a$ occurs in $b$s preference list and vice versa.
\end{def*}
Deleting a pair from a table means removing each from the others preference list:
> delPair :: (Person, Person) -> (PreferenceTable -> PreferenceTable)
> delPair (p1, p2) = Map.mapWithKey delPair'
> where
> delPair' k v = do
> z <- v
> guard $ k == p1 ==> z /= p2
> guard $ k == p2 ==> z /= p1
> return z
\begin{def*}
An ordered pair $(a, b)$ is said to be \emph{semiengaged} if $a$ occurs last in $b$s preference table and $b$ occurs first in $a$s.
This means that, while $b$ is $a$s best choice of partner, $a$ has no worse choice in partner than $a$
\end{def*}
> semiEngaged :: (Person, Person) -> PreferenceTable -> Bool
> -- ^ `semiEngaged (x, y)`; is `x` last in `y`s preference list?
> semiEngaged (x, y) table = x == (last $ table ! y)
Phase 1
=======
> phase1' :: Set Person -> PreferenceTable -> Maybe (Set Person, PreferenceTable)
> phase1' engaged table
> | any null (Map.elems table)
> = Nothing -- If a preference list became empty: fail
> | Set.null free
> = Just (engaged, table) -- If nobody is free, we have nobody left to engage
> | otherwise
> = let x = Set.findMin free -- Arbitrary choice of free person
> y = head $ table ! x -- Best choice of engagement for x
> adjTable = [ delPair (x', y) | x' <- dropWhile (/= x) (table ! y), x' /= x ]
> -- ^ For all worse (than x) choices x' for y; drop them from y's preference list
> adjEngaged = [ Set.insert x -- x is now engaged
> ] ++ [ Set.delete z | z <- Map.keys table, semiEngaged (z, y) table, z /= x ] -- Nobody else is engaged to y
> in Just (engaged &! adjEngaged, table &! adjTable)
> where
> free = Map.keysSet table `Set.difference` engaged
The algorithm is iterated until all participants are engaged
> phase1 :: PreferenceTable -> Maybe PreferenceTable
> phase1 = phase1Iter Set.empty
> where
> phase1Iter :: Set Person -> PreferenceTable -> Maybe PreferenceTable
> -- ^ Call `phase1'` until no person is free
> phase1Iter engaged table = do
> (engaged', table') <- phase1' engaged table
> if engaged' == Map.keysSet table'
> then return table'
> else phase1Iter engaged' table'
|
