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

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

;;;;;;
;;; Player

(def persistent-class* player ()
  ((id :type integer-64 :unique #t :index #t)
   (hash :type (text 32) :unique #t :index #t)
   (name :type (text 16) :index #t)
   (tags :type (text 256) :index #t)
   ;; TODO: eventually remove null
   (version :type (or null (text 8)))
   (signed-data :type (or null text))
   (signature :type (or null text))
   (premium :type boolean)
   (featured :type boolean)
   (enabled :type boolean)
   ;; TODO: eventually remove null
   (country-code :type (or null (string 2)))
   (last-started-at :type (or null timestamp))
   (registered-at :type timestamp :index #t)
   (ip-address :type ip-address)))

(def function player/make-id ()
  (random (1- (expt 2 63))))

(def function player/valid-name? (name)
  (check-type name string)
  (and (> (length name) 0)
       (not (find-if-not (lambda (character)
                           (or (member character '(#\Space #\.) :test #'char=)
                               (alphanumericp character)))
                         name))))

(def function player/find-by-id (id)
  (check-type id integer)
  (select-instance (player player)
    (where (= id (id-of player)))))

(def function player/find-by-hash (hash)
  (check-type hash (string 32))
  (select-instance (player player)
    (where (equal hash (hash-of player)))))

(def function player/find-by-name (name)
  (check-type name string)
  (select-instance (player player)
    (where (equal name (name-of player)))))

(def function player/ensure (&key hash name tags country-code version signed-data signature)
  (check-type hash (string 32))
  (check-type name string)
  (check-type tags (or null string))
  (check-type country-code (or null string))
  (check-type version (or null string))
  (check-type signed-data (or null string))
  (check-type signature (or null string))
  (bind ((player (player/find-by-hash hash))
         (premium (or (and player (premium-p player))
                      (player/verify-signature signed-data signature)))
         (featured (or premium
                       (< (count-instances 'player) 1000000)))
         (tags (if country-code
                   (string-trim-whitespace (string+ tags " " (string-downcase country-code)))
                   tags)))
    (if player
        (progn
          (unless (string= name "anonymous")
            (setf (name-of player) name))
          (setf (tags-of player) tags)
          (setf (country-code-of player) country-code)
          (setf (version-of player) version)
          (setf (premium-p player) premium)
          (setf (featured-p player) featured)
          (when (and premium
                     signed-data
                     signature)
            (setf (signed-data-of player) signed-data)
            (setf (signature-of player) signature))
          player)
        (make-instance 'player
                       :id (player/make-id)
                       :hash hash
                       :name name
                       :tags tags
                       :country-code country-code
                       :version version
                       :signed-data signed-data
                       :signature signature
                       :premium premium
                       :featured featured
                       :enabled #t
                       :last-started-at (now)
                       :registered-at (now)
                       :ip-address *request-remote-address*))))

(def function player/verify-signature (signed-data signature)
  ;; TODO: revive real check
  (not (null (and signed-data signature)))
  #+nil
  (flet ((unpad (data)
           (subseq data (1+ (common-lisp:position 0 data)))))
    ;; TODO: use ASN.1 DER decoding and EQUALP instead of SEARCH
    #+nil(not (null (search (ironclad:digest-sequence :sha1 (base64:base64-string-to-usb8-array signed-data))
                            (unpad (ironclad:encrypt-message (ironclad:make-public-key :rsa :n +public-key-modulus+ :e +public-key-exponent+)
                                                             (base64:base64-string-to-usb8-array signature))))))))

;;;;;;
;;; Challenge

(def persistent-class* challenge ()
  ((id :type integer-64 :unique #t :index #t)
   (name :type (text 16) :unique #t :index #t)
   (size :type integer-8 :index #t)
   (board :type (text 81))
   (submitted-at :type timestamp :index #t)
   (ip-address :type ip-address)))

(def persistent-association*
  ((:class challenge :slot player :type (or null player))
   (:class player :slot challenges :type (set challenge))))

(def function challenge/make (player name size board)
  (check-type player player)
  (check-type name string)
  (check-type size board-size)
  (check-type board board)
  (make-instance 'challenge
                 :player player
                 :id (challenge/make-id size)
                 :name name
                 :size size
                 :board (with-output-to-string (stream) (board/print board stream))
                 :submitted-at (now)
                 :ip-address *request-remote-address*))

(def function challenge/make-id (size)
  (check-type size board-size)
  (+ (challenge/find-maximum-id size) 5))

(def function challenge/valid-name? (name)
  (check-type name string)
  (not (find-if-not (lambda (character)
                      (or (member character '(#\Space #\.) :test #'char=)
                          (alphanumericp character)))
                    name)))

(def function challenge/find-by-id (id)
  (check-type id integer)
  (select-instance (challenge challenge)
    (where (= id (id-of challenge)))))

(def function challenge/find-by-name (name)
  (check-type name string)
  (select-instance (challenge challenge)
    (where (equal name (name-of challenge)))))

(def function challenge/find-maximum-id (&optional size)
  (check-type size (or null board-size))
  (first-elt (if size
                 (select ((max (id-of challenge)))
                   (from (challenge challenge))
                   (where (= size (size-of challenge))))
                 (select ((max (id-of challenge)))
                   (from (challenge challenge))))))

(def function challenge/count-by-player (player)
  (check-type player player)
  (first-elt (select ((count challenge))
               (from (challenge challenge))
               (where (eq player (player-of challenge))))))

;;;;;;
;;; Game

(def persistent-class* game ()
  ((moves :type (text 320))
   (score :type integer-16)
   (submitted-at :type timestamp :index #t)
   (ip-address :type ip-address)))

(def persistent-association*
  ((:class game :slot challenge :type challenge)
   (:class challenge :slot games :type (set game))))

(def persistent-association*
  ((:class game :slot player :type player)
   (:class player :slot games :type (set game))))

(def function game/make (player challenge moves)
  (check-type player player)
  (check-type challenge challenge)
  (check-type moves move-sequence)
  (make-instance 'game
                 :player player
                 :challenge challenge
                 :moves (with-output-to-string (string) (move-sequence/print moves string))
                 :score (game/compute-score challenge moves)
                 :submitted-at (now)
                 :ip-address *request-remote-address*))

(def function game/find-high-score (challenge &optional player)
  (check-type challenge challenge)
  (check-type player (or null player))
  (first (if player
             (select ((max (score-of game)))
               (from (game game))
               (where (and (eq challenge (challenge-of game))
                           (eq player (player-of game)))))
             (select ((max (score-of game)))
               (from (game game))
               (where (eq challenge (challenge-of game)))))))

(def function game/count-by-player (player)
  (check-type player player)
  (first (select ((count game))
           (from (game game))
           (where (eq player (player-of game))))))

(def function game/compute-score (challenge moves)
  (check-type challenge challenge)
  (check-type moves move-sequence)
  (board/compute-score (board/parse (size-of challenge) (board-of challenge)) moves))