;; Code shared by all chess displays
;;
+(require 'chess-message)
(require 'chess-module)
(require 'chess-var)
(require 'chess-input)
+(require 'chess-random)
(defgroup chess-display nil
"Common code used by chess displays."
:group 'chess)
(defcustom chess-display-popup t
- "If non-nil, popup displays whenever a significant event occurs."
+ "If non-nil (the default), popup displays whenever a significant event
+occurs."
:type 'boolean
:group 'chess-display)
+(make-variable-buffer-local 'chess-display-popup)
+
(defcustom chess-display-highlight-legal nil
"If non-nil, highlight legal target squares when a piece is selected."
:type 'boolean
(mode-black . "Black")
(mode-start . "START")
(mode-checkmate . "CHECKMATE")
+ (mode-aborted . "ABORTED")
(mode-resigned . "RESIGNED")
(mode-stalemate . "STALEMATE")
+ (mode-flag-fell . "FLAG FELL")
(mode-drawn . "DRAWN")
(mode-edit . "EDIT")))
(defcustom chess-display-mode-line-format
- '(" " chess-display-side-to-move " "
+ '(" " chess-display-side-to-move " "
chess-display-move-text " "
(:eval (chess-display-clock-string))
"(" (:eval (chess-game-tag chess-module-game "White")) "-"
:type 'sexp
:group 'chess-display)
+(defface chess-display-black-face
+ '((t (:background "Black" :foreground "White")))
+ "*The face used for the word Black in the mode-line."
+ :group 'chess-display)
+
+(defface chess-display-white-face
+ '((t (:background "White" :foreground "Black")))
+ "*The face used for the word White in the mode-line."
+ :group 'chess-display)
+
;;; Code:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar chess-display-side-to-move)
(defvar chess-display-perspective)
(defvar chess-display-event-handler nil)
-(defvar chess-display-no-popup nil)
(defvar chess-display-edit-mode nil)
(defvar chess-display-index-positions nil)
(make-variable-buffer-local 'chess-display-index)
(make-variable-buffer-local 'chess-display-move-text)
(make-variable-buffer-local 'chess-display-side-to-move)
+(put 'chess-display-side-to-move 'risky-local-variable t)
(make-variable-buffer-local 'chess-display-perspective)
(make-variable-buffer-local 'chess-display-event-handler)
-(make-variable-buffer-local 'chess-display-no-popup)
(make-variable-buffer-local 'chess-display-edit-mode)
(make-variable-buffer-local 'chess-display-index-positions)
-(defvar chess-display-handling-event nil)
+(defvar chess-display-handling-event nil
+ "If non-nil, chess-display is already handling the event. This variable
+is used to avoid reentrancy.")
+
(defvar chess-display-style)
(chess-message-catalog 'english
(cannot-yet-add . "Cannot insert moves into a game (yet)")))
(defun chess-display-create (game style perspective)
- "Create a chess display, for displaying chess objects."
+ "Create a chess display, for displaying chess objects.
+Where GAME is the chess game object to use, STYLE should be the display
+type to use (a symbol) and PERSPECTIVE determines the viewpoint
+of the board, if non-nil, the board is viewed from White's perspective."
+ (interactive (list (if current-prefix-arg
+ (chess-game-create (chess-fen-to-pos
+ (read-string "FEN: ")))
+ (chess-game-create))
+ (intern-soft
+ (concat "chess-" (completing-read "Display style: "
+ '(("ics1")
+ ("images")
+ ("plain")))))
+ (y-or-n-p "View from White's perspective? ")))
(if (require style nil t)
- (let ((chess-display-style style))
- (chess-module-create 'chess-display game "*Chessboard*"
- perspective))))
+ (let* ((chess-display-style style)
+ (display (chess-module-create 'chess-display game "*Chessboard*"
+ perspective)))
+ (if (interactive-p)
+ (progn
+ (chess-display-update display)
+ (chess-display-popup display))
+ display))))
(defalias 'chess-display-destroy 'chess-module-destroy)
(defun chess-display-clone (display style perspective)
- (let ((new-display (chess-display-create chess-module-game
+ (let ((new-display (chess-display-create (chess-display-game display)
style perspective)))
;; the display will have already been updated by the `set-' calls,
;; it's just not visible yet
new-display))
(defsubst chess-display-perspective (display)
+ "Return the current perspective of DISPLAY."
(chess-with-current-buffer display
chess-display-perspective))
(erase-buffer))) ; force a complete redraw
(defun chess-display-set-perspective (display perspective)
+ "Set PERSPECTIVE of DISPLAY."
(chess-with-current-buffer display
(chess-display-set-perspective* nil perspective)
(chess-display-update nil)))
(defun chess-display-set-position (display &optional position my-color)
+ "Set the game associated with DISPLAY to use POSITION and MY-COLOR."
(chess-with-current-buffer display
(if position
(progn
(chess-display-set-index nil 0)))
(defun chess-display-position (display)
- "Return the position currently viewed."
+ "Return the position currently viewed on DISPLAY."
(chess-with-current-buffer display
(if chess-display-edit-mode
chess-display-edit-position
(chess-game-ply chess-module-game chess-display-index)))
(defun chess-display-set-variation (display variation &optional index)
- "Set the display variation.
-This will cause the first ply in the variation to be displayed, with
-the user able to scroll back and forth through the moves in the
-variation. Any moves made on the board will extend/change the
+ "Set DISPLAY VARIATION.
+If INDEX is not specified, this will cause the first ply in the variation
+to be displayed, with the user able to scroll back and forth through the
+moves in the variation. Any moves made on the board will extend/change the
variation that was passed in."
(chess-with-current-buffer display
(let ((chess-game-inhibit-events t))
(defun chess-display-clock-string ()
(let ((white (chess-game-data chess-module-game 'white-remaining))
(black (chess-game-data chess-module-game 'black-remaining)))
- (if (not (and white black))
- (let ((last-ply (chess-game-ply chess-module-game
- (1- chess-display-index))))
- (setq white (chess-ply-keyword last-ply :white)
- black (chess-ply-keyword last-ply :black))))
+ (unless (and white black)
+ (let ((last-ply (chess-game-ply chess-module-game
+ (1- chess-display-index))))
+ (setq white (chess-ply-keyword last-ply :white)
+ black (chess-ply-keyword last-ply :black))))
(if (and white black)
(format "W %s%02d:%02d B %s%02d:%02d "
(if (and (< white 0) (= 0 (floor white))) "-" "")
(defun chess-display-set-index (display index)
(chess-with-current-buffer display
- (unless (or (not (integerp index))
- (< index 0)
- (> index (chess-game-index chess-module-game)))
- (chess-game-run-hooks chess-module-game 'set-index index))))
+ (if (not (or (not (integerp index))
+ (< index 0)
+ (> index (chess-game-index chess-module-game))))
+ (chess-game-run-hooks chess-module-game 'set-index index)
+ (when (and (> index (chess-game-index chess-module-game))
+ (not (chess-ply-final-p (chess-game-ply chess-module-game))))
+ (chess-game-run-hooks chess-module-game 'forward)))))
(defun chess-display-set-index* (display index)
(chess-with-current-buffer display
(/ index 2)
(1+ (/ index 2)))
1))
- ". " (and (= 0 (mod index 2)) "... ")
+ "." (and (= 0 (mod index 2)) "..")
(chess-ply-to-algebraic
(chess-game-ply chess-module-game (1- index)))))
chess-display-side-to-move
(let ((status (chess-game-status chess-module-game index)))
(cond
+ ((eq status :aborted) (chess-string 'mode-aborted))
((eq status :resign) (chess-string 'mode-resigned))
- ((eq status :draw) (chess-string 'mode-drawn))
+ ((eq status :drawn) (chess-string 'mode-drawn))
((eq status :checkmate) (chess-string 'mode-checkmate))
((eq status :stalemate) (chess-string 'mode-stalemate))
+ ((eq status :flag-fell) (chess-string 'mode-flag-fell))
(t
- (if (or chess-pos-always-white
- (chess-game-side-to-move chess-module-game index))
- (chess-string 'mode-white)
- (chess-string 'mode-black))))))
+ (let* ((color (or chess-pos-always-white
+ (chess-game-side-to-move chess-module-game
+ index)))
+ (str (format " %s " (if color
+ (chess-string 'mode-white)
+ (chess-string 'mode-black)))))
+ (add-text-properties 0 (length str)
+ (list 'face (if color
+ 'chess-display-white-face
+ 'chess-display-black-face))
+ str)
+ str)))))
(force-mode-line-update)))
(defsubst chess-display-index (display)
"Update the chessboard DISPLAY. POPUP too, if that arg is non-nil."
(chess-with-current-buffer display
(funcall chess-display-event-handler 'draw
- (chess-display-position nil)
- (chess-display-perspective nil))
- (if (and popup (not chess-display-no-popup)
+ (chess-display-position nil) chess-display-perspective)
+ (if (and popup chess-display-popup
(chess-module-leader-p nil))
(chess-display-popup nil))))
(aset chess-display-index-positions pos-index pos))
(setq pos (next-single-property-change pos 'chess-coord)))
(unless (aref chess-display-index-positions 0)
- (aset chess-display-index-positions 0 (point-min)))
+ (aset chess-display-index-positions 0
+ (if chess-display-perspective
+ (point-min)
+ (1- (point-max)))))
(unless (aref chess-display-index-positions 63)
- (aset chess-display-index-positions 63 (1- (point-max))))))
+ (aset chess-display-index-positions 63
+ (if chess-display-perspective
+ (1- (point-max))
+ (point-min))))))
(aref chess-display-index-positions index)))
(defun chess-display-paint-move (display ply)
(downcase new-piece)) to)
(funcall chess-display-event-handler 'draw-square
(chess-display-index-pos nil to)
- (chess-pos-piece position from) to))))
+ (chess-pos-piece position from) to)))
+ (when (chess-ply-keyword ply :en-passant)
+ (funcall chess-display-event-handler 'draw-square
+ (chess-display-index-pos nil (chess-pos-en-passant position))
+ ? (chess-pos-en-passant position))))
(setq ch (cddr ch)))))))
(chess-message-catalog 'english
(chess-error 'game-is-over)))
(if (= chess-display-index (chess-game-index chess-module-game))
(let ((chess-display-handling-event t))
- (chess-display-paint-move nil ply)
(chess-game-move chess-module-game ply)
+ (chess-display-paint-move nil ply)
(chess-display-set-index* nil (chess-game-index chess-module-game)))
;; jww (2002-03-28): This should beget a variation within the
;; game, or alter the game, just as SCID allows
(chess-display-highlight nil "pale green"
(chess-ply-target ply)))))
+(defun chess-display-highlight-passed-pawns (&optional display)
+ (interactive)
+ (mapc
+ (lambda (index) (chess-display-highlight display index :selected))
+ (append
+ (chess-pos-passed-pawns (chess-display-position display) t)
+ (chess-pos-passed-pawns (chess-display-position display) nil))))
+
(defun chess-display-popup (display)
"Popup the given DISPLAY, so that it's visible to the user."
(chess-with-current-buffer display
(defun chess-display-enable-popup (display)
"Popup the given DISPLAY, so that it's visible to the user."
(chess-with-current-buffer display
- (setq chess-display-no-popup nil)))
+ (setq chess-display-popup nil)))
(defun chess-display-disable-popup (display)
"Popup the given DISPLAY, so that it's visible to the user."
(chess-with-current-buffer display
- (setq chess-display-no-popup t)))
+ (setq chess-display-popup t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
(defun chess-display-popup-in-window ()
"Popup the given DISPLAY, so that it's visible to the user."
(unless (get-buffer-window (current-buffer))
- (fit-window-to-buffer (display-buffer (current-buffer)))))
+ (if (> (length (window-list)) 1)
+ (fit-window-to-buffer (display-buffer (current-buffer)))
+ (display-buffer (current-buffer)))))
-(defun chess-display-popup-in-frame (height width &optional
- display no-minibuffer)
+(defun chess-display-popup-in-frame (height width font
+ &optional display no-minibuffer)
"Popup the given DISPLAY, so that it's visible to the user."
(let ((window (get-buffer-window (current-buffer) t)))
(if window
(cons 'width width))))
(if display
(push (cons 'display display) params))
+ (if font
+ (push (cons 'font font) params))
(if no-minibuffer
(push (cons 'minibuffer nil) params))
(select-frame (make-frame params))
:group 'chess-display)
(defcustom chess-display-momentous-events
- '(orient post-undo setup-game pass move resign drawn)
+ '(orient post-undo setup-game pass move resign abort)
"Events that will refresh, and cause 'main' displays to popup.
These are displays for which `chess-display-set-main' has been
called."
(if (eq event 'move)
(progn
(chess-display-paint-move nil (car args))
- (chess-display-popup nil))
- (chess-display-update nil t)))
+ (if chess-display-popup
+ (chess-display-popup nil)))
+ (chess-display-update nil chess-display-popup)))
(if (memq event chess-display-interesting-events)
(chess-display-update nil))))))
(define-key map [(control ?c) (control ?a)] 'chess-display-abort)
(define-key map [?C] 'chess-display-duplicate)
(define-key map [?D] 'chess-display-decline)
+ (define-key map [(control ?c) (control ?c)] 'chess-display-force)
(define-key map [(control ?c) (control ?d)] 'chess-display-draw)
(define-key map [?E] 'chess-display-edit-board)
(define-key map [?F] 'chess-display-set-from-fen)
+ (define-key map [(control ?c) (control ?f)] 'chess-display-call-flag)
(define-key map [?M] 'chess-display-match)
(define-key map [(control ?c) (control ?r)] 'chess-display-resign)
(define-key map [?R] 'chess-display-retract)
(define-key map [?\{] 'chess-display-annotate)
(define-key map [?\"] 'chess-display-chat)
(define-key map [?\'] 'chess-display-chat)
+ (define-key map [?\~] 'chess-display-check-autosave)
(define-key map [(control ?r)] 'chess-display-search-backward)
(define-key map [(control ?s)] 'chess-display-search-forward)
(use-local-map chess-display-mode-map)
(buffer-disable-undo)
(setq buffer-auto-save-file-name nil
- mode-line-format 'chess-display-mode-line-format)
+ mode-line-format chess-display-mode-line-format)
(setq chess-input-position-function
(function
(lambda ()
(defun chess-display-invert ()
"Invert the perspective of the current chess board."
(interactive)
- (chess-display-set-perspective nil (not (chess-display-perspective nil))))
+ (chess-display-set-perspective nil (not chess-display-perspective)))
(defun chess-display-set-from-fen (fen)
"Send the current board configuration to the user."
(defun chess-display-kill-board (&optional arg)
"Send the current board configuration to the user."
(interactive "P")
- (let ((x-select-enable-clipboard t))
+ (let ((x-select-enable-clipboard t)
+ (game chess-module-game))
(if arg
(kill-new (with-temp-buffer
- (chess-game-to-pgn chess-module-game)
+ (chess-game-to-pgn game)
(buffer-string)))
(kill-new (chess-pos-to-fen (chess-display-position nil))))))
(defun chess-display-search-again ()
(interactive)
- (debug)
(chess-display-search nil t))
(defun chess-display-search-key ()
(want-to-quit . "Do you really want to quit? ")))
(defun chess-display-quit ()
+ "Quit the game associated with the current display."
(interactive)
(if (or (not (chess-module-leader-p nil))
(yes-or-no-p (chess-string 'want-to-quit)))
(require 'chess-images)
(let ((chess-images-separate-frame display))
(chess-display-clone (current-buffer) 'chess-images
- (chess-display-perspective nil))))
+ chess-display-perspective)))
(defun chess-display-duplicate (style)
(interactive
(list (concat "chess-"
(read-from-minibuffer "Create new display using style: "))))
(chess-display-clone (current-buffer) (intern-soft style)
- (chess-display-perspective nil)))
+ chess-display-perspective))
(defun chess-display-pass ()
"Pass the move to your opponent. Only valid on the first move."
(chess-game-run-hooks chess-module-game 'retract)
(ding)))
+(defun chess-display-call-flag ()
+ (interactive)
+ (if (chess-display-active-p)
+ (chess-game-run-hooks chess-module-game 'call-flag)
+ (ding)))
+
+(defun chess-display-force ()
+ (interactive)
+ (if (chess-display-active-p)
+ (chess-game-run-hooks chess-module-game 'force)
+ (ding)))
+
+(defun chess-display-check-autosave ()
+ (interactive)
+ (if (chess-display-active-p)
+ (chess-game-run-hooks chess-module-game 'check-autosave)
+ (ding)))
+
(defun chess-display-resign ()
"Resign the current game."
(interactive)
(if (chess-display-active-p)
- (progn
- (chess-game-end chess-module-game :resign)
- (chess-game-run-hooks chess-module-game 'resign))
+ (chess-game-end chess-module-game :resign)
(ding)))
(defun chess-display-abort ()
(chess-message-catalog 'english
'((editing-directly
- . "Now editing position directly, use S when complete...")))
+ . "Now editing position directly, use S when complete...")
+ (clear-chessboard-q . "Really clear the chessboard? ")))
(defun chess-display-edit-board ()
"Setup the current board for editing."
(defun chess-display-clear-board ()
"Setup the current board for editing."
(interactive)
- (when (y-or-n-p "Really clear the chessboard? ")
+ (when (y-or-n-p (chess-string 'clear-chessboard-q))
(let ((position (chess-display-position nil)))
(dotimes (rank 8)
(dotimes (file 8)
(funcall chess-display-event-handler 'draw-square
(point) (or piece last-command-char) index))))
+(unless (fboundp 'event-window)
+ (defalias 'event-point 'ignore))
+
(defun chess-display-mouse-set-piece (event)
"Select the piece the user clicked on."
(interactive "e")
(cdr last-sel)
coord))
(throw 'message (chess-string 'move-not-legal)))
- (chess-display-move nil ply
- (car last-sel) (point)))))
+ (condition-case err
+ (chess-display-move nil ply
+ (car last-sel) (point))
+ (error
+ (throw 'message (error-message-string err)))))))
(setq chess-display-last-selected nil))
(let ((piece (chess-pos-piece position coord)))
(cond
(cdr chess-display-last-selected))
(cdr chess-display-last-selected))
(setq chess-display-last-selected nil))
- (error message)))))
+ (message message)))))
(defun chess-display-mouse-select-piece (event)
"Select the piece the user clicked on."