code.delx.au - gnu-emacs-elpa/blob - chess-game.el

   1 ;;; chess-game.el --- Maintain a chess game that is being played or viewed
   2
   3 ;; Copyright (C) 2002, 2004, 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: John Wiegley <johnw@gnu.org>
   6 ;; Maintainer: Mario Lang <mlang@delysid.org>
   7 ;; Keywords: games
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; A chess game is represented by a set of tags that describe the
  25 ;; game, and a list of plies representing the main variation.
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl-lib))
  30 (require 'chess-ply)
  31 (require 'chess-pgn)
  32
  33 (defvar chess-game-inhibit-events nil)
  34
  35 (defconst chess-game-default-tags
  36   `(("Event"       . "Computer chess game")
  37     ("Round"       . "-")
  38     ("Site"        . ,(system-name))
  39     ("White"       . "?")
  40     ("Black"       . "?")
  41     ("Result"      . "*")
  42     ("TimeControl" . "-")))
  43
  44 (defsubst chess-game-hooks (game)
  45   "Return the event hooks associated with GAME."
  46   (cl-assert game)
  47   (car game))
  48
  49 (defsubst chess-game-set-hooks (game hooks)
  50   "Set the event hooks associated with GAME."
  51   (cl-assert game)
  52   (cl-assert (or hooks (eq hooks nil)))
  53   (setcar game hooks))
  54
  55 (defun chess-game-add-hook (game function &optional data prepend)
  56   "Add to GAME an event hook FUNCTION."
  57   (cl-assert game)
  58   (cl-assert function)
  59   (let ((hooks (chess-game-hooks game)))
  60     (if (null hooks)
  61         (chess-game-set-hooks game (list (cons function data)))
  62       (if prepend
  63           (chess-game-set-hooks game (cons (cons function data) hooks))
  64         (nconc hooks (list (cons function data)))))))
  65
  66 (defun chess-game-remove-hook (game function &optional data)
  67   "Remove from GAME all event hooks that match FUNCTION.
  68 If DATA is specified, only remove those hooks whose associated data
  69 matches."
  70   (cl-assert game)
  71   (cl-assert function)
  72   (let* ((hooks (chess-game-hooks game))
  73          (h hooks) last-hook)
  74     (while h
  75       (if (and (eq (caar h) function)
  76                (or (null data)
  77                    (eq data (cdar h))))
  78           (if last-hook
  79               (setcdr last-hook (cdr h))
  80             (setq hooks (cdr h)))
  81         (setq last-hook h))
  82       (setq h (cdr h)))
  83     (chess-game-set-hooks game hooks)))
  84
  85 (defsubst chess-game-run-hooks (game &rest args)
  86   "Run the event hooks of GAME and pass ARGS."
  87   (cl-assert game)
  88   (unless chess-game-inhibit-events
  89     (let (result)
  90       (dolist (hook (chess-game-hooks game) result)
  91         (setq result (apply (car hook) game (cdr hook) args))))))
  92
  93 (defsubst chess-game-tags (game)
  94   "Return the tags alist associated with GAME."
  95   (cl-assert game)
  96   (cadr game))
  97
  98 (defsubst chess-game-set-tags (game tags)
  99   "Set the tags alist associated with GAME.
 100 After the TAGS alist was set the 'set-tags event is triggered."
 101   (cl-assert game)
 102   (cl-assert (or tags (eq tags nil)))
 103   (setcar (cdr game) tags)
 104   (chess-game-run-hooks game 'set-tags))
 105
 106 (defsubst chess-game-tag (game tag)
 107   "Return the value for TAG in GAME."
 108   (cl-assert game)
 109   (cl-assert tag)
 110   (let ((tags (chess-game-tags game)))
 111     (and tags (cdr (assoc tag tags)))))
 112
 113 (defun chess-game-set-tag (game tag value)
 114   "Set TAG for GAME to VALUE."
 115   (cl-assert game)
 116   (cl-assert tag)
 117   (cl-assert value)
 118   (let ((tags (chess-game-tags game)))
 119     (if (null tags)
 120         (chess-game-set-tags game (list (cons tag value)))
 121       (let ((entry (assoc tag tags)))
 122         (if entry
 123             (setcdr entry value)
 124           (nconc tags (list (cons tag value)))))))
 125   (chess-game-run-hooks game 'set-tag tag))
 126
 127 (defsubst chess-game-del-tag (game tag)
 128   "Delete TAG from GAME."
 129   (cl-assert game)
 130   (cl-assert tag)
 131   (chess-game-set-tags game (assq-delete-all tag (chess-game-tags game)))
 132   (chess-game-run-hooks game 'delete-tag tag))
 133
 134
 135 (defsubst chess-game-data-alist (game)
 136   "Return the data alist associated with GAME."
 137   (cl-assert game)
 138   (nth 2 game))
 139
 140 (defsubst chess-game-set-data-alist (game value)
 141   "Set the data alist associated with GAME."
 142   (cl-assert game)
 143   (setcar (nthcdr 2 game) value))
 144
 145 (defun chess-game-set-data (game key value)
 146   "Set GAME data KEY to VALUE."
 147   (cl-assert game)
 148   (cl-check-type key symbol)
 149   (let* ((alist (chess-game-data-alist game))
 150          (cell (assq key alist)))
 151     (if cell
 152         (setcdr cell value)
 153       (if (null alist)
 154           (setcar (nthcdr 2 game) (list (cons key value)))
 155         (push (cons key value) alist)
 156         (setcar (nthcdr 2 game) alist)))
 157     (chess-game-run-hooks game 'set-data key)
 158     value))
 159
 160 (defun chess-game-data (game key)
 161   "Return the value of GAME data KEY."
 162   (cl-assert game)
 163   (cl-check-type key symbol)
 164   (let ((alist (chess-game-data-alist game)))
 165     (if alist
 166         (cdr (assq key alist)))))
 167
 168 (defun chess-game-del-data (game key)
 169   "Delete KEY from GAME's data alist."
 170   (cl-assert game)
 171   (cl-check-type key symbol)
 172   (let ((alist (chess-game-data-alist game)))
 173     (if alist
 174         (assq-delete-all key alist))))
 175
 176
 177 (defsubst chess-game-plies (game)
 178   "Return the main variation of GAME as a list of plies."
 179   (cl-assert game)
 180   (nth 3 game))
 181
 182 (defalias 'chess-game-main-var 'chess-game-plies)
 183
 184 (defsubst chess-game-set-plies (game plies)
 185   "Set the list of plies which represents the main variation of GAME."
 186   (cl-assert game)
 187   (setcdr (nthcdr 2 game) (if plies (list plies) nil))
 188   (chess-game-run-hooks game 'setup-game game))
 189
 190 (defsubst chess-game-set-start-position (game position)
 191   "Set the initial POSITION of GAME."
 192   (cl-assert game)
 193   (cl-assert (vectorp position))
 194   (chess-game-set-plies game (list (chess-ply-create* position))))
 195
 196 (defsubst chess-game-pos (game &optional index)
 197   "Return the current position of GAME or a position of a given INDEX."
 198   (cl-assert game)
 199   (chess-ply-pos (chess-game-ply game index)))
 200
 201 (defun chess-game-status (game &optional index)
 202   "Return a symbol, such as :checkmate, :resign, etc.
 203 This conveys the status of the game at the given INDEX."
 204   (cl-assert game)
 205   (or (chess-pos-status (chess-game-pos game index))
 206       (chess-ply-final-p (chess-game-ply game index))))
 207
 208 (defsubst chess-game-index (game)
 209   "Return the GAME's current position index."
 210   (cl-assert game)
 211   (1- (length (chess-game-plies game))))
 212
 213 (defsubst chess-game-seq (game)
 214   "Return the current GAME sequence."
 215   (cl-assert game)
 216   (/ (+ 2 (chess-game-index game)) 2))
 217
 218 (defsubst chess-game-side-to-move (game &optional index)
 219   "Return the color whose move it is in GAME at INDEX (or at the last position
 220 if INDEX is nil)."
 221   (cl-assert game)
 222   (chess-pos-side-to-move (chess-game-pos game index)))
 223
 224 (defun chess-game-ply (game &optional index)
 225   "Return a ply of GAME.
 226 If INDEX is non-nil, the last played ply is returned."
 227   (cl-assert game)
 228   (if index
 229       (nth index (chess-game-plies game))
 230     (car (last (chess-game-plies game)))))
 231
 232 (defun chess-game-add-ply (game ply)
 233   "Add PLY to the main variation of GAME."
 234   (cl-assert game)
 235   (cl-check-type ply listp)
 236   (let ((plies (chess-game-plies game)))
 237     (if plies
 238         (nconc plies (list ply))
 239       (let ((chess-game-inhibit-events t))
 240         (chess-game-set-plies game (list ply))))))
 241
 242 (chess-message-catalog 'english
 243   '((undo-limit-reached . "Cannot undo further")
 244     (add-to-completed   . "Cannot add moves to a completed game")))
 245
 246 (defun chess-game-undo (game count)
 247   "Undo the last COUNT plies of GAME."
 248   (cl-assert game)
 249   (cl-check-type count (integer 0))
 250   (if (> count (chess-game-index game))
 251       (chess-error 'undo-limit-reached))
 252   (let ((chess-game-inhibit-events t))
 253     (chess-game-set-plies game (nbutlast (chess-game-plies game) count)))
 254   (chess-game-run-hooks game 'post-undo count))
 255
 256 (defun chess-game-strip-annotations (game)
 257   "Strip all annotations from the given GAME."
 258   (cl-assert game)
 259   (dotimes (i (chess-game-index game))
 260     (let ((position (chess-game-pos game i)))
 261       (chess-pos-set-annotations position nil))))
 262
 263 (defsubst chess-game-over-p (game)
 264   "Return non-nil if GAME is at a final positionn."
 265   (cl-assert game)
 266   (let ((last-ply (car (last (nth 3 game) 2))))
 267     (and last-ply (chess-ply-final-p last-ply))))
 268
 269
 270 (defsubst chess-game-to-string (game &optional indented)
 271   "Convert GAME to a string in PGN format."
 272   (cl-assert game)
 273   (chess-game-to-pgn game indented t))
 274
 275 (defsubst chess-game-from-string (pgn)
 276   "Convert a PGN format string to a chess game object."
 277   (cl-check-type pgn string)
 278   (chess-pgn-to-game pgn))
 279
 280 (defsubst chess-game-copy-game (game new-game)
 281   (cl-assert game)
 282   (cl-assert new-game)
 283   (chess-game-set-tags game (chess-game-tags new-game))
 284   (chess-game-set-plies game (chess-game-plies new-game)))
 285
 286 (defun chess-game-create (&optional position tags)
 287   "Create a new chess game object.
 288 Optionally use the given starting POSITION (see also
 289 `chess-game-set-start-position').
 290 TAGS is the starting set of game tags (which can always be changed
 291 later using the various tag-related methods)."
 292   (let ((game (list nil tags nil
 293                     (list (chess-ply-create* (or position
 294                                                  chess-starting-position))))))
 295     (dolist (tag (cons (cons "Date" (format-time-string "%Y.%m.%d"))
 296                        chess-game-default-tags))
 297       (unless (chess-game-tag game (car tag))
 298         (chess-game-set-tag game (car tag) (cdr tag))))
 299     game))
 300
 301 (defun chess-game-move (game ply)
 302   "Make a move in the current GAME using PLY.
 303 This creates a new position and adds it to the main variation.
 304 The 'changes' of the last ply reflect whether the game is currently in
 305 progress (nil), if it is drawn, resigned, mate, etc."
 306   (cl-assert game)
 307   (cl-assert (listp ply))
 308   (let ((current-ply (chess-game-ply game))
 309         (position (chess-ply-pos ply))
 310         (changes (chess-ply-changes ply)))
 311
 312     (cl-assert current-ply)
 313     (cl-assert (and position (eq position (chess-ply-pos current-ply))))
 314     (cl-assert changes)
 315
 316     (if (chess-ply-final-p current-ply)
 317         (chess-error 'add-to-completed))
 318
 319     (chess-ply-set-changes current-ply changes)
 320     (unless (chess-ply-any-keyword ply :drawn :perpetual :repetition
 321                                    :resign :aborted :flag-fell)
 322       (chess-game-add-ply game (chess-ply-create*
 323                                 (chess-ply-next-pos current-ply))))
 324
 325     (let ((long (> (length changes) 2)))
 326       (cond
 327        ((and long (chess-ply-any-keyword ply :resign :checkmate))
 328         (let ((color (chess-game-side-to-move game)))
 329           (if (chess-ply-any-keyword ply :resign :flag-fell)
 330               (chess-game-set-tag game "Result" (if color "0-1" "1-0"))
 331             (chess-game-set-tag game "Result" (if color "1-0" "0-1")))))
 332        ((and long (chess-ply-any-keyword ply :drawn :perpetual :repetition
 333                                          :stalemate))
 334         (chess-game-set-tag game "Result" "1/2-1/2"))))
 335
 336     (if (chess-ply-keyword ply :resign)
 337         (chess-game-run-hooks game 'resign)
 338       (chess-game-run-hooks game 'move current-ply))))
 339
 340 (defsubst chess-game-end (game keyword)
 341   "End GAME, by resignation, draw, etc."
 342   (chess-game-move game (list (chess-game-pos game) keyword)))
 343
 344 (provide 'chess-game)
 345
 346 ;;; chess-game.el ends here