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