link printf

procedure main()
   smd := IsStable(ShowEngaged(StableMatching(setup())))
   IsStable(ShowEngaged(Swap(\smd,smd.women[1],smd.women[2])))
end

procedure index(L,x)                         #: return index of value or fail
   return ( L[i := 1 to *L] === x, i)
end

procedure ShowEngaged(smd)                   #: Show who's hooked up
   printf("\nEngagements:\n")
   every w := !smd.women do
      printf("%s is engaged to %s\n",w,smd.engaged[w])
   return smd
end

procedure Swap(smd,x0,x1)                    #: swap two couples by m or w
   printf("\nSwapping %s and %s\n",x0,x1)
   e := smd.engaged
   e[x0] :=: e[x1]                           # swap partners
   e[e[x0]] := e[e[x1]]
   return smd
end

procedure IsStable(smd)                      #: validate stability
   stable := 1                                               # assumption
   printf("\n")
   every mp := smd.prefs[m := !smd.men] &                    # man & pref
         w := mp[index(mp,smd.engaged[m])-1 to 1 by -1] do { # better choices
      wp := smd.prefs[w]                                     # her choices
      if index(wp,smd.engaged[w]) > index(wp,m) then {
         printf("Engagement of %s to %s is unstable.\n",w,m)
         stable := &null                                     # broken
         }
      }
   if \stable then {
      printf("Engagments are all stable.\n")
      return smd
      }
end

procedure StableMatching(smd)                #: match making
   freemen   := copy(smd.men)                # Initialize all m memberof M
   freewomen := set(smd.women)               # ... and w memberof W to free
   every (prefmen := table())[m := !freemen] := copy(smd.prefs[m])
   smd.engaged := engaged := table()
   printf("\nMatching:\n")
   while m := get(freemen) do {                 # next freeman
      while w := get(prefmen[m]) do  {          # . with prpoposals left
         if member(freewomen,w) then {          # . . is she free?
            engaged[m] := w                     # . . . (m, w)
            engaged[w] := m
            delete(freewomen,w)
            printf("%s accepted %s's proposal\n",w,m)
            break
            }
         else {                                 # . . no, she's engaged
            m0 := engaged[w]                    #     to m0
            if index(smd.prefs[w],m) < index(smd.prefs[w],m0) then {
               engaged[m] := w                  # (m, w) become engaged
               engaged[w] := m
               delete(freewomen,w)
               engaged[m0] := &null             # m' becomes free
               put(freemen,m0)
               printf("%s chose %s over %s\n",w,m,m0)
               break
               }
            else next                          # she's happier as is
         }
      }
   }
   return smd
end

record sm_data(men,women,prefs,engaged)  #: everyones data

procedure setup()                        #: setup everyones data
   X := sm_data()
   X.men   := ["abe","bob","col","dan","ed","fred","gav","hal","ian","jon"]
   X.women := ["abi","bea","cath","dee","eve","fay","gay","hope","ivy","jan"]

   if *X.men ~= *(M := set(X.men)) then runerr(500,X.men)       # duplicate?
   if *X.women ~= *(W := set(X.women)) then runerr(500,X.women) # duplicate?
   if *(B := M**W) ~= 0 then runerr(500,B)                      # intersect?

   X.prefs := p := table()

   p["abe"]  := ["abi","eve","cath","ivy","jan","dee","fay","bea","hope","gay"]
   p["bob"]  := ["cath","hope","abi","dee","eve","fay","bea","jan","ivy","gay"]
   p["col"]  := ["hope","eve","abi","dee","bea","fay","ivy","gay","cath","jan"]
   p["dan"]  := ["ivy","fay","dee","gay","hope","eve","jan","bea","cath","abi"]
   p["ed"]   := ["jan","dee","bea","cath","fay","eve","abi","ivy","hope","gay"]
   p["fred"] := ["bea","abi","dee","gay","eve","ivy","cath","jan","hope","fay"]
   p["gav"]  := ["gay","eve","ivy","bea","cath","abi","dee","hope","jan","fay"]
   p["hal"]  := ["abi","eve","hope","fay","ivy","cath","jan","bea","gay","dee"]
   p["ian"]  := ["hope","cath","dee","gay","bea","abi","fay","ivy","jan","eve"]
   p["jon"]  := ["abi","fay","jan","gay","eve","bea","dee","cath","ivy","hope"]

   p["abi"]  := ["bob","fred","jon","gav","ian","abe","dan","ed","col","hal"]
   p["bea"]  := ["bob","abe","col","fred","gav","dan","ian","ed","jon","hal"]
   p["cath"] := ["fred","bob","ed","gav","hal","col","ian","abe","dan","jon"]
   p["dee"]  := ["fred","jon","col","abe","ian","hal","gav","dan","bob","ed"]
   p["eve"]  := ["jon","hal","fred","dan","abe","gav","col","ed","ian","bob"]
   p["fay"]  := ["bob","abe","ed","ian","jon","dan","fred","gav","col","hal"]
   p["gay"]  := ["jon","gav","hal","fred","bob","abe","col","ed","dan","ian"]
   p["hope"] := ["gav","jon","bob","abe","ian","dan","hal","ed","col","fred"]
   p["ivy"]  := ["ian","col","hal","gav","fred","bob","abe","ed","jon","dan"]
   p["jan"]  := ["ed","hal","gav","abe","bob","jon","col","ian","fred","dan"]

   return X
end