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

   1 ;;; chess-plain.el --- Plain ASCII chess display
   2
   3 ;; Copyright (C) 2002-2005, 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: John Wiegley <johnw@gnu.org>
   6 ;; Maintainer: Mario Lang <mlang@delysid.org>
   7 ;; Keywords: games
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; This chess display module presents a very compact plain character-based
  25 ;; view of the chessboard.  Contrary to the classic chess-ics1, it does not draw
  26 ;; a border around squares.
  27 ;;
  28 ;; The characters used to display individual pieces can be customized,
  29 ;; see `chess-plain-piece-chars' for a number of suggestions.  Other aspects of
  30 ;; the chessboard are also customizable, see customization group `chess-plain'.
  31
  32 ;;; Code:
  33
  34 (require 'chess-display)
  35
  36 (defgroup chess-plain nil
  37   "A minimal, customizable ASCII display."
  38   :group 'chess-display
  39   :link '(custom-manual "(chess)Plain ASCII diagram displays"))
  40
  41 (defcustom chess-plain-border-style [?+ ?- ?+ ?| ?| ?+ ?- ?+]
  42   "If non-nil, a vector describing the border characters."
  43   :group 'chess-plain
  44   :type '(choice (const :tag "No border" nil)
  45                  (vector :tag "Plain ASCII"
  46                          (const :value ?+ :tag "Upper left corner: +")
  47                          (const :value ?- :tag "Upper border: -")
  48                          (const :value ?+ :tag "Upper right corner: +")
  49                          (const :value ?| :tag "Left border: |")
  50                          (const :value ?| :tag "Right border: |")
  51                          (const :value ?+ :tag "Lower left corrner: +")
  52                          (const :value ?- :tag "Lower border: -")
  53                          (const :value ?+ :tag "Lower right corner: +"))
  54                  (vector :tag "Unicode box drawing characters"
  55                          (const :value ?┌ :tag "Upper left corner: ┌")
  56                          (const :value ?╶ :tag "Upper border: ╶")
  57                          (const :value ?┐ :tag "Upper right corner: ┐")
  58                          (const :value ?╷ :tag "Left border: ╷")
  59                          (const :value ?╷ :tag "Right border: ╷")
  60                          (const :value ?└ :tag "Lower left corrner: └")
  61                          (const :value ?╶ :tag "Lower border: ╶")
  62                          (const :value ?┘ :tag "Lower right corner: ┘"))
  63                  (vector :tag "Custom"
  64                          (character :tag "Upper left corner")
  65                          (character :tag "Upper border")
  66                          (character :tag "Upper right corner")
  67                          (character :tag "Left border")
  68                          (character :tag "Right border")
  69                          (character :tag "Lower left corner")
  70                          (character :tag "Lower border")
  71                          (character :tag "Lower right corner"))))
  72
  73 (defcustom chess-plain-black-square-char ?.
  74   "Character used to indicate empty black squares."
  75   :group 'chess-plain
  76   :type 'character)
  77
  78 (defcustom chess-plain-white-square-char ?.
  79   "Character used to indicate empty white squares."
  80   :group 'chess-plain
  81   :type 'character)
  82
  83 (defcustom chess-plain-piece-chars '((?K . ?K)
  84                                      (?Q . ?Q)
  85                                      (?R . ?R)
  86                                      (?B . ?B)
  87                                      (?N . ?N)
  88                                      (?P . ?P)
  89                                      (?k . ?k)
  90                                      (?q . ?q)
  91                                      (?r . ?r)
  92                                      (?b . ?b)
  93                                      (?n . ?n)
  94                                      (?p . ?p))
  95   "Alist of pieces and their corresponding characters.
  96 Characters defined here should make sense in respect to the current setting
  97 of `chess-plain-upcase-indicates'."
  98   :group 'chess-plain
  99   :type '(choice (list :tag "White has uppercase english letters and black has lowercase english letters"
 100                        (const :tag "White King: K"   (?K . ?K))
 101                        (const :tag "White Queen: Q"  (?Q . ?Q))
 102                        (const :tag "White Rook: R"   (?R . ?R))
 103                        (const :tag "White Bishop: B" (?B . ?B))
 104                        (const :tag "White Knight: N" (?N . ?N))
 105                        (const :tag "White Pawn: P"   (?P . ?P))
 106                        (const :tag "Black King: k"   (?k . ?k))
 107                        (const :tag "Black Queen: q"  (?q . ?q))
 108                        (const :tag "Black Rook: r"   (?r . ?r))
 109                        (const :tag "Black Bishop: b" (?b . ?b))
 110                        (const :tag "Black Knight: n" (?n . ?n))
 111                        (const :tag "Black Pawn: p"   (?p . ?p)))
 112                  (list :tag "White has uppercase german letters and black has lowercase german letters"
 113                        (const :tag "White King: K"   (?K . ?K))
 114                        (const :tag "White Queen: D"  (?Q . ?D))
 115                        (const :tag "White Rook: T"   (?R . ?T))
 116                        (const :tag "White Bishop: L" (?B . ?L))
 117                        (const :tag "White Knight: S" (?N . ?S))
 118                        (const :tag "White Pawn: B"   (?P . ?B))
 119                        (const :tag "Black King: k"   (?k . ?k))
 120                        (const :tag "Black Queen: d"  (?q . ?d))
 121                        (const :tag "Black Rook: t"   (?r . ?t))
 122                        (const :tag "Black Bishop: l" (?b . ?l))
 123                        (const :tag "Black Knight: s" (?n . ?s))
 124                        (const :tag "Black Pawn: b"   (?p . ?b)))
 125                  (list :tag "White has english letters and black has german letters"
 126                        (const :tag "White King: K"   (?K . ?K))
 127                        (const :tag "White Queen: Q"  (?Q . ?Q))
 128                        (const :tag "White Rook: R"   (?R . ?R))
 129                        (const :tag "White Bishop: B" (?B . ?B))
 130                        (const :tag "White Knight: N" (?N . ?N))
 131                        (const :tag "White Pawn: P"   (?P . ?P))
 132                        (const :tag "Black King: J"   (?k . ?J))
 133                        (const :tag "Black Queen: D"  (?q . ?D))
 134                        (const :tag "Black Rook: T"   (?r . ?T))
 135                        (const :tag "Black Bishop: L" (?b . ?L))
 136                        (const :tag "Black Knight: S" (?n . ?S))
 137                        (const :tag "Black Pawn: X"   (?p . ?X)))
 138                  (list :tag "White has german letters and black has english letters"
 139                        (const :tag "White King: J"   (?K . ?J))
 140                        (const :tag "White Queen: D"  (?Q . ?D))
 141                        (const :tag "White Rook: T"   (?R . ?T))
 142                        (const :tag "White Bishop: L" (?B . ?L))
 143                        (const :tag "White Knight: S" (?N . ?S))
 144                        (const :tag "White Pawn: X"   (?P . ?X))
 145                        (const :tag "Black King: K"   (?k . ?K))
 146                        (const :tag "Black Queen: Q"  (?q . ?Q))
 147                        (const :tag "Black Rook: R"   (?r . ?R))
 148                        (const :tag "Black Bishop: B" (?b . ?B))
 149                        (const :tag "Black Knight: N" (?n . ?N))
 150                        (const :tag "Black Pawn: P"   (?p . ?P)))
 151                  (list :tag "Unicode figure pieces"
 152                        (const :tag "White King: ♔"   (?K . ?♔))
 153                        (const :tag "White Queen: ♕"  (?Q . ?♕))
 154                        (const :tag "White Rook: ♖"   (?R . ?♖))
 155                        (const :tag "White Bishop: ♗" (?B . ?♗))
 156                        (const :tag "White Knight: ♘" (?N . ?♘))
 157                        (const :tag "White Pawn: ♙"   (?P . ?♙))
 158                        (const :tag "Black King: ♚"   (?k . ?♚))
 159                        (const :tag "Black Queen: ♛"  (?q . ?♛))
 160                        (const :tag "Black Rook: ♜"   (?r . ?♜))
 161                        (const :tag "Black Bishop: ♝" (?b . ?♝))
 162                        (const :tag "Black Knight: ♞" (?n . ?♞))
 163                        (const :tag "Black Pawn: ♟"   (?p . ?♟)))
 164                  (list :tag "User defined"
 165                        (cons :format "%v"
 166                              (const :format "" ?K) (character :tag "White King"))
 167                        (cons :format "%v"
 168                              (const :format "" ?Q) (character :tag "White Queen"))
 169                        (cons :format "%v"
 170                              (const :format "" ?R) (character :tag "White Rook"))
 171                        (cons :format "%v"
 172                              (const :format "" ?B) (character :tag "White Bishop"))
 173                        (cons :format "%v"
 174                              (const :format "" ?N) (character :tag "White Knight"))
 175                        (cons :format "%v"
 176                              (const :format "" ?P) (character :tag "White Pawn"))
 177                        (cons :format "%v"
 178                              (const :format "" ?k) (character :tag "Black King"))
 179                        (cons :format "%v"
 180                              (const :format "" ?q) (character :tag "Black Queen"))
 181                        (cons :format "%v"
 182                              (const :format "" ?r) (character :tag "Black Rook"))
 183                        (cons :format "%v"
 184                              (const :format "" ?b) (character :tag "Black Bishop"))
 185                        (cons :format "%v"
 186                              (const :format "" ?n) (character :tag "Black Knight"))
 187                        (cons :format "%v"
 188                              (const :format "" ?p) (character :tag "Black Pawn")))
 189                  (function :tag "Function")))
 190
 191 (defcustom chess-plain-upcase-indicates 'color
 192   "Defines what a upcase char should indicate.
 193 The default is 'color, meaning a upcase char is a white piece, a
 194 lowercase char a black piece.  Possible values: 'color (default),
 195 'square-color.  If set to 'square-color, a uppercase character
 196 indicates a piece on a black square. (Note that you also need to
 197 modify `chess-plain-piece-chars' to avoid real confusion.)"
 198   :group 'chess-plain
 199   :type '(choice (const :tag "Upcase indicates white piece" color)
 200                  (const :tag "Upcase indicates black square" square-color)))
 201
 202 (defcustom chess-plain-spacing 1
 203   "Number of spaces between files."
 204   :group 'chess-plain
 205   :type 'integer)
 206
 207 (defface chess-plain-black-face
 208   '((((class color) (background light)) (:foreground "Black"))
 209     (((class color) (background dark)) (:foreground "Green"))
 210     (t (:bold t)))
 211   "The face used for black pieces on the ASCII display."
 212   :group 'chess-plain)
 213
 214 (defface chess-plain-white-face
 215   '((((class color) (background light)) (:foreground "Blue"))
 216     (((class color) (background dark)) (:foreground "Yellow"))
 217     (t (:bold t)))
 218   "The face used for white pieces on the ASCII display."
 219   :group 'chess-plain)
 220
 221 (defface chess-plain-highlight-face
 222   '((((class color) (background light)) (:background "#add8e6"))
 223     (((class color) (background dark)) (:background "#add8e6")))
 224   "Face to use for highlighting pieces that have been selected."
 225   :group 'chess-plain)
 226
 227 (defcustom chess-plain-popup-function 'chess-plain-popup
 228   "The function used to popup a chess-plain display."
 229   :type 'function
 230   :group 'chess-plain)
 231
 232 (defcustom chess-plain-separate-frame nil
 233   "If non-nil, display the chessboard in its own frame."
 234   :type 'boolean
 235   :group 'chess-plain)
 236
 237 ;;; Code:
 238
 239 (defun chess-plain-customize ()
 240   "Show possible customisations for the plain chessboard display."
 241   (interactive)
 242   (customize-group 'chess-plain))
 243
 244 (defun chess-plain-handler (event &rest args)
 245   (cond
 246    ((eq event 'initialize) t)
 247    ((eq event 'popup) (funcall chess-plain-popup-function))
 248    (t (let ((handler (intern-soft (concat "chess-plain-" (symbol-name event)))))
 249         (when handler (apply handler args))))))
 250
 251 (defun chess-plain-popup ()
 252   (if chess-plain-separate-frame
 253       (chess-display-popup-in-frame 9 (* (1+ chess-plain-spacing) 8)
 254                                     nil nil t)
 255     (chess-display-popup-in-window)))
 256
 257 (defun chess-plain-piece-text (piece rank file)
 258   (let ((white-square (zerop (% (+ file rank) 2))))
 259     (if (= piece ? )
 260         (if white-square
 261             chess-plain-white-square-char
 262           chess-plain-black-square-char)
 263       (let* ((pchar (cdr (assq piece chess-plain-piece-chars)))
 264              (p (char-to-string
 265                  (if (eq chess-plain-upcase-indicates 'square-color)
 266                      (if white-square (downcase pchar) (upcase pchar))
 267                    pchar))))
 268         (add-text-properties 0 1 (list 'face (if (> piece ?a)
 269                                                  'chess-plain-black-face
 270                                                'chess-plain-white-face)) p)
 271         p))))
 272
 273 (defun chess-plain-draw-square (pos piece index)
 274   "Draw a piece at POS on an already drawn display."
 275   (save-excursion
 276     (goto-char pos)
 277     (delete-char 1)
 278     (insert (chess-plain-piece-text piece (chess-index-rank index)
 279                                     (chess-index-file index)))
 280     (add-text-properties pos (point) (list 'chess-coord index))))
 281
 282 (defun chess-plain-draw (position perspective)
 283   "Draw the given POSITION from PERSPECTIVE's point of view.
 284 PERSPECTIVE is t for white or nil for black."
 285   (let ((inhibit-redisplay t)
 286         (pos (point)))
 287     (erase-buffer)
 288     (let* ((inverted (not perspective))
 289            (rank (if inverted 7 0))
 290            (file (if inverted 7 0)))
 291       (when chess-plain-border-style
 292         (insert ?  (aref chess-plain-border-style 0)
 293                 (make-string (+ 8 (* 7 chess-plain-spacing))
 294                              (aref chess-plain-border-style 1))
 295                 (aref chess-plain-border-style 2) ?\n))
 296       (while (if inverted (>= rank 0) (< rank 8))
 297         (when chess-plain-border-style
 298           (insert (number-to-string (- 8 rank))
 299                   (aref chess-plain-border-style 3)))
 300         (while (if inverted (>= file 0) (< file 8))
 301           (let ((piece (chess-pos-piece position
 302                                         (chess-rf-to-index rank file)))
 303                 (begin (point)))
 304             (insert (chess-plain-piece-text piece rank file))
 305             (add-text-properties begin (point)
 306                                  (list 'chess-coord
 307                                        (chess-rf-to-index rank file)))
 308             (when (if inverted (>= file 1) (< file 7))
 309               (insert (make-string chess-plain-spacing ? ))))
 310           (setq file (if inverted (1- file) (1+ file))))
 311         (when chess-plain-border-style
 312           (insert (aref chess-plain-border-style 4)))
 313         (insert ?\n)
 314         (setq file (if inverted 7 0)
 315               rank (if inverted (1- rank) (1+ rank))))
 316       (if chess-plain-border-style
 317           (insert ?  (aref chess-plain-border-style 5)
 318                   (make-string (+ 8 (* 7 chess-plain-spacing))
 319                                (aref chess-plain-border-style 6))
 320                   (aref chess-plain-border-style 7) ?\n
 321                   ? ?
 322                   (let ((string (if (not inverted) "abcdefgh" "hgfedcba")))
 323                     (mapconcat 'string (string-to-list string)
 324                                (make-string chess-plain-spacing ? )))))
 325       (set-buffer-modified-p nil)
 326       (goto-char pos))))
 327
 328 (defun chess-plain-highlight (index &optional mode)
 329   (let ((pos (chess-display-index-pos nil index)))
 330     (put-text-property pos (1+ pos) 'face
 331                        (cond
 332                         ((eq mode :selected)
 333                          'chess-plain-highlight-face)
 334                         (t
 335                          (chess-display-get-face mode))))))
 336
 337 (provide 'chess-plain)
 338
 339 ;;; chess-plain.el ends here