;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.number-toss)

;;;;;;
;;; Scoreboard
;;;

(def special-variable *scoreboard-timestamp* (now))

(def special-variable *scoreboards* (make-hash-table :test #'equal :synchronized #t))

(def type rank ()
  'positive-integer)

(def class* scoreboard ()
  ((created-at :type timestamp)
   (entries :type sequence)
   (rank-entries :type sequence)))

(def class* scoreboard/entry ()
  ((rank :type rank)
   (player :type player)
   (submission-count :type integer)))

(def class* scoreboard/rank-entry ()
  ((rank :type rank)
   (player-count :type integer)
   (first-entry-index :type integer)))

(def function scoreboard/clear-all ()
  (clrhash *scoreboards*)
  (setf *scoreboard-timestamp* (now)))

(def function scoreboard/valid-character? (character)
  (or (member character '(#\Space #\.) :test #'char=)
      (alphanumericp character)))

(def function scoreboard/valid-tag? (tag)
  (check-type tag string)
  (not (find-if-not 'scoreboard/valid-character? tag)))

(def function scoreboard/find (key)
  (check-type key cons)
  (the (or null scoreboard) (gethash key *scoreboards*)))

(def function (setf scoreboard/find) (new-value key)
  (check-type key cons)
  (check-type new-value scoreboard)
  (setf (gethash key *scoreboards*) new-value))

(def function scoreboard/find-player-entry (player entries)
  (find (id-of player) entries :key (lambda (entry) (id-of (player-of entry))) :test #'eql))

(def function scoreboard/compute-rank-entries (max-rank entries)
  (iter (for rank :from 1 :to max-rank)
        (collect (make-instance 'scoreboard/rank-entry
                                :rank rank
                                :player-count (funcall 'count rank entries :key #'rank-of)
                                :first-entry-index (common-lisp:position rank entries :key #'rank-of))
          :result-type 'vector)))

(def function scoreboard/compute-selected-ranks (length current-rank max-rank)
  (check-type length non-negative-integer)
  (check-type current-rank (or null rank))
  (check-type max-rank rank)
  (assert (or (not current-rank) (<= 1 current-rank max-rank)))
  (bind ((current-rank (or current-rank 1))
         (current-rank-half (floor (/ current-rank 2)))
         (max-lower-head-length current-rank-half)
         (max-upper-head-length (- current-rank current-rank-half))
         (max-tail-length (- max-rank current-rank))
         (head-length (min current-rank (max (- length max-tail-length) (ceiling (* length 0.8)))))
         (lower-head-length (min max-lower-head-length (floor (/ head-length 2))))
         (upper-head-length (min max-upper-head-length (- head-length lower-head-length)))
         (lower-head-ranks (scoreboard/compute-selected-ranks/sequence lower-head-length 1 current-rank-half))
         (upper-head-ranks (reverse (scoreboard/compute-selected-ranks/sequence upper-head-length current-rank (1+ current-rank-half))))
         (tail-length (min max-tail-length (- length lower-head-length upper-head-length)))
         (tail-ranks (scoreboard/compute-selected-ranks/sequence tail-length (1+ current-rank) max-rank)))
    (assert (= (min length max-rank) (+ lower-head-length upper-head-length tail-length)))
    (assert (= lower-head-length (length lower-head-ranks)))
    (assert (= upper-head-length (length upper-head-ranks)))
    (assert (= tail-length (length tail-ranks)))
    (append lower-head-ranks upper-head-ranks tail-ranks)))

(def function scoreboard/compute-selected-ranks/sequence (length start end)
  (check-type length non-negative-integer)
  (check-type start non-negative-integer)
  (check-type end non-negative-integer)
  (unless (zerop length)
    (flet ((collect (length end)
             (bind (((:values k r q)
                     (iter (for k :from 1 :to end)
                           (for r = (- length k))
                           (unless (zerop r)
                             (for q = (expt (/ (coerce end 'double-float)
                                               (coerce k 'double-float))
                                            (/ (coerce r 'double-float))))
                             (when (> (floor (* k q)) k)
                               (return (values k r q))))
                           (finally
                            (return (values length 0 0)))))
                    (arithmetic (iter (for i :from 1 :to k)
                                      (collect i)))
                    (geometric (iter (for i :from 1 :to r)
                                     (for n :initially (* k q) :then (* n q))
                                     (for v = (floor n))
                                     (collect (if (= i r) end v)))))
               (assert (= length (+ (length arithmetic)
                                    (length geometric))))
               (append arithmetic geometric))))
      (if (<= start end)
          (mapcar (lambda (e)
                    (1- (+ e start)))
                  (collect length (- end start -1)))
          (mapcar (lambda (e)
                    (1+ (- start e)))
                  (collect length (- start end -1)))))))

;;;;;;
;;; Challenge scoreboard

(def class* challenge-scoreboard (scoreboard)
  ((challenge :type challenge)))

(def class* challenge-scoreboard/entry (scoreboard/entry)
  ((high-score :type integer)
   (overall-score :type integer)
   (submitted-at :type timestamp)))

(def function challenge-scoreboard/find (challenge-id scoreboard-tag)
  (check-type challenge-id challenge-id)
  (check-type scoreboard-tag string)
  (scoreboard/find `(challenge-scoreboard ,challenge-id ,scoreboard-tag)))

(def function (setf challenge-scoreboard/find) (new-value challenge-id scoreboard-tag)
  (check-type challenge-id challenge-id)
  (check-type scoreboard-tag string)
  (check-type new-value challenge-scoreboard)
  (setf (scoreboard/find `(challenge-scoreboard ,challenge-id ,scoreboard-tag)) new-value))

(def function challenge-scoreboard/ensure (challenge-id scoreboard-tag)
  (check-type challenge-id challenge-id)
  (check-type scoreboard-tag string)
  (or (challenge-scoreboard/find challenge-id scoreboard-tag)
      (setf (challenge-scoreboard/find challenge-id scoreboard-tag)
            (challenge-scoreboard/compute challenge-id scoreboard-tag))))

(def function challenge-scoreboard/compute-overall-score (entries entry)
  (check-type entries sequence)
  (check-type entry challenge-scoreboard/entry)
  (floor (/ (rank-of (elt entries (1- (length entries))))
            (rank-of entry))))

(def function challenge-scoreboard/compute (challenge-id scoreboard-tag)
  (check-type challenge-id challenge-id)
  (bind ((rank 0)
         (challenge (challenge/find-by-id challenge-id))
         (player-tags (if (string= "" scoreboard-tag)
                          ".*"
                          (string+ "( |^)" scoreboard-tag "( |$)")))
         ;; NOTE: we can select both score and submitted-at with max, because we reject scores that are not higher than the high score
         (records (select ((player-of game) (max (score-of game)) (max (submitted-at-of game)) (count (score-of game)))
                    (from (game game))
                    (where (and (eq challenge (challenge-of game))
                                (featured-p (player-of game))
                                (re-like (tags-of (player-of game)) player-tags)
                                (timestamp< (submitted-at-of game) *scoreboard-timestamp*)))
                    (group-by (player-of game))
                    (order-by :descending (max (score-of game)))))
         (entries (iter (for record :in-sequence records)
                        (for player = (elt record 0))
                        (for high-score = (elt record 1))
                        (for previous-high-score :previous high-score)
                        (when (or (not previous-high-score)
                                  (not (= previous-high-score high-score)))
                          (incf rank))
                        (collect (make-instance 'challenge-scoreboard/entry
                                                :rank rank
                                                :player (make-instance 'player :persistent #f
                                                                       :id (id-of player)
                                                                       :name (name-of player)
                                                                       :country-code (country-code-of player)
                                                                       :registered-at (registered-at-of player))
                                                :high-score high-score
                                                :submitted-at (elt record 2)
                                                :submission-count (elt record 3))
                          :result-type 'vector))))
    (iter (for entry :in-sequence entries)
          (setf (overall-score-of entry) (challenge-scoreboard/compute-overall-score entries entry)))
    (make-instance 'challenge-scoreboard
                   :challenge challenge
                   :created-at (now)
                   :entries (sort entries (lambda (e-1 e-2)
                                            (bind ((rank-1 (rank-of e-1))
                                                   (rank-2 (rank-of e-2)))
                                              (if (= rank-1 rank-2)
                                                  (timestamp< (submitted-at-of e-1) (submitted-at-of e-2))
                                                  (< rank-1 rank-2)))))
                   :rank-entries (scoreboard/compute-rank-entries rank entries))))

;;;;;;
;;; Overall scoreboard

(def class* overall-scoreboard (scoreboard)
  ((size :type integer)))

(def class* overall-scoreboard/entry (scoreboard/entry)
  ((overall-score :type integer)
   (gold-medal :type integer)
   (silver-medal :type integer)
   (bronze-medal :type integer)))

(def function overall-scoreboard/find (size scoreboard-tag)
  (check-type size (integer 5 9))
  (check-type scoreboard-tag string)
  (scoreboard/find `(overall-scoreboard ,size ,scoreboard-tag)))

(def function (setf overall-scoreboard/find) (new-value size scoreboard-tag)
  (check-type size (integer 5 9))
  (check-type scoreboard-tag string)
  (check-type new-value overall-scoreboard)
  (setf (scoreboard/find `(overall-scoreboard ,size ,scoreboard-tag)) new-value))

(def function overall-scoreboard/ensure (size scoreboard-tag)
  (check-type size (integer 5 9))
  (check-type scoreboard-tag string)
  (or (overall-scoreboard/find size scoreboard-tag)
      (setf (overall-scoreboard/find size scoreboard-tag)
            (overall-scoreboard/compute size scoreboard-tag))))

(def function overall-scoreboard/compute (size scoreboard-tag)
  (check-type size (integer 5 9))
  (bind ((entries (iter (with overall-scoreboard-entry-map = (make-hash-table :test #'eql))
                        (for challenge-id :from (- size 5) :to (challenge/find-maximum-id size) :by 5)
                        (for challenge-scoreboard = (challenge-scoreboard/ensure challenge-id scoreboard-tag))
                        (iter (with challenge-scoreboard-entries = (entries-of challenge-scoreboard))
                              (for challenge-scoreboard-entry :in-sequence challenge-scoreboard-entries)
                              (for player = (player-of challenge-scoreboard-entry))
                              (for overall-scoreboard-entry = (or (gethash (id-of player) overall-scoreboard-entry-map)
                                                                  (setf (gethash (id-of player) overall-scoreboard-entry-map)
                                                                        (make-instance 'overall-scoreboard/entry
                                                                                       :player player
                                                                                       :overall-score 0
                                                                                       :gold-medal 0
                                                                                       :silver-medal 0
                                                                                       :bronze-medal 0
                                                                                       :submission-count 0))))
                              (case (rank-of challenge-scoreboard-entry)
                                (1 (incf (gold-medal-of overall-scoreboard-entry)))
                                (2 (incf (silver-medal-of overall-scoreboard-entry)))
                                (3 (incf (bronze-medal-of overall-scoreboard-entry))))
                              (incf (submission-count-of overall-scoreboard-entry) (submission-count-of challenge-scoreboard-entry))
                              (incf (overall-score-of overall-scoreboard-entry) (overall-score-of challenge-scoreboard-entry)))
                        (finally (return (sort (coerce (hash-table-values overall-scoreboard-entry-map) 'vector)
                                               (lambda (a b) (> (overall-score-of a) (overall-score-of b))))))))
         (rank 0))
    (iter (for entry :in-sequence entries)
          (for overall-score = (overall-score-of entry))
          (for previous-overall-score :previous overall-score)
          (when (or (not previous-overall-score)
                    (not (= previous-overall-score overall-score)))
            (incf rank))
          (setf (rank-of entry) rank))
    (make-instance 'overall-scoreboard
                   :size size
                   :created-at (now)
                   :entries (sort entries (lambda (e-1 e-2)
                                            (bind ((rank-1 (rank-of e-1))
                                                   (rank-2 (rank-of e-2)))
                                              (if (= rank-1 rank-2)
                                                  (timestamp< (registered-at-of (player-of e-1)) (registered-at-of (player-of e-2)))
                                                  (< rank-1 rank-2)))))
                   :rank-entries (scoreboard/compute-rank-entries rank entries))))