code.delx.au - gnu-emacs-elpa/blob - chess-display.el

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Code shared by all chess displays
   4 ;;
   5
   6 (require 'chess-module)
   7 (require 'chess-var)
   8 (require 'chess-input)
   9
  10 (defgroup chess-display nil
  11   "Common code used by chess displays."
  12   :group 'chess)
  13
  14 (defcustom chess-display-popup t
  15   "If non-nil (the default), popup displays whenever a significant event
  16 occurs."
  17   :type 'boolean
  18   :group 'chess-display)
  19
  20 (make-variable-buffer-local 'chess-display-popup)
  21
  22 (defcustom chess-display-highlight-legal nil
  23   "If non-nil, highlight legal target squares when a piece is selected."
  24   :type 'boolean
  25   :group 'chess-display)
  26
  27 (chess-message-catalog 'english
  28   '((mode-white     . "White")
  29     (mode-black     . "Black")
  30     (mode-start     . "START")
  31     (mode-checkmate . "CHECKMATE")
  32     (mode-aborted   . "ABORTED")
  33     (mode-resigned  . "RESIGNED")
  34     (mode-stalemate . "STALEMATE")
  35     (mode-flag-fell . "FLAG FELL")
  36     (mode-drawn     . "DRAWN")
  37     (mode-edit      . "EDIT")))
  38
  39 (defcustom chess-display-mode-line-format
  40   '("  " chess-display-side-to-move "  "
  41     chess-display-move-text "   "
  42     (:eval (chess-display-clock-string))
  43     "(" (:eval (chess-game-tag chess-module-game "White")) "-"
  44     (:eval (chess-game-tag chess-module-game "Black")) ", "
  45     (:eval (chess-game-tag chess-module-game "Site"))
  46     (:eval (let ((date (chess-game-tag chess-module-game "Date")))
  47              (and (string-match "\\`\\([0-9]\\{4\\}\\)" date)
  48                   (concat " " (match-string 1 date))))) ")")
  49   "The format of a chess display's modeline.
  50 See `mode-line-format' for syntax details."
  51   :type 'sexp
  52   :group 'chess-display)
  53
  54 (defface chess-display-black-face
  55   '((t (:background "Black" :foreground "White")))
  56   "*The face used for the word Black in the mode-line."
  57   :group 'chess-display)
  58
  59 (defface chess-display-white-face
  60   '((t (:background "White" :foreground "Black")))
  61   "*The face used for the word White in the mode-line."
  62   :group 'chess-display)
  63
  64 ;;; Code:
  65
  66 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  67 ;;
  68 ;; User interface
  69 ;;
  70
  71 (defvar chess-display-index)
  72 (defvar chess-display-move-text)
  73 (defvar chess-display-side-to-move)
  74 (defvar chess-display-perspective)
  75 (defvar chess-display-event-handler nil)
  76 (defvar chess-display-edit-mode nil)
  77 (defvar chess-display-index-positions nil)
  78
  79 (make-variable-buffer-local 'chess-display-index)
  80 (make-variable-buffer-local 'chess-display-move-text)
  81 (make-variable-buffer-local 'chess-display-side-to-move)
  82 (make-variable-buffer-local 'chess-display-perspective)
  83 (make-variable-buffer-local 'chess-display-event-handler)
  84 (make-variable-buffer-local 'chess-display-edit-mode)
  85 (make-variable-buffer-local 'chess-display-index-positions)
  86
  87 (defvar chess-display-handling-event nil
  88   "If non-nil, chess-display is already handling the event.  This variable
  89 is used to avoid reentrancy.")
  90
  91 (defvar chess-display-style)
  92
  93 (chess-message-catalog 'english
  94   '((no-such-style . "There is no such chessboard display style '%s'")
  95     (cannot-yet-add . "Cannot insert moves into a game (yet)")))
  96
  97 (defun chess-display-create (game style perspective)
  98   "Create a chess display, for displaying chess objects.
  99 Where GAME is the chess game object to use, STYLE should be the display
 100 type to use (a symbol) and PERSPECTIVE determines the viewpoint
 101 of the board, if non-nil, the board is viewed from White's perspective."
 102   (interactive (list (if current-prefix-arg
 103                          (chess-game-create (chess-fen-to-pos
 104                                              (read-string "FEN: ")))
 105                        (chess-game-create))
 106                      (intern-soft
 107                       (concat "chess-" (completing-read "Display style: "
 108                                                         '(("ics1")
 109                                                           ("images")
 110                                                           ("plain")))))
 111                      (y-or-n-p "View from White's perspective? ")))
 112   (if (require style nil t)
 113       (let* ((chess-display-style style)
 114              (display (chess-module-create 'chess-display game "*Chessboard*"
 115                              perspective)))
 116         (if (interactive-p)
 117             (progn
 118               (chess-display-update display)
 119               (chess-display-popup display))
 120           display))))
 121
 122 (defalias 'chess-display-destroy 'chess-module-destroy)
 123
 124 (defun chess-display-clone (display style perspective)
 125   (let ((new-display (chess-display-create (chess-display-game display)
 126                                            style perspective)))
 127     ;; the display will have already been updated by the `set-' calls,
 128     ;; it's just not visible yet
 129     (chess-display-popup new-display)
 130     new-display))
 131
 132 (defsubst chess-display-perspective (display)
 133   "Return the current perspective of DISPLAY."
 134   (chess-with-current-buffer display
 135     chess-display-perspective))
 136
 137 (defun chess-display-set-perspective* (display perspective)
 138   (chess-with-current-buffer display
 139     (setq chess-display-perspective perspective
 140           chess-display-index-positions nil)
 141     (erase-buffer)))                    ; force a complete redraw
 142
 143 (defun chess-display-set-perspective (display perspective)
 144   "Set PERSPECTIVE of DISPLAY."
 145   (chess-with-current-buffer display
 146     (chess-display-set-perspective* nil perspective)
 147     (chess-display-update nil)))
 148
 149 (defun chess-display-set-position (display &optional position my-color)
 150   "Set the game associated with DISPLAY to use POSITION and MY-COLOR."
 151   (chess-with-current-buffer display
 152     (if position
 153         (progn
 154           (chess-game-set-start-position chess-module-game position)
 155           (chess-game-set-data chess-module-game 'my-color my-color))
 156       (chess-game-set-start-position chess-module-game
 157                                      chess-starting-position)
 158       (chess-game-set-data chess-module-game 'my-color t))
 159     (chess-display-set-index nil 0)))
 160
 161 (defun chess-display-position (display)
 162   "Return the position currently viewed on DISPLAY."
 163   (chess-with-current-buffer display
 164     (if chess-display-edit-mode
 165         chess-display-edit-position
 166       (chess-game-pos chess-module-game chess-display-index))))
 167
 168 (defun chess-display-set-ply (display ply)
 169   (chess-with-current-buffer display
 170     (let ((chess-game-inhibit-events t))
 171       (chess-display-set-index nil 1))
 172     (chess-game-set-plies chess-module-game
 173                           (list ply (chess-ply-create*
 174                                      (chess-ply-next-pos ply))))))
 175
 176 (defun chess-display-ply (display)
 177   (chess-with-current-buffer display
 178     (chess-game-ply chess-module-game chess-display-index)))
 179
 180 (defun chess-display-set-variation (display variation &optional index)
 181   "Set DISPLAY VARIATION.
 182 If INDEX is not specified, this will cause the first ply in the variation
 183 to be displayed, with the user able to scroll back and forth through the
 184 moves in the variation.  Any moves made on the board will extend/change the
 185 variation that was passed in."
 186   (chess-with-current-buffer display
 187     (let ((chess-game-inhibit-events t))
 188       (chess-display-set-index nil (or index (chess-var-index variation))))
 189     (chess-game-set-plies chess-module-game variation)))
 190
 191 (defun chess-display-variation (display)
 192   (chess-with-current-buffer display
 193     (chess-game-main-var chess-module-game)))
 194
 195 (defun chess-display-set-game* (display game &optional index)
 196   "Set the game associated with the given DISPLAY."
 197   (chess-with-current-buffer display
 198     (chess-module-set-game* display game)
 199     (chess-display-set-index nil (or index (chess-game-index game)))))
 200
 201 (defun chess-display-set-game (display game &optional index)
 202   "Set the given DISPLAY to display the GAME object, optionally at INDEX.
 203 This is the function to call to cause a display to view a game.  It
 204 will also update all of the listening engines and other displays to
 205 also view the same game."
 206   (chess-with-current-buffer display
 207     (chess-game-copy-game chess-module-game game)
 208     (chess-display-set-index nil (or index (chess-game-index game)))))
 209
 210 (defalias 'chess-display-game 'chess-module-game)
 211
 212 (defun chess-display-clock-string ()
 213   (let ((white (chess-game-data chess-module-game 'white-remaining))
 214         (black (chess-game-data chess-module-game 'black-remaining)))
 215     (unless (and white black)
 216       (let ((last-ply (chess-game-ply chess-module-game
 217                                       (1- chess-display-index))))
 218         (setq white (chess-ply-keyword last-ply :white)
 219               black (chess-ply-keyword last-ply :black))))
 220     (if (and white black)
 221         (format "W %s%02d:%02d B %s%02d:%02d   "
 222                 (if (and (< white 0) (= 0 (floor white))) "-" "")
 223                 (/ (floor white) 60) (% (abs (floor white)) 60)
 224                 (if (and (< black 0) (= 0 (floor black))) "-" "")
 225                 (/ (floor black) 60) (% (abs (floor black)) 60)))))
 226
 227 (defun chess-display-set-index (display index)
 228   (chess-with-current-buffer display
 229     (if (not (or (not (integerp index))
 230                  (< index 0)
 231                  (> index (chess-game-index chess-module-game))))
 232         (chess-game-run-hooks chess-module-game 'set-index index)
 233       (when (and (> index (chess-game-index chess-module-game))
 234                  (not (chess-ply-final-p (chess-game-ply chess-module-game))))
 235         (chess-game-run-hooks chess-module-game 'forward)))))
 236
 237 (defun chess-display-set-index* (display index)
 238   (chess-with-current-buffer display
 239     (setq chess-display-index index
 240           chess-display-move-text
 241           (if (= index 0)
 242               (chess-string 'mode-start)
 243             (concat (int-to-string (if (> index 1)
 244                                        (if (= (mod index 2) 0)
 245                                            (/ index 2)
 246                                          (1+ (/ index 2)))
 247                                      1))
 248                     "." (and (= 0 (mod index 2)) "..")
 249                     (chess-ply-to-algebraic
 250                      (chess-game-ply chess-module-game (1- index)))))
 251           chess-display-side-to-move
 252           (let ((status (chess-game-status chess-module-game index)))
 253             (cond
 254              ((eq status :aborted)   (chess-string 'mode-aborted))
 255              ((eq status :resign)    (chess-string 'mode-resigned))
 256              ((eq status :drawn)     (chess-string 'mode-drawn))
 257              ((eq status :checkmate) (chess-string 'mode-checkmate))
 258              ((eq status :stalemate) (chess-string 'mode-stalemate))
 259              ((eq status :flag-fell) (chess-string 'mode-flag-fell))
 260              (t
 261               (let* ((color (or chess-pos-always-white
 262                                 (chess-game-side-to-move chess-module-game
 263                                                          index)))
 264                      (str (format " %s " (if color
 265                                              (chess-string 'mode-white)
 266                                            (chess-string 'mode-black)))))
 267                 (add-text-properties
 268                  0 (length str) (list 'face (if color
 269                                                 'chess-display-white-face
 270                                               'chess-display-black-face)) str)
 271                 str)))))
 272     (force-mode-line-update)))
 273
 274 (defsubst chess-display-index (display)
 275   (chess-with-current-buffer display
 276     chess-display-index))
 277
 278 (defun chess-display-update (display &optional popup)
 279   "Update the chessboard DISPLAY.  POPUP too, if that arg is non-nil."
 280   (chess-with-current-buffer display
 281     (funcall chess-display-event-handler 'draw
 282              (chess-display-position nil) chess-display-perspective)
 283     (if (and popup chess-display-popup
 284              (chess-module-leader-p nil))
 285         (chess-display-popup nil))))
 286
 287 (defun chess-display-redraw (&optional display)
 288   "Just redraw the current display."
 289   (interactive)
 290   (chess-with-current-buffer display
 291     (let ((here (point)))
 292       (erase-buffer)
 293       (chess-display-update nil)
 294       (goto-char here))))
 295
 296 (defun chess-display-index-pos (display index)
 297   (chess-with-current-buffer display
 298     (unless chess-display-index-positions
 299       (setq chess-display-index-positions (make-vector 64 nil))
 300       (let ((pos (next-single-property-change (point-min) 'chess-coord))
 301             pos-index)
 302         (while pos
 303           (if (setq pos-index (get-text-property pos 'chess-coord))
 304               (aset chess-display-index-positions pos-index pos))
 305           (setq pos (next-single-property-change pos 'chess-coord)))
 306         (unless (aref chess-display-index-positions 0)
 307           (aset chess-display-index-positions 0
 308                 (if chess-display-perspective
 309                     (point-min)
 310                   (1- (point-max)))))
 311         (unless (aref chess-display-index-positions 63)
 312           (aset chess-display-index-positions 63
 313                 (if chess-display-perspective
 314                     (1- (point-max))
 315                   (point-min))))))
 316     (aref chess-display-index-positions index)))
 317
 318 (defun chess-display-paint-move (display ply)
 319   (chess-with-current-buffer display
 320     (let ((position (chess-ply-pos ply))
 321           (ch (chess-ply-changes ply)))
 322       (while ch
 323         (if (symbolp (car ch))
 324             (setq ch nil)
 325           (let ((from (car ch))
 326                 (to (cadr ch)))
 327             (funcall chess-display-event-handler 'draw-square
 328                      (chess-display-index-pos nil from) ?  from)
 329             (let ((new-piece (chess-ply-keyword ply :promote)))
 330               (if new-piece
 331                   (funcall chess-display-event-handler 'draw-square
 332                            (chess-display-index-pos nil to)
 333                            (if (chess-pos-side-to-move position)
 334                                new-piece
 335                              (downcase new-piece)) to)
 336                 (funcall chess-display-event-handler 'draw-square
 337                          (chess-display-index-pos nil to)
 338                          (chess-pos-piece position from) to)))
 339             (when (chess-ply-keyword ply :en-passant)
 340               (funcall chess-display-event-handler 'draw-square
 341                        (chess-display-index-pos nil (chess-pos-en-passant position))
 342                        ?  (chess-pos-en-passant position))))
 343           (setq ch (cddr ch)))))))
 344
 345 (chess-message-catalog 'english
 346   '((not-your-move . "It is not your turn to move")
 347     (game-is-over  . "This game is over")))
 348
 349 (defun chess-display-move (display ply &optional prev-pos pos)
 350   "Move a piece on DISPLAY, by applying the given PLY.
 351 The position of PLY must match the currently displayed position.
 352 If only START is given, it must be in algebraic move notation."
 353   (chess-with-current-buffer display
 354     (if (and (chess-display-active-p)
 355              ;; `active' means we're playing against an engine
 356              (chess-game-data chess-module-game 'active)
 357              (not (eq (chess-game-data chess-module-game 'my-color)
 358                       (chess-game-side-to-move chess-module-game))))
 359         (chess-error 'not-your-move)
 360       (if (and (= chess-display-index
 361                   (chess-game-index chess-module-game))
 362                (chess-game-over-p chess-module-game))
 363           (chess-error 'game-is-over)))
 364     (if (= chess-display-index (chess-game-index chess-module-game))
 365         (let ((chess-display-handling-event t))
 366           (chess-display-paint-move nil ply)
 367           (chess-game-move chess-module-game ply)
 368           (chess-display-set-index* nil (chess-game-index chess-module-game)))
 369       ;; jww (2002-03-28): This should beget a variation within the
 370       ;; game, or alter the game, just as SCID allows
 371       (chess-error 'cannot-yet-add))))
 372
 373 (defun chess-display-highlight (display &rest args)
 374   "Highlight the square at INDEX on the current position.
 375 The given highlighting MODE is used, or the default if the style you
 376 are displaying with doesn't support that mode.  `selected' is a mode
 377 that is supported by most displays, and is the default mode."
 378   (chess-with-current-buffer display
 379     (let ((mode :selected))
 380       (dolist (arg args)
 381         (if (or (symbolp arg) (stringp arg))
 382             (setq mode arg)
 383           (funcall chess-display-event-handler 'highlight arg mode))))))
 384
 385 (defun chess-display-highlight-legal (display pos)
 386   "Highlight all legal move targets from POS."
 387   (chess-with-current-buffer display
 388     (dolist (ply (chess-legal-plies (chess-display-position nil)
 389                                     :index pos))
 390       (chess-display-highlight nil "pale green"
 391                                (chess-ply-target ply)))))
 392
 393 (defun chess-display-highlight-passed-pawns (&optional display)
 394   (interactive)
 395   (mapc
 396    (lambda (index) (chess-display-highlight display index :selected))
 397    (append
 398     (chess-pos-passed-pawns (chess-display-position display) t)
 399     (chess-pos-passed-pawns (chess-display-position display) nil))))
 400
 401 (defun chess-display-popup (display)
 402   "Popup the given DISPLAY, so that it's visible to the user."
 403   (chess-with-current-buffer display
 404     (unless (eq (get-buffer-window (current-buffer))
 405                 (selected-window))
 406       (funcall chess-display-event-handler 'popup))))
 407
 408 (defun chess-display-enable-popup (display)
 409   "Popup the given DISPLAY, so that it's visible to the user."
 410   (chess-with-current-buffer display
 411     (setq chess-display-popup nil)))
 412
 413 (defun chess-display-disable-popup (display)
 414   "Popup the given DISPLAY, so that it's visible to the user."
 415   (chess-with-current-buffer display
 416     (setq chess-display-popup t)))
 417
 418 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 419 ;;
 420 ;; Default window and frame popup functions
 421 ;;
 422
 423 (defun chess-display-popup-in-window ()
 424   "Popup the given DISPLAY, so that it's visible to the user."
 425   (unless (get-buffer-window (current-buffer))
 426     (if (> (length (window-list)) 1)
 427         (fit-window-to-buffer (display-buffer (current-buffer)))
 428       (display-buffer (current-buffer)))))
 429
 430 (defun chess-display-popup-in-frame (height width &optional
 431                                             display no-minibuffer)
 432   "Popup the given DISPLAY, so that it's visible to the user."
 433   (let ((window (get-buffer-window (current-buffer) t)))
 434     (if window
 435         (let ((frame (window-frame window)))
 436           (unless (eq frame (selected-frame))
 437             (raise-frame frame)))
 438       (let ((params (list (cons 'name "*Chessboard*")
 439                           (cons 'height height)
 440                           (cons 'width width))))
 441         (if display
 442             (push (cons 'display display) params))
 443         (if no-minibuffer
 444             (push (cons 'minibuffer nil) params))
 445         (select-frame (make-frame params))
 446         (set-window-dedicated-p (selected-window) t)))))
 447
 448 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 449 ;;
 450 ;; Event handler
 451 ;;
 452
 453 (defcustom chess-display-interesting-events
 454   '(set-index)
 455   "Events which will cause a display refresh."
 456   :type '(repeat symbol)
 457   :group 'chess-display)
 458
 459 (defcustom chess-display-momentous-events
 460   '(orient post-undo setup-game pass move resign abort)
 461   "Events that will refresh, and cause 'main' displays to popup.
 462 These are displays for which `chess-display-set-main' has been
 463 called."
 464   :type '(repeat symbol)
 465   :group 'chess-display)
 466
 467 (defun chess-display-handler (game event &rest args)
 468   "This display module presents a standard chessboard.
 469 See `chess-display-type' for the different kinds of displays."
 470   (unless chess-display-handling-event
 471     (if (eq event 'initialize)
 472         (progn
 473           (chess-display-mode)
 474           (setq chess-display-index (chess-game-index game)
 475                 chess-display-side-to-move
 476                 (if (chess-pos-side-to-move (chess-game-pos game))
 477                     (chess-string 'mode-white)
 478                   (chess-string 'mode-black))
 479                 chess-display-move-text (chess-string 'mode-start)
 480                 chess-display-perspective (car args)
 481                 chess-display-event-handler
 482                 (intern-soft (concat (symbol-name chess-display-style)
 483                                      "-handler")))
 484           (and chess-display-event-handler
 485                (funcall chess-display-event-handler 'initialize)))
 486       (cond
 487        ((eq event 'pass)
 488         (let ((my-color (chess-game-data game 'my-color)))
 489           (chess-game-set-data game 'my-color (not my-color))
 490           (chess-display-set-perspective* nil (not my-color))))
 491
 492        ((eq event 'set-index)
 493         (chess-display-set-index* nil (car args)))
 494
 495        ((eq event 'orient)
 496         (let ((my-color (chess-game-data game 'my-color)))
 497           ;; Set the display's perspective to whichever color I'm
 498           ;; playing
 499           (chess-display-set-perspective* nil my-color))))
 500
 501       (if (memq event chess-display-momentous-events)
 502           (progn
 503             (chess-display-set-index* nil (chess-game-index game))
 504             (if (eq event 'move)
 505                 (progn
 506                   (chess-display-paint-move nil (car args))
 507                   (if chess-display-popup
 508                       (chess-display-popup nil)))
 509               (chess-display-update nil chess-display-popup)))
 510         (if (memq event chess-display-interesting-events)
 511             (chess-display-update nil))))))
 512
 513 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 514 ;;
 515 ;; chess-display-mode
 516 ;;
 517
 518 (defvar chess-display-safe-map
 519   (let ((map (make-keymap)))
 520     (suppress-keymap map)
 521     (set-keymap-parent map nil)
 522
 523     (define-key map [(control ?i)] 'chess-display-invert)
 524     (define-key map [tab] 'chess-display-invert)
 525
 526     (define-key map [??] 'describe-mode)
 527     (define-key map [?L] 'chess-display-list-buffers)
 528     ;;(define-key map [?C] 'chess-display-duplicate)
 529     (define-key map [?I] 'chess-display-invert)
 530
 531     (define-key map [?<] 'chess-display-move-first)
 532     (define-key map [?,] 'chess-display-move-backward)
 533     (define-key map [(meta ?<)] 'chess-display-move-first)
 534     (define-key map [?>] 'chess-display-move-last)
 535     (define-key map [?.] 'chess-display-move-forward)
 536     (define-key map [(meta ?>)] 'chess-display-move-last)
 537
 538     (define-key map [(meta ?w)] 'chess-display-kill-board)
 539
 540     (define-key map [(control ?l)] 'chess-display-redraw)
 541
 542     map)
 543   "The mode map used in read-only display buffers.")
 544
 545 (defvar chess-display-mode-map
 546   (let ((map (copy-keymap chess-display-safe-map)))
 547     (define-key map [space] 'chess-display-pass)
 548     (define-key map [? ] 'chess-display-pass)
 549     (define-key map [??] 'describe-mode)
 550     (define-key map [?@] 'chess-display-remote)
 551     (define-key map [?A] 'chess-display-manual-move)
 552     (define-key map [(control ?c) (control ?a)] 'chess-display-abort)
 553     (define-key map [?C] 'chess-display-duplicate)
 554     (define-key map [?D] 'chess-display-decline)
 555     (define-key map [(control ?c) (control ?c)] 'chess-display-force)
 556     (define-key map [(control ?c) (control ?d)] 'chess-display-draw)
 557     (define-key map [?E] 'chess-display-edit-board)
 558     (define-key map [?F] 'chess-display-set-from-fen)
 559     (define-key map [(control ?c) (control ?f)] 'chess-display-call-flag)
 560     (define-key map [?M] 'chess-display-match)
 561     (define-key map [(control ?c) (control ?r)] 'chess-display-resign)
 562     (define-key map [?R] 'chess-display-retract)
 563     (define-key map [?S] 'chess-display-shuffle)
 564     (define-key map [(control ?c) (control ?t)] 'chess-display-undo)
 565     (define-key map [?X] 'chess-display-quit)
 566     (define-key map [?Y] 'chess-display-accept)
 567
 568     (define-key map [?\{] 'chess-display-annotate)
 569     (define-key map [?\"] 'chess-display-chat)
 570     (define-key map [?\'] 'chess-display-chat)
 571     (define-key map [?\~] 'chess-display-check-autosave)
 572
 573     (define-key map [(control ?r)] 'chess-display-search-backward)
 574     (define-key map [(control ?s)] 'chess-display-search-forward)
 575     (define-key map [(control ?y)] 'chess-display-yank-board)
 576
 577     (dolist (key '(?a ?b ?c ?d ?e ?f ?g ?h
 578                    ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8
 579                    ?r ?n ?b ?q ?k
 580                    ?R ?N ?B ?Q ?K
 581                    ?o ?O ?x))
 582       (define-key map (vector key) 'chess-input-shortcut))
 583     (define-key map [backspace] 'chess-input-shortcut-delete)
 584
 585     (define-key map [(control ?m)] 'chess-display-select-piece)
 586     (define-key map [return] 'chess-display-select-piece)
 587     (cond
 588      ((featurep 'xemacs)
 589       (define-key map [(button1)] 'chess-display-mouse-select-piece)
 590       (define-key map [(button2)] 'chess-display-mouse-select-piece)
 591       (define-key map [(button3)] 'ignore))
 592      (t
 593       (define-key map [down-mouse-1] 'chess-display-mouse-select-piece)
 594       (define-key map [drag-mouse-1] 'chess-display-mouse-select-piece)
 595
 596       (define-key map [down-mouse-2] 'chess-display-mouse-select-piece)
 597       (define-key map [drag-mouse-2] 'chess-display-mouse-select-piece)
 598
 599       (define-key map [mouse-3] 'ignore)))
 600
 601     (define-key map [menu-bar files] 'undefined)
 602     (define-key map [menu-bar edit] 'undefined)
 603     (define-key map [menu-bar options] 'undefined)
 604     (define-key map [menu-bar buffer] 'undefined)
 605     (define-key map [menu-bar tools] 'undefined)
 606     (define-key map [menu-bar help-menu] 'undefined)
 607
 608     map)
 609   "The mode map used in a chessboard display buffer.")
 610
 611 (defvar chess-display-move-menu nil)
 612 (unless chess-display-move-menu
 613   (easy-menu-define
 614     chess-display-move-menu chess-display-mode-map ""
 615     '("History"
 616       ["First" chess-display-move-first t]
 617       ["Previous" chess-display-move-backward t]
 618       ["Next" chess-display-move-forward t]
 619       ["Last" chess-display-move-last t])))
 620
 621 (defun chess-display-mode ()
 622   "A mode for displaying and interacting with a chessboard.
 623 The key bindings available in this mode are:
 624 \\{chess-display-mode-map}"
 625   (interactive)
 626   (setq major-mode 'chess-display-mode
 627         mode-name "Chessboard")
 628   (use-local-map chess-display-mode-map)
 629   (buffer-disable-undo)
 630   (setq buffer-auto-save-file-name nil
 631         mode-line-format chess-display-mode-line-format)
 632   (setq chess-input-position-function
 633         (function
 634          (lambda ()
 635            (chess-display-position nil))))
 636   (setq chess-input-move-function 'chess-display-move))
 637
 638 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 639 ;;
 640 ;; Commands used by the keyboard bindings above
 641 ;;
 642
 643 (defsubst chess-display-active-p ()
 644   "Return non-nil if the displayed chessboard reflects an active game.
 645 Basically, it means we are playing, not editing or reviewing."
 646   (and (chess-game-data chess-module-game 'active)
 647        (= chess-display-index
 648           (chess-game-index chess-module-game))
 649        (not (chess-game-over-p chess-module-game))
 650        (not chess-display-edit-mode)))
 651
 652 (defun chess-display-invert ()
 653   "Invert the perspective of the current chess board."
 654   (interactive)
 655   (chess-display-set-perspective nil (not chess-display-perspective)))
 656
 657 (defun chess-display-set-from-fen (fen)
 658   "Send the current board configuration to the user."
 659   (interactive "sSet from FEN string: ")
 660   (chess-display-set-position nil (chess-fen-to-pos fen)))
 661
 662 (defun chess-display-kill-board (&optional arg)
 663   "Send the current board configuration to the user."
 664   (interactive "P")
 665   (let ((x-select-enable-clipboard t)
 666         (game chess-module-game))
 667     (if arg
 668         (kill-new (with-temp-buffer
 669                     (chess-game-to-pgn game)
 670                     (buffer-string)))
 671       (kill-new (chess-pos-to-fen (chess-display-position nil))))))
 672
 673 (defun chess-display-yank-board ()
 674   "Send the current board configuration to the user."
 675   (interactive)
 676   (let ((x-select-enable-clipboard t)
 677         (display (current-buffer))
 678         (text (current-kill 0)))
 679     (with-temp-buffer
 680       (insert text)
 681       (goto-char (point-max))
 682       (while (and (bolp) (not (bobp)))
 683         (delete-backward-char 1))
 684       (goto-char (point-min))
 685       (cond
 686        ((search-forward "[Event " nil t)
 687         (goto-char (match-beginning 0))
 688         (chess-game-copy-game chess-module-game (chess-pgn-to-game)))
 689        ((looking-at (concat chess-algebraic-regexp "$"))
 690         (let ((move (buffer-string)))
 691           (with-current-buffer display
 692             (chess-display-manual-move move))))
 693        (t
 694         (with-current-buffer display
 695           (chess-display-set-from-fen (buffer-string))))))))
 696
 697 (defvar chess-display-search-map
 698   (let ((map (copy-keymap minibuffer-local-map)))
 699     (dolist (key '(?a ?b ?c ?d ?e ?f ?g ?h
 700                       ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8
 701                       ?r ?n ?b ?q ?k
 702                       ?R ?N ?B ?Q ?K
 703                       ?o ?O ?x))
 704       (define-key map (vector key) 'chess-display-search-key))
 705     (define-key map [backspace] 'chess-display-search-delete)
 706     (define-key map [delete] 'chess-display-search-delete)
 707     (define-key map [(control ?h)] 'chess-display-search-delete)
 708     (define-key map [(control ?r)] 'chess-display-search-again)
 709     (define-key map [(control ?s)] 'chess-display-search-again)
 710     map))
 711
 712 (defvar chess-display-search-direction nil)
 713 (defvar chess-current-display nil)
 714 (defvar chess-display-previous-index nil)
 715
 716 (make-variable-buffer-local 'chess-display-previous-index)
 717
 718 (chess-message-catalog 'english
 719   '((san-not-found . "Could not find a matching move")))
 720
 721 (defun chess-display-search (&optional reset again)
 722   (interactive)
 723   (let ((str (concat "\\`" (minibuffer-contents)))
 724         limit index)
 725     (with-current-buffer chess-current-display
 726       (setq index (if reset
 727                       chess-display-previous-index
 728                     chess-display-index))
 729       (if again
 730           (setq index (if chess-display-search-direction
 731                           (1+ index)
 732                         (- index 2))))
 733       (catch 'found
 734         (while (if chess-display-search-direction
 735                    (< index (or limit
 736                                 (setq limit
 737                                       (chess-game-index chess-module-game))))
 738                  (>= index 0))
 739           (let* ((ply (chess-game-ply chess-module-game index))
 740                  (san (chess-ply-keyword ply :san))
 741                  (case-fold-search t))
 742             (when (and san (string-match str san))
 743               (chess-display-set-index nil (1+ index))
 744               (throw 'found t)))
 745           (setq index (funcall (if chess-display-search-direction '1+ '1-)
 746                                index)))
 747         (chess-error 'san-not-found)))))
 748
 749 (defun chess-display-search-again ()
 750   (interactive)
 751   (chess-display-search nil t))
 752
 753 (defun chess-display-search-key ()
 754   (interactive)
 755   (call-interactively 'self-insert-command)
 756   (chess-display-search))
 757
 758 (defun chess-display-search-delete ()
 759   (interactive)
 760   (call-interactively 'delete-backward-char)
 761   (chess-display-search t))
 762
 763 (defun chess-display-search-backward (&optional direction)
 764   (interactive)
 765   (setq chess-display-previous-index chess-display-index)
 766   (condition-case err
 767       (let ((chess-display-search-direction direction)
 768             (chess-current-display (current-buffer)))
 769         (read-from-minibuffer "Find algebraic move: " nil
 770                               chess-display-search-map))
 771     (quit
 772      (chess-display-set-index nil chess-display-previous-index))))
 773
 774 (defun chess-display-search-forward ()
 775   (interactive)
 776   (chess-display-search-backward t))
 777
 778 (chess-message-catalog 'english
 779   '((illegal-notation . "Illegal move notation: %s")
 780     (want-to-quit     . "Do you really want to quit? ")))
 781
 782 (defun chess-display-quit ()
 783   "Quit the game associated with the current display."
 784   (interactive)
 785   (if (or (not (chess-module-leader-p nil))
 786           (yes-or-no-p (chess-string 'want-to-quit)))
 787       (chess-module-destroy nil)))
 788
 789 (defun chess-display-annotate ()
 790   (interactive)
 791   (chess-game-run-hooks chess-module-game 'switch-to-annotations))
 792
 793 (defun chess-display-chat ()
 794   (interactive)
 795   (chess-game-run-hooks chess-module-game 'switch-to-chat))
 796
 797 (defun chess-display-manual-move (move)
 798   "Move a piece manually, using chess notation."
 799   (interactive
 800    (list (read-string
 801           (format "%s(%d): "
 802                   (if (chess-pos-side-to-move (chess-display-position nil))
 803                       "White" "Black")
 804                   (1+ (/ (or chess-display-index 0) 2))))))
 805   (let ((ply (chess-algebraic-to-ply (chess-display-position nil) move)))
 806     (unless ply
 807       (chess-error 'illegal-notation move))
 808     (chess-display-move nil ply)))
 809
 810 (defun chess-display-remote (display)
 811   (interactive "sDisplay this game on X server: ")
 812   (require 'chess-images)
 813   (let ((chess-images-separate-frame display))
 814     (chess-display-clone (current-buffer) 'chess-images
 815                          chess-display-perspective)))
 816
 817 (defun chess-display-duplicate (style)
 818   (interactive
 819    (list (concat "chess-"
 820                  (read-from-minibuffer "Create new display using style: "))))
 821   (chess-display-clone (current-buffer) (intern-soft style)
 822                        chess-display-perspective))
 823
 824 (defun chess-display-pass ()
 825   "Pass the move to your opponent.  Only valid on the first move."
 826   (interactive)
 827   (if (chess-display-active-p)
 828       (chess-game-run-hooks chess-module-game 'pass)
 829     (ding)))
 830
 831 (defun chess-display-shuffle ()
 832   "Generate a shuffled opening position."
 833   (interactive)
 834   (require 'chess-random)
 835   (if (and (chess-display-active-p)
 836            (= 0 chess-display-index))
 837       (chess-game-set-start-position chess-module-game
 838                                      (chess-fischer-random-position))
 839     (ding)))
 840
 841 (defun chess-display-match ()
 842   "Request a match with any listening engine."
 843   (interactive)
 844   (chess-game-run-hooks chess-module-game 'match))
 845
 846 (defun chess-display-accept ()
 847   (interactive)
 848   (if (chess-display-active-p)
 849       (chess-game-run-hooks chess-module-game 'accept)
 850     (ding)))
 851
 852 (defun chess-display-decline ()
 853   (interactive)
 854   (if (chess-display-active-p)
 855       (chess-game-run-hooks chess-module-game 'decline)
 856     (ding)))
 857
 858 (defun chess-display-retract ()
 859   (interactive)
 860   (if (chess-display-active-p)
 861       (chess-game-run-hooks chess-module-game 'retract)
 862     (ding)))
 863
 864 (defun chess-display-call-flag ()
 865   (interactive)
 866   (if (chess-display-active-p)
 867       (chess-game-run-hooks chess-module-game 'call-flag)
 868     (ding)))
 869
 870 (defun chess-display-force ()
 871   (interactive)
 872   (if (chess-display-active-p)
 873       (chess-game-run-hooks chess-module-game 'force)
 874     (ding)))
 875
 876 (defun chess-display-check-autosave ()
 877   (interactive)
 878   (if (chess-display-active-p)
 879       (chess-game-run-hooks chess-module-game 'check-autosave)
 880     (ding)))
 881
 882 (defun chess-display-resign ()
 883   "Resign the current game."
 884   (interactive)
 885   (if (chess-display-active-p)
 886       (chess-game-end chess-module-game :resign)
 887     (ding)))
 888
 889 (defun chess-display-abort ()
 890   "Abort the current game."
 891   (interactive)
 892   (if (chess-display-active-p)
 893       (chess-game-run-hooks chess-module-game 'abort)
 894     (ding)))
 895
 896 (chess-message-catalog 'english
 897   '((draw-offer . "You offer a draw")))
 898
 899 (defun chess-display-draw ()
 900   "Offer to draw the current game."
 901   (interactive)
 902   (if (chess-display-active-p)
 903       (progn
 904         (chess-message 'draw-offer)
 905         (chess-game-run-hooks chess-module-game 'draw))
 906     (ding)))
 907
 908 (defun chess-display-undo (count)
 909   "Abort the current game."
 910   (interactive "P")
 911   (if (chess-display-active-p)
 912       (progn
 913         ;; we can't call `chess-game-undo' directly, because not all
 914         ;; engines will accept it right away!  So we just signal the
 915         ;; desire to undo
 916         (setq count
 917               (if count
 918                   (prefix-numeric-value count)
 919                 (if (eq (chess-pos-side-to-move (chess-display-position nil))
 920                         (chess-game-data chess-module-game 'my-color))
 921                     2 1)))
 922         (chess-game-run-hooks chess-module-game 'undo count))
 923     (ding)))
 924
 925 (defun chess-display-list-buffers ()
 926   "List all buffers related to this display's current game."
 927   (interactive)
 928   (let ((buffer-list-func (symbol-function 'buffer-list)))
 929     (unwind-protect
 930         (let ((chess-game chess-module-game)
 931               (lb-command (lookup-key ctl-x-map [(control ?b)]))
 932               (ibuffer-maybe-show-regexps nil))
 933           (fset 'buffer-list
 934                 (function
 935                  (lambda ()
 936                    (delq nil
 937                          (mapcar (function
 938                                   (lambda (cell)
 939                                     (and (bufferp (cdr cell))
 940                                          (buffer-live-p (cdr cell))
 941                                          (cdr cell))))
 942                                  (chess-game-hooks chess-game))))))
 943           (call-interactively lb-command))
 944       (fset 'buffer-list buffer-list-func))))
 945
 946 (chess-message-catalog 'english
 947   '((return-to-current . "Use '>' to return to the current position")))
 948
 949 (defun chess-display-set-current (dir)
 950   "Change the currently displayed board.
 951 Direction may be - or +, to move forward or back, or t or nil to jump
 952 to the end or beginning."
 953   (let ((index (cond ((eq dir ?-) (1- chess-display-index))
 954                      ((eq dir ?+) (1+ chess-display-index))
 955                      ((eq dir t) nil)
 956                      ((eq dir nil) 0))))
 957     (chess-display-set-index
 958      nil (or index (chess-game-index chess-module-game)))
 959     (unless (chess-display-active-p)
 960       (chess-message 'return-to-current))))
 961
 962 (defun chess-display-move-backward ()
 963   (interactive)
 964   (chess-display-set-current ?-))
 965
 966 (defun chess-display-move-forward ()
 967   (interactive)
 968   (chess-display-set-current ?+))
 969
 970 (defun chess-display-move-first ()
 971   (interactive)
 972   (chess-display-set-current nil))
 973
 974 (defun chess-display-move-last ()
 975   (interactive)
 976   (chess-display-set-current t))
 977
 978 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 979 ;;
 980 ;; chess-display-edit-mode (for editing the position directly)
 981 ;;
 982
 983 (defvar chess-display-edit-position nil)
 984
 985 (make-variable-buffer-local 'chess-display-edit-position)
 986
 987 (defvar chess-display-edit-mode-map
 988   (let ((map (make-keymap)))
 989     (suppress-keymap map)
 990
 991     (define-key map [(control ?l)] 'chess-display-redraw)
 992     (define-key map [(control ?i)] 'chess-display-invert)
 993     (define-key map [tab] 'chess-display-invert)
 994
 995     (define-key map [??] 'describe-mode)
 996     (define-key map [?L] 'chess-display-list-buffers)
 997     ;;(define-key map [?C] 'chess-display-duplicate)
 998     (define-key map [?I] 'chess-display-invert)
 999
1000     (define-key map [?C] 'chess-display-clear-board)
1001     (define-key map [?G] 'chess-display-restore-board)
1002     (define-key map [?S] 'chess-display-send-board)
1003     (define-key map [?X] 'chess-display-quit)
1004
1005     (let ((keys '(?  ?p ?r ?n ?b ?q ?k ?P ?R ?N ?B ?Q ?K)))
1006       (while keys
1007         (define-key map (vector (car keys)) 'chess-display-set-piece)
1008         (setq keys (cdr keys))))
1009
1010     (cond
1011      ((featurep 'xemacs)
1012       (define-key map [(button1)] 'chess-display-mouse-select-piece)
1013       (define-key map [(button2)] 'chess-display-mouse-set-piece)
1014       (define-key map [(button3)] 'chess-display-mouse-set-piece))
1015      (t
1016       (define-key map [down-mouse-1] 'chess-display-mouse-select-piece)
1017       (define-key map [drag-mouse-1] 'chess-display-mouse-select-piece)
1018
1019       (define-key map [mouse-2] 'chess-display-mouse-set-piece)
1020       (define-key map [down-mouse-2] 'chess-display-mouse-set-piece)
1021       (define-key map [mouse-3] 'chess-display-mouse-set-piece)
1022       (define-key map [down-mouse-3] 'chess-display-mouse-set-piece)))
1023
1024     map)
1025   "The mode map used for editing a chessboard position.")
1026
1027 (chess-message-catalog 'english
1028   '((editing-directly
1029      . "Now editing position directly, use S when complete...")
1030     (clear-chessboard-q . "Really clear the chessboard? ")))
1031
1032 (defun chess-display-edit-board ()
1033   "Setup the current board for editing."
1034   (interactive)
1035   (setq chess-display-edit-position
1036         (chess-pos-copy (chess-display-position nil))
1037         chess-display-edit-mode t
1038         chess-display-side-to-move (chess-string 'mode-edit))
1039   (force-mode-line-update)
1040   (use-local-map chess-display-edit-mode-map)
1041   (funcall chess-display-event-handler 'start-edit)
1042   (chess-message 'editing-directly))
1043
1044 (defun chess-display-end-edit-mode ()
1045   (setq chess-display-edit-mode nil)
1046   (funcall chess-display-event-handler 'end-edit)
1047   (use-local-map chess-display-mode-map))
1048
1049 (defun chess-display-send-board ()
1050   "Send the current board configuration to the user."
1051   (interactive)
1052   (chess-display-end-edit-mode)
1053   (chess-game-set-start-position chess-module-game
1054                                  chess-display-edit-position))
1055
1056 (defun chess-display-restore-board ()
1057   "Setup the current board for editing."
1058   (interactive)
1059   (chess-display-end-edit-mode)
1060   ;; reset the modeline
1061   (chess-display-set-index* nil chess-display-index)
1062   (chess-display-update nil))
1063
1064 (defun chess-display-clear-board ()
1065   "Setup the current board for editing."
1066   (interactive)
1067   (when (y-or-n-p (chess-string 'clear-chessboard-q))
1068     (let ((position (chess-display-position nil)))
1069       (dotimes (rank 8)
1070         (dotimes (file 8)
1071           (chess-pos-set-piece position (cons rank file) ? ))))
1072     (chess-display-update nil)))
1073
1074 (defun chess-display-set-piece (&optional piece)
1075   "Set the piece under point to command character, or space for clear."
1076   (interactive)
1077   (if (or (null piece) (char-valid-p piece))
1078       (let ((index (get-text-property (point) 'chess-coord)))
1079         (chess-pos-set-piece chess-display-edit-position index
1080                              (or piece last-command-char))
1081         (funcall chess-display-event-handler 'draw-square
1082                  (point) (or piece last-command-char) index))))
1083
1084 (defun chess-display-mouse-set-piece (event)
1085   "Select the piece the user clicked on."
1086   (interactive "e")
1087   (if (fboundp 'event-window)           ; XEmacs
1088       (progn
1089         (set-buffer (window-buffer (event-window event)))
1090         (and (event-point event) (goto-char (event-point event))))
1091     (set-buffer (window-buffer (posn-window (event-start event))))
1092     (goto-char (posn-point (event-start event))))
1093   (let ((pieces (if (memq (car event) '(down-mouse-3 mouse-3))
1094                     '("Set black piece"
1095                       ("Pieces"
1096                        ("Pawn"   . ?p)
1097                        ("Knight" . ?n)
1098                        ("Bishop" . ?b)
1099                        ("Queen"  . ?q)
1100                        ("King"   . ?k)))
1101                   '("Set white piece"
1102                     ("Pieces"
1103                      ("Pawn"   . ?P)
1104                      ("Knight" . ?N)
1105                      ("Bishop" . ?B)
1106                      ("Queen"  . ?Q)
1107                      ("King"   . ?K))))))
1108     (chess-display-set-piece (x-popup-menu t pieces))))
1109
1110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1111 ;;
1112 ;; Mousing around on the chess-display
1113 ;;
1114
1115 (defvar chess-display-last-selected nil)
1116
1117 (make-variable-buffer-local 'chess-display-last-selected)
1118
1119 (chess-message-catalog 'english
1120   '((cannot-mount   . "You cannot move pieces on top of each other")
1121     (move-not-legal . "That is not a legal move")
1122     (not-your-move  . "It is not your turn to move")
1123     (wrong-color    . "You cannot move your opponent's pieces")
1124     (selected-empty . "You cannot select an empty square")
1125     (piece-immobile . "That piece cannot move now")))
1126
1127 (defun chess-display-select-piece ()
1128   "Select the piece under the cursor.
1129 Clicking once on a piece selects it; then click on the target location."
1130   (interactive)
1131   (let ((coord (get-text-property (point) 'chess-coord))
1132         (position (chess-display-position nil))
1133         message)
1134     (when coord
1135       (setq message
1136             (catch 'message
1137               (if chess-display-last-selected
1138                   (let ((last-sel chess-display-last-selected))
1139                     ;; if they select the same square again, just deselect
1140                     ;; it by redrawing the display and removing all
1141                     ;; highlights
1142                     (if (= (point) (car last-sel))
1143                         (funcall chess-display-event-handler 'draw-square
1144                                  (car last-sel)
1145                                  (chess-pos-piece position (cdr last-sel))
1146                                  (cdr last-sel))
1147                       (let ((s-piece (chess-pos-piece position (cdr last-sel)))
1148                             (t-piece (chess-pos-piece position coord)) ply)
1149                         (if chess-display-edit-mode
1150                             (progn
1151                               (chess-pos-set-piece position (cdr last-sel) ? )
1152                               (chess-pos-set-piece position coord s-piece)
1153                               (chess-display-update nil))
1154                           (if (and (/= t-piece ? )
1155                                    (or (and (< t-piece ?a)
1156                                             (< s-piece ?a))
1157                                        (and (> t-piece ?a)
1158                                             (> s-piece ?a))))
1159                               (throw 'message (chess-string 'cannot-mount)))
1160                           (unless (setq ply (chess-ply-create position nil
1161                                                               (cdr last-sel)
1162                                                               coord))
1163                             (throw 'message (chess-string 'move-not-legal)))
1164                           (condition-case err
1165                               (chess-display-move nil ply
1166                                                   (car last-sel) (point))
1167                             (error
1168                              (throw 'message (error-message-string err)))))))
1169                     (setq chess-display-last-selected nil))
1170                 (let ((piece (chess-pos-piece position coord)))
1171                   (cond
1172                    ((eq piece ? )
1173                     (throw 'message (chess-string 'selected-empty)))
1174                    ((not (or chess-display-edit-mode
1175                              (not (chess-display-active-p))
1176                              (eq (chess-pos-side-to-move position)
1177                                  (chess-game-data chess-module-game
1178                                                   'my-color))))
1179                     (throw 'message (chess-string 'not-your-move)))
1180                    ((and (not chess-display-edit-mode)
1181                          (if (chess-pos-side-to-move position)
1182                              (> piece ?a)
1183                            (< piece ?a)))
1184                     (throw 'message (chess-string 'wrong-color)))
1185                    ((and (not chess-display-edit-mode)
1186                          chess-display-highlight-legal
1187                          (null (chess-legal-plies position :any :index coord)))
1188                     (throw 'message (chess-string 'piece-immobile))))
1189                   (setq chess-display-last-selected (cons (point) coord))
1190                   (chess-display-highlight nil coord)
1191                   (if (and (not chess-display-edit-mode)
1192                            chess-display-highlight-legal)
1193                       (chess-display-highlight-legal nil coord))))))
1194       (when message
1195         (when chess-display-last-selected
1196           (funcall chess-display-event-handler 'draw-square
1197                    (car chess-display-last-selected)
1198                    (chess-pos-piece position
1199                                     (cdr chess-display-last-selected))
1200                    (cdr chess-display-last-selected))
1201           (setq chess-display-last-selected nil))
1202         (message message)))))
1203
1204 (defun chess-display-mouse-select-piece (event)
1205   "Select the piece the user clicked on."
1206   (interactive "e")
1207   (if (fboundp 'event-window)           ; XEmacs
1208       (progn
1209         (set-buffer (window-buffer (event-window event)))
1210         (and (event-point event) (goto-char (event-point event))))
1211     (if (equal (event-start event) (event-end event))
1212         (progn
1213           (set-buffer (window-buffer (posn-window (event-start event))))
1214           (goto-char (posn-point (event-start event))))
1215       (goto-char (posn-point (event-end event)))))
1216   (chess-display-select-piece))
1217
1218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1219 ;;
1220 ;; Maintain a face cache for given color strings
1221 ;;
1222
1223 (defvar chess-display-face-cache '((t . t)))
1224
1225 (defun chess-display-get-face (color)
1226   (or (cdr (assoc color chess-display-face-cache))
1227       (let ((face (make-face 'chess-display-highlight)))
1228         (set-face-attribute face nil :background color)
1229         (add-to-list 'chess-display-face-cache (cons color face))
1230         face)))
1231
1232 (provide 'chess-display)
1233
1234 ;;; chess-display.el ends here