;;; PREFERENCE ALLOCATION

(eval-when  (:execute :compile-toplevel)
  (ql:quickload :linear-programming-glpk)
  (ql:quickload :lparallel))

(defpackage preference-allocation
  (:nicknames #:pa)
  (:use #:common-lisp #:lparallel)
  (:local-nicknames (:lp :linear-programming)
		    (:glpk :linear-programming-glpk))
  (:export #:with-configuration
	   #:calculate-assignments
	   
	   #:assignment-p
	   #:assignment-pref
	   #:assignment-semester
	   #:assignment-class))

(setf *random-state* (make-random-state t))

(in-package :pa)

(declaim (optimize (debug 3) (speed 1) (space 1) (safety 1)))

(defparameter *configuration*
  '(:class-data
    (
     ;; 43-94
     (:baseball          :min 20 :max 30 :group :a :popularity 28198)
     (:box-lacrosse      :min 5  :max 15 :group :a :popularity 9411)
     (:arena-football    :min 10 :max 30 :group :a :popularity 8947)
     (:softball          :min 8  :max 19 :group :a :popularity 1127)

     ;; 32-82
     (:basketball        :min 15 :max 40 :group :b :popularity 17864)
     (:field-lacrosse    :min 5  :max 10 :group :b :popularity 4384)
     (:indoor-soccer     :min 12 :max 32 :group :b :popularity 4658)

     ;; 50-70
     (:ice-hockey        :min 20 :max 20 :group :c :popularity 17481)
     (:american-football :min 30 :max 40 :group :c :popularity 67405 :sex (:male)))
    :regular-constraints ((:a :min 1 :max 2)
			  (:b :min 1 :max 2)
			  (:c :max 2))
    :additum-constraints ((:a :min 2 :max 2)
			  (:b :min 2 :max 2)
			  (:c :max 0))
    :semesters 4
    :additum-chance 0.2
    :non-participation-chance 0.1
    :preference-count 3
    :exclusion-count 1
    :max-repeat 2
    :objective-function satisfaction-sum
    :preference-mode generalized
    :solver glpk:glpk-solver
    :skew-factor 1
    :sanction-factor 0
    :enforce-courses nil
    :fairness-measure jmm*-preferable-p)
  "Default configuration to use.")

(defmacro with-configuration ((&rest extra) &body body)
  "Override the default configuration in BODY."
  `(let ((*configuration* (list* ,@extra *configuration*)))
     ,@body))


;;; common data structures

(defclass preference ()
  ((id :initarg :id :accessor preference-id)
   (sex :initarg :sex :type (member :male :female))))

(defgeneric assignment-allowed-p (pref class)
  (:method-combination and)
  (:method and ((pref preference) class
		&aux (class-data (getf *configuration* :class-data)))
    (assert (assoc class class-data))
    (with-slots (sex) pref
      (let ((sex-restriction (getf (cdr (assoc class class-data)) :sex)))
	(not (and sex-restriction (null (member sex sex-restriction))))))))

(defgeneric assignment-preference (pref class)
  (:method (pref class)
    (declare (ignore pref class))
    0.0))

(defclass regular-preference (preference)
  ((excluded :initarg :excludes :type list)))

(defun regular-preference-p (pref)
  (typep pref 'regular-preference))

(defmethod assignment-allowed-p and ((pref regular-preference) class)
  (with-slots (excluded) pref
    (not (member class excluded))))

(defclass enumerating-preference (regular-preference)
  ((wanted :initarg :wants :type list)))

(defmethod assignment-preference ((pref enumerating-preference) class)
  (with-slots (wanted) pref
    (if (and (assignment-allowed-p pref class)
	     (member class wanted))
	(- 1 (/ (position class wanted)
		(length wanted)))
	0.0)))

(defclass general-preference (regular-preference)
  ((preferences :initarg :preferences :type list)))

(defmethod assignment-preference ((pref general-preference) class)
  (with-slots (preferences) pref
    (or (cdr (assoc class preferences)) 0)))

(defclass additum-preference (preference)
  ((needed :initarg :needs :type list)))

(defmethod assignment-allowed-p and ((pref additum-preference) class)
  (with-slots (needed) pref
    (not (null (member class needed)))))

(defun additum-preference-p (pref)
  (typep pref 'additum-preference))

(defclass empty-preference (preference)
  ())

(defun empty-preference-p (pref)
  (typep pref 'empty-preference))

(defstruct assignment
  (pref nil :type preference)
  (semester nil :type (integer 0 *))
  (class nil :type (or (eql nil) symbol)))

(defmethod print-object ((a assignment) stream)
  (with-slots (pref class semester) a
    (format stream "~A@~A/~A" (preference-id pref) class semester)))


;;; utility functions and macros

(defmacro awhen (check &body body)
  "Anaphoric when"
  `(let ((it ,check))
     (when it ,@body)))

(defun without (list &rest elements)
  "Return LIST without ELEMENTS."
  (set-difference list elements))

(defun nshuffle (seq)
  "Shuffle a generic sequence."
  (loop for i from (length seq) downto 2
	do (rotatef (elt seq (random i))
		    (elt seq (1- i)))
	finally (return seq)))

(defun shuffle (seq)
  "Shuffle a generic sequence non-destructivly."
  (nshuffle (copy-seq seq)))

(defun weighted-choice (alist)
  "Return random element from ALIST by weight in cdr."
  (assert (not (null alist)))
  (let* ((total (float (reduce #'+ alist :key #'cdr)))
	 (nounce (random total)) 
	 (choice (car (last alist)))
	 (sum 0))
    (dolist (ent alist)
      (when (< nounce (incf sum (cdr ent)))
	(setf choice ent)
	(return)))
    (car choice)))

(defun pick (list)
  "Return a random element from LIST."
  (assert (not (null list)))
  (nth (random (length list)) list))

(defun one-of (&rest options)
  "Return a random parameter."
  (pick options))

(defmacro random-pop (list)
  "Pick an element from LIST and remove it."
  (assert (symbolp list))
  (let ((sym (gensym)))
    `(let ((,sym (pick ,list)))
       (setf ,list (delete ,sym ,list))
       ,sym)))

(defmacro weighted-pop (list)
  "Pick a random weighted element from LIST and remove it."
  (assert (symbolp list))
  (let ((sym (gensym)))
    `(let ((,sym (weighted-choice ,list)))
       (setf ,list (delete (assoc ,sym ,list) ,list))
       ,sym)))

(defun average (data)
  "Calculate the arithmetic average of DATA."
  (let ((data (remove nil data)))
    (and data (/ (reduce #'+ data) (length data)))))

(defun standard-deviation (data)
  "Calculate the standard deviation of DATA."
  (let ((avg (/ (apply #'+ data) (length data))))
    (sqrt (* (loop for d in data summing (expt (- d avg) 2))
	     (/ (length data))))))

(defun jains-index (data)
  "Calculate Jain's Index of DATA."
  (let ((data (remove nil data)))
    (if (every #'zerop data) 1
	(/ (loop for d in data summing d into sum
		 finally (return (* sum sum)))
	   (loop for d in data summing (* d d))
	   (length data)))))

(defun jain-preferable-p (data-1 data-2)
  (> (jains-index data-1) (jains-index data-2)))

(defun min-max-preferable-p (data-1 data-2)
  "Check if DATA-1 is more min-max-fair than DATA-2."
  (assert (= (length data-1) (length data-2)))
  (loop for point-1 in (sort (copy-list data-1) #'<=)
	for point-2 in (sort (copy-list data-2) #'<=)
	always (>= point-1 point-2)))

(defun jmm*-preferable-p (data-1 data-2)
  (and (jain-preferable-p data-1 data-2)
       (min-max-preferable-p data-1 data-2)))

(defun jmm+-preferable-p (data-1 data-2)
  (or (jain-preferable-p data-1 data-2)
      (min-max-preferable-p data-1 data-2)))

(defun absolutly-preferable-p (state-1 state-2)
  (and (jmm*-preferable-p state-1 state-2)
       (>= (average state-1)
	   (average state-2))))

(defun reapply (n fn arg &rest args)
  "Apply FN to ARG + ARGS, N times"
  (loop repeat n do (setf arg (apply fn arg args)))
  arg)

(defmacro roll (&body events)
  "Chance-based cond."
  (let* ((random (gensym))
	 (vars (loop for (chance . _) in events
		     collect (list (gensym) chance)))
	 (body (loop for (chance . action) in events
		     for (var . _) in vars
		     collect var into sum
		     collect
		     (cons (if (eq chance t) t
			       `(< ,random (+ ,@(copy-list sum))))
			   action))))
    `(let ((,random (random 1d0)) ,@vars)
       (declare (ignorable ,@(mapcar #'car vars)))
       (cond ,@body))))

(defmacro benchmark (&body body)
  (let ((start (gensym)))
    `(let ((,start (get-internal-real-time)))
       (progn ,@body)
       (/ (- (get-internal-real-time) ,start)
	  internal-time-units-per-second))))

(defun must (val)
  (assert (not (null val)))
  val)


;;; synthetic class-data generation

(defun class-list ()
  (mapcar #'car (getf *configuration* :class-data)))

(defun class-prop (class prop &optional default
		   &aux (class-data (getf *configuration* :class-data)))
  (assert (assoc class class-data))
  (getf (cdr (assoc class class-data)) prop default))

(defun relative-popularity (class)
  (/ (class-prop class :popularity 1)
     (loop for class* in (class-list)
	   sum (class-prop class* :popularity 1))))

(defun scaled-popularity (class)
  (/ (class-prop class :popularity 1)
     (loop for class* in (class-list)
	   maximize (class-prop class* :popularity 1))))

(defun preference-allowed (pref)
  (declare (type preference pref))
  (loop for class in (class-list) 
	when (assignment-allowed-p pref class)
	  collect class))

(defun preference-excluded (pref)
  (declare (type preference pref))
  (loop for class in (class-list) 
	unless (assignment-allowed-p pref class)
	  collect class))

(defun generate-class-data (class-count mid
			    &key
			      (up-deviation 0.1)
			      (down-deviation 0.1)
			      (popularity-skew 1)
			    &aux
			      (semesters (getf *configuration* :semesters)))
  "Generate CLASS-COUNT classes for N students."
  (flet ((generate ()
	   (loop repeat class-count
		 ;; all random assumptions are randomly assumed
		 collect (list (gensym)
			       ;; courses are taken to have a higher deviance
			       ;; from the average required course-size towards
			       ;; the maximum capacity, than the minimum
			       ;; capacity.
			       :min (max (- mid (floor (* down-deviation (random 1.0) mid)))
					 0)
			       :max (+ mid (floor (* up-deviation (random 1.0) mid)))
			       ;; there's a 3/7 chance a course is of type :a
 			       ;; or :b (respectivly) and a 1/7 chance it's of
			       ;; type :c
			       :group (weighted-choice '((:a . 3) (:b . 3) (:c . 1)))
			       ;; there's a 1/32 chance that a semester won't
			       ;; take place
			       :semesters (loop repeat semesters
						for i from 0
						when (/= 0 (random 32))
						  collect i)
			       ;; there's a 1/16 chance a course is male-only,
			       ;; a 3/16 chance a course is female only
			       :sex (weighted-choice '((nil . 13) ((:male) . 1) ((:female) . 3)))
			       ;; it is assumed course popularity can be
			       ;; modeled using a normal distribution
			       :popularity (1+ (* (abs (* (sqrt (* -2 (log (random 1.0))))
							  (cos (* 2 pi (random 1.0)))
							  0.5))
						  popularity-skew)))))
	 (legal (data)
	   data))
    (loop for class-data = (generate)
	  when (legal class-data)
	    return class-data)))


;;; synthetic preference generation

(defun generate-preference (n
			    &aux
			      (class-data
			       (getf *configuration* :class-data))
			      (preference-count
			       (getf *configuration* :preference-count))
			      (exclusion-count
			       (getf *configuration* :exclusion-count))
			      (additum-chance
			       (getf *configuration* :additum-chance))
			      (non-participation-chance
			       (getf *configuration* :non-participation-chance))
			      (preference-mode
			       (getf *configuration* :preference-mode)))
  "Randomly generate N 'preference' selections."
  (declare (type (integer 0 *) n)
	   (type (or (integer 1 *) (eql :rest))
		 preference-count)
	   (type (integer 0 *) exclusion-count)
	   (type (real 0 1) additum-chance)
	   (type (real 0 1) non-participation-chance))
  (when (eq preference-count :rest)
    (setf preference-count (- (length class-data) exclusion-count)))
  (assert (if (eq preference-mode 'generalized)
	      (<= exclusion-count (length class-data))
	      (<= (+ preference-count exclusion-count) (length class-data)))
	  (preference-count exclusion-count class-data)
	  "Not enough data.")
  (assert (<= (+ additum-chance non-participation-chance) 1)
	  (additum-chance non-participation-chance)
	  "Invalid chances")
  (let* ((pop-data (loop for class in (class-list)
			 for pop = (relative-popularity class)
			 collect (cons class pop)))
	 (group-a (loop for (_ . data) in class-data
			for pop in pop-data
			when (eq (getf data :group) :a)
			  collect pop))
	 (group-b (loop for (_ . data) in class-data
			for pop in pop-data
			when (eq (getf data :group) :b)
			  collect pop)))
    (labels ((generate-preferences ()
	       (let* ((copy (shuffle pop-data))
		      (dont-want (loop repeat exclusion-count
				       collect (car (random-pop copy)))))
		 (values (or (eq preference-mode 'generalized)
			     (loop repeat preference-count
				   for choice = (weighted-pop copy)
				   collect choice))
			 dont-want)))
	     (choose-subject (sex group)
	       (weighted-choice
		(remove-if (lambda (c)
			     (let ((allowed (class-prop (car c) :sex)))
			       (and allowed (not (member sex allowed)))))
			   group)))
	     (person (id)
	       ;; excluded preferences are binary, and stand in no relation
	       ;; to one another. wishes are listed in decreasing order of
	       ;; preference.
	       (roll
		 (additum-chance
		  (let ((sex (one-of :male :female)))
		    (make-instance 'additum-preference
				   :needs (list
					   ;; (choose-subject sex (append group-a group-b))
					   (choose-subject sex group-a)
					   (choose-subject sex group-b))
				   :sex sex
				   :id id)))
		 (non-participation-chance
		  (make-instance 'empty-preference
				 :sex (one-of :male :female)
				 :id id))
		 (t (multiple-value-bind (want dont-want) (generate-preferences)
		      (if (eq preference-mode 'generalized)
			  (make-instance 'general-preference
					 :preferences
					 (loop for class in (class-list)
					       for x = (/ (+ (scaled-popularity class)
							     (random 1d0))
							  2) 
					       collect (cons class x))
					 :excludes dont-want
					 :sex (one-of :male :female)
					 :id id)
			  (make-instance 'enumerating-preference
					 :wants want
					 :excludes dont-want
					 :sex (one-of :male :female)
					 :id id)))))))
      (loop repeat n for i from 0
	    collect (person i)))))


;;; initial preference allocation

(defun empty-objective (data preferenes)
  "Generate objective function that treads all results equally."
  (declare (ignore data preferenes))
  '(max 0))

(defun assignment-sum (data preferences)
  "Generate objective function to maximize number of assignments."
  (declare (ignore preferences))
  `(max (+ ,@(loop for i below (array-total-size data)
		   collect (row-major-aref data i)))))

(defun satisfaction-sum (data preferences
			 &aux
			   (semesters (getf *configuration* :semesters))
			   (skew (getf *configuration* :skew-factor))
			   (sanction (getf *configuration* :sanction-factor)))
  "Generate objective function to maximize satisfaction."
  (loop for pref in preferences for p from 0
	append (loop for class in (class-list) for c from 0
		     append (loop for s below semesters
				  for sat = (assignment-preference pref class)
				  when (< 0 sat)
				    collect `(* ,(- (* (+ sanction 1)
						       (expt sat skew))
						    sanction)
						,(aref data p s c))))
	  into sum
	finally (return `(max (+ ,@sum)))))

(defun translate-problem (preferences &optional preset flexible-p
			  &aux
			    (class-data (getf *configuration* :class-data))
			    (semesters (getf *configuration* :semesters))
			    (max-repeat (getf *configuration* :max-repeat))
			    (enforce-courses (getf *configuration* :enforce-courses))
			    (regular-constraints
			     (getf *configuration* :regular-constraints))
			    (additum-constraints
			     (getf *configuration* :additum-constraints)))
  (let ((data (make-array (list (length preferences)
				semesters
				(length class-data))
			  :initial-element nil
			  :element-type 'symbol))
	constraints variables)
    
    (dotimes (p (length preferences))
      (dotimes (s semesters)
	(dotimes (c (length class-data))
	  (push (setf (aref data p s c)
		      (intern (format nil "p~D s~D c~D" p s c)))
		variables))))
    
    ;; only assign one class per semester
    (dotimes (p (length preferences))
      (dotimes (s semesters)
	(push `(,(if flexible-p '<= '=)
		(+ ,@(loop for i below (length class-data)
			   collect (aref data p s i)))
		1)
	      constraints)))

    ;; don't take a course more than max-repeat times
    (dotimes (p (length preferences))
      (dotimes (c (length class-data))
	(push `(<= (+ ,@(loop for i below semesters
			      collect (aref data p i c)))
		   ,max-repeat)
	      constraints)))

    ;; ensure that each class has enough participants (min <= n <= max)
    (dotimes (s semesters)
      (dotimes (c (length class-data))
	(let ((min (getf (cdr (nth c class-data)) :min 0))
	      (max (getf (cdr (nth c class-data)) :max (length preferences)))
	      (allowed (class-prop (car (nth c class-data)) :semesters
				   (loop for i below semesters collect i)))
	      (xor (gensym)))
	  (push `(<= (* ,xor ,min)
		     (+ ,@(loop for p below (length preferences)
				collect (aref data p s c)))
		     (* ,xor ,max))
		constraints)
	  (cond ((not (member s allowed))
		 (push `(= ,xor 0) constraints))
		(enforce-courses
		 (push `(= ,xor 1) constraints)))
	  (push xor variables))))

    ;; don't allow classes to be taken if they don't take place
    (dotimes (c (length class-data))
      (let ((allowed (class-prop (car (nth c class-data)) :semesters
				 (loop for i below semesters collect i))))
	(assert (or (every (lambda (x) (<= 0 x (1- semesters)))
			   allowed)
		    (not allowed)))
	(dotimes (s semesters)
	  (cond ((not (member s allowed))
		 (push `(= 0 (+ ,@(loop for p below (length preferences)
					collect (aref data p s c))))
		       constraints))
		(enforce-courses
		 (push `(< 0 (+ ,@(loop for p below (length preferences)
					collect (aref data p s c))))
		       constraints))))))

    ;; ensure that all assignments are legal
    (dotimes (p (length preferences))
      (dotimes (c (length class-data))
	(unless (assignment-allowed-p (nth p preferences)
				      (car (nth c class-data)))
	  (dotimes (s semesters)
	    (push `(= 0 ,(aref data p s c))
		  constraints)))))

    ;; respect group constraints
    (dolist (group (union (mapcar #'car regular-constraints)
			  (mapcar #'car additum-constraints)))
      (dotimes (p (length preferences))
	(let ((pref (nth p preferences)))
	  (push `(<= ,(getf (cdr (assoc group (if (additum-preference-p pref)
						  additum-constraints
						  regular-constraints)))
			    :min 0)
		     (+ ,@(loop for s below semesters
				append (loop for c in (class-list)
					     for i from 0
					     when (eq (class-prop c :group) group)
					       collect (aref data p s i))))
		     ,(getf (cdr (assoc group (if (additum-preference-p pref)
						  additum-constraints
						  regular-constraints)))
			    :max semesters))
		constraints))))
    
    ;; set preset assignments
    (dolist (assign preset)
      (push `(= ,(aref data
		       (position (assignment-pref assign) preferences)
		       (assignment-semester assign)
		       (position (assignment-class assign) class-data
				 :key #'car))
		1)
	    constraints))
    
    (values (cons `(lp:binary ,@variables)
		  constraints)
	    data)))

(deftype assignment-issue ()
  '(member
    :invalid-semester
    :missing-semester
    :sex-restrictions
    :duplicate-assignments
    :course-capacity
    :max-repeat
    :group-constraints
    :additum-requirements))

(defun assignments-valid-p (assignments
			    &key flexible-p quick-check skip-check log
			    &aux
			      (class-data (getf *configuration* :class-data))
			      (semesters (getf *configuration* :semesters))
			      (max-repeat (getf *configuration* :max-repeat))
			      (regular-constraints
			       (getf *configuration* :regular-constraints))
			      (additum-constraints
			       (getf *configuration* :additum-constraints)))
  "Check if ASSIGNMENTS is valid in regards to *CONFIGURATION*."
  (declare (optimize (space 3) (speed 1) (debug 0) (safety 0))
	   (type list skip-check)
	   (type boolean flexible-p quick-check))
  (let ((classes (let ((courses (loop repeat semesters collect (make-hash-table))))
		   (dolist (a assignments)
		     (push a (gethash (assignment-class a)
				      (nth (assignment-semester a) courses))))
		   courses))
	(students (let ((students (make-hash-table)))
		    (dolist (a assignments)
		      (push a (gethash (assignment-pref a)
				       students)))
		    students))
	issues)
    (flet ((issue (type problem message &rest args)
	     (when log
	       (fresh-line)
	       (apply #'format *debug-io* message args))
	     (if quick-check
		 (return-from assignments-valid-p)
		 (push (cons type problem) issues))))

      ;; check course capacity
      (unless (member :course-capacity skip-check)
	(dolist (semester classes)
	  (loop for class being the hash-key of semester
		  using (hash-value participants)
		when (> (length participants)
			(getf (cdr (assoc class class-data)) :max
			      (hash-table-size students)))
		  do (issue :course-capacity participants
			    "course ~A/~A above maximum capacity (~A > ~A)"
			    class (position semester classes)
			    (length participants)
			    (getf (cdr (assoc class class-data)) :max))
		when (< (length participants)
			(getf (cdr (assoc class class-data)) :min))
		  do (issue :course-capacity participants
			    "course ~A/~A below minimum capacity (~A < ~A)"
			    class (position semester classes)
			    (length participants)
			    (getf (cdr (assoc class class-data)) :min)))))

      ;; for every student
      (loop for courses being the hash-value of students
	      using (hash-key id)
	    for pref = (assignment-pref (car courses))

	    ;; ensure MAX-REPEAT
	    do (unless (member :max-repeat skip-check)
		 (loop for assignment in courses
		       when (> (count (assignment-class assignment)
				      courses :key #'assignment-class)
			       max-repeat)
			 do (issue :max-repeat nil
				   "class ~A assigned too often to ~A"
				   (assignment-class assignment) id)))

	       ;; ensure group constraints
	    do (unless (member :group-constraints skip-check)
		 (loop for (group . constr)
			 in (if (additum-preference-p pref)
				additum-constraints
				regular-constraints)
		       for num = (loop for course in courses
				       for class = (assignment-class course)
				       for data = (assoc class class-data)
				       count (eq (getf (cdr data) :group) group))
		       unless (<= (getf constr :min 0)
				  num
				  (getf constr :max semesters))
			 do (issue :group-constraints courses
				   "group constraints for ~A broken for ~A (~D <= ~D <= ~D)"
				   group id (getf constr :min 0) num
				   (1- (getf constr :max semesters)))))

	       ;; ensure additum requirements
	    do (unless (member :additum-requirements skip-check)
		 (when (additum-preference-p pref)
		   (with-slots (needed) pref
		     (when (set-exclusive-or (mapcar #'assignment-class courses) needed)
		       (issue :additum-requirements courses
			      "additum requirements broken, got ~A, needs ~A"
			      (mapcar #'assignment-class courses)
			      needed))))))

      ;; check if semester number is valid
      (unless (member :invalid-semester skip-check)
	(dolist (assignment assignments)
	  (unless (<= 0 (assignment-semester assignment) (1- semesters))
	    (issue :skip-check assignment "invalid semester number ~A" assignment))))

      ;; accept missing assignments in flexible mode
      (unless (member :missing-semester skip-check)
	(unless flexible-p
	  (loop for courses being the hash-value of students
		do (dolist (assignment courses)
		     (when (null (assignment-class assignment))
		       (issue :missing-semester assignment
			      "course not assigned ~A" assignment))))))

      ;; ensure sex-restrictions
      (unless (member :sex-restrictions skip-check)
	(dolist (assignment assignments)
	  (let ((class (assignment-class assignment)))
	    (when (getf (cdr (assoc class class-data)) :sex)
	      (with-slots (sex) (assignment-pref assignment)
		(unless (member sex (getf (cdr (assoc class class-data)) :sex))
		  (issue :sex-restrictions assignment "forbidden sex for ~A" assignment)))))))

      ;; ensure no duplicate assignments
      (unless (member :duplicate-assignments skip-check)
	(dolist (assignment assignments)
	  (let ((other (find assignment assignments
			     :test (lambda (a b)
				     (and (not (eq a b))
					  (= (assignment-semester a)
					     (assignment-semester b))
					  (eq (assignment-pref a)
					      (assignment-pref b)))))))
	    (when other
	      (issue :duplicate-assignments assignment
		     "duplicate assignment ~A and ~A" assignment other))))))
    (values (null issues) issues)))

(defun calculate-assignments (preferences
			      &key preset flexible-p
			      &aux
				(class-data (getf *configuration* :class-data))
				(solver (getf *configuration* :solver))
				(semesters (getf *configuration* :semesters))
				(time-limit (getf *configuration* :time-limit))
				(objective-function
				 (getf *configuration* :objective-function)))
  (multiple-value-bind (constraints data)
      (translate-problem preferences preset flexible-p)
    (let* ((lp:*solver* solver)
	   (sol (handler-case
		    (if time-limit
			(lp:solve-problem (lp:parse-linear-problem
					   (funcall objective-function data preferences)
					   constraints)
					  :solver-method :integer
					  :heuristics '(:proxy-search)
					  :time-limit (floor (* time-limit 1000))
					  :message-level t)
			(lp:solve-problem (lp:parse-linear-problem
					   (funcall objective-function data preferences)
					   constraints)
					  :solver-method :integer
					  :heuristics '(:proxy-search)
					  :message-level t))
		  (lp:infeasible-problem-error ()
		    ;; abort if no results could be determined
		    (return-from calculate-assignments))))
	   assignments)

      ;; generate assignment objects
      (dotimes (p (length preferences))
	(dotimes (s semesters)
	  (let (assigned)
	    (dotimes (c (length class-data))
	      (when (= (lp:solution-variable sol (aref data p s c)) 1)
		(push (make-assignment :class (car (nth c class-data))
				       :pref (nth p preferences)
				       :semester s)
		      assignments)
		(setf assigned t))))))

      (assert (assignments-valid-p assignments :flexible-p flexible-p
					       :quick-check t
					       :log t)
	      (assignments))
      assignments)))


;;; fairness and satisfaction analysis

(defun assignment-preference-value (assignment)
  (assignment-preference (assignment-pref assignment)
			 (assignment-class assignment)))

(defun assignments-ranking (assignments aggr)
  "Merge ASSIGNMENTS satisfaction using AGGR"
  (let ((vals (loop for a in assignments
		    when (regular-preference-p (assignment-pref a))
		      collect (assignment-preference-value a))))
    (funcall aggr vals)))

(defun assignments-fairness (assignments)
  "Calculate the fairness of ASSIGNMENTS using Jain's index."
  (assignments-ranking assignments #'jains-index))

(defun assignments-satisfaction (assignments)
  "Calculate the average satisfaction of ASSIGNMENTS."
  (assignments-ranking assignments #'average))

(defun average-group-fairness (groups)
  "Calculate the average fairness of each group.
GROUPS is a list of lists, each consisting of assignments."
  (average (mapcar #'assignments-fairness groups)))

(defun average-group-satisfaction (groups)
  "Calculate the average fairness of each group.
GROUPS is a list of lists, each consisting of assignments."
  (average (mapcar #'assignments-satisfaction groups)))

(defun fairness-group-average (groups)
  "Calculate the fairness of the average of each group.
GROUPS is a list of lists, each consisting of assignments."
  (jains-index (mapcar #'assignments-satisfaction groups)))

(defun group-by (assignments grouping)
  "Group assignments into "
  (declare (type (member student semester course class) grouping)
	   (type list assignments))
  (let ((groups (make-hash-table :test #'equal)))
    (dolist (assignment assignments)
      (ecase grouping
	((student)
	 (push assignment
	       (gethash (assignment-pref assignment)
			groups)))
	((semester)
	 (push assignment
	       (gethash (assignment-semester assignment)
			groups)))
	((class)
	 (push assignment
	       (gethash (assignment-class assignment)
			groups)))
	((course)
	 (push assignment
	       (gethash (cons (assignment-semester assignment)
			      (assignment-class assignment))
			groups)))))
    (loop for group being the hash-value of groups
	  collect group)))

(defun group-ranking (assignments grouping mode)
  (funcall (ecase mode
	     ((satisfaction)	#'average-group-satisfaction)
	     ((fairness)	#'average-group-fairness)
	     ((fairness*)	#'fairness-group-average))
	   (group-by assignments grouping)))

(defun course-saturation (class n &aux (cd (getf *configuration* :class-data)))
  "Calculate the satiration of a course with N participants.
The saturation is the ratio of participants to the maximal number of
participants."
  (let ((max (getf (cdr (assoc class cd)) :max)))
    (/ n max)))

(defun course-fill-rate (class n &aux (cd (getf *configuration* :class-data)))
  "Calculate the fill-rate of a course with N partitipants.
The fill-rate is the ratio of participants over the minimal number
to maximal number of participants, again over the minimal number."
  (let ((max (getf (cdr (assoc class cd)) :max))
	(min (getf (cdr (assoc class cd)) :min)))
    (if (= max min) 1 (/ (- n min) (- max min)))))

(defun course-plan (assignments
		    &aux
		      (semesters (getf *configuration* :semesters)))
  (format t "~2%Course Plan")
  (dotimes (sem semesters)
    (format t "~%* Semester ~D" (1+ sem))
    (dolist (class (class-list))
      (if (loop for a in assignments
		  thereis (and (eq (assignment-semester a) sem)
			       (eq (assignment-class a) class)))
	  (format t "~%~A: ~{~A~^ ~}" class
		  (loop for a in (reverse assignments)
			when (and (eq (assignment-semester a) sem)
				  (eq (assignment-class a) class))
			  collect (with-slots (id) (assignment-pref a) id)))
	  (format t "~%~A: no" class)))
    (format t "~% UNASSIGNED: ~{~A~^ ~}"
	    (loop for p in (delete-duplicates (mapcar #'assignment-pref assignments))
		  unless (loop for a in assignments
				 thereis (and (eq (assignment-semester a) sem)
					      (eq (assignment-pref a) p)))
		    collect (with-slots (id) p id)))))

(defun number-of-courses (assignments
			  &aux
			    (semesters (getf *configuration* :semesters))
			    (count 0))
  (dotimes (sem semesters)
    (dolist (class (class-list))
      (when (loop for a in assignments
		  thereis (and (eq (assignment-semester a) sem)
			       (eq (assignment-class a) class)))
	(incf count))))
  count)

(defun min-max-capacity (&aux (semesters (getf *configuration* :semesters)))
  (labels ((semester (sem)
	     (loop for c in (class-list)
		   when (or (null (class-prop c :semesters))
			    (member sem (class-prop c :semesters)))
		     collect c)))
    (loop for sem below semesters
	  maximize (loop for c in (semester sem)
			 unless (eq (class-prop c :group) :c)
			   sum (class-prop c :min 0))
	    into min
	  minimize (loop for c in (semester sem)
			 sum (class-prop c :max 0))
	    into max
	  finally (return (values min max)))))


;;; fairness optimisation

(defun swap-classes (left right assignments)
  (let ((new (list* (copy-assignment left)
		    (copy-assignment right)
		    (without assignments left right))))
    (rotatef (assignment-class (first new))
	     (assignment-class (second new)))
    new))

(defun check-swap-classes (left right assignments)
  "Swap the courses for assignments LEFT and RIGHT.
If the swap doesn't results in a valid set of ASSIGNMENTS,
return nil. Otherwise return the new set of assignments."
  (let ((new (swap-classes left right assignments)))
    (and (assignments-valid-p new :quick-check t)
	 new)))

(defun possible-swaps (assignments)
  "Return a list of possible swaps.
Each swap is denoted by a cons-cell (FROM . TO)."
  (loop for this in assignments
	for rest on (rest assignments)
	append (loop for other in rest
		     when (and (not (eq (assignment-class this)
					(assignment-class other)))
			       (check-swap-classes this other assignments))
		       collect (cons this other))))

(defun legal-swaps (assignments)
  "Return a list of legal swaps.
Each swap is denoted by a cons-cell (FROM . TO)."
  (mapcan (lambda (pair &aux (this (car pair)) (other (cdr pair)))
	    (and (not (eq (assignment-class this)
			  (assignment-class other)))
		 (check-swap-classes this other assignments)
		 (list (cons this other))))
	  (possible-swaps assignments)))

(defun prefereable-assignments-p (state-1 state-2)
  (funcall (getf *configuration* :fairness-measure)
	   (mapcar #'assignment-preference-value state-1)
	   (mapcar #'assignment-preference-value state-2)))

(defun preferable-swaps (assignments)
  (loop for (left . right) in (legal-swaps assignments)
	for swapped = (swap-classes left right assignments)
	when (prefereable-assignments-p swapped assignments)
	  collect (cons left right)))

(defun most-preferable-swap (assignments)
  (let ((swaps (preferable-swaps assignments)))
    (when swaps
      (loop with best-swap = (first swaps)
	    with best-state = (swap-classes (car best-swap)
					    (cdr best-swap)
					    assignments)
	    for swap in (rest swaps)
	    for swapped = (swap-classes (car swap) (cdr swap) assignments)
	    when (prefereable-assignments-p swapped best-state)
	      do (setf best-swap swap best-state swapped)
	    finally (return best-swap)))))

(defun random-swap (assignments)
  (let ((swaps (legal-swaps assignments)))
    (and swaps (pick swaps))))

(defun random-multi-swap (assginments n)
  (flet ((swap (state)
	   (let ((swap (random-swap state)))
	     (and swap (swap-classes (car swap)
				     (cdr swap)
				     state)))))
    (random-swap (reapply (1- n) #'swap assginments))))

(defun random-preferable-swap (assignments)
  (pick (preferable-swaps assignments)))

(defun swap-at-random (&optional (n 1))
  (lambda (assignments)
    (let ((swap (random-multi-swap assignments n)))
      (and swap (swap-classes (car swap) (cdr swap)
			      assignments)))))

(defun quick-swap-at-random (assignments)
  (loop for left = (pick assignments)
	for right = (pick assignments)
	for new = (and (not (eq left right))
		       (swap-classes left right assignments))
	when (and new (assignments-valid-p new :quick-check t))
	  return new))

(defun swap-for-preferable (assignments)
  (let ((swap (random-preferable-swap assignments)))
    (and swap (swap-classes (car swap) (cdr swap)
			    assignments))))

(defun replace-at-random (&optional (n 1) &aux (class-data (getf *configuration* :class-data)))
  (lambda (assignments)
    (loop with classes = (mapcar #'car class-data)
	  for random = (pick assignments)
	  for copy = (copy-assignment random)
	  for new = (cons (progn (setf (assignment-class copy)
				       (pick classes))
				 copy)
			  (without assignments random))
	  when (assignments-valid-p new :quick-check t)
	    do (if (<= 1 n) (return new)
		   (setf assignments new
			 n (1- n))))))

(defun hill-climbing (assignments &optional (change #'swap-for-preferable))
  (loop with old = assignments
	for i from 0
	for new = (funcall change old)
	unless new
	  return old
	do (format *debug-io* "~%~D ~F ~F" i
		   (assignments-fairness new)
		   (assignments-fairness new))
	   (setf old new)))

(defun linear-schedule (start step)
  (lambda () (setf start (- start step))))

(defun exponential-schedule (start alpha &optional (cutoff 1))
  (lambda ()
    (if (< start cutoff) 0
	(setf start (* alpha start)))))

(defun simulated-annealing (assignments schedule
			    &optional (change (swap-at-random))
			      (amplifier 1))
  (loop with old = assignments
	for i from 1
	for temp = (funcall schedule)
	for new = (or (funcall change old) old)
	when (<= temp 0)
	  return old
	when new
	  do (let ((diff (- (assignments-fairness new)
			    (assignments-fairness old))))
	       (when (or (prefereable-assignments-p new old)
			 (handler-case (>= (exp (/ (* amplifier diff) temp))
					   (random 1.0))
			   (arithmetic-error () t)))
		 (setf old new)))
	do (format t "~%~D ~F ~F ~F ~F ~F" i
		   (assignments-fairness old)
		   (assignments-fairness new)
		   (assignments-satisfaction old)
		   (assignments-satisfaction new)
		   temp)))


;;; visualisation

(defun visualize-assignments (assignments file rating)
  (flet ((sorter (a b)
	   (> (funcall rating a)
	      (funcall rating b))))
    (with-open-file (*standard-output* file
				       :if-does-not-exist :create
				       :if-exists :rename
				       :direction :output)
      (let* ((semesters (group-by assignments 'semester)))
	(assert (apply #'= (mapcar #'length semesters)))
	(format t "P2~%~D ~D~%255~%"
		(length (first semesters))
		(length semesters))
	(dolist (semester semesters)
	  (dolist (assignment (sort semester #'sorter))
	    (format t "~&~D" (floor (* (funcall rating assignment)
				       255)))))))))

(defun visualize-satisfaction (assignments file)
  (visualize-assignments assignments file
			 #'assignment-preference-value))


;;; tests and test-related functions

(defun generate-assignments (n &key flexible-p)
  (let* ((preferences (generate-preference n))
	 (results (calculate-assignments preferences :flexible-p flexible-p)))
    (values results preferences)))

(defun print-ranking (metric results)
  (format t "~&~{~F~^ ~} ~F ~F ~F ~F ~F ~F ~F ~F ~F ~F ~F ~F ~F ~F "
	  (if (listp metric) metric (list metric))
	  (assignments-satisfaction results)		  ;2
	  (assignments-fairness results)		  ;3
	  (group-ranking results 'student 'satisfaction)  ;4
	  (group-ranking results 'student 'fairness)	  ;5
	  (group-ranking results 'student 'fairness*)	  ;6
	  (group-ranking results 'semester 'satisfaction) ;7
	  (group-ranking results 'semester 'fairness)	  ;8
	  (group-ranking results 'semester 'fairness*)	  ;9
	  (group-ranking results 'course 'satisfaction)	  ;10
	  (group-ranking results 'course 'fairness)	  ;11
	  (group-ranking results 'course 'fairness*)	  ;12
	  (group-ranking results 'class 'satisfaction)	  ;13
	  (group-ranking results 'class 'fairness)	  ;14
	  (group-ranking results 'class 'fairness*)))	  ;15

(defun output-file (experiment &rest args)
  (format nil "./data/~D:~A~{-~D~}"
	  (get-internal-real-time)
	  (or (getf *configuration* :experiment-name)
	      experiment)
	  args))

(defun test-sizes (&key (rounds 30) start end)
  (multiple-value-bind (min max) (min-max-capacity)
    (with-open-file (*standard-output* (output-file "size" min max rounds)
				       :if-does-not-exist :create
				       :if-exists :rename
				       :direction :output)
      (loop for size from (or start min) to (or end max)
	    do (dotimes (round rounds)
		 (format *debug-io* "~&size: ~D, ~D" size round)
		 (let ((results (generate-assignments size)))
		   (when results
		     (print-ranking size results))
		   (format *debug-io* " ~:[fail~;ok~]" results)))))))

(defun test-classes (&key (count-from 1) (count-to 30) (count-by 1)
		       (size 100) (rounds 50))
  (with-open-file (*standard-output* (output-file "class" count-from count-to rounds)
				     :if-does-not-exist :create
				     :if-exists :rename
				     :direction :output)
    (loop for count from count-from to count-to by count-by
	  do (dotimes (round rounds)
	       (format *debug-io* "~&size: ~D, ~D" count round)
	       (with-configuration (:class-data (generate-class-data count size))
		 (let ((results (generate-assignments size)))
		   (when results
		     (print-ranking size results))
		   (format *debug-io* " ~:[fail~;ok~]" results)))))))

(defun usable-preferences (size)
  (loop for prefs = (generate-preference size)
	when (calculate-assignments prefs)
	  return prefs))

(defun test-sanction (&key (size 200) (steps '(0 1/2 1)))
  (with-open-file (*standard-output* (output-file "sanction" size)
				     :if-does-not-exist :create
				     :if-exists :rename
				     :direction :output)
    (loop with prefs = (generate-preference size)
	  for sanc in steps
	  do (with-configuration (:sanction-factor sanc)
	       (format *debug-io* "~&sanc ~D" sanc)
	       (let ((results (calculate-assignments prefs)))
		 (if results
		     (print-ranking size results))
		 (format *debug-io* " ~:[fail~;ok~]" results))))))

(defun test-skew (&key (size 200) (steps '(1/2 1 2)))
  (with-open-file (*standard-output* (output-file "skew" size)
				     :if-does-not-exist :create
				     :if-exists :rename
				     :direction :output)
    (loop with prefs = (generate-preference size)
	  for skew in steps
	  do (with-configuration (:skew-factor skew)
	       (format *debug-io* "~&skew ~D" skew)
	       (let ((results (calculate-assignments prefs)))
		 (when results
		   (print-ranking size results))
		 (format *debug-io* " ~:[fail~;ok~]" results))))))

(defun test-size-enforce (&key (rounds 5) start end)
  (multiple-value-bind (min max) (min-max-capacity)
    (with-open-file (out-1 (output-file "size-noenforce" min max rounds)
			   :if-does-not-exist :create
			   :if-exists :rename
			   :direction :output)
      (with-open-file (out-2 (output-file "size-enforce" min max rounds)
			     :if-does-not-exist :create
			     :if-exists :rename
			     :direction :output)
	(loop for size from (or start min) to (or end max)
	      do (dotimes (round rounds)
		   (format *debug-io* "~&size*: ~D, ~D" size round)
		   (let* ((preferences (generate-preference size)))
		     (with-configuration (:enforce-courses t)
		       (let ((*standard-output* out-1))
			 (let ((assignments (time (calculate-assignments preferences))))
			   (when assignments
			     (print-ranking (list size (number-of-courses assignments))
					    assignments))
			   (format *debug-io* " ~:[fail~;ok~]" assignments))))
		     (with-configuration (:enforce-courses nil)
		       (let ((*standard-output* out-2))
			 (let ((assignments (time (calculate-assignments preferences))))
			   (when assignments
			     (print-ranking (list size (number-of-courses assignments))
					    assignments))
			   (format *debug-io* " ~:[fail~;ok~]" assignments)))))))))))

(defun test-size-difference (&key (rounds 5) start end)
  (multiple-value-bind (min max) (min-max-capacity)
    (with-open-file (*standard-output* (output-file "benchmark-noenforce" min max rounds)
				       :if-does-not-exist :create
				       :if-exists :rename
				       :direction :output)
      (loop for size from (or start min) to (or end max)
	    do (dotimes (round rounds)
		 (format *debug-io* "~&size*: ~D, ~D" size round)
		 (let ((preferences (generate-preference size)))
		   (let ((enforce (with-configuration (:enforce-courses t)
				    (assignments-satisfaction
				     (calculate-assignments preferences))))
			 (no-enforce (with-configuration (:enforce-courses nil)
				       (assignments-satisfaction
					(calculate-assignments preferences)))))
		     (format t "~&~D ~F ~F ~F" size
			     enforce no-enforce (- no-enforce enforce)))))))))

(defun benchmark-size-enforce (&key (rounds 5) start end)
  (multiple-value-bind (min max) (min-max-capacity)
    (with-open-file (*standard-output* (output-file "test-size-diff" min max rounds)
				       :if-does-not-exist :create
				       :if-exists :rename
				       :direction :output)
      (loop for size from (or start min) to (or end max)
	    do (dotimes (round rounds)
		 (format *debug-io* "~&size*: ~D, ~D" size round)
		 (let ((preferences (generate-preference size)))
		   (format t "~&~D ~F ~F" size
			   (with-configuration (:enforce-courses t)
			     (benchmark (calculate-assignments preferences)))
			   (with-configuration (:enforce-courses nil)
			     (benchmark (calculate-assignments preferences))))
		   (format *debug-io* " ok")))))))

(defvar *experiment-counter* 0)

(defun test-simulated-annealing (jobs &key (rounds 16) (size 210) )
  (let ((state (loop thereis (generate-assignments size)))
	(nr (incf *experiment-counter*)))
    (dolist (job jobs)
      (destructuring-bind (name schedule measure change amp) job
	(with-configuration (:fairness-measure measure)
	  (dotimes (i rounds)
	    (with-open-file (*standard-output* (output-file "sa" nr name i)
					       :if-does-not-exist :create
					       :if-exists :rename
					       :direction :output)
	      (simulated-annealing state schedule change amp))))))))