[bknr-cvs] r2228 - in branches/trunk-reorg/projects/scrabble: src website website/en

bknr at bknr.net bknr at bknr.net
Sat Oct 6 23:09:40 UTC 2007


Author: hhubner
Date: 2007-10-06 19:09:39 -0400 (Sat, 06 Oct 2007)
New Revision: 2228

Added:
   branches/trunk-reorg/projects/scrabble/src/game-constants.lisp
   branches/trunk-reorg/projects/scrabble/src/game.lisp
   branches/trunk-reorg/projects/scrabble/src/rules.lisp
   branches/trunk-reorg/projects/scrabble/src/web.lisp
   branches/trunk-reorg/projects/scrabble/website/en/
   branches/trunk-reorg/projects/scrabble/website/en/A.png
   branches/trunk-reorg/projects/scrabble/website/en/B.png
   branches/trunk-reorg/projects/scrabble/website/en/C.png
   branches/trunk-reorg/projects/scrabble/website/en/D.png
   branches/trunk-reorg/projects/scrabble/website/en/E.png
   branches/trunk-reorg/projects/scrabble/website/en/F.png
   branches/trunk-reorg/projects/scrabble/website/en/G.png
   branches/trunk-reorg/projects/scrabble/website/en/H.png
   branches/trunk-reorg/projects/scrabble/website/en/I.png
   branches/trunk-reorg/projects/scrabble/website/en/J.png
   branches/trunk-reorg/projects/scrabble/website/en/K.png
   branches/trunk-reorg/projects/scrabble/website/en/L.png
   branches/trunk-reorg/projects/scrabble/website/en/M.png
   branches/trunk-reorg/projects/scrabble/website/en/N.png
   branches/trunk-reorg/projects/scrabble/website/en/NIL.png
   branches/trunk-reorg/projects/scrabble/website/en/O.png
   branches/trunk-reorg/projects/scrabble/website/en/P.png
   branches/trunk-reorg/projects/scrabble/website/en/Q.png
   branches/trunk-reorg/projects/scrabble/website/en/R.png
   branches/trunk-reorg/projects/scrabble/website/en/S.png
   branches/trunk-reorg/projects/scrabble/website/en/T.png
   branches/trunk-reorg/projects/scrabble/website/en/U.png
   branches/trunk-reorg/projects/scrabble/website/en/V.png
   branches/trunk-reorg/projects/scrabble/website/en/W.png
   branches/trunk-reorg/projects/scrabble/website/en/X.png
   branches/trunk-reorg/projects/scrabble/website/en/Y.png
   branches/trunk-reorg/projects/scrabble/website/en/Z.png
   branches/trunk-reorg/projects/scrabble/website/en/charmap.xml
   branches/trunk-reorg/projects/scrabble/website/en/double-letter.png
   branches/trunk-reorg/projects/scrabble/website/en/double-word.png
   branches/trunk-reorg/projects/scrabble/website/en/scrabble.css
   branches/trunk-reorg/projects/scrabble/website/en/scrabble.html
   branches/trunk-reorg/projects/scrabble/website/en/scrabble.js
   branches/trunk-reorg/projects/scrabble/website/en/standard.png
   branches/trunk-reorg/projects/scrabble/website/en/triple-letter.png
   branches/trunk-reorg/projects/scrabble/website/en/triple-word.png
Removed:
   branches/trunk-reorg/projects/scrabble/src/scrabble.lisp
Modified:
   branches/trunk-reorg/projects/scrabble/src/package.lisp
   branches/trunk-reorg/projects/scrabble/src/scrabble.asd
Log:
Snapshot - Modularized a little, made most game objects persistent,
add XML generation function for games.


Added: branches/trunk-reorg/projects/scrabble/src/game-constants.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/game-constants.lisp	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/src/game-constants.lisp	2007-10-06 23:09:39 UTC (rev 2228)
@@ -0,0 +1,29 @@
+(in-package :scrabble)
+
+(defparameter *board-scoring*
+  #2A((:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word)
+      (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil)
+      (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil)
+      (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter)
+      (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil)
+      (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil)
+      (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil)
+      (:triple-word nil nil :double-letter nil nil nil :double-word nil nil nil :double-letter nil nil :triple-word)
+      (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil)
+      (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil)
+      (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil)
+      (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter)
+      (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil)
+      (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil)
+      (:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word)))
+
+(defparameter *tile-sets* '(:de ((#\A 1 5) (#\B 3 2) (#\C 4 2) (#\D 1 4) (#\E 1 15) (#\F 4 2) (#\G 2 3) (#\H 2 4) (#\I 1 6)
+				 (#\J 6 1) (#\K 4 2) (#\L 2 3) (#\M 3 4) (#\N 1 9) (#\O 2 3) (#\P 4 1) (#\Q 10 1) (#\R 1 6)
+				 (#\S 1 7) (#\T 1 6) (#\U 1 6) (#\V 6 1) (#\W 3 1) (#\X 8 1) (#\Y 10 1) (#\Z 3 1)
+				 (#\LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS 6 1)
+				 (#\LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS 8 1)
+				 (#\LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS 6 1)
+				 (nil 0 2))
+			    :en '((#\A 1 9) (#\B 3 2) (#\C 3 2) (#\D 2 4) (#\E 1 12) (#\F 4 2) (#\G 2 3) (#\H 4 2) (#\I 1 9)
+				  (#\J 8 1) (#\K 5 1) (#\L 1 4) (#\M 3 2) (#\N 1 6) (#\O 1 8) (#\P 3 2) (#\Q 10 1) (#\R 1 6)
+				  (#\S 1 4) (#\T 1 6) (#\U 1 4) (#\V 4 2) (#\W 4 2) (#\X 8 1) (#\Y 4 2) (#\Z 10 1) (nil 0 2))))
\ No newline at end of file

Added: branches/trunk-reorg/projects/scrabble/src/game.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/game.lisp	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/src/game.lisp	2007-10-06 23:09:39 UTC (rev 2228)
@@ -0,0 +1,70 @@
+(in-package :scrabble)
+
+(defclass tile-bag (store-object)
+  ((tiles :initarg :tiles :accessor tiles-of))
+  (:metaclass persistent-class))
+
+(defmethod remaining-tile-count ((tile-bag tile-bag))
+  (fill-pointer (tiles-of tile-bag)))
+
+(defmethod print-object ((tile-bag tile-bag) stream)
+  (print-unreadable-object (tile-bag stream :type t :identity t)
+    (format stream "~A letters remaining" (remaining-tile-count 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
+                (dotimes (i count)
+                  (vector-push-extend (make-tile char value) tiles))))
+            (or (getf *tile-sets* language)
+                 (error "language ~A not defined" language)))
+    (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-instance 'tile-bag :tiles tiles)))
+
+(define-condition no-tiles-remaining (simple-error)
+  ())
+
+(defmethod draw-tile ((tile-bag tile-bag))
+  (unless (plusp (remaining-tile-count tile-bag))
+    (error 'no-tiles-remaining))
+  (with-slots (tiles) tile-bag
+    (prog1
+        (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)))))
+
+(defclass player (user)
+  ((games :initform nil :accessor games-of))
+  (:metaclass persistent-class))
+
+(defclass game (store-object)
+  ((language :initarg :language
+	     :reader language-of)
+   (players :initarg :players
+	    :reader players-of
+	    :documentation "List of players in this game")
+   (board :accessor board-of)
+   (tile-bag :accessor tile-bag-of))
+  (:metaclass persistent-class))
+
+(defmethod initialize-persistent-instance :after ((game game))
+  (setf (board-of game) (make-instance 'board))
+  (setf (tile-bag-of game) (make-tile-bag (language-of game)))
+  game)
\ No newline at end of file

Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/package.lisp	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/src/package.lisp	2007-10-06 23:09:39 UTC (rev 2228)
@@ -1,14 +1,47 @@
-
-(defpackage :scrabble
-  (:use :cl :alexandria :anaphora :bknr.datastore)
-  (:export "*BOARD-SCORING*"
-           "*TILE-SETS*"
-           "FIELD-TYPE"))
-
-(defpackage :scrabble.graphics
-  (:use :cl :alexandria :vecto :scrabble)
-  (:shadowing-import-from :vecto "ROTATE"))
-  
-(defpackage :scrabble.web
-  (:use :cl :alexandria :hunchentoot :scrabble))
+
+(defpackage :scrabble
+  (:use :cl
+	:alexandria
+	:anaphora
+	:bknr.datastore
+	:bknr.user)
+  (:export "*BOARD-SCORING*"
+           "*TILE-SETS*"
+
+           "FIELD-TYPE"
+
+	   "TILE"
+	   "CHAR-OF"
+	   "VALUE-OF"
+
+	   "BOARD"
+	   "AT-XY"
+
+	   "TILE-BAG"
+	   "REMAINING-TILE-COUNT"
+
+	   "PLAYER"
+
+	   "GAME"
+	   "LANGUAGE-OF"
+	   "PLAYERS-OF"
+	   "BOARD-OF"
+	   "TILE-BAG-OF"))
+
+(defpackage :scrabble.graphics
+  (:use :cl
+	:alexandria
+	:vecto
+	:scrabble)
+  (:shadowing-import-from :vecto "ROTATE"))
+  
+(defpackage :scrabble.web
+  (:use :cl
+	:alexandria
+	:anaphora
+	:hunchentoot
+	:bknr.datastore
+	:bknr.user
+	:cxml
+	:scrabble))
   
\ No newline at end of file

Added: branches/trunk-reorg/projects/scrabble/src/rules.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/rules.lisp	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/src/rules.lisp	2007-10-06 23:09:39 UTC (rev 2228)
@@ -0,0 +1,197 @@
+(in-package :scrabble)
+
+(defun field-type (x y)
+  (or (aref *board-scoring* x y)
+      :standard))
+
+(define-condition invalid-move (simple-error)
+  ()
+  (:report (lambda (c stream)
+             (format stream "Invalid move: ~A" (type-of c)))))
+
+(defun seq (from to)
+  (loop for i from from upto to
+        collect i))
+
+(defun positions-between (start-position end-position)
+  (if (= (first start-position)
+         (first end-position))
+      (mapcar (lambda (y) (list (first start-position) y))
+              (seq (second start-position) (second end-position)))
+      (mapcar (lambda (x) (list x (second start-position)))
+              (seq (first start-position) (first end-position)))))
+
+(defclass tile-placement ()
+  ((x :reader x-of :initarg :x)
+   (y :reader y-of :initarg :y)
+   (tile :reader tile-of :initarg :tile))
+  (:documentation "Represents placement of a letter tile on the board"))
+
+(defun make-tile-placement (x y tile)
+  (make-instance 'tile-placement :x x :y y :tile tile))
+
+(defun make-tile-placements (list-of-moves)
+  (mapcar (curry #'apply 'make-tile-placement) list-of-moves))
+
+(defmethod equal-position ((tile-placement-1 tile-placement) (tile-placement-2 tile-placement))
+  (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))
+  "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))))
+
+(defmethod position-< ((a tile-placement) (b tile-placement))
+  "Compare positions of placements, for sorting"
+  (or (< (x-of a) (x-of b))
+      (< (y-of a) (y-of b))))
+
+(defclass board (store-object)
+  ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil)))
+  (:metaclass persistent-class))
+
+(defmethod print-object ((board board) stream)
+  (print-unreadable-object (board stream :type t :identity t)
+    (terpri stream)
+    (dotimes (x 15)
+      (dotimes (y 15)
+        (format stream "~C " (aif (at-xy board x y) (char-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)))
+
+(defmethod put-letter ((board board) tile x y)
+  (setf (aref (placed-tiles-of board) x y) tile))
+
+(defclass tile (store-object)
+  ((char :reader char-of :initarg :char)
+   (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))))
+
+(defun make-tile (char value)
+  (make-object 'tile :char char :value value))
+
+(defmethod placed-tile-adjacent ((board board) (tile-placement tile-placement))
+  "Check whether the given TILE-PLACEMENT on the board is adjacent to
+another tile or if it is the start position."
+  (with-accessors ((x x-of) (y y-of))
+    tile-placement
+    (or (and (eql x 7)
+             (eql y 7))
+        (and (plusp x)
+             (at-xy board (1- x) y))
+        (and (plusp y)
+             (at-xy board x (1- y)))
+        (and (< x 14)
+             (at-xy board (1+ x) y))
+        (and (< y 14)
+             (at-xy board x (1+ y))))))
+
+(defun placed-or-being-placed (board placed-tiles position)
+  (or (at-xy board (first position) (second position))
+      (awhen (find position placed-tiles :test #'position-equal)
+        (values (tile-of it) t))))
+
+(define-condition not-touching-other-tile (invalid-move) ())
+(define-condition not-in-a-row (invalid-move) ())
+(define-condition placed-on-occupied-field (invalid-move) ())
+(define-condition no-tile-placed (invalid-move) ())
+(define-condition multiple-letters-placed-on-one-field (invalid-move) ())
+(define-condition placement-with-holes (invalid-move) ())
+
+(defun check-move-legality (board placed-tiles)
+  "Verify that placing the PLACED-TILES on BOARD is a legal Scrabble
+move.  If the move is not valid, a specific INVALID-MOVE condition is
+signalled.  Otherwise, t is returned."
+  (unless placed-tiles
+    (error 'no-tile-placed))
+
+  (unless (or (apply #'= (mapcar #'x-of placed-tiles))
+              (apply #'= (mapcar #'y-of placed-tiles)))
+    (error 'not-in-a-row))
+
+  (when (some (curry #'at-placement board) placed-tiles)
+    (error 'tile-placed-on-occupied-field))
+
+  (unless (equal placed-tiles
+                 (remove-duplicates placed-tiles :test #'equal-position))
+    (error 'multiple-letters-placed-on-one-field))
+
+  (let* ((placed-tiles (sort (copy-list placed-tiles) #'position-<))
+         (start-of-placement (first placed-tiles))
+         (end-of-placement (first (last placed-tiles))))
+    (unless (every (curry 'placed-or-being-placed board placed-tiles)
+                   (positions-between (list (x-of start-of-placement) (y-of start-of-placement))
+                                      (list (x-of end-of-placement) (y-of end-of-placement))))
+      (error 'placement-with-holes)))
+
+  (unless (or (find '(7 7) placed-tiles :test #'position-equal)
+              (some (curry #'placed-tile-adjacent board) placed-tiles))
+    (error 'not-touching-other-tile))
+  
+  t)
+
+(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
+scanned horizontally, else vertically.  This is called by WORDS-FORMED
+below, see there for a description of the return value format."
+  (let (words)
+    (dotimes (x 15)
+      (when (find x placed-tiles :key (if verticalp #'y-of #'x-of) :test #'=)
+        (let (word is-new-word)
+          (dotimes (y 15)
+            (multiple-value-bind (placed-tile being-placed) (placed-or-being-placed board placed-tiles (if verticalp (list y x) (list x y)))
+              (when (and word (null placed-tile))
+                (when (and (cdr word) is-new-word)
+                  (push (nreverse word) words))
+                (setf word nil is-new-word nil))
+              (when placed-tile
+                (push (list placed-tile (and being-placed (field-type x y))) word)
+                (when being-placed
+                  (setf is-new-word t)))))
+          (when (and (cdr word) is-new-word)
+            (push (nreverse word) words)))))
+    (nreverse words)))
+
+(defun words-formed (board placed-tiles)
+  "Return list of all words formed by placing the tiles in
+PLACED-TILES on the BOARD.  Returns each word as a list, with each
+letter of the word represented by a list (TILE FIELD-TYPE).  TILE is
+the tile for the letter, FIELD-TYPE is either the field type of the
+field that the letter has been placed on, or NIL if the tile was
+already on the board."
+  (append (words-formed% board placed-tiles nil)
+          (words-formed% board placed-tiles t)))
+
+(defun word-score (word-result)
+  "Process one word result from WORDS-FORMED and calculate the score
+for the word."
+  (let ((factor 1)
+        (value 0))
+    (dolist (entry word-result)
+      (destructuring-bind (tile field-type) entry
+        (incf value (value-of tile))
+        (case field-type
+          ((:double-letter) (incf value (value-of tile)))
+          ((:triple-letter) (incf value (* 2 (value-of tile))))
+          ((:double-word) (setf factor (* factor 2)))
+          ((:triple-word) (setf factor (* factor 3))))))
+    (* value factor)))
+
+(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))
+

Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.asd
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/scrabble.asd	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/src/scrabble.asd	2007-10-06 23:09:39 UTC (rev 2228)
@@ -10,9 +10,18 @@
 (defsystem :scrabble
     :name "Scrabble"
     :licence "BSD"
-    :depends-on (:bknr-datastore :hunchentoot :cxml :vecto :alexandria :anaphora)
+    :depends-on (:bknr-datastore
+		 :bknr-web
+		 :hunchentoot
+		 :cxml
+		 :vecto
+		 :alexandria
+		 :anaphora)
     :serial t
     :components ((:file "package")
-                 (:file "scrabble")
+		 (:file "game-constants")
+                 (:file "rules")
+		 (:file "game")
+		 (:file "web")
                  (:file "make-html")
                  (:file "make-letters")))

Deleted: branches/trunk-reorg/projects/scrabble/src/scrabble.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/scrabble.lisp	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/src/scrabble.lisp	2007-10-06 23:09:39 UTC (rev 2228)
@@ -1,277 +0,0 @@
-(in-package :scrabble)
-
-(defparameter *board-scoring*
-  #2A((:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word)
-      (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil)
-      (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil)
-      (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter)
-      (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil)
-      (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil)
-      (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil)
-      (:triple-word nil nil :double-letter nil nil nil :double-word nil nil nil :double-letter nil nil :triple-word)
-      (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil)
-      (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil)
-      (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil)
-      (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter)
-      (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil)
-      (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil)
-      (:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word)))
-
-(defun field-type (x y)
-  (or (aref *board-scoring* x y)
-      :standard))
-
-(defparameter *tile-sets* (make-hash-table))
-
-(setf (gethash :de *tile-sets*)
-      '((#\A 1 5) (#\B 3 2) (#\C 4 2) (#\D 1 4) (#\E 1 15) (#\F 4 2) (#\G 2 3) (#\H 2 4) (#\I 1 6)
-        (#\J 6 1) (#\K 4 2) (#\L 2 3) (#\M 3 4) (#\N 1 9) (#\O 2 3) (#\P 4 1) (#\Q 10 1) (#\R 1 6)
-        (#\S 1 7) (#\T 1 6) (#\U 1 6) (#\V 6 1) (#\W 3 1) (#\X 8 1) (#\Y 10 1) (#\Z 3 1)
-	(#\LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS 6 1)
-	(#\LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS 8 1)
-	(#\LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS 6 1)
-        (nil 0 2)))
-(setf (gethash :en *tile-sets*)
-      '((#\A 1 9) (#\B 3 2) (#\C 3 2) (#\D 2 4) (#\E 1 12) (#\F 4 2) (#\G 2 3) (#\H 4 2) (#\I 1 9)
-	(#\J 8 1) (#\K 5 1) (#\L 1 4) (#\M 3 2) (#\N 1 6) (#\O 1 8) (#\P 3 2) (#\Q 10 1) (#\R 1 6)
-	(#\S 1 4) (#\T 1 6) (#\U 1 4) (#\V 4 2) (#\W 4 2) (#\X 8 1) (#\Y 4 2) (#\Z 10 1) (nil 0 2)))
-
-(define-condition invalid-move (simple-error)
-  ()
-  (:report (lambda (c stream)
-             (format stream "Invalid move: ~A" (type-of c)))))
-
-(defun seq (from to)
-  (loop for i from from upto to
-        collect i))
-
-(defun positions-between (start-position end-position)
-  (if (= (first start-position)
-         (first end-position))
-      (mapcar (lambda (y) (list (first start-position) y))
-              (seq (second start-position) (second end-position)))
-      (mapcar (lambda (x) (list x (second start-position)))
-              (seq (first start-position) (first end-position)))))
-
-(defclass tile-placement ()
-  ((x :reader x-of :initarg :x)
-   (y :reader y-of :initarg :y)
-   (tile :reader tile-of :initarg :tile))
-  (:documentation "Represents placement of a letter tile on the board"))
-
-(defun make-tile-placement (x y tile)
-  (make-instance 'tile-placement :x x :y y :tile tile))
-
-(defun make-tile-placements (list-of-moves)
-  (mapcar (curry #'apply 'make-tile-placement) list-of-moves))
-
-(defmethod equal-position ((tile-placement-1 tile-placement) (tile-placement-2 tile-placement))
-  (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))
-  "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))))
-
-(defmethod position-< ((a tile-placement) (b tile-placement))
-  "Compare positions of placements, for sorting"
-  (or (< (x-of a) (x-of b))
-      (< (y-of a) (y-of b))))
-
-(defclass board (store-object)
-  ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil)))
-  (:metaclass persistent-class))
-
-(defmethod print-object ((board board) stream)
-  (print-unreadable-object (board stream :type t :identity t)
-    (terpri stream)
-    (dotimes (x 15)
-      (dotimes (y 15)
-        (format stream "~C " (aif (at-xy board x y) (char-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)))
-
-(defmethod put-letter ((board board) tile x y)
-  (setf (aref (placed-tiles-of board) x y) tile))
-
-(defclass tile (store-object)
-  ((char :reader char-of :initarg :char)
-   (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))))
-
-(defun make-tile (char value)
-  (make-object 'tile :char char :value value))
-
-(defclass tile-bag (store-object)
-  ((tiles :initarg :tiles :accessor tiles-of))
-  (:metaclass persistent-class))
-
-(defmethod remaining-tile-count ((tile-bag tile-bag))
-  (fill-pointer (tiles-of tile-bag)))
-
-(defmethod print-object ((tile-bag tile-bag) stream)
-  (print-unreadable-object (tile-bag stream :type t :identity t)
-    (format stream "~A letters remaining" (remaining-tile-count 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
-                (dotimes (i count)
-                  (vector-push-extend (make-tile char value) tiles))))
-            (or (gethash language *tile-sets*)
-                 (error "language ~A not defined" language)))
-    (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-instance 'tile-bag :tiles tiles)))
-
-(define-condition no-tiles-remaining (simple-error)
-  ())
-
-(defmethod draw-tile ((tile-bag tile-bag))
-  (unless (plusp (remaining-tile-count tile-bag))
-    (error 'no-tiles-remaining))
-  (with-slots (tiles) tile-bag
-    (prog1
-        (aref tiles (1- (fill-pointer tiles)))
-      (decf (fill-pointer tiles)))))
-
-(defmethod placed-tile-adjacent ((board board) (tile-placement tile-placement))
-  "Check whether the given TILE-PLACEMENT on the board is adjacent to
-another tile or if it is the start position."
-  (with-accessors ((x x-of) (y y-of))
-    tile-placement
-    (or (and (eql x 7)
-             (eql y 7))
-        (and (plusp x)
-             (at-xy board (1- x) y))
-        (and (plusp y)
-             (at-xy board x (1- y)))
-        (and (< x 14)
-             (at-xy board (1+ x) y))
-        (and (< y 14)
-             (at-xy board x (1+ y))))))
-
-(defun placed-or-being-placed (board placed-tiles position)
-  (or (at-xy board (first position) (second position))
-      (awhen (find position placed-tiles :test #'position-equal)
-        (values (tile-of it) t))))
-
-(define-condition not-touching-other-tile (invalid-move) ())
-(define-condition not-in-a-row (invalid-move) ())
-(define-condition placed-on-occupied-field (invalid-move) ())
-(define-condition no-tile-placed (invalid-move) ())
-(define-condition multiple-letters-placed-on-one-field (invalid-move) ())
-(define-condition placement-with-holes (invalid-move) ())
-
-(defun check-move-legality (board placed-tiles)
-  "Verify that placing the PLACED-TILES on BOARD is a legal Scrabble
-move.  If the move is not valid, a specific INVALID-MOVE condition is
-signalled.  Otherwise, t is returned."
-  (unless placed-tiles
-    (error 'no-tile-placed))
-
-  (unless (or (apply #'= (mapcar #'x-of placed-tiles))
-              (apply #'= (mapcar #'y-of placed-tiles)))
-    (error 'not-in-a-row))
-
-  (when (some (curry #'at-placement board) placed-tiles)
-    (error 'tile-placed-on-occupied-field))
-
-  (unless (equal placed-tiles
-                 (remove-duplicates placed-tiles :test #'equal-position))
-    (error 'multiple-letters-placed-on-one-field))
-
-  (let* ((placed-tiles (sort (copy-list placed-tiles) #'position-<))
-         (start-of-placement (first placed-tiles))
-         (end-of-placement (first (last placed-tiles))))
-    (unless (every (curry 'placed-or-being-placed board placed-tiles)
-                   (positions-between (list (x-of start-of-placement) (y-of start-of-placement))
-                                      (list (x-of end-of-placement) (y-of end-of-placement))))
-      (error 'placement-with-holes)))
-
-  (unless (or (find '(7 7) placed-tiles :test #'position-equal)
-              (some (curry #'placed-tile-adjacent board) placed-tiles))
-    (error 'not-touching-other-tile))
-  
-  t)
-
-(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
-scanned horizontally, else vertically.  This is called by WORDS-FORMED
-below, see there for a description of the return value format."
-  (let (words)
-    (dotimes (x 15)
-      (when (find x placed-tiles :key (if verticalp #'y-of #'x-of) :test #'=)
-        (let (word is-new-word)
-          (dotimes (y 15)
-            (multiple-value-bind (placed-tile being-placed) (placed-or-being-placed board placed-tiles (if verticalp (list y x) (list x y)))
-              (when (and word (null placed-tile))
-                (when (and (cdr word) is-new-word)
-                  (push (nreverse word) words))
-                (setf word nil is-new-word nil))
-              (when placed-tile
-                (push (list placed-tile (and being-placed (field-type x y))) word)
-                (when being-placed
-                  (setf is-new-word t)))))
-          (when (and (cdr word) is-new-word)
-            (push (nreverse word) words)))))
-    (nreverse words)))
-
-(defun words-formed (board placed-tiles)
-  "Return list of all words formed by placing the tiles in
-PLACED-TILES on the BOARD.  Returns each word as a list, with each
-letter of the word represented by a list (TILE FIELD-TYPE).  TILE is
-the tile for the letter, FIELD-TYPE is either the field type of the
-field that the letter has been placed on, or NIL if the tile was
-already on the board."
-  (append (words-formed% board placed-tiles nil)
-          (words-formed% board placed-tiles t)))
-
-(defun word-score (word-result)
-  "Process one word result from WORDS-FORMED and calculate the score
-for the word."
-  (let ((factor 1)
-        (value 0))
-    (dolist (entry word-result)
-      (destructuring-bind (tile field-type) entry
-        (incf value (value-of tile))
-        (case field-type
-          ((:double-letter) (incf value (value-of tile)))
-          ((:triple-letter) (incf value (* 2 (value-of tile))))
-          ((:double-word) (setf factor (* factor 2)))
-          ((:triple-word) (setf factor (* factor 3))))))
-    (* value factor)))
-
-(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))
-
-(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)))))

Added: branches/trunk-reorg/projects/scrabble/src/web.lisp
===================================================================
--- branches/trunk-reorg/projects/scrabble/src/web.lisp	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/src/web.lisp	2007-10-06 23:09:39 UTC (rev 2228)
@@ -0,0 +1,24 @@
+(in-package :scrabble.web)
+
+(defmethod as-xml ((board board))
+  (with-element "board"
+      (dotimes (x 15)
+	(dotimes (y 15)
+	  (awhen (at-xy board x y)
+	    (with-element "tile"
+	      (attribute "x" x)
+	      (attribute "y" y)
+	      (attribute "letter" (char-of it))
+	      (attribute "value" (value-of it))))))))
+
+(defmethod as-xml ((player player))
+  (with-element "player"
+    (attribute "name" (user-full-name player))))
+
+(defmethod as-xml ((game game))
+  (with-element "game"
+    (attribute "language" (princ-to-string (language-of game)))
+    (attribute "remaining-tiles" (remaining-tile-count (tile-bag-of game)))
+    (dolist (player (players-of game))
+      (as-xml player))
+    (as-xml (board-of game))))

Added: branches/trunk-reorg/projects/scrabble/website/en/A.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/A.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/B.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/B.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/C.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/C.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/D.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/D.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/E.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/E.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/F.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/F.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/G.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/G.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/H.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/H.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/I.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/I.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/J.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/J.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/K.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/K.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/L.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/L.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/M.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/M.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/N.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/N.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/NIL.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/NIL.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/O.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/O.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/P.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/P.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/Q.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/Q.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/R.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/R.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/S.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/S.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/T.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/T.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/U.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/U.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/V.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/V.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/W.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/W.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/X.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/X.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/Y.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/Y.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/Z.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/Z.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/charmap.xml
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/en/charmap.xml	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/website/en/charmap.xml	2007-10-06 23:09:39 UTC (rev 2228)
@@ -0,0 +1,2 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<chars><char filename="A.png">A</char><char filename="B.png">B</char><char filename="C.png">C</char><char filename="D.png">D</char><char filename="E.png">E</char><char filename="F.png">F</char><char filename="G.png">G</char><char filename="H.png">H</char><char filename="I.png">I</char><char filename="J.png">J</char><char filename="K.png">K</char><char filename="L.png">L</char><char filename="M.png">M</char><char filename="N.png">N</char><char filename="O.png">O</char><char filename="P.png">P</char><char filename="Q.png">Q</char><char filename="R.png">R</char><char filename="S.png">S</char><char filename="T.png">T</char><char filename="U.png">U</char><char filename="V.png">V</char><char filename="W.png">W</char><char filename="X.png">X</char><char filename="Y.png">Y</char><char filename="Z.png">Z</char><char filename="NIL.png">NIL</char></chars>
\ No newline at end of file

Added: branches/trunk-reorg/projects/scrabble/website/en/double-letter.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/double-letter.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/double-word.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/double-word.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/scrabble.css
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/en/scrabble.css	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.css	2007-10-06 23:09:39 UTC (rev 2228)
@@ -0,0 +1 @@
+link ../de/scrabble.css
\ No newline at end of file


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/scrabble.css
___________________________________________________________________
Name: svn:special
   + *

Added: branches/trunk-reorg/projects/scrabble/website/en/scrabble.html
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/en/scrabble.html	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.html	2007-10-06 23:09:39 UTC (rev 2228)
@@ -0,0 +1 @@
+link ../de/scrabble.html
\ No newline at end of file


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/scrabble.html
___________________________________________________________________
Name: svn:special
   + *

Added: branches/trunk-reorg/projects/scrabble/website/en/scrabble.js
===================================================================
--- branches/trunk-reorg/projects/scrabble/website/en/scrabble.js	2007-10-06 23:08:12 UTC (rev 2227)
+++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.js	2007-10-06 23:09:39 UTC (rev 2228)
@@ -0,0 +1 @@
+link ../de/scrabble.js
\ No newline at end of file


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/scrabble.js
___________________________________________________________________
Name: svn:special
   + *

Added: branches/trunk-reorg/projects/scrabble/website/en/standard.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/standard.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/triple-letter.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/triple-letter.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: branches/trunk-reorg/projects/scrabble/website/en/triple-word.png
===================================================================
(Binary files differ)


Property changes on: branches/trunk-reorg/projects/scrabble/website/en/triple-word.png
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream




More information about the Bknr-cvs mailing list