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

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

;;;;;;
;;; Request

(def function request/find-player (request)
  (player/find-by-id (parse-integer (slot-value request 'player-id))))

(def function request/find-challenge (request)
  ;; TODO: eventually delete obsolete challenge request parameter
  (challenge/find-by-id (parse-integer (or (slot-value request 'challenge)
                                           (slot-value request 'challenge-id)))))

(def function request/find-scoreboard-tag (request)
  (remove-if-not 'scoreboard/valid-character? (string-downcase (or (slot-value request 'scoreboard-tag) ""))))

;;;;;;
;;; <register-player-request player-hash="..." player-name="..." player-tags="..." player-country-code="..." signed-data="..." signature="..." version="..." variant="..."/>
;;;
;;; <register-player-response result="..." player-id="..." player-status="..." premium="..." featured="..."/>

(def function service/process-register-player-request (request)
  (bind ((player-hash (slot-value request 'player-hash))
         (player-name (slot-value request 'player-name))
         (player-tags (string-downcase (or (slot-value request 'player-tags) "")))
         (anonymous? (string= player-name "anonymous"))
         (player (unless anonymous? (player/find-by-name player-name))))
    (cond ((not (player/valid-name? player-name))
           <register-player-response (:result "denied" :reason ,(format nil "player name '~A' contains invalid characters" player-name))>)
          ((and player (not (string= player-hash (hash-of player))))
           <register-player-response (:result "denied" :reason ,(format nil "player name '~A' already exists" player-name))>)
          ((not (scoreboard/valid-tag? player-tags))
           <register-player-response (:result "denied" :reason ,(format nil "player tags '~A' contains invalid characters" player-tags))>)
          (t
           (bind ((player-country-code (slot-value request 'player-country-code))
                  (version (slot-value request 'version))
                  (signed-data (slot-value request 'signed-data))
                  (signature (slot-value request 'signature))
                  (player (player/ensure :hash player-hash :name player-name :tags player-tags :country-code (unless (string= player-country-code "") player-country-code)
                                         :signed-data signed-data :signature signature :version version)))
             (scoreboard/clear-all)
             ;; TODO: eventually delete obsolete player-status attribute
             <register-player-response (:result "done" :player-id ,(id-of player) :player-status ,(if (premium-p player) "premium" "free")
                                        :premium ,(if (premium-p player) "true" "false") :featured ,(if (featured-p player) "true" "false"))>)))))

;;;;;;
;;; <refresh-global-settings-request player-id="..." version="..." variant="..."/>
;;;
;;; <refresh-global-settings-response result="..." challenge-limit="..." recalculation-frequency="..."/>

(def function service/process-refresh-global-settings-request (request)
  (bind ((player (request/find-player request)))
    (cond ((not player)
           <refresh-global-settings-response (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <refresh-global-settings-response (:result "denied" :reason "player disabled")>)
          (t
           (bind ((version (slot-value request 'version)))
             (setf (version-of player) version)
             (setf (last-started-at-of player) (now))
             ;; TODO: eventually delete obsolete challenge-limit attribute
             <refresh-global-settings-response (:result "done" :challenge-limit "100" :recalculation-frequency ,+recalculation-frequency+)>)))))

;;;;;;
;;; <refresh-high-scores-request player-id="..." scoreboard-tag="..." version="..." variant="..."/>
;;;
;;; <refresh-high-scores-response result="...">
;;;   <entry player-id="..." player-name=".." challenge-id="..." high-score="..." rank="..." submitted-at="..."/>
;;; </refresh-high-scores-response>

(def function service/process-refresh-high-scores-request (request)
  (bind ((player (request/find-player request)))
    (cond ((not player)
           <refresh-high-scores-response (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <refresh-high-scores-response (:result "denied" :reason "player disabled")>)
          (t
           (bind ((scoreboard-tag (request/find-scoreboard-tag request)))
             <refresh-high-scores-response (:result "done")
               ,@(iter (for challenge-id :from 0 :to (challenge/find-maximum-id))
                       (for challenge-scoreboard = (challenge-scoreboard/ensure challenge-id scoreboard-tag))
                       (for entries = (entries-of challenge-scoreboard))
                       (unless (emptyp entries)
                         (bind ((first-entry (first-elt entries))
                                (last-entry (last-elt entries))
                                (player-entry (scoreboard/find-player-entry player entries)))
                           (iter (for entry :in (remove-if 'null (remove-duplicates (list first-entry last-entry player-entry))))
                                 (for player = (player-of entry))
                                 (for submitted-at = (format-timestring nil (submitted-at-of entry) :timezone +utc-zone+ :format +java-timestamp-format+))
                                 ;; TODO: eventually delete obsolete challenge attribute
                                 <entry (:rank ,(rank-of entry) :player-id ,(id-of player) :player-name ,(name-of player)
                                         :challenge ,challenge-id :challenge-id ,challenge-id :high-score ,(high-score-of entry) :submitted-at ,submitted-at)>))))>)))))

;;;;;;
;;; <submit-game-request player-id="..." challenge-id="..." moves="..." version="..." variant="..."/>
;;;
;;; <submit-game-response result="..."/>

(def function service/process-submit-game-request (request)
  (bind ((player (request/find-player request))
         (challenge (request/find-challenge request)))
    (cond ((not player)
           <submit-game-respose (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <submit-game-respose (:result "denied" :reason "player disabled")>)
          ((not challenge)
           <submit-game-respose (:result "denied" :reason "unknown challenge")>)
          (t
           (bind ((moves (move-sequence/parse (slot-value request 'moves)))
                  (score (game/compute-score challenge moves))
                  (high-score (game/find-high-score challenge player)))
             (if (and high-score (<= score high-score))
                 ;; NOTE: if the game is not a player high score, then it's not worth storing
                 <submit-game-response (:result "done")>
                 (progn
                   (game/make player challenge moves)
                   <submit-game-response (:result "done")>)))))))

;;;;;;
;;; <submit-challenge-request player-id="..." challenge-name="..." size="..." board="..." version="..." variant="..."/>
;;;
;;; <submit-challenge-response result="..." challenge-id="..."/>

(def function service/process-submit-challenge-request (request)
  (bind ((player (request/find-player request))
         (challenge-name (slot-value request 'challenge-name))
         (challenge (challenge/find-by-name challenge-name))
         (required-high-score-game-count (when player (- (* 10 (1+ (challenge/count-by-player player)))
                                                         (game/count-by-player player)))))
    (cond ((not player)
           <submit-challenge-respose (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <submit-challenge-respose (:result "denied" :reason "player disabled")>)
          ((not (challenge/valid-name? challenge-name))
           <submit-challenge-respose (:result "denied" :reason ,(format nil "challenge name '~A' contains invalid characters" challenge-name))>)
          (challenge
           <submit-challenge-respose (:result "denied" :reason ,(format nil "challenge name '~A' already exists" challenge-name))>)
          ((minusp required-high-score-game-count)
           <submit-challenge-respose (:result "denied" :reason ,(format nil "submit ~A player high scores before submitting a new challenge" required-high-score-game-count))>)
          (t
           (bind ((size (parse-integer (slot-value request 'size)))
                  (board (board/parse size (slot-value request 'board)))
                  (challenge (challenge/make player challenge-name size board)))
             <submit-challenge-respose (:result "done" :challenge-id ,(id-of challenge))>)))))

;;;;;;
;;; <refresh-challenge-list-request player-id="..." version="..." variant="..."/>
;;;
;;; <refresh-challenge-list-response result="...">
;;;   <entry player-id="..." player-name="..." challenge-id="..." challenge-name="..." size="..." board="..." submitted-at="..."/>
;;;   ...
;;; </refresh-challenge-list-response>

(def function service/process-refresh-challenge-list-request (request)
  (bind ((player (request/find-player request)))
    (cond ((not player)
           <refresh-challenge-list-response (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <refresh-challenge-list-response (:result "denied" :reason "player disabled")>)
          (t
           <refresh-challenge-list-response (:result "done")
             ,@(iter (for challenge :in-sequence (select (challenge)
                                                   (from (challenge challenge))
                                                   (where (not (null (player-of challenge))))))
                     (for player = (player-of challenge))
                     (for submitted-at = (format-timestring nil (submitted-at-of challenge) :timezone +utc-zone+ :format +java-timestamp-format+))
                     <entry (:player-id ,(id-of player) :player-name ,(name-of player) :player-country-code ,(country-code-of player)
                             :challenge-id ,(id-of challenge) :challenge-name ,(name-of challenge)
                             :size ,(size-of challenge) :board ,(board-of challenge) :submitted-at ,submitted-at)>)>))))

;;;;;;
;;; <refresh-challenge-scoreboard-request player-id="..." challenge-id="..." scoreboard-tag="..." version="..." variant="..."/>
;;;
;;; <refresh-challenge-scoreboard-response result="...">
;;;   <entry rank="..." player-id="..." player-name="..." player-count="..." high-score="..." submission-count="..."/>
;;;   ...
;;; </refresh-challenge-scoreboard-response>

(def function service/process-refresh-challenge-scoreboard-request (request)
  (bind ((player (request/find-player request)))
    (cond ((not player)
           <refresh-challenge-scoreboard-response (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <refresh-challenge-scoreboard-response (:result "denied" :reason "player disabled")>)
          (t
           (bind ((challenge (request/find-challenge request))
                  (scoreboard-tag (request/find-scoreboard-tag request))
                  (challenge-scoreboard (challenge-scoreboard/ensure (id-of challenge) scoreboard-tag))
                  (entries (entries-of challenge-scoreboard))
                  (rank-entries (rank-entries-of challenge-scoreboard)))
             <refresh-challenge-scoreboard-response (:result "done")
               ,(unless (emptyp entries)
                  (bind ((player-entry (scoreboard/find-player-entry player entries))
                         (current-rank (when player-entry (rank-of player-entry)))
                         (max-rank (rank-of (elt entries (1- (length entries)))))
                         (selected-ranks (scoreboard/compute-selected-ranks +scoreboard-size+ current-rank max-rank))
                         (extra-lines (- +scoreboard-size+ (length selected-ranks))))
                    (iter (for rank :in-sequence selected-ranks)
                          (for rank-entry = (elt rank-entries (1- rank)))
                          (for player-count = (player-count-of rank-entry))
                          (for extract-rank-entry = (< (player-count-of rank-entry) extra-lines))
                          (when extract-rank-entry
                            (decf extra-lines player-count))
                          (iter (for entry :in-sequence (if extract-rank-entry
                                                            (subseq entries (first-entry-index-of rank-entry) (+ player-count
                                                                                                                 (first-entry-index-of rank-entry)))
                                                            (list (if (and player-entry
                                                                           (= (rank-of rank-entry) (rank-of player-entry)))
                                                                      player-entry
                                                                      (elt entries (first-entry-index-of rank-entry))))))
                                (for player = (player-of entry))
                                <entry (:rank ,(rank-of entry) :player-id ,(id-of player) :player-name ,(name-of player)
                                        :player-country-code ,(country-code-of player) :player-count ,(if extract-rank-entry 1 (player-count-of rank-entry))
                                        :high-score ,(high-score-of entry) :submission-count ,(submission-count-of entry))>))))>)))))

;;;;;;
;;; <refresh-challenge-player-scoreboard-request player-id="..." target-player-id="..." challenge-id="..." scoreboard-tag="..." version="..." variant="..."/>
;;;
;;; <refresh-challenge-player-scoreboard-response result="...">
;;;   <entry score="..." submitted-at="..."/>
;;;   ...
;;; </refresh-challenge-player-scoreboard-response>

(def function service/process-refresh-challenge-player-scoreboard-request (request)
  (bind ((player (request/find-player request)))
    (cond ((not player)
           <refresh-challenge-player-scoreboard-response (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <refresh-challenge-player-scoreboard-response (:result "denied" :reason "player disabled")>)
          ((not (featured-p player))
           <refresh-challenge-player-scoreboard-response (:result "denied" :reason "featured disabled")>)
          (t
           (bind ((target-player (player/find-by-id (parse-integer (slot-value request 'target-player-id))))
                  (challenge (request/find-challenge request))
                  (scoreboard-tag (request/find-scoreboard-tag request))
                  (records (select ((score-of game) (submitted-at-of game))
                             (from (game game))
                             (where (and (eq challenge (challenge-of game))
                                         (eq target-player (player-of game))))
                             (order-by :descending (submitted-at-of game)))))
             <refresh-challenge-player-scoreboard-response (:result "done")
               ,@(iter (for record :in-sequence records)
                       (for submitted-at = (format-timestring nil (elt record 1) :timezone +utc-zone+ :format +java-timestamp-format+))
                       <entry (:score ,(elt record 0) :submitted-at ,submitted-at)>)>)))))

;;;;;;
;;; <refresh-overall-scoreboard-request player-id="..." size="..." scoreboard-tag="..." version="..." variant="..."/>
;;;
;;; <refresh-overall-scoreboard-response result="...">
;;;   <entry rank="..." player-id="..." player-name="..." high-score="..." submission-count="..."/>
;;;   ...
;;; </refresh-overall-scoreboard-response>

(def function service/process-refresh-overall-scoreboard-request (request)
  (bind ((player (request/find-player request)))
    (cond ((not player)
           <refresh-overall-scoreboard-response (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <refresh-overall-scoreboard-response (:result "denied" :reason "player disabled")>)
          (t
           (bind ((size (parse-integer (slot-value request 'size)))
                  (scoreboard-tag (request/find-scoreboard-tag request))
                  (overall-scoreboard (overall-scoreboard/ensure size scoreboard-tag))
                  (entries (entries-of overall-scoreboard))
                  (rank-entries (rank-entries-of overall-scoreboard)))
             <refresh-overall-scoreboard-response (:result "done")
               ,(unless (emptyp entries)
                  (bind ((player-entry (scoreboard/find-player-entry player entries))
                         (current-rank (when player-entry (rank-of player-entry)))
                         (max-rank (rank-of (elt entries (1- (length entries)))))
                         (selected-ranks (scoreboard/compute-selected-ranks +scoreboard-size+ current-rank max-rank))
                         (extra-lines (- +scoreboard-size+ (length selected-ranks))))
                    (iter (for rank :in-sequence selected-ranks)
                          (for rank-entry = (elt rank-entries (1- rank)))
                          (for player-count = (player-count-of rank-entry))
                          (for extract-rank-entry = (< (player-count-of rank-entry) extra-lines))
                          (when extract-rank-entry
                            (decf extra-lines player-count))
                          (iter (for entry :in-sequence (if extract-rank-entry
                                                            (subseq entries (first-entry-index-of rank-entry) (+ (first-entry-index-of rank-entry) player-count))
                                                            (list (if (and player-entry
                                                                           (= (rank-of rank-entry) (rank-of player-entry)))
                                                                      player-entry
                                                                      (elt entries (first-entry-index-of rank-entry))))))
                                (for player = (player-of entry))
                                <entry (:rank ,(rank-of entry) :player-id ,(id-of player) :player-name ,(name-of player)
                                        :player-country-code ,(country-code-of player) :player-count ,(if extract-rank-entry 1 (player-count-of rank-entry))
                                        :gold-medal ,(gold-medal-of entry) :silver-medal ,(silver-medal-of entry) :bronze-medal ,(bronze-medal-of entry)
                                        :overall-score ,(overall-score-of entry) :submission-count ,(submission-count-of entry))>))))>)))))

;;;;;;
;;; <refresh-overall-player-scoreboard-request player-id="..." target-player-id="..." size="..." scoreboard-tag="..." version="..." variant="..."/>
;;;
;;; <refresh-overall-player-scoreboard-response result="...">
;;;   <entry challenge-id="..." rank="..." high-core="..." submission-count="..."/>
;;;   ...
;;; </refresh-overall-player-scoreboard-response>

(def function service/process-refresh-overall-player-scoreboard-request (request)
  (bind ((player (request/find-player request)))
    (cond ((not player)
           <refresh-overall-player-scoreboard-response (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <refresh-overall-player-scoreboard-response (:result "denied" :reason "player disabled")>)
          ((not (featured-p player))
           <refresh-overall-player-scoreboard-response (:result "denied" :reason "featured disabled")>)
          (t
           (bind ((target-player-id (slot-value request 'target-player-id))
                  (scoreboard-tag (request/find-scoreboard-tag request))
                  (target-player (player/find-by-id (parse-integer target-player-id)))
                  (size (slot-value request 'size))
                  (records (select ((challenge-of game) (max (score-of game)))
                             (from (game game))
                             (where (and (= size (size-of (challenge-of game)))
                                         (eq target-player (player-of game))))
                             (group-by (challenge-of game))
                             (order-by :ascending (challenge-of game)))))
             <refresh-overall-player-scoreboard-response (:result "done")
               ,@(iter (for record :in-sequence records)
                       (for challenge = (elt record 0))
                       (for challenge-id = (id-of challenge))
                       (for challenge-scoreboard = (challenge-scoreboard/ensure challenge-id scoreboard-tag))
                       (for challenge-scoreboard-entry = (scoreboard/find-player-entry target-player (entries-of challenge-scoreboard)))
                       (for rank = (rank-of challenge-scoreboard-entry))
                       (for submitted-at = (format-timestring nil (submitted-at-of challenge-scoreboard-entry) :timezone +utc-zone+ :format +java-timestamp-format+))
                       (for overall-score = (overall-score-of challenge-scoreboard-entry))
                       ;; TODO: eventually delete obsolete challenge attribute
                       <entry (:challenge ,challenge-id :challenge-id ,challenge-id :rank ,rank :high-score ,(elt record 1) :submitted-at ,submitted-at
                               :overall-score ,overall-score :submission-count ,(submission-count-of challenge-scoreboard-entry))>)>)))))

;;;;;;
;;; <refresh-challenge-suggestion-request player-id="..." size="..." scoreboard-tag="..." version="..." variant="..."/>
;;;
;;; <refresh-challenge-suggestion-response result="...">
;;;   <entry challenge-id="..." overall-score="..." overall-high-score="..."/>
;;;   ...
;;; <refresh-challenge-suggestion-response>

(def function service/process-refresh-challenge-suggestion-request (request)
  (bind ((player (request/find-player request)))
    (cond ((not player)
           <refresh-challenge-suggestion-respose (:result "denied" :reason "player not found")>)
          ((not (enabled-p player))
           <refresh-challenge-suggestion-respose (:result "denied" :reason "player disabled")>)
          ((not (featured-p player))
           <refresh-challenge-suggestion-respose (:result "denied" :reason "feature disabled")>)
          (t
           (bind ((size (parse-integer (slot-value request 'size)))
                  (scoreboard-tag (request/find-scoreboard-tag request)))
             <refresh-challenge-suggestion-respose (:result "done")
               ,@(iter (for challenge-id :from (- size 5) :to (challenge/find-maximum-id size) :by 5)
                       (for challenge-scoreboard = (challenge-scoreboard/ensure challenge-id scoreboard-tag))
                       (for entries = (entries-of challenge-scoreboard))
                       (for player-entry = (scoreboard/find-player-entry player entries))
                       (unless (emptyp entries)
                         ;; TODO: eventually delete obsolete challenge attribute
                         <entry (:challenge ,challenge-id :challenge-id ,challenge-id :overall-score ,(if player-entry (overall-score-of player-entry) 0)
                                 :overall-high-score ,(overall-score-of (first-elt entries)))>))>)))))