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

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