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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Chessboard display style using graphical images
   4 ;;
   5
   6 ;;; Commentary:
   7
   8 ;; In addition to what all displays offer, the images display adds a
   9 ;; few commands:
  10 ;;
  11 ;;   ^  increase the size of the display (if larger pieces exist)
  12 ;;   V  decrease the size of the display (if smaller pieces exist)
  13 ;;   D  use pieces from another directory
  14 ;;
  15 ;; When using pieces from another directory, they will be loaded and
  16 ;; displayed immediately, allowing you to easily browse among
  17 ;; different piece sets if you have them (such as the ZIICS set, see
  18 ;; the xboard man page).
  19
  20 (require 'chess-display)
  21
  22 (defgroup chess-images nil
  23   "Module for drawing a chess-display using graphical images."
  24   :group 'chess-display)
  25
  26 (defvar chess-images-cache nil)
  27 (defvar chess-images-size nil)
  28 (defvar chess-images-sizes nil)
  29
  30 (make-variable-buffer-local 'chess-images-cache)
  31 (make-variable-buffer-local 'chess-images-size)
  32 (make-variable-buffer-local 'chess-images-sizes)
  33
  34 (defun chess-images-clear-image-cache (sym value)
  35   (set sym value)
  36   (setq chess-images-cache nil))
  37
  38 (defcustom chess-images-separate-frame (display-multi-frame-p)
  39   "If non-nil, display the chessboard in its own frame."
  40   :type 'boolean
  41   :group 'chess-images)
  42
  43 (defcustom chess-images-directory
  44   (if (file-directory-p "/usr/share/games/xboard/pixmaps")
  45       "/usr/share/games/xboard/pixmaps"
  46     (expand-file-name "pieces/xboard"
  47                       (file-name-directory
  48                        (or load-file-name buffer-file-name))))
  49   "Directory containing the chess piece bitmap images.
  50 You are free to use your own chess pieces, of any size.  By default, I
  51 assume you have xboard installed, or can go get the pixmaps that come
  52 with xboard.  I am not an artist, and have not taken the time to draw
  53 my own set of pieces.
  54
  55 If you want to draw your own images, each piece must be named
  56 COLOR-PIECE.EXT, where COLOR is either black or white, and PIECE is
  57 one of rook, knight, bishop, queen, king or pawn.
  58
  59 At the moment only XPM has been tested, and I'm afraid it's probably
  60 the only one that will work.  ImageMagick can be used to convert other
  61 graphics formats into XPM for you.
  62
  63 Each piece must define the background color to use the symbolic color
  64 name \"background\", so that the chess program can use the same pieces
  65 for all squares.  If you want really custom pieces, you can use the
  66 symbolic colors dark_square, light_square and dark_piece and
  67 light_piece."
  68   :type 'directory
  69   :set 'chess-images-clear-image-cache
  70   :group 'chess-images)
  71
  72 (defcustom chess-images-default-size nil
  73   "The default pixel width to use for chess pieces.
  74 If this width is not available, then next smallest will be chosen.
  75 If there is none smaller, then the best size available will be chosen.
  76 If `chess-images-default-size' is nil (the default), then the best
  77 width for the current display is calculated used."
  78   :type '(choice integer (const :tag "Best fit" nil))
  79   :group 'chess-images)
  80
  81 (defcustom chess-images-background-image "blank"
  82   "The name of the file used for background squares.
  83 This file is optional.  If there is no file available by this name, a
  84 solid color square will be created and used.  This option exists so
  85 that specialized squares may be used such as marble tiles, etc."
  86   :type 'file
  87   :set 'chess-images-clear-image-cache
  88   :group 'chess-images)
  89
  90 (defcustom chess-images-border-color (cdr (assq 'background-color
  91                                                 (frame-parameters)))
  92   "Color to use for the border around pieces."
  93   :type 'color
  94   :set 'chess-images-clear-image-cache
  95   :group 'chess-images)
  96
  97 (defcustom chess-images-dark-color
  98   (if (display-color-p) "#77a26d" "gray60")
  99   "Color to use for \"dark\" background squares."
 100   :type 'color
 101   :set 'chess-images-clear-image-cache
 102   :group 'chess-images)
 103
 104 (defcustom chess-images-light-color
 105   (if (display-color-p) "#c8c365" "gray80")
 106   "Color to use for \"light\" background squares."
 107   :type 'color
 108   :set 'chess-images-clear-image-cache
 109   :group 'chess-images)
 110
 111 (defcustom chess-images-black-color
 112   (if (display-color-p) "#202020" "gray0")
 113   "Color to use for \"black\" pieces."
 114   :type 'color
 115   :set 'chess-images-clear-image-cache
 116   :group 'chess-images)
 117
 118 (defcustom chess-images-white-color
 119   (if (display-color-p) "#ffffcc" "gray100")
 120   "Color to use for \"white\" pieces."
 121   :type 'color
 122   :set 'chess-images-clear-image-cache
 123   :group 'chess-images)
 124
 125 (defcustom chess-images-highlight-color
 126   (if (display-color-p) "#add8e6" "gray90")
 127   "Color to use for highlighting pieces that have been selected."
 128   :type 'color
 129   :set 'chess-images-clear-image-cache
 130   :group 'chess-images)
 131
 132 (defcustom chess-images-extension "xpm"
 133   "The file extension used for chess display bitmaps."
 134   :type 'file
 135   :set 'chess-images-clear-image-cache
 136   :group 'chess-images)
 137
 138 (defcustom chess-images-border-width 2
 139   "This defines the width of the border that surrounds each piece."
 140   :type '(choice integer (const :tag "No border" nil))
 141   :set 'chess-images-clear-image-cache
 142   :group 'chess-images)
 143
 144 (defcustom chess-images-popup-function 'chess-images-popup
 145   "The function used to popup a chess-images display.
 146 The current-buffer is set to the display buffer when this function is
 147 called."
 148   :type 'function
 149   :group 'chess-images)
 150
 151 ;;; Code:
 152
 153 (defconst chess-images-piece-names
 154   '((?r "rook"   0)
 155     (?n "knight" 1)
 156     (?b "bishop" 2)
 157     (?q "queen"  3)
 158     (?k "king"   4)
 159     (?p "pawn"   5))
 160   "The names and index values of the different pieces.")
 161
 162 (chess-message-catalog 'english
 163   '((no-images-fallback . "Could not find any suitable or properly sized chess images")))
 164
 165 (defun chess-images-handler (event &rest args)
 166   (cond
 167    ((eq event 'initialize)
 168     (when (display-graphic-p)
 169       (chess-images-initialize)
 170       (or chess-images-size
 171           (ignore
 172            (chess-message 'no-images-fallback)))))
 173
 174    ((eq event 'popup)
 175     (funcall chess-images-popup-function))
 176
 177    ((eq event 'draw)
 178     (apply 'chess-images-draw args))
 179
 180    ((eq event 'draw-square)
 181     (apply 'chess-images-draw-square args))
 182
 183    ((eq event 'highlight)
 184     (apply 'chess-images-highlight args))
 185
 186    ((eq event 'start-edit)
 187     (setq cursor-type t))
 188
 189    ((eq event 'end-edit)
 190     (setq cursor-type nil))))
 191
 192 (defun chess-images-determine-size ()
 193   (let ((display (and (stringp chess-images-separate-frame)
 194                       chess-images-separate-frame)))
 195     (setq cursor-type nil
 196           chess-images-cache nil
 197           chess-images-size (chess-images-best-size
 198                              (- (if display
 199                                     (x-display-pixel-height display)
 200                                   (display-pixel-height)) 20)
 201                              (- (if display
 202                                     (x-display-pixel-width display)
 203                                   (display-pixel-width)) 20)))))
 204
 205 (defun chess-images-initialize ()
 206   (let ((map (current-local-map)))
 207     (define-key map [?^] 'chess-images-increase-size)
 208     (define-key map [?V] 'chess-images-decrease-size)
 209     (define-key map [?P] 'chess-images-set-directory))
 210   (chess-images-determine-size))
 211
 212 (chess-message-catalog 'english
 213   '((no-images . "Cannot find any piece images; check `chess-images-directory'")))
 214
 215 (defun chess-images-popup ()
 216   (unless chess-images-size
 217     (chess-error 'no-images))
 218   (if chess-images-separate-frame
 219       (let* ((size (float (+ (* (or chess-images-border-width 0) 8)
 220                              (* chess-images-size 8))))
 221              (max-char-height (ceiling (/ size (frame-char-height))))
 222              (max-char-width  (ceiling (/ size (frame-char-width))))
 223              (display (and (stringp chess-images-separate-frame)
 224                            chess-images-separate-frame)))
 225         ;; create the frame whenever necessary
 226         (chess-display-popup-in-frame (+ max-char-height 2)
 227                                       max-char-width))
 228     (chess-display-popup-in-window)))
 229
 230 (defun chess-images-piece-image (piece rank file)
 231   "Return the image used for PIECE at RANK and FILE.
 232 Rank and file are important because the colors of the squares on the
 233 chess board are light or dark depending on location."
 234   (let ((square-color (% (+ file rank) 2))) ; 0 is white
 235     (if (= piece ? )
 236         (aref chess-images-cache (- 3 square-color))
 237       (aref (aref (aref chess-images-cache
 238                         (if (> piece ?a) 0 1))
 239                   (if (= square-color 0) 1 0))
 240             (nth 2 (assq (downcase piece)
 241                          chess-images-piece-names))))))
 242
 243 (defsubst chess-images-draw-square (pos piece index)
 244   "Draw a piece image at point on an already drawn display."
 245   (put-text-property pos (1+ pos) 'display
 246                      (chess-images-piece-image piece (chess-index-rank index)
 247                                                (chess-index-file index))))
 248
 249 (defun chess-images-draw (position perspective)
 250   "Draw the current chess display position."
 251   (let* ((inhibit-redisplay t)
 252          (inverted (not perspective))
 253          (rank (if inverted 7 0))
 254          (file (if inverted 7 0))
 255          (pos (point)) new beg)
 256     (unless chess-images-cache
 257       (chess-images-init-cache)
 258       (erase-buffer))
 259     (unless (setq new (= (point-min) (point-max)))
 260       (goto-char (point-min)))
 261     (while (if inverted (>= rank 0) (< rank 8))
 262       (while (if inverted (>= file 0) (< file 8))
 263         (let* ((piece (chess-pos-piece position
 264                                        (chess-rf-to-index rank file)))
 265                (image (chess-images-piece-image piece rank file)))
 266           (if (not new)
 267               (progn
 268                 (put-text-property (point) (1+ (point)) 'display image)
 269                 (unless (= (1+ (point)) (point-max))
 270                   (forward-char 2)))
 271             (setq beg (point))
 272             (insert-image image)
 273             (if (= file (if inverted 0 7))
 274                 (unless (= rank (if inverted 0 7))
 275                   (insert ?\n))
 276               (insert-image (aref chess-images-cache 5)))
 277             (add-text-properties
 278              beg (point) (list 'intangible (chess-rf-to-index rank file)
 279                                'rear-nonsticky '(intangible)
 280                                'chess-coord (chess-rf-to-index rank file)))))
 281         (setq file (if inverted (1- file) (1+ file))))
 282       (setq file (if inverted 7 0)
 283             rank (if inverted (1- rank) (1+ rank))))
 284     (set-buffer-modified-p nil)
 285     (goto-char pos)))
 286
 287 (defun chess-images-highlight (index &optional mode)
 288   "Highlight the piece on the board at INDEX, using the given MODE.
 289 Common modes are:
 290   `selected'    show that the piece has been selected for movement.
 291   `unselected'  show that the piece has been unselected."
 292   (let* ((inverted (not (chess-display-perspective nil)))
 293          (pos (chess-display-index-pos nil index))
 294          (highlight (copy-alist (get-text-property pos 'display))))
 295     (setcar (last highlight)
 296             (list (cons "light_square" (if (eq mode :selected)
 297                                            chess-images-highlight-color
 298                                          mode))
 299                   (cons "dark_square" (if (eq mode :selected)
 300                                           chess-images-highlight-color
 301                                         mode))
 302                   (cons "background" (if (eq mode :selected)
 303                                          chess-images-highlight-color
 304                                        mode))))
 305     (put-text-property pos (1+ pos) 'display highlight)))
 306
 307 (chess-message-catalog 'english
 308   '((redrawing-frame . "Redrawing chess display with different size...")
 309     (redrawing-frame-done . "Redrawing chess display with different size...done")))
 310
 311 (defun chess-images-change-size (size)
 312   (let* ((buffer (current-buffer))
 313          (window (get-buffer-window buffer))
 314          (frame (and window (window-frame window))))
 315     (setq chess-images-size size
 316           chess-images-cache nil )
 317     (if frame
 318         (delete-frame frame t))
 319     (chess-message 'redrawing-frame)
 320     (chess-display-update buffer t)
 321     (chess-message 'redrawing-frame-done)))
 322
 323 (defun chess-images-resize ()
 324   "Resize the chessboard based on the frame or window's new size."
 325   (chess-images-determine-size)
 326   (if chess-images-size
 327       (chess-images-change-size chess-images-size)
 328     (chess-message 'no-images-fallback)))
 329
 330 (defun chess-images-alter-size (test)
 331   (let ((sizes chess-images-sizes))
 332     (if (eq test '<)
 333         (setq sizes (reverse sizes)))
 334     (while sizes
 335       (if (funcall test (car sizes) chess-images-size)
 336           (progn
 337             (chess-images-change-size (car sizes))
 338             (setq sizes nil))
 339         (setq sizes (cdr sizes))))))
 340
 341 (defun chess-images-increase-size ()
 342   "Increase the size of the pieces on the board."
 343   (interactive)
 344   (chess-images-alter-size '>))
 345
 346 (defun chess-images-decrease-size ()
 347   "Increase the size of the pieces on the board."
 348   (interactive)
 349   (chess-images-alter-size '<))
 350
 351 (defun chess-images-sizes ()
 352   "Return the set of available sizes for the current piece set.
 353 They are returned in ascending order, or nil for no sizes available."
 354   (let ((file (expand-file-name (format "black-rook.%s"
 355                                         chess-images-extension)
 356                                 chess-images-directory)))
 357     (if (file-readable-p file)
 358         (with-temp-buffer
 359           (insert-file-contents-literally file)
 360           (re-search-forward "\"\\([0-9]+\\)")
 361           (setq chess-images-sizes (list (string-to-int (match-string 1)))))
 362       (let (sizes)
 363         (dolist (file (directory-files chess-images-directory nil
 364                                        (format "rdd[0-9]+\\.%s"
 365                                                chess-images-extension)))
 366           (if (string-match "rdd\\([0-9]+\\)\\." file)
 367               (push (string-to-int (match-string 1 file)) sizes)))
 368         (setq chess-images-sizes (sort sizes '<))))))
 369
 370 (defun chess-images-best-size (&optional height width)
 371   "Return the piece size that works best for a window of HEIGHT."
 372   (let* ((size (or chess-images-default-size
 373                    (min (- (/ (or height (frame-pixel-height)) 8)
 374                            (or chess-images-border-width 0))
 375                         (- (/ (or width (frame-pixel-width)) 8)
 376                            (or chess-images-border-width 0)))))
 377          (sizes (chess-images-sizes))
 378          (last (car sizes)))
 379     (while sizes
 380       (if (> (car sizes) size)
 381           (setq sizes nil)
 382         (setq last (car sizes)
 383               sizes (cdr sizes))))
 384     (or last (and chess-images-default-size
 385                   (let (chess-images-default-size)
 386                     (chess-images-best-size height width))))))
 387
 388 (defun chess-images-set-directory (directory)
 389   "Increase the size of the pieces on the board."
 390   (interactive "DUse chess pieces in: ")
 391   (setq chess-images-directory directory
 392         chess-images-sizes (chess-images-sizes)
 393         chess-images-size (chess-images-best-size)
 394         chess-images-cache nil)
 395   (chess-images-alter-size '=))
 396
 397 (defun chess-images-create-xpm (height &optional width)
 398   (with-temp-buffer
 399     (insert "/* XPM */\n")
 400     (insert "static char *chessdotel[] = {\n")
 401     (insert "/* columns rows colors chars-per-pixel */\n")
 402     (insert (format "\"%d %d 2 1\",\n" (or width height) height))
 403     (insert "\"  c red s void\",\n")
 404     (insert "\". c red s background\",\n")
 405     (insert "/* pixels */\n")
 406     (dotimes (i height)
 407       (insert ?\" (make-string (or width height) ?.) ?\" ?, ?\n))
 408     (delete-backward-char 2)
 409     (insert "\n};\n")
 410     (buffer-string)))
 411
 412 (defun chess-images-hack-xpm (file add-height color)
 413   "Hack an XPM to append ADD-HEIGHT rows of COLOR.
 414 This is necessary for bizzare Emacs reasons."
 415   (with-temp-buffer
 416     (if (string-match "\\`/\\* XPM \\*/" file)
 417         (insert file)
 418       (insert-file-contents-literally file))
 419     (goto-char (point-min))
 420     (if (re-search-forward (concat "\"\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+"
 421                                    "\\([0-9]+\\)\\s-+\\([0-9]+\\)\"") nil t)
 422         (let* ((width (string-to-int (match-string 1)))
 423                (height (string-to-int (match-string 2)))
 424                (colors (string-to-int (match-string 3)))
 425                (chars-per-color (string-to-int (match-string 4)))
 426                (color-char (make-string chars-per-color ?~)))
 427           (replace-match (int-to-string (+ height add-height)) t t nil 2)
 428           (unless
 429               (save-match-data
 430                 (save-excursion
 431                   (if (re-search-forward
 432                        (format "^\"\\(..\\)\\s-*c\\s-+%s" color) nil t)
 433                       (setq color-char
 434                             (substring (match-string 1) 0 chars-per-color)))))
 435             (replace-match (int-to-string (1+ colors)) t t nil 3)
 436             (end-of-line)
 437             (insert "\n\"" color-char "\tc " color "\","))
 438           (beginning-of-line)
 439           (forward-line (1+ colors))
 440           (while (looking-at "/\\*")
 441             (forward-line))
 442           (dotimes (i add-height)
 443             (insert "\"")
 444             (dotimes (j width)
 445               (insert color-char))
 446             (insert "\",\n"))))
 447     (buffer-string)))
 448
 449 (defsubst chess-images-create-image (file background &optional foreground)
 450   "Create an Emacs image object, for insertion on the board."
 451   (let ((syms (list (nth background
 452                          `(("dark_square"  . ,chess-images-dark-color)
 453                            ("light_square" . ,chess-images-light-color)))
 454                     (nth background
 455                          `(("background"   . ,chess-images-dark-color)
 456                            ("background"   . ,chess-images-light-color))))))
 457     (if foreground
 458         (nconc syms
 459                (list (nth foreground
 460                           `(("dark_piece"   . ,chess-images-black-color)
 461                             ("light_piece"  . ,chess-images-white-color))))))
 462     (if chess-images-border-width
 463         (create-image
 464          (chess-images-hack-xpm file chess-images-border-width
 465                                 chess-images-border-color)
 466          nil t :color-symbols syms)
 467       (create-image file nil (string-match "\\`/\\* XPM \\*/" file)
 468                     :color-symbols syms))))
 469
 470 (chess-message-catalog 'english
 471   '((piece-images-loading . "Loading chess piece images...")
 472     (piece-images-loaded  . "Loading chess piece images...done")))
 473
 474 (defun chess-images-init-cache ()
 475   "Initialize the display image cache."
 476   (chess-message 'piece-images-loading)
 477
 478   ;; Make a vector of two vectors of 6-item vectors: each piece of
 479   ;; each color on each color square; and lastly two slots for the
 480   ;; blank squares
 481   (setq chess-images-cache
 482         (vector (vector (make-vector 6 nil)
 483                         (make-vector 6 nil))
 484                 (vector (make-vector 6 nil)
 485                         (make-vector 6 nil))
 486                 nil nil nil nil))
 487
 488   (let* ((colors '("black" "white"))
 489          (backgrounds (list chess-images-dark-color
 490                             chess-images-light-color))
 491          (piece-colors (list chess-images-black-color
 492                              chess-images-white-color))
 493          blank name image-data)
 494     (dotimes (c 2)
 495       (dotimes (b 2)
 496         (dolist (piece chess-images-piece-names)
 497           (let ((file (expand-file-name
 498                        (format "%s-%s.%s" (nth c colors) (nth 1 piece)
 499                                chess-images-extension)
 500                        chess-images-directory)))
 501             (if (file-readable-p file)
 502                 (aset (aref (aref chess-images-cache c) b)
 503                       (nth 2 piece)
 504                       (chess-images-create-image file b c))
 505               ;; try loading an xboard format file
 506               (setq file (expand-file-name
 507                           (format "%c%c%c%d.%s" (car piece)
 508                                   (if (= c 0) ?d ?l)
 509                                   (if (= b 0) ?d ?l) chess-images-size
 510                                   chess-images-extension)
 511                           chess-images-directory))
 512               (aset (aref (aref chess-images-cache c) b)
 513                     (nth 2 piece)
 514                     (chess-images-create-image file b c)))))))
 515     (cond
 516      ((file-readable-p
 517        (setq blank (expand-file-name
 518                     (format "%s.%s" chess-images-background-image
 519                             chess-images-extension)
 520                     chess-images-directory)))
 521       (aset chess-images-cache 2 (chess-images-create-image blank 0))
 522       (aset chess-images-cache 3 (chess-images-create-image blank 1)))
 523      ;; try loading an xboard format file
 524      ((file-readable-p
 525        (setq name (format "dsq%d.%s" chess-images-size
 526                           chess-images-extension)
 527              blank (expand-file-name name chess-images-directory)))
 528       (aset chess-images-cache 2 (chess-images-create-image blank 0))
 529       (aset name 0 ?l)
 530       (setq blank (expand-file-name name chess-images-directory))
 531       (aset chess-images-cache 3 (chess-images-create-image blank 1)))
 532      ;; if all else fails, create one
 533      (t
 534       (setq image-data
 535             (cond
 536              ((string= chess-images-extension "xpm")
 537               (chess-images-create-xpm chess-images-size))))
 538       (aset chess-images-cache 2 (chess-images-create-image image-data 0))
 539       (aset chess-images-cache 3 (chess-images-create-image image-data 1))))
 540
 541     (when chess-images-border-width
 542       (aset chess-images-cache 4
 543             (create-image
 544              (chess-images-create-xpm
 545               chess-images-border-width
 546               (+ (* 8 chess-images-size)
 547                  (* 9 chess-images-border-width)))
 548              nil t :color-symbols
 549              (list (cons "background" chess-images-border-color))))
 550       (aset chess-images-cache 5
 551             (create-image
 552              (chess-images-create-xpm chess-images-size
 553                                       chess-images-border-width)
 554              nil t :color-symbols
 555              (list (cons "background" chess-images-border-color))))))
 556
 557   ;; let the garbage collector know we're through here
 558   (garbage-collect)
 559   (chess-message 'piece-images-loaded))
 560
 561 (provide 'chess-images)
 562
 563 ;;; chess-images.el ends here