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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Plain ASCII chess display
   4 ;;
   5
   6 (require 'chess-display)
   7
   8 ;;; Code:
   9
  10 (defgroup chess-plain nil
  11   "A minimal, customizable ASCII display."
  12   :group 'chess-display)
  13
  14 (defcustom chess-plain-draw-border nil
  15   "Non-nil if a border should be drawn (using `chess-plain-border-chars')."
  16   :group 'chess-plain
  17   :type 'boolean)
  18
  19 (defcustom chess-plain-border-chars '(?+ ?- ?+ ?| ?| ?+ ?- ?+)
  20   "A list of characters used to draw borders."
  21   :group 'chess-plain
  22   :type '(list (character :tag "Upper left corner")
  23                (character :tag "Upper border")
  24                (character :tag "Upper right corner")
  25                (character :tag "Left border")
  26                (character :tag "Right border")
  27                (character :tag "Lower left corner")
  28                (character :tag "Lower border")
  29                (character :tag "Lower right corner")))
  30
  31 (defcustom chess-plain-black-square-char ?.
  32   "Character used to indicate empty black squares."
  33   :group 'chess-plain
  34   :type 'character)
  35
  36 (defcustom chess-plain-white-square-char ?.
  37   "Character used to indicate empty white squares."
  38   :group 'chess-plain
  39   :type 'character)
  40
  41 (defcustom chess-plain-piece-chars
  42   '((?K . ?K)
  43     (?Q . ?Q)
  44     (?R . ?R)
  45     (?B . ?B)
  46     (?N . ?N)
  47     (?P . ?P)
  48     (?k . ?k)
  49     (?q . ?q)
  50     (?r . ?r)
  51     (?b . ?b)
  52     (?n . ?n)
  53     (?p . ?p))
  54   "Alist of pieces and their corresponding characters."
  55   :group 'chess-plain
  56   :type '(alist :key-type (character :tag "Internal representation")
  57                 :value-type (character :tag "Printed representation")))
  58
  59 (defcustom chess-plain-upcase-indicates 'color
  60   "*Defines what a upcase char should indicate.
  61 The default is 'color, meaning a upcase char is a white piece, a
  62 lowercase char a black piece.  Possible values: 'color (default),
  63 'square-color.  If set to 'square-color, a uppercase character
  64 indicates a piece on a black square. (Note that you also need to
  65 modify `chess-plain-piece-chars' to avoid real confusion.)"
  66   :group 'chess-plain
  67   :type '(choice (const :tag "Upcase indicates white piece" color)
  68                  (const :tag "Upcase indicates black square" square-color)))
  69
  70 (defcustom chess-plain-spacing 1
  71   "Number of spaces between files."
  72   :group 'chess-plain
  73   :type 'integer)
  74
  75 (defface chess-plain-black-face
  76   '((((class color) (background light)) (:foreground "Black"))
  77     (((class color) (background dark)) (:foreground "Green"))
  78     (t (:bold t)))
  79   "The face used for black pieces on the ASCII display."
  80   :group 'chess-plain)
  81
  82 (defface chess-plain-white-face
  83   '((((class color) (background light)) (:foreground "Blue"))
  84     (((class color) (background dark)) (:foreground "Yellow"))
  85     (t (:bold t)))
  86   "The face used for white pieces on the ASCII display."
  87   :group 'chess-plain)
  88
  89 (defface chess-plain-highlight-face
  90   '((((class color) (background light)) (:background "#add8e6"))
  91     (((class color) (background dark)) (:background "#add8e6")))
  92   "Face to use for highlighting pieces that have been selected."
  93   :group 'chess-plain)
  94
  95 (defcustom chess-plain-popup-function 'chess-plain-popup
  96   "The function used to popup a chess-plain display."
  97   :type 'function
  98   :group 'chess-plain)
  99
 100 (defcustom chess-plain-separate-frame nil
 101   "If non-nil, display the chessboard in its own frame."
 102   :type 'boolean
 103   :group 'chess-plain)
 104
 105 ;;; Code:
 106
 107 (defun chess-plain-handler (event &rest args)
 108   (cond
 109    ((eq event 'initialize) t)
 110
 111    ((eq event 'popup)
 112     (funcall chess-plain-popup-function))
 113
 114    ((eq event 'draw)
 115     (apply 'chess-plain-draw args))
 116
 117    ((eq event 'draw-square)
 118     (apply 'chess-plain-draw-square args))
 119
 120    ((eq event 'highlight)
 121     (apply 'chess-plain-highlight args))))
 122
 123 (defun chess-plain-popup ()
 124   (if chess-plain-separate-frame
 125       (chess-display-popup-in-frame 9 (* (1+ chess-plain-spacing) 8)
 126                                     nil nil t)
 127     (chess-display-popup-in-window)))
 128
 129 (defun chess-plain-piece-text (piece rank file)
 130   (let ((white-square (= (% (+ file rank) 2) 0)))
 131     (if (eq piece ? )
 132         (if white-square
 133             chess-plain-white-square-char
 134           chess-plain-black-square-char)
 135       (let* ((pchar (cdr (assq piece chess-plain-piece-chars)))
 136              (p (char-to-string
 137                  (if (eq chess-plain-upcase-indicates 'square-color)
 138                      (if white-square
 139                          (downcase pchar)
 140                        (upcase pchar))
 141                    pchar))))
 142         (add-text-properties 0 1 (list 'face (if (> piece ?a)
 143                                                  'chess-plain-black-face
 144                                                'chess-plain-white-face)) p)
 145         p))))
 146
 147 (defsubst chess-plain-draw-square (pos piece index)
 148   "Draw a piece image at POS on an already drawn display."
 149   (save-excursion
 150     (goto-char pos)
 151     (delete-char 1)
 152     (insert (chess-plain-piece-text piece (chess-index-rank index)
 153                                     (chess-index-file index)))
 154     (add-text-properties pos (point) (list 'chess-coord index))))
 155
 156 (defun chess-plain-draw (position perspective)
 157   "Draw the given POSITION from PERSPECTIVE's point of view.
 158 PERSPECTIVE is t for white or nil for black."
 159   (let ((inhibit-redisplay t)
 160         (pos (point)))
 161     (erase-buffer)
 162     (let* ((inverted (not perspective))
 163            (rank (if inverted 7 0))
 164            (file (if inverted 7 0)) beg)
 165       (if chess-plain-draw-border
 166           (insert ?  (nth 0 chess-plain-border-chars)
 167                   (make-string (+ 8 (* 7 chess-plain-spacing))
 168                                (nth 1 chess-plain-border-chars))
 169                   (nth 2 chess-plain-border-chars) ?\n))
 170       (while (if inverted (>= rank 0) (< rank 8))
 171         (if chess-plain-draw-border
 172             (insert (number-to-string (- 8 rank))
 173                     (nth 3 chess-plain-border-chars)))
 174         (while (if inverted (>= file 0) (< file 8))
 175           (let ((piece (chess-pos-piece position
 176                                         (chess-rf-to-index rank file)))
 177                 (begin (point)))
 178             (insert (chess-plain-piece-text piece rank file))
 179             (add-text-properties begin (point)
 180                                  (list 'chess-coord
 181                                        (chess-rf-to-index rank file)))
 182             (when (if inverted (>= file 1) (< file 7))
 183               (insert (make-string chess-plain-spacing ? ))))
 184           (setq file (if inverted (1- file) (1+ file))))
 185         (if chess-plain-draw-border
 186             (insert (nth 4 chess-plain-border-chars)))
 187         (insert ?\n)
 188         (setq file (if inverted 7 0)
 189               rank (if inverted (1- rank) (1+ rank))))
 190       (if chess-plain-draw-border
 191           (insert ?  (nth 5 chess-plain-border-chars)
 192                   (make-string (+ 8 (* 7 chess-plain-spacing))
 193                                (nth 6 chess-plain-border-chars))
 194                   (nth 7 chess-plain-border-chars) ?\n
 195                   ? ?
 196                   (let ((string (if (not inverted) "abcdefgh" "hgfedcba")))
 197                     (mapconcat 'string (string-to-list string)
 198                                (make-string chess-plain-spacing ? )))))
 199       (set-buffer-modified-p nil)
 200       (goto-char pos))))
 201
 202 (defun chess-plain-highlight (index &optional mode)
 203   (let ((pos (chess-display-index-pos nil index)))
 204     (put-text-property pos (1+ pos) 'face
 205                        (cond
 206                         ((eq mode :selected)
 207                          'chess-plain-highlight-face)
 208                         (t
 209                          (chess-display-get-face mode))))))
 210
 211 (provide 'chess-plain)
 212
 213 ;;; chess-plain.el ends here