[bknr-cvs] r2276 - in branches/trunk-reorg/projects/scrabble: src website
bknr at bknr.net
bknr at bknr.net
Wed Nov 14 05:27:46 UTC 2007
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))
}
}
More information about the Bknr-cvs
mailing list