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