gale-shapley.lisp

(defun gale-shapley (set1 set2 prefs1 prefs2)
  "Finds a stable matching between 2 sets ordered by preference of each element using the Gale-Shapley algorithm."
  ;;; output to a file
  (with-open-file (str "./output.txt"
		       :direction :output
		       :if-exists :supersede
		       :if-does-not-exist :create)
    (format str "prefs1: ~a~%" prefs1)
    (format str "prefs2: ~a~%" prefs2)
    (let ((pairs1 (make-hash-table :test #'equal))
	  (pairs2 (make-hash-table :test #'equal)))
      (loop while (< (hash-table-count pairs1) (length set1))
	 do (loop for i from 0 to (1- (length set1)) ;;; loop until as many pairs as (length set1)
	       do (let* ((s1 (elt set1 i)) ;;; set1 A of (A B C D)
			 (pref-set1 (elt prefs2 i)))
		    (block main_loop
		      (if (null (gethash s1 pairs1))
			  (;;; not paired
			   progn
			   (loop for pref in pref-set1
			      do
				(let* ((pref-set2 (elt prefs1 (position pref set2)))
				       (current-pos (position s1 pref-set2)))
				  (if (null (gethash pref pairs2))
				      (progn 
					(setf (gethash s1 pairs1) pref)
					(setf (gethash pref pairs2) s1)  
					(return-from main_loop))
				      (progn
					(let ((previous-pos (position (gethash pref pairs2) pref-set2)))
					  (if (> previous-pos current-pos)
					      (progn
						(remhash (gethash pref pairs2) pairs1)
						(remhash pref pairs2)
						(setf (gethash s1 pairs1) pref)
						(setf (gethash pref pairs2) s1)
						(return-from main_loop))
					      )))))))
			  (;;; paired
			   progn
			    ;;;nothing to do
			   )))
		    )))
      (format str "~%===================== RESULT ==============================~%")
      (maphash #'(lambda (k v)
		   (format str "(~S, ~S) " k v)) pairs1))))