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   "Add to GAME an event hook FUNCTION."
  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   "Run the event hooks of GAME and pass ARGS."
  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 (defsubst chess-game-tags (game)
  75   "Return the tags alist associated with GAME."
  76   (assert game)
  77   (cadr game))
  78
  79 (defsubst chess-game-set-tags (game tags)
  80   "Set the tags alist associated with GAME.
  81 After the TAGS alist was set the 'set-tags event is triggered."
  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   "Delete a TAG from GAME."
 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   "Return the data alist associated with GAME."
 118   (assert game)
 119   (nth 2 game))
 120
 121 (defsubst chess-game-set-data-alist (game value)
 122   "Set the data alist associated with GAME."
 123   (assert game)
 124   (setcar (nthcdr 2 game) value))
 125
 126 (defun chess-game-set-data (game key value)
 127   "Set GAME data KEY to VALUE."
 128   (assert game)
 129   (assert (symbolp key))
 130   (let* ((alist (chess-game-data-alist game))
 131          (cell (assq key alist)))
 132     (if cell
 133         (setcdr cell value)
 134       (if (null alist)
 135           (setcar (nthcdr 2 game) (list (cons key value)))
 136         (push (cons key value) alist)
 137         (setcar (nthcdr 2 game) alist)))
 138     (chess-game-run-hooks game 'set-data key)
 139     value))
 140
 141 (defun chess-game-data (game key)
 142   "Return the value of GAME data KEY."
 143   (assert game)
 144   (assert (symbolp key))
 145   (let ((alist (chess-game-data-alist game)))
 146     (if alist
 147         (cdr (assq key alist)))))
 148
 149 (defun chess-game-del-data (game key)
 150   "Delete KEY from GAME's data alist."
 151   (assert game)
 152   (assert (symbolp key))
 153   (let ((alist (chess-game-data-alist game)))
 154     (if alist
 155         (assq-delete-all key alist))))
 156
 157
 158 (defsubst chess-game-plies (game)
 159   "Return the main variation of GAME as a list of plies."
 160   (assert game)
 161   (nth 3 game))
 162
 163 (defalias 'chess-game-main-var 'chess-game-plies)
 164
 165 (defsubst chess-game-set-plies (game plies)
 166   "Set the list of plies which represents the main variation of GAME."
 167   (assert game)
 168   (setcdr (nthcdr 2 game) (if plies (list plies) nil))
 169   (chess-game-run-hooks game 'setup-game game))
 170
 171 (defsubst chess-game-set-start-position (game position)
 172   "Set the initial POSITION of GAME."
 173   (assert game)
 174   (assert (vectorp position))
 175   (chess-game-set-plies game (list (chess-ply-create* position))))
 176
 177 (defsubst chess-game-pos (game &optional index)
 178   "Return the current position of GAME or a position of a given INDEX."
 179   (assert game)
 180   (chess-ply-pos (chess-game-ply game index)))
 181
 182 (defun chess-game-status (game &optional index)
 183   "Return a symbol, such as :checkmate, :resign, etc.
 184 This conveys the status of the game at the given INDEX."
 185   (assert game)
 186   (or (chess-pos-status (chess-game-pos game index))
 187       (chess-ply-final-p (chess-game-ply game index))))
 188
 189 (defsubst chess-game-index (game)
 190   "Return the GAME's current position index."
 191   (assert game)
 192   (1- (length (chess-game-plies game))))
 193
 194 (defsubst chess-game-seq (game)
 195   "Return the current GAME sequence."
 196   (assert game)
 197   (/ (+ 2 (chess-game-index game)) 2))
 198
 199 (defsubst chess-game-side-to-move (game &optional index)
 200   "Return the color whose move it is in GAME at INDEX (or at the last position
 201 if INDEX is nil)."
 202   (assert game)
 203   (chess-pos-side-to-move (chess-game-pos game index)))
 204
 205 (defun chess-game-ply (game &optional index)
 206   "Return a ply of GAME.
 207 If INDEX is non-nil, the last played ply is returned."
 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   (assert (> count 0))
 232   (if (> count (chess-game-index game))
 233       (chess-error 'undo-limit-reached))
 234   (let ((chess-game-inhibit-events t))
 235     (chess-game-set-plies game (nbutlast (chess-game-plies game) count)))
 236   (chess-game-run-hooks game 'post-undo count))
 237
 238
 239 (defun chess-game-strip-annotations (game)
 240   "Strip all annotations from the given GAME."
 241   (assert game)
 242   (dotimes (i (chess-game-index game))
 243     (let ((position (chess-game-pos game i)))
 244       (chess-pos-set-annotations position nil))))
 245
 246
 247 (defsubst chess-game-over-p (game)
 248   "Return non-nil if GAME is at a final positionn."
 249   (assert game)
 250   (let ((last-ply (car (last (nth 3 game) 2))))
 251     (and last-ply (chess-ply-final-p last-ply))))
 252
 253
 254 (defsubst chess-game-to-string (game &optional indented)
 255   "Convert GAME to a string in PGN format."
 256   (assert game)
 257   (chess-game-to-pgn game indented t))
 258
 259 (defsubst chess-game-from-string (pgn)
 260   "Convert a PGN format string to a chess game object."
 261   (assert (stringp pgn))
 262   (chess-pgn-to-game pgn))
 263
 264
 265 (defsubst chess-game-copy-game (game new-game)
 266   (assert game)
 267   (assert new-game)
 268   (chess-game-set-tags game (chess-game-tags new-game))
 269   (chess-game-set-plies game (chess-game-plies new-game)))
 270
 271 (defun chess-game-create (&optional position tags)
 272   "Create a new chess game object.
 273 Optionally use the given starting POSITION (see also
 274 `chess-game-set-start-position').
 275 TAGS is the starting set of game tags (which can always be changed
 276 later using the various tag-related methods)."
 277   (let ((game (list nil tags nil
 278                     (list (chess-ply-create* (or position
 279                                                  chess-starting-position))))))
 280     (dolist (tag (cons (cons "Date" (format-time-string "%Y.%m.%d"))
 281                        chess-game-default-tags))
 282       (unless (chess-game-tag game (car tag))
 283         (chess-game-set-tag game (car tag) (cdr tag))))
 284     game))
 285
 286 (defun chess-game-move (game ply)
 287   "Make a move in the current GAME using PLY.
 288 This creates a new position and adds it to the main variation.
 289 The 'changes' of the last ply reflect whether the game is currently in
 290 progress (nil), if it is drawn, resigned, mate, etc."
 291   (assert game)
 292   (assert (listp ply))
 293   (let ((current-ply (chess-game-ply game))
 294         (position (chess-ply-pos ply))
 295         (changes (chess-ply-changes ply)))
 296
 297     (assert current-ply)
 298     (assert (and position (eq position (chess-ply-pos current-ply))))
 299     (assert changes)
 300
 301     (if (chess-ply-final-p current-ply)
 302         (chess-error 'add-to-completed))
 303
 304     (chess-ply-set-changes current-ply changes)
 305     (unless (chess-ply-any-keyword ply :drawn :perpetual :repetition
 306                                    :resign :aborted :flag-fell)
 307       (chess-game-add-ply game (chess-ply-create*
 308                                 (chess-ply-next-pos current-ply))))
 309
 310     (let ((long (> (length changes) 2)))
 311       (cond
 312        ((and long (chess-ply-any-keyword ply :resign :checkmate))
 313         (let ((color (chess-game-side-to-move game)))
 314           (if (chess-ply-any-keyword ply :resign :flag-fell)
 315               (chess-game-set-tag game "Result" (if color "0-1" "1-0"))
 316             (chess-game-set-tag game "Result" (if color "1-0" "0-1")))))
 317        ((and long (chess-ply-any-keyword ply :drawn :perpetual :repetition
 318                                          :stalemate))
 319         (chess-game-set-tag game "Result" "1/2-1/2"))))
 320
 321     (if (chess-ply-keyword ply :resign)
 322         (chess-game-run-hooks game 'resign)
 323       (chess-game-run-hooks game 'move current-ply)
 324       (chess-game-run-hooks game 'post-move))))
 325
 326 (defsubst chess-game-end (game keyword)
 327   "End GAME, by resignation, draw, etc."
 328   (chess-game-move game (list (chess-game-pos game) keyword)))
 329
 330 (provide 'chess-game)
 331
 332 ;;; chess-game.el ends here