;;;; -*- 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)))
(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 ;;;;