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 ;; $Revision$
   6
   7 ;;; Commentary:
   8
   9 ;; A chess game is represented by a set of tags that describe the
  10 ;; game, and a list of plies representing the main variation.
  11
  12 (require 'chess-ply)
  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   (car game))
  28
  29 (defsubst chess-game-set-hooks (game hooks)
  30   "Return the tags alist associated with GAME."
  31   (setcar game hooks))
  32
  33 (defun chess-game-add-hook (game function &optional data prepend)
  34   "Return the tags alist associated with GAME."
  35   (let ((hooks (chess-game-hooks game)))
  36     (if (null hooks)
  37         (chess-game-set-hooks game (list (cons function data)))
  38       (if prepend
  39           (chess-game-set-hooks game (cons (cons function data) hooks))
  40         (nconc hooks (list (cons function data)))))))
  41
  42 (defun chess-game-remove-hook (game function &optional data)
  43   "Remove from GAME all event hooks that match FUNCTION.
  44 If DATA is specified, only remove those hooks whose associated data
  45 matches."
  46   (let* ((hooks (chess-game-hooks game))
  47          (h hooks) last-hook)
  48     (while h
  49       (if (and (eq (caar h) function)
  50                (or (null data)
  51                    (eq data (cdar h))))
  52           (if last-hook
  53               (setcdr last-hook (cdr h))
  54             (setq hooks (cdr h)))
  55         (setq last-hook h))
  56       (setq h (cdr h)))
  57     (chess-game-set-hooks game hooks)))
  58
  59 (defsubst chess-game-run-hooks (game &rest args)
  60   "Return the tags alist associated with GAME."
  61   (unless chess-game-inhibit-events
  62     (dolist (hook (chess-game-hooks game))
  63       (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 (defun chess-game-set-data (game key value)
 101   (let* ((alist (chess-game-data-alist game))
 102          (cell (assq key alist)))
 103     (if cell
 104         (setcdr cell value)
 105       (if (null alist)
 106           (setcar (nthcdr 2 game) (list (cons key value)))
 107         (push (cons key value) alist)
 108         (setcar (nthcdr 2 game) alist)))
 109     (chess-game-run-hooks game 'set-data key)))
 110
 111 (defun chess-game-data (game key)
 112   (let ((alist (chess-game-data-alist game)))
 113     (if alist
 114         (cdr (assq key alist)))))
 115
 116 (defun chess-game-del-data (game key)
 117   (let ((alist (chess-game-data-alist game)))
 118     (if alist
 119         (assq-delete-all key alist))))
 120
 121
 122 (defsubst chess-game-plies (game)
 123   "Return the tags alist associated with GAME."
 124   (nth 3 game))
 125
 126 (defalias 'chess-game-main-var 'chess-game-plies)
 127
 128 (defsubst chess-game-set-plies (game plies)
 129   "Return the tags alist associated with GAME."
 130   (setcdr (nthcdr 2 game) (list plies))
 131   (chess-game-run-hooks game 'setup-game game))
 132
 133 (defsubst chess-game-set-start-position (game position)
 134   "Return the tags alist associated with GAME."
 135   (chess-game-set-plies game (list (chess-ply-create position))))
 136
 137 (defsubst chess-game-pos (game &optional index)
 138   "Return the position related to GAME's INDEX position."
 139   (chess-ply-pos (chess-game-ply game index)))
 140
 141 (defsubst chess-game-index (game)
 142   "Return the GAME's current position index."
 143   (1- (length (chess-game-plies game))))
 144
 145 (defsubst chess-game-seq (game)
 146   "Return the current GAME sequence."
 147   (1+ (/ (chess-game-index game) 2)))
 148
 149 (defsubst chess-game-side-to-move (game)
 150   (chess-pos-side-to-move (chess-game-pos game)))
 151
 152 (defun chess-game-ply (game &optional index)
 153   "Return the position related to GAME's INDEX position."
 154   (if index
 155       (nth index (chess-game-plies game))
 156     (car (last (chess-game-plies game)))))
 157
 158 (defun chess-game-add-ply (game ply)
 159   "Return the position related to GAME's INDEX position."
 160   (let ((plies (chess-game-plies game)))
 161     (if plies
 162         (nconc plies (list ply))
 163       (let ((chess-game-inhibit-events t))
 164         (chess-game-set-plies game (list ply))))))
 165
 166 (defun chess-game-undo (game count)
 167   "Undo the last COUNT plies of GAME."
 168   (if (> count (chess-game-index game))
 169       (error "Cannot undo further")
 170     (chess-game-set-plies game (nbutlast (chess-game-plies game) count))))
 171
 172
 173 (defsubst chess-game-over-p (game)
 174   "Return the position related to GAME's INDEX position."
 175   (let ((last-ply (car (last game 2))))
 176     (and last-ply (chess-ply-final-p last-ply))))
 177
 178
 179 (defsubst chess-game-to-string (game &optional indented)
 180   (chess-game-to-pgn game indented t))
 181
 182 (defsubst chess-game-from-string (pgn)
 183   (chess-pgn-to-game pgn))
 184
 185
 186 (defun chess-game-create (&optional position tags)
 187   "Create a new chess game object.
 188 Optionally use the given starting POSITION.
 189 TAGS is the starting set of game tags (which can always be changed
 190 later using the various tag-related methods)."
 191   (let ((game (list nil tags nil
 192                     (list (chess-ply-create (or position
 193                                                 (chess-pos-create)))))))
 194     (dolist (tag (cons (cons "Date" (format-time-string "%Y.%m.%d"))
 195                        chess-game-default-tags))
 196       (unless (chess-game-tag game (car tag))
 197         (chess-game-set-tag game (car tag) (cdr tag))))
 198     game))
 199
 200 (defun chess-game-move (game ply)
 201   "Make a move in the current GAME, from FROM to TO.
 202 This creates a new position and adds it to the main variation.
 203 The 'changes' of the last ply reflect whether the game is currently in
 204 progress (nil), if it is drawn, resigned, mate, etc."
 205   (let ((current-ply (chess-game-ply game))
 206         (changes (chess-ply-changes ply))
 207         (position (chess-ply-pos ply)))
 208     (if (chess-ply-final-p current-ply)
 209         (error "Cannot add moves to a completed game"))
 210     (unless (equal position (chess-ply-pos current-ply))
 211       (error "Positions do not match"))
 212     (chess-ply-set-changes current-ply changes)
 213     (chess-game-add-ply game (chess-ply-create
 214                               (chess-ply-next-pos current-ply)))
 215     (cond
 216      ((chess-ply-any-keyword ply :draw :perpetual :repetition :stalemate)
 217       (chess-game-set-tag game "Result" "1/2-1/2")
 218       (chess-game-run-hooks game 'game-drawn))
 219
 220      ((chess-ply-any-keyword ply :resign :checkmate)
 221       (let ((color (chess-game-side-to-move game)))
 222         (chess-game-set-tag game "Result" (if color "0-1" "1-0"))
 223         (if (chess-ply-keyword ply :resign)
 224             (chess-game-run-hooks game 'resign color)
 225           (chess-game-run-hooks game 'move current-ply))))
 226
 227      (t
 228       (chess-game-run-hooks game 'move current-ply)))))
 229
 230 (defsubst chess-game-end (game keyword)
 231   "End the current game, by resignation, draw, etc."
 232   (chess-game-move game (list (chess-game-pos game) keyword)))
 233
 234 (provide 'chess-game)
 235
 236 ;;; chess-game.el ends here