Author: hhubner Date: 2007-11-10 14:47:50 -0500 (Sat, 10 Nov 2007) New Revision: 2264

Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/rules.lisp branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp branches/trunk-reorg/projects/scrabble/src/web.lisp branches/trunk-reorg/projects/scrabble/website/scrabble.js Log: game play back end enhanced. move withdrawal untested.

Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-08 19:17:13 UTC (rev 2263) +++ branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-10 19:47:50 UTC (rev 2264) @@ -11,26 +11,31 @@ (print-unreadable-object (tile-bag stream :type t :identity t) (format stream "~A letters remaining" (remaining-tile-count tile-bag))))

+(defmethod shake-tile-bag ((tile-bag tile-bag)) + (with-slots (tiles) tile-bag + (dotimes (i (fill-pointer tiles)) + (let ((tmp (aref tiles i)) + (random-index (random (fill-pointer tiles)))) + (setf (aref tiles i) (aref tiles random-index)) + (setf (aref tiles random-index) tmp))))) + +(defmethod initialize-persistent-instance :after ((tile-bag tile-bag)) + (shake-tile-bag tile-bag)) + (defun make-tile-bag (language) (let ((tiles (make-array 102 :adjustable t :fill-pointer 0))) (mapcar (lambda (entry) - (destructuring-bind (char value count) entry + (destructuring-bind (letter value count) entry (dotimes (i count) - (vector-push-extend (make-tile char value) tiles)))) + (vector-push-extend (make-tile letter value) tiles)))) (or (getf *tile-sets* language) (error "language ~A not defined" language))) - #+(or) - (dotimes (i (fill-pointer tiles)) - (let ((tmp (aref tiles i)) - (random-index (random (fill-pointer tiles)))) - (setf (aref tiles i) (aref tiles random-index)) - (setf (aref tiles random-index) tmp))) (make-object 'tile-bag :tiles tiles)))

(define-condition no-tiles-remaining (simple-error) ())

-(deftransaction draw-tile (tile-bag) +(defun draw-tile (tile-bag) (unless (plusp (remaining-tile-count tile-bag)) (error 'no-tiles-remaining)) (with-slots (tiles) tile-bag @@ -38,31 +43,57 @@ (aref tiles (1- (fill-pointer tiles))) (decf (fill-pointer tiles)))))

-(defun make-move (board placed-tiles) - "Actually perform a move. BOARD contains the already placed tiles, -PLACED-TILES contains the letters for the move to make. BOARD is -modified to include the tiles placed. Returns the two values that -CALCULATE-SCORE returns for the move." - (check-move-legality board placed-tiles) - (prog1 - (mapcar (lambda (word-result) - (list (word-text word-result) (word-score word-result))) - (words-formed board placed-tiles)) - (dolist (placed-tile placed-tiles) - (put-letter board (tile-of placed-tile) (x-of placed-tile) (y-of placed-tile))))) +(defun draw-tiles (tile-bag count) + (loop for i below count + collect (draw-tile tile-bag)))

+(defmethod undraw-tiles ((tile-bag tile-bag) tiles) + (dolist (tile tiles) + (vector-push-extend tile (tiles-of tile-bag))) + (shake-tile-bag tile-bag)) + (defclass player (user) ((games :initform nil :accessor games-of)) (:metaclass persistent-class))

(defclass participant (store-object) ((player :initarg :player :reader player-of) - (tray :initarg :tray :accessor tray-of)) + (tray :initarg :tray :accessor tray-of) + (score :initform 0 :accessor score-of)) (:metaclass persistent-class))

+(defmethod print-object ((participant participant) stream) + (print-unreadable-object (participant stream :type t) + (format stream "~A score: ~A, ~A tile~:P" + (user-login (player-of participant)) + (score-of participant) + (length (tray-of participant))))) + (defmethod tray-size ((participant participant)) (length (tray-of participant)))

+(defclass move (store-object) + ((participant :initarg :participant + :reader participant-of) + (placed-tiles :initarg :placed-tiles + :reader placed-tiles) + (new-tiles-drawn :initarg :new-letters-drawn + :reader new-tiles-drawn-of + :documentation "New letters that have been drawn after +the move, should the move need to be undone") + (words-formed :initarg :words-formed + :reader words-formed-of) + (score :initarg :score + :reader score-of)) + (:metaclass persistent-class)) + +(defmethod print-object ((move move) stream) + (print-unreadable-object (move stream :type t) + (format stream "by ~A, ~A points (~{~A~^, ~})" + (player-of (participant-of move)) + (reduce #'+ (mapcar #'cdr (words-formed-of move))) + (words-formed-of move)))) + (defclass game (store-object) ((language :initarg :language :reader language-of) @@ -72,7 +103,10 @@ :accessor tile-bag-of) (participants :initarg :participants :accessor participants-of - :documentation "List of participants in this game")) + :documentation "List of participants in this game") + (moves :initform nil + :accessor moves-of + :documentation "List of moves that have been made in this game")) (:metaclass persistent-class))

(deftransaction make-game (language players) @@ -94,16 +128,130 @@ :tile-bag tile-bag :participants participants)))

+(defmethod next-participant-of ((game game)) + (car (participants-of game))) + (defun participants-turn-p (game participant) - (eq participant (car (participants-of game)))) + (eq participant (next-participant-of game)))

(defun ensure-participants-turn (game participant) - (assert (participants-turn-p game participant) nil - "It's not ~s's turn.")) + (unless (participants-turn-p game participant) + (error "It's not ~A's turn." (user-login (player-of participant)))))

-(deftransaction next-participants-turn (game) - (with-accessors ((participants participants-of)) - game - (let ((first (pop participants))) - (setf participants (nconc participants (list first)))))) +(defun rotate-participants (game) + (with-slots (participants) game + (setf participants (append (cdr participants) (list (car participants))))))

+(defun unrotate-participants (game) + (with-slots (participants) game + (setf participants (append (last participants) (butlast participants))))) + +(defmethod letter-equal ((letter1 character) (letter2 character)) + (eql letter1 letter2)) + +(defmethod letter-equal ((letter1 character) (letter2 (eql nil))) + nil) + +(defmethod letter-equal ((tile1 tile) (tile2 tile)) + (letter-equal (letter-of tile1) (letter-of tile2))) + +(defun ensure-participant-has-tiles (participant placed-tiles) + (let ((tray-letters (mapcar #'letter-of (tray-of participant))) + (placed-letters (mapcar (compose #'letter-of #'tile-of) placed-tiles))) + (dolist (letter placed-letters) + (let ((has-letter (find letter tray-letters :test #'letter-equal)) + (has-blank (find nil tray-letters))) + (unless (or has-letter has-blank) + (error "participant ~A does not have tile ~A" participant letter)) + (setf tray-letters + (if has-letter + (remove letter tray-letters :test #'letter-equal :count 1) + (remove nil tray-letters :key #'letter-of :count 1))))))) + +(defun remove-letters-from-participant-tray (participant tiles) + (let (removed-tiles) + (with-slots (tray) participant + (dolist (tile tiles) + (push (find tile tray :test #'letter-equal) removed-tiles) + (setf tray (remove tile tray :test #'letter-equal :count 1)))) + removed-tiles)) + +(defun draw-new-letters (tile-bag participant count) + (let ((drawn (draw-tiles tile-bag (min count (remaining-tile-count tile-bag))))) + (setf (tray-of participant) + (append drawn (tray-of participant))) + drawn)) + +(defun make-move (game participant placed-tiles) + (ensure-participants-turn game participant) + (ensure-participant-has-tiles participant placed-tiles) + (check-move-legality (board-of game) placed-tiles) + (with-transaction (:make-move) + (let ((words-formed (mapcar (lambda (word-result) + (cons (word-text word-result) (word-score word-result))) + (words-formed (board-of game) placed-tiles)))) + (dolist (placed-tile placed-tiles) + (put-letter (board-of game) (tile-of placed-tile) (x-of placed-tile) (y-of placed-tile))) + (let ((tiles-used (remove-letters-from-participant-tray participant (mapcar #'tile-of placed-tiles))) + (tiles-drawn (draw-new-letters (tile-bag-of game) participant (length placed-tiles))) + (score (reduce #'+ (mapcar #'cdr words-formed)))) + (when (= 7 (length tiles-used)) + (incf score 50)) + (incf (score-of participant) score) + (push (make-object 'move + :participant participant + :placed-tiles placed-tiles + :new-tiles-drawn tiles-drawn + :words-formed words-formed + :score score) + (moves-of game)))) + (rotate-participants game))) + +(defclass move-withdrawal (store-object) + ((participant :initarg :participant + :reader participant-of) + (reason :initarg :reason + :reader reason-of)) + (:metaclass persistent-class)) + +(defun withdraw-last-move (game reason) + (let ((move (car (moves-of game)))) + (unless move + (error "no move in game to withdraw")) + (unless (typep game 'move) + (error "last move was not a letter placement, can't be withdrawn")) + (with-transaction (:withdraw-last-move) + (with-slots (participant placed-tiles new-tiles-drawn score) move + (decf (score-of participant) score) + (setf (tiles-of (tray-of participant)) + (append (set-difference (tiles-of (tray-of participant)) + new-tiles-drawn) + (mapcar #'tile-of placed-tiles))) + (undraw-tiles (tile-bag-of game) new-tiles-drawn) + (dolist (placement placed-tiles) + (put-letter (board-of game) nil (x-of placement) (y-of placement))) + (push (make-object 'move-withdrawal + :participant participant + :reason reason) + (moves-of game)))))) + +(defclass tile-swap (store-object) + ((participant :initarg :participant + :reader participant-of) + (count :initarg :count + :reader count-of)) + (:metaclass persistent-class)) + +(defun swap-tiles (game participant tiles) + (unless (<= 7 (remaining-tile-count (tile-bag-of game))) + (error "not enough remaining tiles to swap")) + (with-transaction (:swap-tiles) + (setf (tray-of participant) + (append (set-difference (tray-of participant) + tiles) + (draw-tiles (tile-bag-of game) (length tiles)))) + (undraw-tiles (tile-bag-of game) tiles) + (push (make-object 'tile-swap + :participant participant + :count (length tiles)) + (moves-of game))))

Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-08 19:17:13 UTC (rev 2263) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-10 19:47:50 UTC (rev 2264) @@ -11,7 +11,7 @@ "FIELD-TYPE"

"TILE" - "CHAR-OF" + "LETTER-OF" "VALUE-OF"

"BOARD" @@ -29,6 +29,10 @@

"MAKE-TILE-PLACEMENTS" "MAKE-MOVE" + "MOVE" + "SCORE-OF" + "PARTICIPANT-OF" + "WORDS-FORMED-OF"

"GAME" "LANGUAGE-OF"

Modified: branches/trunk-reorg/projects/scrabble/src/rules.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-11-08 19:17:13 UTC (rev 2263) +++ branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-11-10 19:47:50 UTC (rev 2264) @@ -60,7 +60,7 @@ (terpri stream) (dotimes (x 15) (dotimes (y 15) - (format stream "~C " (aif (at-xy board x y) (char-of it) #.))) + (format stream "~C " (aif (at-xy board x y) (letter-of it) #.))) (terpri stream))))

@@ -70,21 +70,21 @@ (defmethod at-placement ((board board) tile-placement) (at-xy board (x-of tile-placement) (y-of tile-placement)))

-(deftransaction put-letter (board tile x y) +(defun put-letter (board tile x y) (setf (aref (placed-tiles-of board) x y) tile))

(defclass tile (store-object) - ((char :reader char-of :initarg :char) + ((letter :reader letter-of :initarg :letter) (value :reader value-of :initarg :value)) (:metaclass persistent-class))

(defmethod print-object ((tile tile) stream) (print-unreadable-object (tile stream :type t :identity nil) - (with-slots (char value) tile - (format stream "~A (~A)" char value)))) + (with-slots (letter value) tile + (format stream "~A (~A)" (when letter (char-name letter)) value))))

-(defun make-tile (char value) - (make-object 'tile :char char :value value)) +(defun make-tile (letter value) + (make-object 'tile :letter letter :value value))

(defmethod placed-tile-adjacent ((board board) (tile-placement tile-placement)) "Check whether the given TILE-PLACEMENT on the board is adjacent to @@ -197,5 +197,5 @@ (defun word-text (word-result) "Convert the letter in a word result returned by WORDS-FORMED to a string." - (coerce (mapcar (compose #'char-of #'car) word-result) 'string)) + (coerce (mapcar (compose #'letter-of #'car) word-result) 'string))

Modified: branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-11-08 19:17:13 UTC (rev 2263) +++ branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-11-10 19:47:50 UTC (rev 2264) @@ -3,15 +3,18 @@ (defclass scrabble-store (mp-store random-mixin) ())

-(defun open-scrabble-store () +(defun open-scrabble-store (&optional delete-old-p) (ignore-errors (close-store)) - (asdf:run-shell-command "rm -rf /tmp/scrabble-store/") + (when delete-old-p + (sb-ext:run-program "/bin/rm" '("-rf" "/tmp/scrabble-store/") :environment nil)) (make-instance 'scrabble-store :directory "/tmp/scrabble-store/" :subsystems (list (make-instance 'store-object-subsystem) (make-instance 'random-mixin-subsystem))) - (let ((user1 (make-user "user1" :class 'player :full-name "User Eins")) - (user2 (make-user "user2" :class 'player :full-name "User Zwei"))) - (make-game :de (list user1 user2)))) + (unless (class-instances 'user) + (format t "creating test users and game~%") + (let ((user1 (make-user "user1" :class 'player :full-name "User Eins")) + (user2 (make-user "user2" :class 'player :full-name "User Zwei"))) + (make-game :de (list user1 user2)))))

(defparameter *website-directory* (make-pathname :name nil :type nil :version nil

Modified: branches/trunk-reorg/projects/scrabble/src/web.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-08 19:17:13 UTC (rev 2263) +++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-10 19:47:50 UTC (rev 2264) @@ -27,18 +27,29 @@ (defmethod encode-json ((tile-bag tile-bag) stream) (encode-json-plist (list :remaining-tiles (remaining-tile-count tile-bag)) stream))

+(defmethod encode-json ((move move) stream) + (encode-json-plist (list :participant-login (user-login (player-of (participant-of move))) + :score (score-of move) + :words (mapcar (lambda (word-cons) + (list :word (car word-cons) + :score (cdr word-cons))) + (words-formed-of move))) + stream)) + + (defmethod encode-json ((board board) stream) (princ #[ stream) (dotimes (x 15) (dotimes (y 15) (awhen (at-xy board x y) - (encode-json (list x y (char-of it) (value-of it)) stream) + (encode-json (list x y (letter-of it) (value-of it)) stream) (princ #, stream)))) (princ #] stream))

(defmethod encode-json ((participant participant) stream) (start-session) - (encode-json-plist (append (list :name (user-full-name (player-of participant)) + (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)) @@ -66,20 +77,27 @@ (:tr (:td "Password") (:td (:input :type "PASSWORD" :name "password"))) (:tr (:td) (:td (:input :type "SUBMIT")))))))))

-(defun parse-move (tray string) +(defun parse-move (participant string) "Given a string X1,Y1,LETTER1,X2,Y2,LETTER2..., return a list of -moves ((X1 Y1 LETTER-TILE2) (X2 Y2 LETTER-TILE2) ...)" - (let (list-of-moves) +moves ((X1 Y1 LETTER-TILE2) (X2 Y2 LETTER-TILE2) ...). LETTERx may +either be a single-character letter which will be used directly or a +character name (like LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS) which will +be converted into a character using NAME-CHAR." + (let ((tray (tray-of participant)) + list-of-moves) (labels ((use-letter (letter) - (awhen (find letter tray :key #'char-of) + (awhen (or (find letter tray :key #'letter-of) + (find nil tray :key #'letter-of)) (setf tray (remove it tray)) (return-from use-letter it)) - (error "tray does not contain letter ~A" letter)) + (error "tray of ~A does not contain letter ~A" participant letter)) (recurse (x-string y-string letter &rest more) (push (list (parse-integer x-string) (parse-integer y-string) - (use-letter (aref letter 0))) + (use-letter (if (= 1 (length letter)) + (aref letter 0) + (name-char letter)))) list-of-moves) (when more (apply #'recurse more)))) @@ -97,13 +115,18 @@ (define-easy-handler (make-move-handler :uri "/make-move" :default-request-type :post) (move game) (start-session) - ;; MOVE contains the move to make. (This should) check that it is - ;; the session users' turn, that the move is legal, then actually - ;; make the move. - (let* ((game (find-game game)) - (participant (find (find-user (session-value :user)) (participants-of game) :key #'player-of))) - (scrabble:make-move (board-of game) - (parse-move (tray-of participant) move)))) + ;; 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))) + (scrabble:make-move game + participant + (parse-move participant move)) + (encode-json-plist (list :game game) s))) + (error (e) + (encode-json-plist (list :error (princ-to-string e)) s)))))

(define-easy-handler (games :uri "/games") () (start-session)

Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-08 19:17:13 UTC (rev 2263) +++ branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-10 19:47:50 UTC (rev 2264) @@ -31,10 +31,59 @@ ["triple-word",null,null,"double-letter",null,null,null,"triple-word", null,null,null,"double-letter",null,null,"triple-word"]];

+// Scrabble rule enforcement + +function checkMoveLegality(placedTiles) +{ + // Given the board and list of placed tiles, either throw an error or + // return if the move is legal. + + var positions = map(function (placement) { return [ placement[0], placement[1] ] }, placedTiles) + .sort(function (a, b) { (a[0] > b[0]) || (a[1] > b[1])}); + + if (filter(partial(operator.ne, positions[0][0]), map(function (position) { return position[0] }, positions)).length + && filter(partial(operator.ne, positions[0][1]), map(function (position) { return position[1] }, positions)).length) { + throw "not-in-a-row"; + } + + var startOfPlacement = positions[0]; + var endOfPlacement = positions[positions.length - 1]; + + for (var x = startOfPlacement[0]; x <= endOfPlacement[0]; x++) { + for (var y = startOfPlacement[1]; y <= endOfPlacement[1]; y++) { + if (!letterAt(x, y) && (findValue(positions, [ x, y ]) == -1)) { + throw "placement-with-holes"; + } + } + } + + if (findValue(positions, [ 7, 7 ]) == -1) { + var found = false; + for (var x = startOfPlacement[0]; !found && x <= endOfPlacement[0]; x++) { + for (var y = startOfPlacement[1]; !found && y <= endOfPlacement[1]; y++) { + if (((x > 0) && letterAt(x - 1, y)) + || ((x < 14) && letterAt(x + 1, y)) + || ((y > 0) && letterAt(x, y - 1)) + || ((y < 14) && letterAt(x, y + 1))) { + found = true; + } + } + } + if (!found) { + throw "not-touching-other-tile"; + } + } +} + + +// + function getFieldScore(x, y) { return boardScoring[x][y] || 'standard'; }

+var theirTrays; + var gameID = 108; var board;

@@ -67,6 +116,13 @@ setElementPosition(myTrayContainer, { x: border + 194, y: border + 665 }); appendChildNodes(container, myTrayContainer);

+ 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'; @@ -176,9 +232,15 @@ var move = [];

function makeMove(x, y, letter) { - move.push([x, y, letter]); + move[move.length] = [x, y, letter]; $('move').onclick = submitMove; $('move').innerHTML = move.toString(); + try { + checkMoveLegality(move); + } + catch (e) { + $('move').innerHTML = e.toString(); + } }

function clearMove() { @@ -197,9 +259,21 @@ res.addCallbacks(moveSuccess, moveFailure); }

-function moveSuccess() +function moveSuccess(result) { - clearMove(); + var response; + try { + response = eval('(' + result.responseText + ')'); + } + catch (e) { + alert("invalid JSON reply: " + result.responseText); + return; + } + if (response.error) { + alert(response.error); + } else { + clearMove(); + } }

function moveFailure(e) @@ -207,8 +281,12 @@ alert('failed: ' + e); }

+var specialKeyCodes = { 59: 'LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS', + 192: 'LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS', + 222: 'LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS' }; + function letterKeyPressed(type, args, obj) { - var letter = String.fromCharCode(args[0]); + var letter = specialKeyCodes[args[0]] || String.fromCharCode(args[0]); var x = cursor.x; var y = cursor.y; cursor.advance(); @@ -310,6 +388,13 @@ tray = newTray; }

+function addTheirTray (participant) { + appendChildNodes(theirTrays, DIV(null, + DIV(null, participant.name), + DIV(null, map(function () { return IMG({ src: 'images/NIL.png' }) }, + new Array(participant.remainingTiles))))); +} + function drawGameState (gameState) { for (var i = 0; i < gameState.board.length; i++) { var x = gameState.board[i][0]; @@ -317,19 +402,29 @@ var char = gameState.board[i][2]; setLetter(x, y, char); } + for (var i = 0; i < gameState.participants.length; i++) { + var participant = gameState.participants[i]; + if (typeof participant.remainingTiles == 'number') { + addTheirTray(participant); + } else { + makeMyTray(map(function (entry) { return entry.letter }, participant.remainingTiles)); + } + } }

-var legalLetters = "ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß".split(""); +var legalLetters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ".split("");

function init() { makeBoard(); - var d = loadJSONDoc("/game/" + gameID); - d.addCallbacks(drawGameState, alert);

var letterKeyCodes = []; for (var i = 0; i < legalLetters.length; i++) { letterKeyCodes[i] = legalLetters[i].charCodeAt(0); } + // add mozilla key codes + letterKeyCodes.push(59); // u" + letterKeyCodes.push(192); // o" + letterKeyCodes.push(222); // a" var letterKeyListener = new YAHOO.util.KeyListener(document, { keys: letterKeyCodes }, { fn: letterKeyPressed, scope: this, correctScope: true }); @@ -345,6 +440,6 @@ moveDisplay.style.position = 'absolute'; setElementPosition(moveDisplay, { x: border + 550, y: border + 665 }); appendChildNodes(document.body, moveDisplay); - var d = loadJSONDoc("/game/108"); + var d = loadJSONDoc("/game/" + gameID); d.addCallbacks(drawGameState, alert); }