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

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