;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               mine-web-player.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    This program let a user play with mine thru a hunchentoot web page.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2008-05-16 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal Bourguignon 2008 - 2008
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************


(in-package "COM.INFORMATIMAGO.GAME.MINE-WEB-PLAYER")

(defparameter *application-name*  "MINE")
(defparameter *application-port* 8007)

(defparameter *this-file* (load-time-value
                           (or #.*compile-file-pathname* *load-pathname*)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defmacro with-app-page ((&key (title *application-name*)) &body body)
  `(with-output-to-string (*html-output-stream*)
     (let ((*DOCTYPE* :loose))
       (with-html-output (*html-output-stream* :encoding "UTF-8")
         (html
           (head ()
                 (title () (pcdata "~A" ,title))
                 (link (:rel "stylesheet" :href  "/resources/style.css" :type "text/css"))
                 )
           (body (:class "body")
                 (h1 (pcdata "~A" ,title))
                 ,@body))))))




(defmacro reporting-errors (&body body)
  `(handler-bind
       ((error (lambda  (err)
                 (with-app-page (:title "Error")
                   (hunchentoot:log-message :error "Got an error: ~A" err)
                   #+sbcl
                   (dolist (frame (SB-DEBUG:BACKTRACE-AS-LIST))
                     (hunchentoot:log-message :error "Backtrace: ~S" frame))
                   (pcdata "Got an error: ~A" err)
                   (table ()
                          (dolist (frame (SB-DEBUG:BACKTRACE-AS-LIST))
                            (tr () (td () (code () (pcdata "~S" frame))))))))))
     (progn ,@body)))


(eval-when (:execute :compile-toplevel :load-toplevel)
  (defun make-form (enctype action key-and-values body)
   `(form (:action ,action
                   :method "POST"
                   :charset :utf-8
                   :enctype ,enctype
                   )
          ,@(loop
               :for (key value) :on key-and-values :by (function cddr)
               :collect `(input (:type "hidden"
                                       :name ,(string-downcase key)
                                       :value ,value)))
          ,@body)))


(defmacro insert-form ((action &rest key-and-values &key &allow-other-keys)
                       &body body)
  (make-form "application/x-www-form-urlencoded" action key-and-values body))

(defmacro insert-file-form ((action &rest key-and-values &key &allow-other-keys)
                            &body body)
  (make-form "multipart/form-data" action key-and-values body))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *game-map* (make-hash-table :test (function equal)))

(defstruct gaque
  key
  (message-present (bordeaux-threads:make-condition-variable))
  (lock            (bordeaux-threads:make-lock))
  (messages        (cons nil nil)))

(defun gaque-enqueue (message gaque)
  (bordeaux-threads:with-lock-held ((gaque-lock gaque))
    (if (null (car (gaque-messages gaque)))
        (setf (car (gaque-messages gaque)) (list message)
              (cdr (gaque-messages gaque)) (car (gaque-messages gaque)))
        (push message (cdr (gaque-messages gaque))))
    (bordeaux-threads:condition-notify (gaque-message-present gaque))))

(defun gaque-dequeue (gaque)
  (bordeaux-threads:with-lock-held ((gaque-lock gaque))
    (loop
       :while (null (car (gaque-messages gaque)))
       :do (bordeaux-threads:condition-wait (gaque-message-present gaque)
                                            (gaque-lock gaque)))
    (if (eq  (cdr (gaque-messages gaque)) (car (gaque-messages gaque)))
        (prog1 (car (car (gaque-messages gaque)))
          (setf (cdr (gaque-messages gaque)) nil
                (car (gaque-messages gaque)) nil))
        (pop (car (gaque-messages gaque))))))


(defun send-to-ui (message display total-mine-count remaining-mine-count)
  (gaque-enqueue (list message display total-mine-count remaining-mine-count)
                 (gethash (cons 'ui (bordeaux-threads:current-thread)) *game-map*)))

(defun receive-ui-message ()
  (values-list (gaque-dequeue
                (gethash (cons 'ui (hunchentoot:session-value 'thread)) *game-map*))))

(defun send-order (action x y)
  (gaque-enqueue (list (if (eq action :auto) :step action) x y)
                 (gethash (cons 'order (hunchentoot:session-value 'thread)) *game-map*)))

(defun receive-order-message ()
  (values-list (gaque-dequeue
                 (gethash (cons 'order (bordeaux-threads:current-thread)) *game-map*))))



(defun player (message &key display total-mine-count remaining-mine-count)
  "
Must return (values :step x y) or (values :flag x y) unless message is :explosion or :win.
"
  (send-to-ui message display total-mine-count remaining-mine-count)
  (if (member message '(:explosion :win))
      (values)
      (receive-order-message)))


(defun launch-game (width height number-of-mines)
  ;; this creates the session:
  (setf (hunchentoot:session-value 'parameters) (list width height number-of-mines))
  ;; now we can use hunchentoot:*session*
  (let* ((lock  (bordeaux-threads:make-lock))
         (start (bordeaux-threads:make-condition-variable))
         (thread
          (bordeaux-threads:make-thread
           (lambda ()
             (bordeaux-threads:with-lock-held (lock)
               (bordeaux-threads:condition-wait start lock))
             (com.informatimago.game.mine:mine
              :width width
              :height height
              :mines number-of-mines
              :player (function player)))
           :name (let ((*print-pretty* nil))
                   (format nil "mine player ~S"
                           (list (hunchentoot::session-id          hunchentoot:*session*)
                                 (hunchentoot::session-user-agent  hunchentoot:*session*)
                                 (hunchentoot::session-remote-addr hunchentoot:*session*)
                                 (hunchentoot::session-start       hunchentoot:*session*)))))))
    (setf (hunchentoot:session-value 'thread) thread)
    (let ((key (cons 'ui thread)))
      (setf (gethash key  *game-map*) (make-gaque :key key)))
    (let ((key (cons 'order thread)))
      (setf (gethash key *game-map*) (make-gaque :key key)))
    (bordeaux-threads:with-lock-held (lock)
      (bordeaux-threads:condition-notify start))))



(defun insert-mine-board (display total-mine-count remaining-mine-count donep)
  (flet ((cell (x y cell buttonp)
           (if (and buttonp (not (eql cell 0)))
               (button
                 (:class "board-cell"
                         :type "submit"
                         :name "cell"
                         :value (format nil "(~D ~D)" x y))
                 (img (:src (case cell
                              ((:nothing)  "/resources/nothing.png")
                              ((:mine)     "/resources/hidden.png")
                              ((:wrong)    "/resources/not.png")
                              ((:exploded) "/resources/dead.png")
                              ((:flag)     "/resources/found.png")
                              ((:beware)   "/resources/dunno.png")
                              (otherwise
                               (format nil "/resources/~D.png" cell)))
                            :class "board-cell")))
                 (img (:src (case cell
                              ((:nothing)  "/resources/nothing.png")
                              ((:mine)     "/resources/hidden.png")
                              ((:wrong)    "/resources/not.png")
                              ((:exploded) "/resources/dead.png")
                              ((:flag)     "/resources/found.png")
                              ((:beware)   "/resources/dunno.png")
                              (otherwise
                               (format nil "/resources/~D.png" cell)))
                            :class "board-cell")))))
    (if donep
        (progn
          (table
            (:class "counters")
            (tr (:class "counters")
                (td (:class "counter-total-mine-count")
                    (pcdata "~D" total-mine-count))
                (td (:class "counter-remaining-mine-count")
                    (pcdata "~D" remaining-mine-count))
                (td (:class "action-menu"))))
          (table
            (:class "board")
            (loop
               :for y :from 0 :below (array-dimension display 1)
               :do (tr (:class "board-row")
                       (loop
                          :for x :from 0 :below (array-dimension display 0)
                          :do (td (:class "board-cell")
                                  (cell x y  (aref display x y) nil)))))))
        (insert-form
         ("play")
         (table
           (:class "counters")
           (tr (:class "counters")
               (td (:class "counter-total-mine-count")
                   (pcdata "~D" total-mine-count))
               (td (:class "counter-remaining-mine-count")
                   (pcdata "~D" remaining-mine-count))
               (td (:class "action-menu")
                   (unless donep
                     (select (:class "action" :name "action")
                             (option (:class "action" :name "step" :value "step" :selected :selected)
                                     (pcdata "Step"))
                             (option (:class "action" :name "flag" :value "flag")
                                     (pcdata "Put a flag"))
                             (option (:class "action" :name "auto" :value "auto")
                                     (pcdata "Auto step")))))))
         (table
           (:class "board")
           (loop
              :for y :from 0 :below (array-dimension display 1)
              :do (tr (:class "board-row")
                      (loop
                         :for x :from 0 :below (array-dimension display 0)
                         :do (td (:class "board-cell")
                                 (cell x y  (aref display x y) t))))))))))



(defun insert-new-game-form (width height number-of-mines title)
  (insert-form
   ("new-game")
   (table
     (:class "form")
     (tr (:class "field")
         (td (:clas "field-name")  (pcdata "Width:"))
         (td (:clas "field-value")
             (input (:type "text" :size "4" :name "width"
                           :value width)))
         (td (:class "field-range") (pcdata "(9 to 30)")))
     (tr (:class "field")
         (td (:clas "field-name")  (pcdata "Height:"))
         (td (:clas "field-value")
             (input (:type "text" :size "4" :name "height"
                           :value height)))
         (td (:class "field-range") (pcdata "(9 to 24)")))
     (tr (:class "field")
         (td (:clas "field-name")  (pcdata "Number Of Mines:"))
         (td (:clas "field-value")
             (input (:type "text" :size "4" :name "number-of-mines"
                           :value number-of-mines)))
         (td (:class "field-range") (pcdata "(10 to width*height-10)"))))
   (input (:type "submit" :value title))))


(defun play (&optional first-time-p)
  (reporting-errors
   (unless first-time-p
     (let ((action (hunchentoot:post-parameter "action"))
           (cell   (hunchentoot:post-parameter "cell"))
           x y next)
       (if (and (member action '(:step :flag :auto) :test (function string-equal))
                (<= 5 (length cell))
                (char= #\( (aref cell 0))
                (char= #\) (aref cell (1- (length cell))))
                (multiple-value-setq (x next)
                  (parse-integer cell :start 1 :junk-allowed t))
                (multiple-value-setq (y next)
                  (parse-integer cell :start next :junk-allowed t))
                (= next (1- (length cell))))
           (send-order (intern (string-upcase action) "KEYWORD") x y)
           (return-from play
             (with-app-page (:title "Web Mines -- Error")
               (p (:class "error")
                  (pcdata "Got an invalid request; action=~S cell=~S"
                          action cell))
               (br)
               (p () (a (:href "/") (pcdata "Start again"))))))))
   (multiple-value-bind (message display total-mine-count remaining-mine-count) (receive-ui-message)
     (hunchentoot:no-cache)
     (case message
       ((nil)
        (with-app-page (:title "Web Mines -- Error")
          (p () (pcdata "Sorry I didn't get a message from the mine player."))
          (hr)
          (div (:class "menu")
              (insert-new-game-form (array-dimension display 0)
                                    (array-dimension display 1)
                                    total-mine-count
                                    "Play again"))))
       ((:explosion :win)
        (with-app-page (:title (format nil "Web Mines -- ~:[Lost~;Won~]"
                                       (eq message :win)))
          (p () (pcdata "~:[Sorry, you lost.~;Yippi, you win!~]"
                        (eq message :win)))
          (hr)
          (insert-mine-board display total-mine-count remaining-mine-count :done)
          (hr)
          (div (:class "menu")
              (insert-new-game-form (array-dimension display 0)
                                    (array-dimension display 1)
                                    total-mine-count
                                    "Play again"))))
       (otherwise
        (with-app-page (:title "Web Mines -- Your turn")
          (hr)
          (insert-mine-board display total-mine-count remaining-mine-count nil)
          (hr)
          ;; (div (:class "menu")
          ;;     (insert-new-game-form (array-dimension display 0)
          ;;                           (array-dimension display 1)
          ;;                           total-mine-count
          ;;                           "Play again"))
          ))))))





(defun home ()
  (reporting-errors
   (with-app-page (:title "Web Mines")
     (div (:class "menu")
         (insert-new-game-form 30 24 99 "Play")))))


(defun new-game ()
  (reporting-errors
   (let ((width            (parse-integer (hunchentoot:post-parameter "width")           :junk-allowed nil))
         (height           (parse-integer (hunchentoot:post-parameter "height")          :junk-allowed nil))
         (number-of-mines  (parse-integer (hunchentoot:post-parameter "number-of-mines") :junk-allowed nil)))
     (if (and width (<= 9 width 30)
              height (<= 9 height 24)
              number-of-mines (<= 10 number-of-mines (- (* width height) 10)))
         (progn
           (launch-game width height number-of-mines)
           (play t))
         (hunchentoot:redirect "/")))))




(defun initialize ()
  (values))


(defun create-dispatcher (script-name page-function)
  "Creates a dispatch function which will dispatch to the
function denoted by PAGE-FUNCTION if the file name of the current
request is PATH."
  (lambda (request)
    (and (string= (hunchentoot:script-name request) script-name)
         page-function)))


(defvar *server* nil)

(defun start-server ()
  (when *server*
    (hunchentoot:stop *server*))
  (setf *server* nil)
  (initialize)
  (setf hunchentoot:*dispatch-table*
        `(,(hunchentoot:create-folder-dispatcher-and-handler
           "/resources/"
           (make-pathname :directory '(:relative "resources")
                          :name nil :type nil :version nil
                          :defaults *this-file*)
           #|mime-type|#"image/png")
          ,@(mapcar
             (lambda (args) (apply (function create-dispatcher) args))
             '(("/"             home)
               ("/new-game"     new-game)
               ("/play"         play)))
          ,(function hunchentoot:default-dispatcher)))
   (hunchentoot:start (setf *server* (make-instance 'hunchentoot:acceptor :port  *application-port*))))

(defun stop-server ()
  (when *server*
    (hunchentoot:stop *server*)
    (setf *server* nil)))


(defun kill-mine-threads ()
  (mapc
   (lambda (x)
     (bordeaux-threads:destroy-thread (cdr x))
     (remhash (cons 'ui    (cdr x)) *game-map*)
     (remhash (cons 'order (cdr x)) *game-map*))
   (remove-if-not
    (lambda (x) (or (com.informatimago.common-lisp.cesarum.string:prefixp "mine player" (car x))
               (com.informatimago.common-lisp.cesarum.string:prefixp "hunchentoot-worker-" (car x))))
    (mapcar (lambda (x) (cons (bordeaux-threads:thread-name x) x))
            (bordeaux-threads:all-threads)))))

;;;; THE END ;;;;
ViewGit