(defclass person ()
  ((name :initform "" :initarg :name :reader person-name)
   (type :initform :student :initarg :type :reader person-type)
   ;; INTERESTS is just a list of keywords
   (interests :initform nil :initarg :interests :accessor person-interests)
   ;; WANTS-TO-MEET¬is a list of other person objects
   (wants-to-meet :initform nil :accessor person-wants-to-meet-with)
   ;; SCHEDULE is a list of meetings or other TIME-BLOCKs
   (schedule :initform nil :reader person-schedule)
   (all-people :initform nil :allocation :class)))

(defmethod print-object ((person person) stream)
  (print-unreadable-object (person stream)
    (format stream "~a ~s" 
            (person-type person)
            (person-name person))))

(defmethod initialize-instance :before ((person person) &key)
  (with-slots (all-people) person
    (push person all-people)))

(defun find-people (&key match (type nil type-p))
  (let ((all-people (slot-value (class-prototype (find-class 'person)) 'all-people)))
    (remove-if-not #'(lambda (person)
                       (and (or (not type-p)
                                (eq type (person-type person)))
                            (or (null match)
                                (search match (person-name person) :test #'char-equal))))
                   all-people)))

(defun flush-all-people ()
  (setf (slot-value (class-prototype (find-class 'person)) 'all-people)
        nil))


(defclass time-block ()
  ((start :initarg :start :reader tb-start-time)
   (duration :initarg :duration :reader tb-duration)))

(defmethod print-object ((tb time-block) stream)
  (print-unreadable-object (tb stream :type t)
    (format stream "~a - ~a"
            (time-to-string (tb-start-time tb))
            (time-to-string (tb-end-time tb)))))

(defmethod initialize-instance :after ((tb time-block) &key end)
  (with-slots (start duration) tb
    (when end
      (setq duration (- end start)))))

(defmethod tb-end-time ((tb time-block))
  (+ (tb-start-time tb) (tb-duration tb)))


(defclass meeting (time-block)
  ((participants :initform nil :initarg :participants
                 :reader meeting-participants)))

(defmethod initialize-instance :after ((meeting meeting) &key)
  (with-slots (participants) meeting
    (dolist (p participants)
      (add-meeting p meeting))))


(defmethod time-block-overlaps-p ((tb1 time-block) (tb2 time-block))
  (flet ((time-within (time time-block)
           (and (<= (tb-start-time time-block) time)
                (< time (tb-end-time time-block)))))
    (or (time-within (tb-start-time tb2) tb1)
        (time-within (tb-end-time tb2) tb1))))

(defmethod time-block-overlaps-p ((tb time-block) (others list))
  (not (null (member tb others :test #'time-block-overlaps-p))))


(defmethod add-meeting ((person person) (meeting time-block))
  ;; scheduling conflicts are not detected at ths level.
  (with-slots (schedule) person
    (setq schedule (merge 'list (list meeting) schedule #'<
                          :key #'tb-start-time))))


(define-condition scheduling-conflict (condition)
                  ((time-block :initarg :time-block)
                   (participants :initarg :participants)
                   (conflicting-participants :initarg :have-conflicts))
  (:report (lambda (condition stream)
             condition
             (format stream "Scheduling conflict"))))

#|
(defun schedule-meeting (start duration participants)
  (let ((time-block (make-instance 'time-block :start start :duration duration)))
    (let ((conflicts nil))
      (dolist (p participants)
        (when (time-block-overlaps-p time-block (person-schedule p))
          (push p conflicts)))
      (if conflicts
        (signal 'scheduling-conflict
                :time-block time-block
                :participants participants
                :have-conflicts conflicts)
        (make-instance 'meeting 
          :start (tb-start-time time-block)
          :duration (tb-duration time-block)
          :participants participants)))))
|#


(defmethod free-time-blocks (within-time-blocks duration-threshhold (participants list))
  (let ((time-blocks within-time-blocks))
    (dolist (p participants)
      (setq time-blocks (free-time-blocks within-time-blocks duration-threshhold p)))
    time-blocks))

(defmethod free-time-blocks (within-time-blocks duration-threshhold (participant person))
  (let ((time-blocks within-time-blocks))
    (dolist (m (person-schedule participant))
      (setq time-blocks (free-time-blocks time-blocks duration-threshhold m)))
    time-blocks))

(defmethod free-time-blocks ((within-time-blocks list) duration-threshhold (used time-block))
  (let ((time-blocks nil))
    (dolist (tb within-time-blocks)
      (setq time-blocks 
            (nconc (free-time-blocks tb duration-threshhold used) 
                   time-blocks)))
    time-blocks))

(defmethod free-time-blocks ((time-block time-block) duration-threshhold (used time-block))
  (if (time-block-overlaps-p time-block used)
    (let ((good-times nil)
          (tbs (tb-start-time time-block)) (tbe (tb-end-time time-block))
          (us (tb-start-time used)) (ue (tb-end-time used))
          (d duration-threshhold))
      (when (<= (+ tbs d) us)
        (push (make-instance 'time-block :start tbs :end us)
              good-times))
      (when (<= (+ ue d) tbe)
        (push (make-instance 'time-block :start ue :end tbe)
              good-times))
      good-times)
    (list time-block)))


(defun times-available (start-time end-time duration participants)
  ;; Try to find a time block of DURATION, between START-TIME and END-TIME
  ;; in which all PARTICIPANTS are free.
  (free-time-blocks (make-instance 'time-block 
                      :start start-time
                      :duration (- end-time start-time))
                    duration participants))
  

(defparameter +person-person-score+ 15)
(defparameter +interest-interest-score+ 6)

(defmethod meeting-desirability-score ((person1 person) (person2 person))
  (let ((score 0))
    (incf score
          (* +interest-interest-score+
             (length (intersection (person-interests person1) 
                                   (person-interests person2)))))
    (when (member person2 (person-wants-to-meet-with person1))
      (incf score +person-person-score+))
    (when (member person1 (person-wants-to-meet-with person2))
      (incf score +person-person-score+))
    score))

(defun what-to-schedule ()
  (let ((students (find-people :type :student))
        (faculty (find-people :type :professor))
        (collected nil))
    (dolist (f faculty)
      (dolist (s students)
        (let ((score (meeting-desirability-score f s)))
          (when (> score 0)
            (push (list score f s) collected)))))
    (sort collected #'> :key #'car)))

(defun schedule-meetings (how-much-time all-day)
  (let ((what (what-to-schedule))
        (failed nil))
    (loop
      (unless what (return))
      (let ((this (pop what)))
        (destructuring-bind (score &rest participants) this
          (declare (ignore score))
          (let ((time (first (free-time-blocks all-day how-much-time 
                                               participants))))
            (if time
              (make-instance 'meeting
                :start (tb-start-time time)
                :duration how-much-time
                :participants participants)
              (push this failed))))))
    failed))


(defun show-schedule (person)
  (format t "~&Schedule for ~(~a~) ~a"
          (person-type person)
          (person-name person))
  (dolist (m (person-schedule person))
    (format t "~&   ~6@a - ~6a  "
            (time-to-string (tb-start-time m))
            (time-to-string (tb-end-time m)))
    (etypecase m
      (meeting (format t "~{~a~^;  ~}"
                       (mapcar #'person-name 
                               (remove person (meeting-participants m)))))
      (lunch (format t "lunch"))
      (unavailable (format t "unavailable"))))
  person)

(defun show-all-schedules ()
  (dolist (person (find-people))
    (fresh-line) (terpri)
    (show-schedule person)
    (fresh-line) (terpri)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; user interface

(defun string-to-time (string)
  (let ((p (position #\: string))
        hour min)
    (handler-case 
      (progn 
        (setq hour (parse-integer string :end p :junk-allowed t))
        (setq min (parse-integer string :start (1+ p) :junk-allowed t)))
      (error () (error "Time must be h:mm")))
    (case (aref string (1- (length string)))
      ((#\a #\A) 
       (unless (<= hour 12) (error "Theres no ~d am" hour))
       (when (= hour 12) (setq hour 0)))
      ((#\p #\P) 
       (when (< 0 hour 12) (incf hour 12)))
      (t (when (< hour 9)
           (incf hour 12))))
    (+ (* 60 hour) min)))

(defmethod time-to-string (time)
  (multiple-value-bind (hour min)
                       (floor time 60)
    (format nil "~d:~2,'0d~:[a~;p~]" 
            (if (>= hour 13) (- hour 12) hour)
            min 
            (>= hour 12))))

(defun as-time (time)
  (etypecase time
    (integer time)
    (string (string-to-time time))))


(defparameter +earliest-time+ (string-to-time "10:00a"))
(defparameter +latest-time+ (string-to-time "5:00p"))

(defun find-person (name &optional (type nil type-p))
  (if (typep name 'person)
    name
    (let ((found (if type-p 
                   (find-people :match name :type type)
                   (find-people :match name))))
      (when (cdr found) 
        (error "~a ~s does not identify a unique person"
               type name))
      (unless found
        (error "no one found matching ~a ~s" type name))
      (car found))))

(defun make-a (type name &rest interests)
  (make-instance 'person 
    :name name
    :type type
    :interests (copy-list interests)))

(defun person-wants-to-meet-with-1 (person to-meet)
  (let ((person (find-person person))
        (to-meet (mapcar #'find-person to-meet)))
    (setf (person-wants-to-meet-with person) to-meet)))

(defmacro student (name &rest interests)
  `(make-a :student ,name ,@interests))
(defmacro prof (name &rest interests)
  `(make-a :professor ,name ,@interests))

(defmacro to-meet (person &body others)
  `(person-wants-to-meet-with-1 ,person (list ,@others)))

(defclass unavailable (time-block) ())

(defun unavailable (person start-time end-time)
  (let ((st (as-time (or start-time +earliest-time+)))
        (et (as-time (or end-time +latest-time+)))
        (p (find-person person)))
    (add-meeting p (make-instance 'unavailable
                     :start st :end et))))

(defclass lunch (time-block) ())

(defun lunch-break (start end)
  (let* ((start (as-time start))
         (end (as-time end))
         (lunch (make-instance 'lunch 
                  :start start
                  :end end)))
    (mapc #'(lambda (person) 
              (add-meeting person lunch)) 
          (find-people)))
  nil)

#|
;;; test data

(setq all-day (make-instance 'time-block 
                :start +earliest-time+
                :duration (- +latest-time+ +earliest-time+)))

(flush-all-people)

(student "Oded" :learning :beer)
(student "Holly" :robotics)
(student "Carlin" :circuits :beer)
(student "Greg" :learning)
(student "Charles" :learning)

(prof "Stein" :intelligent-agents)
(unavailable "Stein" "3:00p" nil)
(prof "Viola" :vision :learning)
(prof "Knight" :circuits :meat)
(prof "Grimson" :vision)
(prof "Brooks" :robotics)
(prof "Berwick" :natural-language)
(unavailable "Berwick" nil "11:30a")


(lunch-break "12:30p" "1:00p")

(to-meet "Holly" "Stein")
(to-meet "Knight" "Carlin")

(schedule-meetings 30 all-day)


|#