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))
 201                                 ;; On Macs and Windows, account for
 202                                 ;; the Start/Status bar
 203                                 (if (memq window-system '(mac windows w32))
 204                                     80 20))
 205                              (- (if display
 206                                     (x-display-pixel-width display)
 207                                   (display-pixel-width)) 20)))))
 208
 209 (defun chess-images-initialize ()
 210   (let ((map (current-local-map)))
 211     (define-key map [?^] 'chess-images-increase-size)
 212     (define-key map [?V] 'chess-images-decrease-size)
 213     (define-key map [?P] 'chess-images-set-directory))
 214   (chess-images-determine-size))
 215
 216 (chess-message-catalog 'english
 217   '((no-images . "Cannot find any piece images; check `chess-images-directory'")))
 218
 219 (defun chess-images-popup ()
 220   (unless chess-images-size
 221     (chess-error 'no-images))
 222   (if chess-images-separate-frame
 223       (let* ((size (float (+ (* (or chess-images-border-width 0) 8)
 224                              (* chess-images-size 8))))
 225              (max-char-height (ceiling (/ size (frame-char-height))))
 226              (max-char-width  (ceiling (/ size (frame-char-width))))
 227              (display (and (stringp chess-images-separate-frame)
 228                            chess-images-separate-frame)))
 229         ;; create the frame whenever necessary
 230         (chess-display-popup-in-frame (+ max-char-height 2)
 231                                       max-char-width
 232                                       (cdr (assq 'font (frame-parameters)))))
 233     (chess-display-popup-in-window)))
 234
 235 (defun chess-images-piece-image (piece rank file)
 236   "Return the image used for PIECE at RANK and FILE.
 237 Rank and file are important because the colors of the squares on the
 238 chess board are light or dark depending on location."
 239   (let ((square-color (% (+ file rank) 2))) ; 0 is white
 240     (if (= piece ? )
 241         (aref chess-images-cache (- 3 square-color))
 242       (aref (aref (aref chess-images-cache
 243                         (if (> piece ?a) 0 1))
 244                   (if (= square-color 0) 1 0))
 245             (nth 2 (assq (downcase piece)
 246                          chess-images-piece-names))))))
 247
 248 (defsubst chess-images-draw-square (pos piece index)
 249   "Draw a piece image at point on an already drawn display."
 250   (put-text-property pos (1+ pos) 'display
 251                      (chess-images-piece-image piece (chess-index-rank index)
 252                                                (chess-index-file index))))
 253
 254 (defun chess-images-draw (position perspective)
 255   "Draw the current chess display position."
 256   (let* ((inhibit-redisplay t)
 257          (inverted (not perspective))
 258          (rank (if inverted 7 0))
 259          (file (if inverted 7 0))
 260          (pos (point)) new beg)
 261     (unless chess-images-cache
 262       (chess-images-init-cache)
 263       (erase-buffer))
 264     (unless (setq new (= (point-min) (point-max)))
 265       (goto-char (point-min)))
 266     (while (if inverted (>= rank 0) (< rank 8))
 267       (while (if inverted (>= file 0) (< file 8))
 268         (let* ((piece (chess-pos-piece position
 269                                        (chess-rf-to-index rank file)))
 270                (image (chess-images-piece-image piece rank file)))
 271           (if (not new)
 272               (progn
 273                 (put-text-property (point) (1+ (point)) 'display image)
 274                 (unless (= (1+ (point)) (point-max))
 275                   (forward-char 2)))
 276             (setq beg (point))
 277             (insert-image image)
 278             (if (= file (if inverted 0 7))
 279                 (unless (= rank (if inverted 0 7))
 280                   (insert ?\n))
 281               (insert-image (aref chess-images-cache 5)))
 282             (add-text-properties
 283              beg (point) (list 'intangible (chess-rf-to-index rank file)
 284                                'rear-nonsticky '(intangible)
 285                                'chess-coord (chess-rf-to-index rank file)))))
 286         (setq file (if inverted (1- file) (1+ file))))
 287       (setq file (if inverted 7 0)
 288             rank (if inverted (1- rank) (1+ rank))))
 289     (set-buffer-modified-p nil)
 290     (goto-char pos)))
 291
 292 (defun chess-images-highlight (index &optional mode)
 293   "Highlight the piece on the board at INDEX, using the given MODE.
 294 Common modes are:
 295   `selected'    show that the piece has been selected for movement.
 296   `unselected'  show that the piece has been unselected."
 297   (let* ((inverted (not (chess-display-perspective nil)))
 298          (pos (chess-display-index-pos nil index))
 299          (highlight (copy-alist (get-text-property pos 'display))))
 300     (setcar (last highlight)
 301             (list (cons "light_square" (if (eq mode :selected)
 302                                            chess-images-highlight-color
 303                                          mode))
 304                   (cons "dark_square" (if (eq mode :selected)
 305                                           chess-images-highlight-color
 306                                         mode))
 307                   (cons "background" (if (eq mode :selected)
 308                                          chess-images-highlight-color
 309                                        mode))))
 310     (put-text-property pos (1+ pos) 'display highlight)))
 311
 312 (chess-message-catalog 'english
 313   '((redrawing-frame . "Redrawing chess display with different size...")
 314     (redrawing-frame-done . "Redrawing chess display with different size...done")))
 315
 316 (defun chess-images-change-size (size)
 317   (let* ((buffer (current-buffer))
 318          (window (get-buffer-window buffer))
 319          (frame (and window (window-frame window))))
 320     (setq chess-images-size size
 321           chess-images-cache nil)
 322     (if frame
 323         (delete-frame frame t))
 324     (chess-message 'redrawing-frame)
 325     (chess-display-update buffer t)
 326     (chess-display-popup buffer)
 327     (chess-message 'redrawing-frame-done)))
 328
 329 (defun chess-images-resize ()
 330   "Resize the chessboard based on the frame or window's new size."
 331   (chess-images-determine-size)
 332   (if chess-images-size
 333       (chess-images-change-size chess-images-size)
 334     (chess-message 'no-images-fallback)))
 335
 336 (defun chess-images-alter-size (test)
 337   (let ((sizes chess-images-sizes))
 338     (if (eq test '<)
 339         (setq sizes (reverse sizes)))
 340     (while sizes
 341       (if (funcall test (car sizes) chess-images-size)
 342           (progn
 343             (chess-images-change-size (car sizes))
 344             (setq sizes nil))
 345         (setq sizes (cdr sizes))))))
 346
 347 (defun chess-images-increase-size ()
 348   "Increase the size of the pieces on the board."
 349   (interactive)
 350   (chess-images-alter-size '>))
 351
 352 (defun chess-images-decrease-size ()
 353   "Increase the size of the pieces on the board."
 354   (interactive)
 355   (chess-images-alter-size '<))
 356
 357 (defun chess-images-sizes ()
 358   "Return the set of available sizes for the current piece set.
 359 They are returned in ascending order, or nil for no sizes available."
 360   (let ((file (expand-file-name (format "black-rook.%s"
 361                                         chess-images-extension)
 362                                 chess-images-directory)))
 363     (if (file-readable-p file)
 364         (with-temp-buffer
 365           (insert-file-contents-literally file)
 366           (re-search-forward "\"\\([0-9]+\\)")
 367           (setq chess-images-sizes (list (string-to-number (match-string 1)))))
 368       (let (sizes)
 369         (dolist (file (directory-files chess-images-directory nil
 370                                        (format "rdd[0-9]+\\.%s"
 371                                                chess-images-extension)))
 372           (if (string-match "rdd\\([0-9]+\\)\\." file)
 373               (push (string-to-number (match-string 1 file)) sizes)))
 374         (setq chess-images-sizes (sort sizes '<))))))
 375
 376 (defun chess-images-best-size (&optional height width)
 377   "Return the piece size that works best for a window of HEIGHT."
 378   (let* ((size (or chess-images-default-size
 379                    (min (- (/ (or height (frame-pixel-height)) 8)
 380                            (or chess-images-border-width 0))
 381                         (- (/ (or width (frame-pixel-width)) 8)
 382                            (or chess-images-border-width 0)))))
 383          (sizes (chess-images-sizes))
 384          (last (car sizes)))
 385     (while sizes
 386       (if (> (car sizes) size)
 387           (setq sizes nil)
 388         (setq last (car sizes)
 389               sizes (cdr sizes))))
 390     (or last (and chess-images-default-size
 391                   (let (chess-images-default-size)
 392                     (chess-images-best-size height width))))))
 393
 394 (defun chess-images-set-directory (directory)
 395   "Increase the size of the pieces on the board."
 396   (interactive "DUse chess pieces in: ")
 397   (setq chess-images-directory directory
 398         chess-images-sizes (chess-images-sizes)
 399         chess-images-size (chess-images-best-size)
 400         chess-images-cache nil)
 401   (chess-images-alter-size '=))
 402
 403 (defun chess-images-create-xpm (height &optional width)
 404   (with-temp-buffer
 405     (insert "/* XPM */\n")
 406     (insert "static char *chessdotel[] = {\n")
 407     (insert "/* columns rows colors chars-per-pixel */\n")
 408     (insert (format "\"%d %d 2 1\",\n" (or width height) height))
 409     (insert "\"  c red s void\",\n")
 410     (insert "\". c red s background\",\n")
 411     (insert "/* pixels */\n")
 412     (dotimes (i height)
 413       (insert ?\" (make-string (or width height) ?.) ?\" ?, ?\n))
 414     (delete-char -2)
 415     (insert "\n};\n")
 416     (buffer-string)))
 417
 418 (defun chess-images-hack-xpm (file add-height color)
 419   "Hack an XPM to append ADD-HEIGHT rows of COLOR.
 420 This is necessary for bizzare Emacs reasons."
 421   (with-temp-buffer
 422     (if (string-match "\\`/\\* XPM \\*/" file)
 423         (insert file)
 424       (insert-file-contents-literally file))
 425     (goto-char (point-min))
 426     (if (re-search-forward (concat "\"\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+"
 427                                    "\\([0-9]+\\)\\s-+\\([0-9]+\\)\"") nil t)
 428         (let* ((width (string-to-number (match-string 1)))
 429                (height (string-to-number (match-string 2)))
 430                (colors (string-to-number (match-string 3)))
 431                (chars-per-color (string-to-number (match-string 4)))
 432                (color-char (make-string chars-per-color ?~)))
 433           (replace-match (int-to-string (+ height add-height)) t t nil 2)
 434           (unless
 435               (save-match-data
 436                 (save-excursion
 437                   (if (re-search-forward
 438                        (format "^\"\\(..\\)\\s-*c\\s-+%s" color) nil t)
 439                       (setq color-char
 440                             (substring (match-string 1) 0 chars-per-color)))))
 441             (replace-match (int-to-string (1+ colors)) t t nil 3)
 442             (end-of-line)
 443             (insert "\n\"" color-char "\tc " color "\","))
 444           (beginning-of-line)
 445           (forward-line (1+ colors))
 446           (while (looking-at "/\\*")
 447             (forward-line))
 448           (dotimes (i add-height)
 449             (insert "\"")
 450             (dotimes (j width)
 451               (insert color-char))
 452             (insert "\",\n"))))
 453     (buffer-string)))
 454
 455 (defsubst chess-images-create-image (file background &optional foreground)
 456   "Create an Emacs image object, for insertion on the board."
 457   (let ((syms (list (nth background
 458                          `(("dark_square"  . ,chess-images-dark-color)
 459                            ("light_square" . ,chess-images-light-color)))
 460                     (nth background
 461                          `(("background"   . ,chess-images-dark-color)
 462                            ("background"   . ,chess-images-light-color))))))
 463     (if foreground
 464         (nconc syms
 465                (list (nth foreground
 466                           `(("dark_piece"   . ,chess-images-black-color)
 467                             ("light_piece"  . ,chess-images-white-color))))))
 468     (if chess-images-border-width
 469         (create-image
 470          (chess-images-hack-xpm file chess-images-border-width
 471                                 chess-images-border-color)
 472          nil t :color-symbols syms)
 473       (create-image file nil (string-match "\\`/\\* XPM \\*/" file)
 474                     :color-symbols syms))))
 475
 476 (chess-message-catalog 'english
 477   '((piece-images-loading . "Loading chess piece images...")
 478     (piece-images-loaded  . "Loading chess piece images...done")))
 479
 480 (defun chess-images-init-cache ()
 481   "Initialize the display image cache."
 482   (chess-message 'piece-images-loading)
 483
 484   ;; Make a vector of two vectors of 6-item vectors: each piece of
 485   ;; each color on each color square; and lastly two slots for the
 486   ;; blank squares
 487   (setq chess-images-cache
 488         (vector (vector (make-vector 6 nil)
 489                         (make-vector 6 nil))
 490                 (vector (make-vector 6 nil)
 491                         (make-vector 6 nil))
 492                 nil nil nil nil))
 493
 494   (let* ((colors '("black" "white"))
 495          (backgrounds (list chess-images-dark-color
 496                             chess-images-light-color))
 497          (piece-colors (list chess-images-black-color
 498                              chess-images-white-color))
 499          blank name image-data)
 500     (dotimes (c 2)
 501       (dotimes (b 2)
 502         (dolist (piece chess-images-piece-names)
 503           (let ((file (expand-file-name
 504                        (format "%s-%s.%s" (nth c colors) (nth 1 piece)
 505                                chess-images-extension)
 506                        chess-images-directory)))
 507             (if (file-readable-p file)
 508                 (aset (aref (aref chess-images-cache c) b)
 509                       (nth 2 piece)
 510                       (chess-images-create-image file b c))
 511               ;; try loading an xboard format file
 512               (setq file (expand-file-name
 513                           (format "%c%c%c%d.%s" (car piece)
 514                                   (if (= c 0) ?d ?l)
 515                                   (if (= b 0) ?d ?l) chess-images-size
 516                                   chess-images-extension)
 517                           chess-images-directory))
 518               (aset (aref (aref chess-images-cache c) b)
 519                     (nth 2 piece)
 520                     (chess-images-create-image file b c)))))))
 521     (cond
 522      ((file-readable-p
 523        (setq blank (expand-file-name
 524                     (format "%s.%s" chess-images-background-image
 525                             chess-images-extension)
 526                     chess-images-directory)))
 527       (aset chess-images-cache 2 (chess-images-create-image blank 0))
 528       (aset chess-images-cache 3 (chess-images-create-image blank 1)))
 529      ;; try loading an xboard format file
 530      ((file-readable-p
 531        (setq name (format "dsq%d.%s" chess-images-size
 532                           chess-images-extension)
 533              blank (expand-file-name name chess-images-directory)))
 534       (aset chess-images-cache 2 (chess-images-create-image blank 0))
 535       (aset name 0 ?l)
 536       (setq blank (expand-file-name name chess-images-directory))
 537       (aset chess-images-cache 3 (chess-images-create-image blank 1)))
 538      ;; if all else fails, create one
 539      (t
 540       (setq image-data
 541             (cond
 542              ((string= chess-images-extension "xpm")
 543               (chess-images-create-xpm chess-images-size))))
 544       (aset chess-images-cache 2 (chess-images-create-image image-data 0))
 545       (aset chess-images-cache 3 (chess-images-create-image image-data 1))))
 546
 547     (when chess-images-border-width
 548       (aset chess-images-cache 4
 549             (create-image
 550              (chess-images-create-xpm
 551               chess-images-border-width
 552               (+ (* 8 chess-images-size)
 553                  (* 9 chess-images-border-width)))
 554              nil t :color-symbols
 555              (list (cons "background" chess-images-border-color))))
 556       (aset chess-images-cache 5
 557             (create-image
 558              (chess-images-create-xpm chess-images-size
 559                                       chess-images-border-width)
 560              nil t :color-symbols
 561              (list (cons "background" chess-images-border-color))))))
 562
 563   ;; let the garbage collector know we're through here
 564   (garbage-collect)
 565   (chess-message 'piece-images-loaded))
 566
 567 (provide 'chess-images)
 568
 569 ;;; chess-images.el ends here