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

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