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-illegal nil)
  15 (put 'chess-illegal 'error-conditions '(error))
  16
  17 (defconst chess-game-default-tags
  18   `(("Event"       . "Computer chess game")
  19     ("Round"       . "-")
  20     ("Site"        . ,(system-name))
  21     ("White"       . "?")
  22     ("Black"       . "?")
  23     ("Result"      . "*")
  24     ("TimeControl" . "-")))
  25
  26 (defsubst chess-game-hooks (game)
  27   "Return the tags alist associated with GAME."
  28   (car game))
  29
  30 (defsubst chess-game-set-hooks (game hooks)
  31   "Return the tags alist associated with GAME."
  32   (setcar game hooks))
  33
  34 (defun chess-game-add-hook (game function &optional data prepend)
  35   "Return the tags alist associated with GAME."
  36   (let ((hooks (chess-game-hooks game)))
  37     (if (null hooks)
  38         (chess-game-set-hooks game (list (cons function data)))
  39       (if prepend
  40           (chess-game-set-hooks game (cons (cons function data) hooks))
  41         (nconc hooks (list (cons function data)))))))
  42
  43 (defun chess-game-remove-hook (game function &optional data)
  44   "Remove from GAME all event hooks that match FUNCTION.
  45 If DATA is specified, only remove those hooks whose associated data
  46 matches."
  47   (let* ((hooks (chess-game-hooks game))
  48          (h hooks) last-hook)
  49     (while h
  50       (if (and (eq (caar h) function)
  51                (or (null data)
  52                    (eq data (cdar h))))
  53           (if last-hook
  54               (setcdr last-hook (cdr h))
  55             (setq hooks (cdr h)))
  56         (setq last-hook h))
  57       (setq h (cdr h)))
  58     (chess-game-set-hooks game hooks)))
  59
  60 (defsubst chess-game-run-hooks (game &rest args)
  61   "Return the tags alist associated with GAME."
  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     (if (null alist)
 103         (setcar (nthcdr 2 game) (list (cons key value)))
 104       (push (cons key value) alist))
 105     (chess-game-run-hooks game 'set-data key)))
 106
 107 (defun chess-game-get-data (game key)
 108   (let ((alist (chess-game-data-alist game)))
 109     (if alist
 110         (cdr (assq key alist)))))
 111
 112 (defun chess-game-del-data (game key)
 113   (let ((alist (chess-game-data-alist game)))
 114     (if alist
 115         (assq-delete-all key alist))))
 116
 117
 118 (defsubst chess-game-plies (game)
 119   "Return the tags alist associated with GAME."
 120   (nth 3 game))
 121
 122 (defalias 'chess-game-main-var 'chess-game-plies)
 123
 124 (defsubst chess-game-set-plies (game plies)
 125   "Return the tags alist associated with GAME."
 126   (setcdr (nthcdr 2 game) (list plies))
 127   (chess-game-run-hooks game 'setup (chess-ply-pos (car (last plies)))))
 128
 129 (defsubst chess-game-set-start-position (game position)
 130   "Return the tags alist associated with GAME."
 131   (chess-game-set-plies game (list (chess-ply-create position))))
 132
 133 (defsubst chess-game-pos (game &optional index)
 134   "Return the position related to GAME's INDEX position."
 135   (chess-ply-pos (chess-game-ply game index)))
 136
 137 (defsubst chess-game-index (game)
 138   "Return the GAME's current position index."
 139   (1- (length (chess-game-plies game))))
 140
 141 (defsubst chess-game-seq (game)
 142   "Return the current GAME sequence."
 143   (1+ (/ (chess-game-index game) 2)))
 144
 145 (defsubst chess-game-side-to-move (game)
 146   (chess-pos-side-to-move (chess-game-pos game)))
 147
 148 (defun chess-game-ply (game &optional index)
 149   "Return the position related to GAME's INDEX position."
 150   (if index
 151       (nth index (chess-game-plies game))
 152     (car (last (chess-game-plies game)))))
 153
 154 (defun chess-game-add-ply (game ply)
 155   "Return the position related to GAME's INDEX position."
 156   (let ((plies (chess-game-plies game)))
 157     (if plies
 158         (nconc plies (list ply))
 159       (chess-game-set-plies game (list ply)))))
 160
 161
 162 (defun chess-game-create (&optional position tags)
 163   "Create a new chess game object.
 164 Optionally use the given starting POSITION.
 165 TAGS is the starting set of game tags (which can always be changed
 166 later using the various tag-related methods)."
 167   (let ((game (list nil tags nil
 168                     (list (chess-ply-create (or position
 169                                                 (chess-pos-create)))))))
 170     (dolist (tag (cons (cons "Date" (format-time-string "%Y.%m.%d"))
 171                        chess-game-default-tags))
 172       (unless (chess-game-tag game (car tag))
 173         (chess-game-set-tag game (car tag) (cdr tag))))
 174     game))
 175
 176 (defun chess-game-move (game ply)
 177   "Make a move in the current GAME, from FROM to TO.
 178 This creates a new position and adds it to the main variation.
 179 The 'changes' of the last ply reflect whether the game is currently in
 180 progress (nil), if it is drawn, resigned, mate, etc."
 181   (let ((current-ply (chess-game-ply game))
 182         (changes (chess-ply-changes ply))
 183         (position (chess-ply-pos ply)))
 184     (if (chess-ply-final-p current-ply)
 185         (error "Cannot add moves to a completed game"))
 186     (unless (equal position (chess-ply-pos current-ply))
 187       (error "Positions do not match"))
 188     (unless (or (chess-ply-has-keyword ply :resign)
 189                 (chess-search-position
 190                  position (cadr (chess-ply-changes ply))
 191                  (chess-pos-piece position (car (chess-ply-changes ply)))))
 192       (signal 'chess-illegal "Illegal move"))
 193     (chess-ply-set-changes current-ply changes)
 194     (chess-game-add-ply game (chess-ply-create
 195                               (chess-ply-next-pos current-ply)))
 196     (cond
 197      ((chess-ply-has-keyword ply :draw :perpetual :repetition :stalemate)
 198       (chess-game-set-tag game "Result" "1/2-1/2")
 199       (chess-game-run-hooks game 'game-drawn))
 200
 201      ((chess-ply-has-keyword ply :resign :checkmate)
 202       (let ((color (chess-game-side-to-move game)))
 203         (chess-game-set-tag game "Result" (if color "0-1" "1-0"))
 204         (if (chess-ply-has-keyword ply :resign)
 205             (chess-game-run-hooks game 'resign color)
 206           (chess-game-run-hooks game 'game-over))))
 207
 208      (t
 209       (chess-game-run-hooks game 'move current-ply)))))
 210
 211 (defsubst chess-game-resign (game)
 212   "Resign the current game."
 213   (chess-game-move game (list (chess-game-pos game) :resign)))
 214
 215 (provide 'chess-game)
 216
 217 ;;; chess-game.el ends here