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

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