Author: hhubner Date: 2007-11-26 06:19:32 -0500 (Mon, 26 Nov 2007) New Revision: 2286 Added: branches/trunk-reorg/projects/scrabble/src/portable-queue.lisp branches/trunk-reorg/projects/scrabble/src/publish-subscribe.lisp branches/trunk-reorg/projects/scrabble/src/queue.lisp Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/scrabble.asd branches/trunk-reorg/projects/scrabble/src/web.lisp branches/trunk-reorg/projects/scrabble/website/scrabble.js Log: Add publish/subscribe mechanism. Add queue implementation so that threads can signal each other with some data. The queue implementation for OpenMCL uses CCL primitives with timeout, the portable version uses the HUNCHENTOOT-MP package and polling. Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-25 05:37:30 UTC (rev 2285) +++ branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-26 11:19:32 UTC (rev 2286) @@ -50,10 +50,20 @@ (vector-push-extend tile (tiles-of tile-bag))) (shake-tile-bag tile-bag)) -(defclass player (user) - ((games :initform nil :accessor games-of)) +(defclass player (user subscriber) + ((games :initform nil + :accessor games-of) + (event-queue :initform (make-instance 'queue) + :reader event-queue-of + :transient t) + (publish-subscribe:subscriptions :transient t)) (:metaclass persistent-class)) +(defmethod wait-for-event ((player player) timeout) + "Return next event for PLAYER or nil if TIMEOUT seconds have elapsed +without any new events occuring on the queue." + (queue-pop (event-queue-of player) timeout)) + (defclass participant (store-object) ((player :initarg :player :reader player-of) (tray :initarg :tray :accessor tray-of) @@ -74,7 +84,12 @@ (defclass move (store-object) ((participant :initarg :participant :reader participant-of) - (placed-tiles :initarg :placed-tiles + (time :initarg :time + :reader time-of)) + (:metaclass persistent-class)) + +(defclass letter-placement (move) + ((placed-tiles :initarg :placed-tiles :reader placed-tiles-of) (new-tiles-drawn :initarg :new-tiles-drawn :reader new-tiles-drawn-of @@ -93,7 +108,7 @@ (score-of move) (words-formed-of move)))) -(defclass game (store-object) +(defclass game (store-object publication) ((language :initarg :language :reader language-of) (board :initarg :board @@ -105,7 +120,8 @@ :documentation "List of participants in this game") (moves :initform nil :accessor moves-of - :documentation "List of moves that have been made in this game")) + :documentation "List of moves that have been made in this game") + (publish-subscribe:subscriptions :transient t)) (:metaclass persistent-class)) (deftransaction make-game (language players) @@ -186,7 +202,17 @@ (append drawn (tray-of participant))) drawn)) -(deftransaction make-move% (game participant placed-tiles) +(defmethod signal-subscriber ((player player) (game game) move) + (queue-push (list :type "move" :game-id (store-object-id game) :move move) + (event-queue-of player))) + +(defun make-move (participant class &rest initargs) + (apply #'make-object class + :participant participant + :time (get-universal-time) + initargs)) + +(deftransaction make-letter-placement% (game participant placed-tiles) (dolist (placed-tile placed-tiles) (when (used-for placed-tile) (setf (used-for (tile-of placed-tile)) (used-for placed-tile)))) @@ -201,31 +227,29 @@ (when (eql 7 (length tiles-used)) (incf score 50)) (incf (score-of participant) score) - (let ((move (make-object 'move - :participant participant - :placed-tiles placed-tiles - :new-tiles-drawn tiles-drawn - :words-formed words-formed - :score score))) + (let ((move (make-move participant 'letter-placement + :placed-tiles placed-tiles + :new-tiles-drawn tiles-drawn + :words-formed words-formed + :score score))) (push move (moves-of game)) (rotate-participants game) + (publish game move) move)))) -(defun make-move (game participant placed-tiles) +(defun make-letter-placement (game participant placed-tiles) (ensure-participants-turn game participant) (ensure-participant-has-tiles participant placed-tiles) (check-move-legality (board-of game) placed-tiles) - (make-move% game participant (mapcar (lambda (placement) - (list (x-of placement) - (y-of placement) - (tile-of placement) - (used-for placement))) - placed-tiles))) + (make-letter-placement% game participant (mapcar (lambda (placement) + (list (x-of placement) + (y-of placement) + (tile-of placement) + (used-for placement))) + placed-tiles))) -(defclass move-withdrawal (store-object) - ((participant :initarg :participant - :reader participant-of) - (reason :initarg :reason +(defclass move-withdrawal (move) + ((reason :initarg :reason :reader reason-of)) (:metaclass persistent-class)) @@ -252,10 +276,8 @@ (error "last move was not a letter placement, can't be withdrawn")) (withdraw-last-move% game reason move))) -(defclass tile-swap (store-object) - ((participant :initarg :participant - :reader participant-of) - (count :initarg :count +(defclass tile-swap (move) + ((count :initarg :count :reader count-of)) (:metaclass persistent-class)) Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-25 05:37:30 UTC (rev 2285) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-26 11:19:32 UTC (rev 2286) @@ -1,10 +1,38 @@ +#+openmcl +(defpackage :mp-utils + (:use :cl :ccl) + (:export "QUEUE" + "QUEUE-PUSH" + "QUEUE-POP")) + +#-openmcl +(defpackage :mp-utils + (:use :cl :hunchentoot-mp) + (:export "QUEUE" + "QUEUE-PUSH" + "QUEUE-POP")) + +(defpackage :publish-subscribe + (:use :cl) + (:export "PUBLICATION" + "SUBSCRIBER" + "SUBSCRIBE-TO" + "SUBSCRIPTIONS" + "CANCEL-SUBSCRIPTION" + "CANCEL-SUBSCRIPTIONS" + "PUBLISH" + "SIGNAL-SUBSCRIBER")) + (defpackage :scrabble (:use :cl :alexandria :anaphora + :publish-subscribe + :mp-utils :bknr.datastore :bknr.user) + (:shadowing-import-from :bknr.user "SUBSCRIPTIONS") (:export "*BOARD-SCORING*" "*TILE-SETS*" @@ -25,6 +53,7 @@ "PLAYER" "GAMES-OF" + "WAIT-FOR-EVENT" "PARTICIPANT" "PLAYER-OF" @@ -35,17 +64,18 @@ "Y-OF" "TILE-OF" - "MAKE-MOVE" - - "MOVE" + "MAKE-LETTER-PLACEMENT" + "LETTER-PLACEMENT" "SCORE-OF" "PARTICIPANT-OF" "WORDS-FORMED-OF" "PLACED-TILES-OF" - "MOVE-WITHDRAWAL" + "MAKE-MOVE-WITHDRAWAL" + "MOVE-WITHDRAWAL" "REASON-OF" + "MAKE-TILE-SWAP" "TILE-SWAP" "COUNT-OF" @@ -70,11 +100,13 @@ :hunchentoot :bknr.datastore :bknr.user + :publish-subscribe :cl-who :cl-interpol :cl-ppcre :json - :scrabble) + :scrabble + :mp-utils) + (:shadowing-import-from :bknr.user "SUBSCRIPTIONS") (:shadowing-import-from :cl-interpol "QUOTE-META-CHARS") - (:export "START-WEBSERVER")) - \ No newline at end of file + (:export "START-WEBSERVER")) \ No newline at end of file Added: branches/trunk-reorg/projects/scrabble/src/portable-queue.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/portable-queue.lisp 2007-11-25 05:37:30 UTC (rev 2285) +++ branches/trunk-reorg/projects/scrabble/src/portable-queue.lisp 2007-11-26 11:19:32 UTC (rev 2286) @@ -0,0 +1,35 @@ +(in-package :mp-utils) + +(defclass queue () + ((count :initform 0 :accessor count-of) + (lock :initform (make-lock "queue") :reader lock-of) + (head :initform nil :accessor head-of) + (tail :initform nil :accessor tail-of))) + +(defmethod print-object ((queue queue) stream) + (print-unreadable-object (queue stream :type t :identity t) + (format stream "~A" (head-of queue)))) + +(defmethod queue-push (data (queue queue)) + (with-lock ((lock-of queue)) + (let ((new-cell (cons data nil))) + (when (tail-of queue) + (setf (cdr (tail-of queue)) new-cell)) + (setf (tail-of queue) new-cell) + (unless (head-of queue) + (setf (head-of queue) new-cell))) + (incf (count-of queue))) + queue) + +(defmethod queue-pop ((queue queue) timeout) + (loop while (plusp timeout) + do (with-lock ((lock-of queue)) + (when (plusp (count-of queue)) + (decf (count-of queue)) + (let ((retval (pop (head-of queue)))) + (unless (head-of queue) + (setf (tail-of queue) nil)) + (return-from queue-pop (values retval t))))) + do (decf timeout) + do (sleep 1)) + (values nil nil)) \ No newline at end of file Added: branches/trunk-reorg/projects/scrabble/src/publish-subscribe.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/publish-subscribe.lisp 2007-11-25 05:37:30 UTC (rev 2285) +++ branches/trunk-reorg/projects/scrabble/src/publish-subscribe.lisp 2007-11-26 11:19:32 UTC (rev 2286) @@ -0,0 +1,42 @@ + +(in-package :publish-subscribe) + +(defclass publication () + ((subscriptions :initform nil :accessor subscriptions-of))) + +(defclass subscription () + ((subscriber :initarg :subscriber :reader subscriber-of) + (publication :initarg :publication :reader publication-of))) + +(defclass subscriber () + ((subscriptions :initform nil :accessor subscriptions-of))) + +(defmethod subscribe-to ((subscriber subscriber) + (publication publication)) + (make-instance 'subscription + :subscriber subscriber + :publication publication)) + +(defmethod initialize-instance :after ((subscription subscription) &key) + (pushnew subscription (subscriptions-of (publication-of subscription))) + (pushnew subscription (subscriptions-of (subscriber-of subscription)))) + +(defmethod cancel-subscription ((subscription subscription)) + (with-slots (publication subscriber) subscription + (setf (subscriptions-of publication) + (remove subscription (subscriptions-of publication))) + (setf (subscriptions-of subscriber) + (remove subscription (subscriptions-of subscriber))))) + +(defmethod cancel-subscriptions (holder) + (mapcar #'cancel-subscription (subscriptions-of holder))) + +(defgeneric signal-subscriber (subscriber publication payload) + (:documentation "Notify SUBSCRIBER that PULICATION has been +published with the given PAYLOAD.")) + +(defmethod publish ((publication publication) payload) + (dolist (subscription (subscriptions-of publication)) + (signal-subscriber (subscriber-of subscription) + (publication-of subscription) + payload))) Added: branches/trunk-reorg/projects/scrabble/src/queue.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/queue.lisp 2007-11-25 05:37:30 UTC (rev 2285) +++ branches/trunk-reorg/projects/scrabble/src/queue.lisp 2007-11-26 11:19:32 UTC (rev 2286) @@ -0,0 +1,31 @@ +(in-package :mp-utils) + +(defclass queue () + ((semaphore :initform (make-semaphore) :reader semaphore-of) + (lock :initform (make-lock) :reader lock-of) + (head :initform nil :accessor head-of) + (tail :initform nil :accessor tail-of))) + +(defmethod print-object ((queue queue) stream) + (print-unreadable-object (queue stream :type t :identity t) + (format stream "~A" (head-of queue)))) + +(defmethod queue-push (data (queue queue)) + (with-lock-grabbed ((lock-of queue)) + (let ((new-cell (cons data nil))) + (when (tail-of queue) + (setf (cdr (tail-of queue)) new-cell)) + (setf (tail-of queue) new-cell) + (unless (head-of queue) + (setf (head-of queue) new-cell))) + (signal-semaphore (semaphore-of queue))) + queue) + +(defmethod queue-pop ((queue queue) timeout) + (if (timed-wait-on-semaphore (semaphore-of queue) timeout) + (with-lock-grabbed ((lock-of queue)) + (let ((retval (pop (head-of queue)))) + (unless (head-of queue) + (setf (tail-of queue) nil)) + (values retval t))) + (values nil nil))) \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.asd =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-11-25 05:37:30 UTC (rev 2285) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-11-26 11:19:32 UTC (rev 2286) @@ -23,6 +23,11 @@ :cl-json) :serial t :components ((:file "package") + (:file "publish-subscribe") + #+openmcl + (:file "queue") + #-openmcl + (:file "portable-queue") (:file "game-constants") (:file "rules") (:file "game") Modified: branches/trunk-reorg/projects/scrabble/src/web.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-25 05:37:30 UTC (rev 2285) +++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-26 11:19:32 UTC (rev 2286) @@ -5,14 +5,16 @@ (defparameter *ignore-slots* '(bknr.datastore::id bknr.indices::destroyed-p)) (defun encode-json-plist (plist stream) - (princ #\{ stream) - (loop for (key value &rest rest) on plist by #'cddr - do (encode-json key stream) - do (princ #\: stream) - do (encode-json value stream) - when rest - do (princ #\, stream)) - (princ #\} stream)) + (let (printed) + (princ #\{ stream) + (loop for (key value) on plist by #'cddr + when printed + do (princ #\, stream) + do (setf printed t) + do (encode-json key stream) + do (princ #\: stream) + do (encode-json value stream)) + (princ #\} stream))) (defmethod encode-json ((object store-object) stream) (let (printed) @@ -28,6 +30,11 @@ (encode-json (slot-value object (closer-mop:slot-definition-name slotdef)) stream))) (princ #\} stream))) +(defmethod encode-json ((game game) stream) + (let ((*ignore-slots* (append *ignore-slots* + '(publish-subscribe::subscriptions)))) + (call-next-method))) + (defmethod encode-json ((tile-bag tile-bag) stream) (encode-json-plist (list :remaining-tiles (remaining-tile-count tile-bag)) stream)) @@ -43,7 +50,7 @@ (list :used-for it))) stream)) -(defmethod encode-json ((move move) stream) +(defmethod encode-json ((move letter-placement) stream) (encode-json-plist (list :type "move" :participant-login (user-login (player-of (participant-of move))) :score (score-of move) @@ -83,23 +90,23 @@ (defmethod encode-json ((participant participant) stream) (start-session) - (format t "user: ~A~%" (session-value :user)) (encode-json-plist (append (list :login (user-login (player-of participant)) :name (user-full-name (player-of participant)) :remaining-tiles) - (list (if (equal (user-login (player-of participant)) - (session-value :user)) + (list (if (eq (player-of participant) + (session-value :user)) (tray-of participant) (length (tray-of participant))))) stream)) -(define-easy-handler (login :uri "/login" :default-request-type :get) +(define-easy-handler (login :uri "/login") (login password) (format t "warning: password not checked~*~%" password) - (when (and login - (find-user login)) + (no-cache) + (awhen (and login + (find-user login)) (start-session) - (setf (session-value :user) login) + (setf (session-value :user) it) (redirect "/scrabble.html")) (with-html-output-to-string (*standard-output* nil) (:html @@ -123,7 +130,6 @@ list-of-moves) (labels ((use-letter (letter is-blank) - (format t "use-letter ~A ~A~%" letter is-blank) (awhen (find (if is-blank nil letter) tray :key #'letter-of) (setf tray (remove it tray)) (return-from use-letter it)) @@ -151,25 +157,37 @@ (defmethod find-game ((game-id string)) (find-game (parse-integer game-id))) -(define-easy-handler (make-move-handler :uri "/make-move" :default-request-type :post) +(define-easy-handler (place-tiles-handler :uri "/place-tiles") (move game) (start-session) + (no-cache) ;; MOVE contains the move to make, GAME is the object ID of the game. (with-output-to-string (s) (handler-case (progn (let* ((game (find-game game)) - (participant (find (find-user (session-value :user)) (participants-of game) :key #'player-of))) + (participant (find (session-value :user) (participants-of game) :key #'player-of))) (encode-json-plist - (list :move (scrabble:make-move game - participant - (parse-move participant move)) + (list :move (make-letter-placement game + participant + (parse-move participant move)) :tray (tray-of participant)) s))) (error (e) (encode-json-plist (list :error (princ-to-string e)) s))))) +(defparameter *no-event-timeout* 60) + +(define-easy-handler (wait-event-handler :uri "/wait-event") () + (start-session) + (no-cache) + (unless (session-value :user) + (redirect "/login")) + (with-output-to-string (s) + (encode-json-plist (wait-for-event (session-value :user) *no-event-timeout*) s))) + (define-easy-handler (games :uri "/games") () (start-session) + (no-cache) (with-html-output-to-string (*standard-output* nil) (:html (:head @@ -177,7 +195,7 @@ (:body (:ul (dolist (game (remove-if-not (lambda (game) - (member (find-user (session-value :user)) (participants-of game) + (member (session-value :user) (participants-of game) :key #'player-of)) (class-instances 'game))) (htm @@ -185,13 +203,16 @@ (defun game-handler () (start-session) + (no-cache) (register-groups-bind (object-id-string) (#?r".*/(\d+)$" (request-uri)) - (let ((object (and object-id-string ; avoid sbcl warning + (let ((game (and object-id-string ; avoid sbcl warning (find-store-object (parse-integer object-id-string))))) - (when (typep object 'game) + (when (typep game 'game) + (awhen (session-value :user) + (subscribe-to it game)) (return-from game-handler (with-output-to-string (s) - (encode-json object s)))))) + (encode-json game s)))))) (with-html-output-to-string (*standard-output* nil) (:html (:head @@ -199,10 +220,11 @@ (:body (:div "Invalid game ID"))))) -(define-easy-handler (move :uri "/move" :default-request-type :get) +(define-easy-handler (move :uri "/move") ((game-id :parameter-type 'integer) (move :parameter-type 'json:decode-json-from-string)) (start-session) + (no-cache) (assert game-id) (let ((game (find-store-object game-id))) (assert game) Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-25 05:37:30 UTC (rev 2285) +++ branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-26 11:19:32 UTC (rev 2286) @@ -111,13 +111,6 @@ appendChildNodes(container, board[x]); } - theirTrays = DIV(); - theirTrays.style.position = 'absolute'; - theirTrays.style.width = 7 * 44 + 'px'; - theirTrays.style.height = '70px'; - setElementPosition(theirTrays, { x: border + 16 * 40, y: border + 40 }); - appendChildNodes(container, theirTrays); - var shuffleButton = DIV(null, "shuffle"); shuffleButton.style.color = 'white'; shuffleButton.style.position = 'absolute'; @@ -193,13 +186,15 @@ } }; - this.advance = function() { + this.advance = function(isHoriz) { var horizontal = 1; var vertical = 2; var direction = this.direction; if (direction == 0) { // Direction not determined - if (((this.y < 14) && letterAt(this.x, this.y + 1)) + if (isHoriz != undefined) { + direction = isHoriz ? horizontal : vertical; + } else if (((this.y < 14) && letterAt(this.x, this.y + 1)) || ((this.y > 1) && letterAt(this.x, this.y - 1) && !letterAt(this.x, this.y - 2)) @@ -257,7 +252,7 @@ function submitMove() { var queryString = MochiKit.Base.queryString({ move: move.toString(), game: gameID }); - var res = MochiKit.Async.doXHR("/make-move", + var res = MochiKit.Async.doXHR("/place-tiles", { method: 'POST', sendContent: queryString, headers: { "Content-Type": "application/x-www-form-urlencoded" } }); @@ -311,7 +306,11 @@ if (tilePosition == -1) { alert("You don't have that letter!"); } else { - cursor.advance(); + var isHoriz; + if (move.length > 0) { + isHoriz = (move[0][0] != x); + } + cursor.advance(isHoriz); if (!letterAt(x, y)) { var tile = tray[tilePosition]; tray.splice(tilePosition, 1); @@ -392,8 +391,7 @@ element.style.height = '34px'; element.style.zIndex = '10'; element.onclick = trayClick; - // setElementPosition(element, { x: border + 194 + i * 40, y: border + 665 }); - YAHOO.util.Dom.setXY(element, [ border + 194 + i * 40, border + 665 ]); + setElementPosition(element, { x: border + 194 + i * 40, y: border + 665 }); tray[i] = element; } appendChildNodes($('playfield'), tray); @@ -416,11 +414,28 @@ tray = newTray; } -function addTheirTray (participant) { - appendChildNodes(theirTrays, DIV(null, - DIV(null, participant.name), - DIV(null, map(function () { return IMG({ src: 'images/null.png' }) }, - new Array(participant.remainingTiles))))); +var otherPlayerIndex = 0; + +function makeTheirTray (name, tileCount) { + var tray = []; + for (var i = 0; i < tileCount; i++) { + var element = IMG({src: 'images/null.png'}); + element.style.position = 'absolute'; + element.style.width = '34px'; + element.style.height = '34px'; + element.style.zIndex = '10'; + setElementPosition(element, { x: border + 680 + i * 40, y: border + 80 * otherPlayerIndex }); + tray[i] = element; + } + appendChildNodes($('playfield'), tray); + + var nameTag = DIV(null, name); + nameTag.style.position = 'absolute'; + nameTag.style.width = '200px'; + nameTag.style.textAlign = 'left'; + setElementPosition(nameTag, { x: border + 680, y: border + 80 * otherPlayerIndex + 50 }); + appendChildNodes($('playfield'), nameTag); + otherPlayerIndex++; } function drawGameState (gameState) { @@ -433,7 +448,7 @@ for (var i = 0; i < gameState.participants.length; i++) { var participant = gameState.participants[i]; if (typeof participant.remainingTiles == 'number') { - addTheirTray(participant); + makeTheirTray(participant.name, participant.remainingTiles); } else { makeMyTray(map(function (entry) { return entry.letter }, participant.remainingTiles)); }