gistfile1.lisp

; 3. cviceni

; UKOL (20): 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 (max (length muzi) (length zeny)))
	 (parovani (make-list N :initial-element (list -1 -1))))

    (labels ((pozice-nejlepsiho (x)
               (position (apply #'max x) x))
;je muz volny?
             (jsem-volny? (x)
               (= (second (nth x parovani)) -1))
;ma zena nabidku?
             (mam-nabidku? (x)
               (some (lambda (p) (and (= (second p) x)
                                      (= (first p) -1))) 
                     parovani))
      

             ; vsichni jsou zadani
             (konec? ()
               (every (lambda (x) (not (or (= (first x) -1)
                                           (= (second x) -1)))) parovani))

             (muz (i)
               ;kod muze
               (let* ((preference (nth i muzi))
                      (nezaslane-nabidky (mapcar #'second
                                                 (sort (mapcar #'list 
                                                               preference
                                                               (build-list N #'identity))
                                                       #'>
                                                       :key #'car))))
                      ;v nezaslanych nabidkach je ted seznam zen setrizenych dle preference.
                 (loop while t do
                       ; da nabidku nejpreferovanejsi zene, a uz se ji ptat nebude (zmizi ze seznamu)
                       (setf (nth i parovani) (list -1 (pop nezaslane-nabidky)))
                       ; ceka dokud neni volny nebo neni konec
                       (await (or (jsem-volny? i) 
                                  (konec?)))
                       ; pokud nenastal konec znovu skoci do cyklu a da nabidku dalsi zene
                       (if (konec?) (return i)))))

             (zena (i)
               ;kod zeny
               (let ((preference (nth i zeny)))
                 (loop while t do
                       ; ceka dokud nektera nabidka neni pro ni nebo dokud neni konec
                       (await (or (mam-nabidku? i)
                                  (konec?)))

                       (if (konec?) 
                           (return i)
                       ; else vetev - neni konec, cili jsme se sem dostali protoze byla detekovana nabidka
                         (let* ((nabidky (loop for p in parovani when (= (second p) i) collect (position p parovani)))
                                (jeji-hodnoceni (mapcar (lambda (u) (nth u preference)) nabidky))
                              ; ten co nebude odmitnut (nejlepsi)
                                (nejlepsi (nth (pozice-nejlepsiho jeji-hodnoceni) nabidky))
                              ; ti co budou odmitnuti (krome nejlepsiho)
                                (k-odmitnuti (remove nejlepsi nabidky)))
                           (setf (nth nejlepsi parovani) (list nejlepsi i)) ; sparovani
                           
                         ; odmitnuti ostatnich
                         (dolist (j k-odmitnuti)
                           (setf (nth j parovani) (list -1 -1)))))))))

      (co-progn
        (co-dotimes (i N) (muz i))
        (co-dotimes (i N) (zena i)))


;protoze jsme pracovali s indexy v poli tak je potreba vsechno zvednout o jednicku
      (dolist (i parovani)
        (setf (first i) (1+ (first i))
              (second i) (1+ (second i)))) parovani)))
;konec stabilnich manzelstvi



#| testovani

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

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

|#