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
  13 (defvar chess-game-inhibit-events nil)
  14
  15 (defconst chess-game-default-tags
  16   `(("Event"       . "Computer chess game")
  17     ("Round"       . "-")
  18     ("Site"        . ,(system-name))
  19     ("White"       . "?")
  20     ("Black"       . "?")
  21     ("Result"      . "*")
  22     ("TimeControl" . "-")))
  23
  24 (defsubst chess-game-hooks (game)
  25   "Return the tags alist associated with GAME."
  26   (car game))
  27
  28 (defsubst chess-game-set-hooks (game hooks)
  29   "Return the tags alist associated with GAME."
  30   (setcar game hooks))
  31
  32 (defun chess-game-add-hook (game function &optional data prepend)
  33   "Return the tags alist associated with GAME."
  34   (let ((hooks (chess-game-hooks game)))
  35     (if (null hooks)
  36         (chess-game-set-hooks game (list (cons function data)))
  37       (if prepend
  38           (chess-game-set-hooks game (cons (cons function data) hooks))
  39         (nconc hooks (list (cons function data)))))))
  40
  41 (defun chess-game-remove-hook (game function &optional data)
  42   "Remove from GAME all event hooks that match FUNCTION.
  43 If DATA is specified, only remove those hooks whose associated data
  44 matches."
  45   (let* ((hooks (chess-game-hooks game))
  46          (h hooks) last-hook)
  47     (while h
  48       (if (and (eq (caar h) function)
  49                (or (null data)
  50                    (eq data (cdar h))))
  51           (if last-hook
  52               (setcdr last-hook (cdr h))
  53             (setq hooks (cdr h)))
  54         (setq last-hook h))
  55       (setq h (cdr h)))
  56     (chess-game-set-hooks game hooks)))
  57
  58 (defsubst chess-game-run-hooks (game &rest args)
  59   "Return the tags alist associated with GAME."
  60   (unless chess-game-inhibit-events
  61     (let (result)
  62       (dolist (hook (chess-game-hooks game) result)
  63         (setq result (apply (car hook) game (cdr hook) args))))))
  64
  65
  66 (defsubst chess-game-tags (game)
  67   "Return the tags alist associated with GAME."
  68   (cadr game))
  69
  70 (defsubst chess-game-set-tags (game tags)
  71   "Return the tags alist associated with GAME."
  72   (setcar (cdr game) tags)
  73   (chess-game-run-hooks game 'set-tags))
  74
  75 (defsubst chess-game-tag (game tag)
  76   "Return the value for TAG in GAME."
  77   (let ((tags (chess-game-tags game)))
  78     (and tags (cdr (assoc tag tags)))))
  79
  80 (defun chess-game-set-tag (game tag value)
  81   "Set a TAG for GAME to VALUE."
  82   (let ((tags (chess-game-tags game)))
  83     (if (null tags)
  84         (chess-game-set-tags game (list (cons tag value)))
  85       (let ((entry (assoc tag tags)))
  86         (if entry
  87             (setcdr entry value)
  88           (nconc tags (list (cons tag value)))))))
  89   (chess-game-run-hooks game 'set-tag tag))
  90
  91 (defsubst chess-game-del-tag (game tag)
  92   "Set a TAG for GAME to VALUE."
  93   (chess-game-set-tags game (assq-delete-all tag (chess-game-tags game)))
  94   (chess-game-run-hooks game 'delete-tag tag))
  95
  96
  97 (defsubst chess-game-data-alist (game)
  98   (nth 2 game))
  99
 100 (defsubst chess-game-set-data-alist (game value)
 101   (setcar (nthcdr 2 game) value))
 102
 103 (defun chess-game-set-data (game key value)
 104   (let* ((alist (chess-game-data-alist game))
 105          (cell (assq key alist)))
 106     (if cell
 107         (setcdr cell value)
 108       (if (null alist)
 109           (setcar (nthcdr 2 game) (list (cons key value)))
 110         (push (cons key value) alist)
 111         (setcar (nthcdr 2 game) alist)))
 112     (chess-game-run-hooks game 'set-data key)))
 113
 114 (defun chess-game-data (game key)
 115   (let ((alist (chess-game-data-alist game)))
 116     (if alist
 117         (cdr (assq key alist)))))
 118
 119 (defun chess-game-del-data (game key)
 120   (let ((alist (chess-game-data-alist game)))
 121     (if alist
 122         (assq-delete-all key alist))))
 123
 124
 125 (defsubst chess-game-plies (game)
 126   "Return the tags alist associated with GAME."
 127   (nth 3 game))
 128
 129 (defalias 'chess-game-main-var 'chess-game-plies)
 130
 131 (defsubst chess-game-set-plies (game plies)
 132   "Return the tags alist associated with GAME."
 133   (setcdr (nthcdr 2 game) (list plies))
 134   (chess-game-run-hooks game 'setup-game game))
 135
 136 (defsubst chess-game-set-start-position (game position)
 137   "Return the tags alist associated with GAME."
 138   (chess-game-set-plies game (list (chess-ply-create* position))))
 139
 140 (defsubst chess-game-pos (game &optional index)
 141   "Return the position related to GAME's INDEX position."
 142   (chess-ply-pos (chess-game-ply game index)))
 143
 144 (defsubst chess-game-index (game)
 145   "Return the GAME's current position index."
 146   (1- (length (chess-game-plies game))))
 147
 148 (defun chess-game-seq (game)
 149   "Return the current GAME sequence."
 150   (let ((index (chess-game-index game)))
 151     (if (> index 1)
 152         (/ index 2)
 153       (1+ (/ index 2)))))
 154
 155 (defsubst chess-game-side-to-move (game)
 156   (chess-pos-side-to-move (chess-game-pos game)))
 157
 158 (defun chess-game-ply (game &optional index)
 159   "Return the position related to GAME's INDEX position."
 160   (if index
 161       (nth index (chess-game-plies game))
 162     (car (last (chess-game-plies game)))))
 163
 164 (defun chess-game-add-ply (game ply)
 165   "Return the position related to GAME's INDEX position."
 166   (let ((plies (chess-game-plies game)))
 167     (if plies
 168         (nconc plies (list ply))
 169       (let ((chess-game-inhibit-events t))
 170         (chess-game-set-plies game (list ply))))))
 171
 172 (chess-message-catalog 'english
 173   '((undo-limit-reached . "Cannot undo further")
 174     (add-to-completed   . "Cannot add moves to a completed game")))
 175
 176 (defun chess-game-undo (game count)
 177   "Undo the last COUNT plies of GAME."
 178   (if (> count (chess-game-index game))
 179       (chess-error 'undo-limit-reached))
 180   (let ((chess-game-inhibit-events t))
 181     (chess-game-set-plies game (nbutlast (chess-game-plies game) count)))
 182   (chess-game-run-hooks game 'post-undo count))
 183
 184
 185 (defsubst chess-game-over-p (game)
 186   "Return the position related to GAME's INDEX position."
 187   (let ((last-ply (car (last game 2))))
 188     (and last-ply (chess-ply-final-p last-ply))))
 189
 190
 191 (defsubst chess-game-to-string (game &optional indented)
 192   (chess-game-to-pgn game indented t))
 193
 194 (defsubst chess-game-from-string (pgn)
 195   (chess-pgn-to-game pgn))
 196
 197
 198 (defsubst chess-game-copy-game (game new-game)
 199   (chess-game-set-tags game (chess-game-tags new-game))
 200   (chess-game-set-plies game (chess-game-plies new-game)))
 201
 202
 203 (defun chess-game-create (&optional position tags)
 204   "Create a new chess game object.
 205 Optionally use the given starting POSITION.
 206 TAGS is the starting set of game tags (which can always be changed
 207 later using the various tag-related methods)."
 208   (let ((game (list nil tags nil
 209                     (list (chess-ply-create* (or position
 210                                                  (chess-pos-create))
 211                                              (null position))))))
 212     (dolist (tag (cons (cons "Date" (format-time-string "%Y.%m.%d"))
 213                        chess-game-default-tags))
 214       (unless (chess-game-tag game (car tag))
 215         (chess-game-set-tag game (car tag) (cdr tag))))
 216     game))
 217
 218 (defun chess-game-move (game ply)
 219   "Make a move in the current GAME, from FROM to TO.
 220 This creates a new position and adds it to the main variation.
 221 The 'changes' of the last ply reflect whether the game is currently in
 222 progress (nil), if it is drawn, resigned, mate, etc."
 223   (let ((current-ply (chess-game-ply game))
 224         (changes (chess-ply-changes ply))
 225         (position (chess-ply-pos ply)))
 226     (if (chess-ply-final-p current-ply)
 227         (chess-error 'add-to-completed))
 228     (assert (equal position (chess-ply-pos current-ply)))
 229     (chess-ply-set-changes current-ply changes)
 230     (chess-game-add-ply game (chess-ply-create*
 231                               (chess-ply-next-pos current-ply) t))
 232     (cond
 233      ((chess-ply-any-keyword ply :draw :perpetual :repetition :stalemate)
 234       (chess-game-set-tag game "Result" "1/2-1/2")
 235       (chess-game-run-hooks game 'game-drawn))
 236
 237      ((chess-ply-any-keyword ply :resign :checkmate)
 238       (let ((color (chess-game-side-to-move game)))
 239         (chess-game-set-tag game "Result" (if color "0-1" "1-0"))
 240         (if (chess-ply-keyword ply :resign)
 241             (chess-game-run-hooks game 'resign color)
 242           (chess-game-run-hooks game 'move current-ply))))
 243
 244      (t
 245       (chess-game-run-hooks game 'move current-ply)))
 246     (chess-game-run-hooks game 'post-move)))
 247
 248 (defsubst chess-game-end (game keyword)
 249   "End the current game, by resignation, draw, etc."
 250   (chess-game-move game (list (chess-game-pos game) keyword)))
 251
 252 (provide 'chess-game)
 253
 254 ;;; chess-game.el ends here