[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