Author: hhubner Date: 2007-11-14 00:27:46 -0500 (Wed, 14 Nov 2007) New Revision: 2276 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.html branches/trunk-reorg/projects/scrabble/website/scrabble.js Log: snapshot Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-14 05:26:34 UTC (rev 2275) +++ branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-11-14 05:27:46 UTC (rev 2276) @@ -17,12 +17,10 @@ (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))))) + (setf (aref tiles random-index) tmp)))) + tile-bag) -(defmethod initialize-persistent-instance :after ((tile-bag tile-bag)) - (shake-tile-bag tile-bag)) - -(defun make-tile-bag (language) +(deftransaction make-tile-bag (language) (let ((tiles (make-array 102 :adjustable t :fill-pointer 0))) (mapcar (lambda (entry) (destructuring-bind (letter value count) entry @@ -30,7 +28,7 @@ (vector-push-extend (make-tile letter value) tiles)))) (or (getf *tile-sets* language) (error "language ~A not defined" language))) - (make-object 'tile-bag :tiles tiles))) + (shake-tile-bag (make-object 'tile-bag :tiles tiles)))) (define-condition no-tiles-remaining (simple-error) ()) @@ -76,8 +74,8 @@ ((participant :initarg :participant :reader participant-of) (placed-tiles :initarg :placed-tiles - :reader placed-tiles) - (new-tiles-drawn :initarg :new-letters-drawn + :reader placed-tiles-of) + (new-tiles-drawn :initarg :new-tiles-drawn :reader new-tiles-drawn-of :documentation "New letters that have been drawn after the move, should the move need to be undone") @@ -91,7 +89,7 @@ (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))) + (score-of move) (words-formed-of move)))) (defclass game (store-object) @@ -159,14 +157,13 @@ (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))))))) + (let ((has-letter (find letter tray-letters :test #'letter-equal))) + (unless (or has-letter (find nil tray-letters)) + (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) @@ -182,30 +179,35 @@ (append drawn (tray-of participant))) drawn)) +(deftransaction make-move% (game participant placed-tiles) + (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 (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))) + (push move (moves-of game)) + (rotate-participants game) + move)))) + (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))) + (make-move% game participant (mapcar (lambda (placement) + (list (x-of placement) (y-of placement) (tile-of placement))) + placed-tiles))) (defclass move-withdrawal (store-object) ((participant :initarg :participant @@ -214,26 +216,28 @@ :reader reason-of)) (:metaclass persistent-class)) +(deftransaction withdraw-last-move% (game reason move) + (with-slots (participant placed-tiles new-tiles-drawn score) move + (decf (score-of participant) score) + (setf (tray-of participant) + (append (set-difference (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))) + (unrotate-participants game) + (push (make-object 'move-withdrawal + :participant participant + :reason reason) + (moves-of game)))) + (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) + (unless (typep move '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)))))) + (withdraw-last-move% game reason move))) (defclass tile-swap (store-object) ((participant :initarg :participant @@ -247,8 +251,7 @@ (error "not enough remaining tiles to swap")) (with-transaction (:swap-tiles) (setf (tray-of participant) - (append (set-difference (tray-of participant) - tiles) + (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 Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-14 05:26:34 UTC (rev 2275) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-11-14 05:27:46 UTC (rev 2276) @@ -28,11 +28,16 @@ "TRAY-OF" "MAKE-TILE-PLACEMENTS" + "X-OF" + "Y-OF" + "TILE-OF" + "MAKE-MOVE" "MOVE" "SCORE-OF" "PARTICIPANT-OF" "WORDS-FORMED-OF" + "PLACED-TILES-OF" "GAME" "LANGUAGE-OF" Modified: branches/trunk-reorg/projects/scrabble/src/rules.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-11-14 05:26:34 UTC (rev 2275) +++ branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-11-14 05:27:46 UTC (rev 2276) @@ -41,7 +41,7 @@ (and (= (x-of tile-placement-1) (x-of tile-placement-2)) (= (y-of tile-placement-1) (y-of tile-placement-2)))) -(defmethod position-equal ((position list) (tile-placement tile-placement)) +(defmethod position-equal ((position list) tile-placement) "Return non-nil if the given POSITION is at the position of PLACED-TILE" (and (= (first position) (x-of tile-placement)) (= (second position) (y-of tile-placement)))) @@ -63,14 +63,13 @@ (format stream "~C " (aif (at-xy board x y) (letter-of it) #\.))) (terpri stream)))) - (defmethod at-xy ((board board) x y) (aref (placed-tiles-of board) x y)) (defmethod at-placement ((board board) tile-placement) (at-xy board (x-of tile-placement) (y-of tile-placement))) -(defun put-letter (board tile x y) +(deftransaction put-letter (board tile x y) (setf (aref (placed-tiles-of board) x y) tile)) (defclass tile (store-object) @@ -81,7 +80,7 @@ (defmethod print-object ((tile tile) stream) (print-unreadable-object (tile stream :type t :identity nil) (with-slots (letter value) tile - (format stream "~A (~A)" (when letter (char-name letter)) value)))) + (format stream "~A (~A) ID:~A" (when letter (char-name letter)) value (store-object-id tile))))) (defun make-tile (letter value) (make-object 'tile :letter letter :value value)) @@ -146,6 +145,15 @@ t) +(defmethod x-of ((placement list)) + (first placement)) + +(defmethod y-of ((placement list)) + (second placement)) + +(defmethod tile-of ((placement list)) + (third placement)) + (defun words-formed% (board placed-tiles verticalp) "Scan for words that would be formed by placing PLACED-TILES on BOARD. VERTICALP determines the scan order, if nil, the board is Modified: branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-11-14 05:26:34 UTC (rev 2275) +++ branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-11-14 05:27:46 UTC (rev 2276) @@ -1,15 +1,11 @@ (in-package :scrabble.web) -(defclass scrabble-store (mp-store random-mixin) - ()) - (defun open-scrabble-store (&optional delete-old-p) (ignore-errors (close-store)) (when delete-old-p (asdf:run-shell-command "rm -rf /tmp/scrabble-store/")) - (make-instance 'scrabble-store :directory "/tmp/scrabble-store/" - :subsystems (list (make-instance 'store-object-subsystem) - (make-instance 'random-mixin-subsystem))) + (make-instance 'mp-store :directory "/tmp/scrabble-store/" + :subsystems (list (make-instance 'store-object-subsystem))) (unless (class-instances 'user) (format t "creating test users and game~%") (let ((user1 (make-user "user1" :class 'player :full-name "User Eins")) Modified: branches/trunk-reorg/projects/scrabble/src/web.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-14 05:26:34 UTC (rev 2275) +++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-11-14 05:27:46 UTC (rev 2276) @@ -28,15 +28,22 @@ (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))) + (encode-json-plist (list :type "move" + :participant-login (user-login (player-of (participant-of move))) :score (score-of move) + :placed-tiles (placed-tiles-of move) :words (mapcar (lambda (word-cons) (list :word (car word-cons) :score (cdr word-cons))) (words-formed-of move))) stream)) - +(defmethod encode-json ((move move-withdrawal) stream) + (encode-json-plist (list :type "move-withdrawal" + :participant-login (user-login (player-of (participant-of move))) + :reason (or (reason-of move) "")) + stream)) + (defmethod encode-json ((board board) stream) (princ #\[ stream) (dotimes (x 15) @@ -57,16 +64,15 @@ (length (tray-of participant))))) stream)) -(define-easy-handler (login :uri "/login" :default-request-type :post) +(define-easy-handler (login :uri "/login" :default-request-type :get) (login password) (format t "warning: password not checked~*~%" password) (when (and login (find-user login)) (start-session) (setf (session-value :user) login) - (redirect "/games")) + (redirect "/scrabble.html")) (with-html-output-to-string (*standard-output* nil) - (:html (:head (:title "scrabble login")) @@ -121,10 +127,11 @@ (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))) + (encode-json-plist + (list :move (scrabble:make-move game + participant + (parse-move participant move)) + :tray (tray-of participant)) s))) (error (e) (encode-json-plist (list :error (princ-to-string e)) s))))) Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.html =================================================================== --- branches/trunk-reorg/projects/scrabble/website/scrabble.html 2007-11-14 05:26:34 UTC (rev 2275) +++ branches/trunk-reorg/projects/scrabble/website/scrabble.html 2007-11-14 05:27:46 UTC (rev 2276) @@ -12,5 +12,7 @@ <body onload="init()"> <div id='playfield'> </div> + <div style="position: absolute; right: 20px; top: 20px;"><a style="color: white;" href="/login?login=user1">user1</a></div> + <div style="position: absolute; right: 20px; top: 40px;"><a style="color: white;" href="/login?login=user2">user2</a></div> </body> </html> \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-14 05:26:34 UTC (rev 2275) +++ branches/trunk-reorg/projects/scrabble/website/scrabble.js 2007-11-14 05:27:46 UTC (rev 2276) @@ -273,6 +273,7 @@ alert(response.error); } else { clearMove(); + makeMyTray(map(function (entry) { return entry.letter }, response.tray)) } }