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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Plain ASCII chess display
   4 ;;
   5 ;; $Revision$
   6
   7 (require 'chess-display)
   8
   9 ;;; Code:
  10
  11 (defgroup chess-plain nil
  12   "A minimal, customizable ASCII display."
  13   :group 'chess-display)
  14
  15 (defcustom chess-plain-draw-border nil
  16   "*Non-nil if a border should be drawn (using `chess-plain-border-chars')."
  17   :group 'chess-plain
  18   :type 'boolean)
  19
  20 (defcustom chess-plain-border-chars '(?+ ?- ?+ ?| ?| ?+ ?- ?+)
  21   "*Characters used to draw borders."
  22   :group 'chess-plain
  23   :type '(list character character character character
  24                character character character character))
  25
  26 (defcustom chess-plain-black-square-char ?.
  27   "*Character used to indicate black squares."
  28   :group 'chess-plain
  29   :type 'character)
  30
  31 (defcustom chess-plain-white-square-char ?.
  32   "*Character used to indicate white squares."
  33   :group 'chess-plain
  34   :type 'character)
  35
  36 (defcustom chess-plain-piece-chars
  37   '((?K . ?K)
  38     (?Q . ?Q)
  39     (?R . ?R)
  40     (?B . ?B)
  41     (?N . ?N)
  42     (?P . ?P)
  43     (?k . ?k)
  44     (?q . ?q)
  45     (?r . ?r)
  46     (?b . ?b)
  47     (?n . ?n)
  48     (?p . ?p))
  49   "*Alist of pieces and their corresponding characters."
  50   :group 'chess-plain
  51   :type '(alist :key-type character :value-type character))
  52
  53 (defcustom chess-plain-upcase-indicates 'color
  54   "*Defines what a upcase char should indicate.
  55 The default is 'color, meaning a upcase char is a white piece, a
  56 lowercase char a black piece.  Possible values: 'color (default),
  57 'square-color.  If set to 'square-color, a uppercase character
  58 indicates a piece on a black square. (Note that you also need to
  59 modify `chess-plain-piece-chars' to avoid real confusion.)"
  60   :group 'chess-plain
  61   :type '(choice (const 'color) (const 'square-color)))
  62          ;; fails somehow
  63
  64 (defcustom chess-plain-popup-function 'chess-display-popup-in-window
  65   "The function used to popup a chess-plain display."
  66   :type 'function
  67   :group 'chess-plain)
  68
  69 ;;; Code:
  70
  71 (defun chess-plain-handler (event &rest args)
  72   (cond
  73    ((eq event 'initialize) t)
  74    ((eq event 'popup)
  75     (if chess-display-popup
  76         (funcall chess-plain-popup-function)))
  77    ((eq event 'draw)
  78     (apply 'chess-plain-draw args))
  79    ((eq event 'highlight)
  80     (apply 'chess-plain-highlight args))))
  81
  82 (defun chess-plain-draw (position perspective)
  83   "Draw the given POSITION from PERSPECTIVE's point of view.
  84 PERSPECTIVE is t for white or nil for black."
  85   (let ((inhibit-redisplay t)
  86         (pos (point)))
  87     (erase-buffer)
  88     (let* ((inverted (not perspective))
  89            (rank (if inverted 7 0))
  90            (file (if inverted 7 0))
  91            beg)
  92       (if chess-plain-draw-border
  93           (insert ?  (nth 0 chess-plain-border-chars)
  94                   (make-string 8 (nth 1 chess-plain-border-chars))
  95                   (nth 2 chess-plain-border-chars) ?\n))
  96       (while (if inverted (>= rank 0) (< rank 8))
  97         (if chess-plain-draw-border
  98             (insert (number-to-string (- 8 rank))
  99                     (nth 3 chess-plain-border-chars)))
 100         (while (if inverted (>= file 0) (< file 8))
 101           (let ((piece (chess-pos-piece position
 102                                         (chess-rf-to-index rank file)))
 103                 (white-square (evenp (+ file rank)))
 104                 (begin (point)))
 105             (insert (if (eq piece ? )
 106                         (if white-square
 107                             chess-plain-white-square-char
 108                           chess-plain-black-square-char)
 109                       (let ((what chess-plain-upcase-indicates)
 110                             (pchar (cdr (assq piece chess-plain-piece-chars))))
 111                         (cond
 112                          ((eq what 'square-color)
 113                           (if white-square
 114                               (downcase pchar)
 115                             (upcase pchar)))
 116                          (t pchar)))))
 117             (add-text-properties begin (point)
 118                                  (list 'chess-coord
 119                                        (chess-rf-to-index rank file))))
 120           (setq file (if inverted (1- file) (1+ file))))
 121         (if chess-plain-draw-border
 122             (insert (nth 4 chess-plain-border-chars)))
 123         (insert ?\n)
 124         (setq file (if inverted 7 0)
 125               rank (if inverted (1- rank) (1+ rank))))
 126       (if chess-plain-draw-border
 127           (insert ?  (nth 5 chess-plain-border-chars)
 128                   (make-string 8 (nth 6 chess-plain-border-chars))
 129                   (nth 7 chess-plain-border-chars) ?\n
 130                   ? ?  (if (not inverted) "abcdefgh" "hgfedcba")))
 131       (set-buffer-modified-p nil)
 132       (goto-char pos))))
 133
 134 (defun chess-plain-highlight (index &optional mode)
 135   (let ((inverted (not (chess-display-perspective nil))))
 136     (save-excursion
 137       (beginning-of-line)
 138       (let ((rank (chess-index-rank index))
 139             (file (chess-index-file index)))
 140         (if inverted
 141             (setq rank (- 7 rank)
 142                   file (- 7 file)))
 143         (goto-line (if chess-plain-draw-border
 144                        (+ 2 rank)
 145                      (1+ rank)))
 146         (forward-char (if chess-plain-draw-border
 147                           (1+ file)
 148                         file)))
 149       (put-text-property (point) (1+ (point)) 'face
 150                          (cond
 151                           ((eq mode :selected)
 152                            'chess-plain-highlight-face)
 153                           (t
 154                            (chess-display-get-face mode)))))))
 155
 156 (provide 'chess-plain)
 157
 158 ;;; chess-plain.el ends here