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 (defconst chess-game-default-tags
  15   (list '("Event" . "Computer chess game")
  16         '("Round" . "-")
  17         (cons "Site" (system-name))
  18         '("White" . "?")
  19         '("Black" . "?")
  20         '("Result" . "*")
  21         '("TimeControl" . "-")))
  22
  23 (defsubst chess-game-tags (game)
  24   "Return the tags alist associated with GAME."
  25   (car game))
  26
  27 (defsubst chess-game-set-tags (game tags)
  28   "Return the tags alist associated with GAME."
  29   (setcar game tags))
  30
  31 (defsubst chess-game-plies (game)
  32   "Return the tags alist associated with GAME."
  33   (cdr game))
  34
  35 (defsubst chess-game-set-plies (game plies)
  36   "Return the tags alist associated with GAME."
  37   (setcdr game plies))
  38
  39 (defsubst chess-game-tag (game tag)
  40   "Return the value for TAG in GAME."
  41   (let ((tags (chess-game-tags game)))
  42     (and tags (cdr (assoc tag tags)))))
  43
  44 (defun chess-game-set-tag (game tag value)
  45   "Set a TAG for GAME to VALUE."
  46   (let ((tags (chess-game-tags game)))
  47     (if (null tags)
  48         (setcar game (list (cons tag value)))
  49       (let ((entry (assoc tag tags)))
  50         (if entry
  51             (setcdr entry value)
  52           (nconc (car game)
  53                  (list (cons tag value))))))))
  54
  55 (defun chess-game-del-tag (game tag)
  56   "Set a TAG for GAME to VALUE."
  57   (setcar game (assq-delete-all tag (chess-game-tags game))))
  58
  59 (defsubst chess-game-index (game)
  60   "Return the GAME's current position index."
  61   (length (cdr game)))
  62
  63 (defsubst chess-game-seq (game)
  64   "Return the current GAME sequence."
  65   (1+ (/ (chess-game-index game) 2)))
  66
  67 (defun chess-game-ply (game &optional index)
  68   "Return the position related to GAME's INDEX position."
  69   (if index
  70       (nth index (cdr game))
  71     (car (last (cdr game)))))
  72
  73 (defun chess-game-pos (game &optional index)
  74   "Return the position related to GAME's INDEX position."
  75   (car (chess-game-ply game index)))
  76
  77 (defun chess-game-create (&optional tags position)
  78   "Create a new chess game object.
  79 If TAGS is non-nil, it is a list of cons cell that define starting
  80 tags to use.  If POSITION is non-nil, the game starts at that
  81 position."
  82   (let ((game (cons nil nil)))
  83     (dolist (tag chess-game-default-tags)
  84       (chess-game-set-tag game (car tag) (cdr tag)))
  85     (chess-game-set-tag game "Date" (format-time-string "%Y.%m.%d"))
  86     (dolist (tag tags)
  87       (chess-game-set-tag game (car tag) (cdr tag)))
  88     (setcdr game (list (chess-ply-create
  89                         (or position (chess-pos-create)))))
  90     game))
  91
  92 (defun chess-game-move (game ply)
  93   "Make a move in the current GAME, from FROM to TO.
  94 This creates a new position and adds it to the main variation.
  95 The 'changes' of the last ply reflect whether the game is currently in
  96 progress (nil), if it is drawn, resigned, mate, etc."
  97   (let ((current-ply (chess-game-ply game))
  98         (changes (chess-ply-changes ply)))
  99     (assert (equal (chess-ply-pos current-ply) (chess-ply-pos ply)))
 100     (chess-ply-set-changes current-ply changes)
 101     (cond
 102      ((or (memq ':draw changes)
 103           (memq ':perpetual changes)
 104           (memq ':repetition changes)
 105           (memq ':stalemate changes))
 106       (chess-game-set-tag game "Result" "1/2-1/2"))
 107      ((or (memq ':resign changes)
 108           (memq ':checkmate changes))
 109       (chess-game-set-tag game "Result"
 110                           (if (chess-pos-side-to-move (chess-game-pos game))
 111                               "0-1" "1-0")))
 112      (t (nconc (cdr game)
 113                (list (chess-ply-create
 114                       (chess-ply-next-pos current-ply))))))))
 115
 116 (provide 'chess-game)
 117
 118 ;;; chess-game.el ends here