gistfile1.lisp

; 3. cviceni

; 5.UKOL (15b): Problem stabilnich (nebo spise ne nestabilnich) manzelstvi
; N procesu muzu a N procesu zen
; kazdy muz hodnoti kazdou zenu cislem od 1 do N, vetsi cislo je lepsi
; hodnoceni
; kazda zena hodnoti kazdeho muze cislem od 1 do N, vetsi cislo je
; lepsi hodnoceni
; parovani (pary muzu a zen 1:1) je stabilni, kdyz pro muze m1, m2 a
; jejich protejsky z1, z2 zaroven plati:
; 1. m1 hodnoti z1 lepe nez z2 nebo z2 hodnoti m2 lepe nez m1
; 2. m2 hodnoti z2 lepe nez z1 nebo z1 hodnoti m1 lepe nez m2
; reseni problemu: stabilnich parovani N paru
; vyreste problem a nastinte dukaz reseni
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun build-list (n fun)
  (let (list)
    (dotimes (i n (reverse list))
      (push (funcall fun i) list))))

(defun stabilni-manzelstvi (muzi zeny)
  (let* ((N (min (length muzi) (length zeny)))
	 (parovani (make-list N))
         (prihradky (make-list N :initial-element nil)))
;kazda zena ma v seznamovaci agenture svou prihradku, do ktere 
;muzi strkaji listecky se svym cislem. Zena ceka dokud se v jeji
;schrance neco nevyskytne, a pokud ano, rozhodne se zda se 
;zasnoubi dle svych preferenci.
;parovani je ve formatu (zena muz), razene dle zeny.
    (labels ((muz (i)
               (let* (
                      (preference (nth i muzi))
                      (zaslane-nabidky '())
                      (nezaslane-nabidky (mapcar #'second 
                                                (sort #'> 
                                                      (mapcar #'list 
                                                              preference 
                                                              (build-list N #'identity)) 
                                                      :key #'car))))
;v nezaslanych nabidkach je ted seznam zen setrizenych dle preference.
;pokud sme zasnoubeni, cekame
                 (dotimes (index-k-nicemu N)
                   (await (not (position (lambda (element) (= i (nth 1 element)))
                                         parovani)))
;ted je treba se zacit dvorit, cili dat sve cislo do prihradky
                   (let ((nejlepsi (pop nezaslane-nabidky)))
                   (setf (nth nejlepsi prihradky) i)
                   (push nejlepsi zaslane-nabidky)
                   )
                )))


	     (zena (i)
;cekej na listecek v prihradce, dokud se nam nekdo nezacne dvorit
               (let ((zadana-komu -1)
                     (preference (nth i zeny)))
                 (dotimes (index-k-nicemu N)
                   (await (nth i prihradky))
;protoze se nam nekdo nabidl, je treba zjistit jestli je lepsi nez nas soucasny snoubenec a pripadne je vymenit.
                 (if (> (nth i prihradky) zadana-komu)
                     (progn
                       (setf zadana-komu (nth i prihradky))
                       (setf (nth i parovani) (list (nth i prihradky) i))
                       (setf (nth i prihradky) NIL))
                   (setf (nth i prihradky) NIL))
                 ))))
  

; spustime paralelne procesy zen a muzu
      (co-progn
        (co-dotimes (i N) (muz i))
        (co-dotimes (i N) (zena i))
        )
      parovani
      )))

(stabilni-manzelstvi '((1 3 2) (2 1 3) (1 3 2))
		     '((1 3 2) (1 3 2) (2 1 3)))

;=> #((1 3) (3 2) (2 1))

; navod
; http://www1.cs.columbia.edu/~evs/intro/stable/writeup.html

|#
function stableMatching {
    Initialize all m  M and w  W to free
    while  free man m who still has a woman w to propose to {
       w = m's highest ranked such woman
       if w is free
         (m, w) become engaged
       else some pair (m', w) already exists
         if w prefers m to m'
           (m, w) become engaged
           m' becomes free
         else
           (m', w) remain engaged
    }
}
#|