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

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