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

   1 ;;; chess-ics1.el --- Classic ICS1 style chessboard display
   2
   3 ;; Copyright (C) 2002, 2005, 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: John Wiegley <johnw@gnu.org>
   6 ;; Keywords: games
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Code:
  22
  23 (require 'chess-display)
  24
  25 (defgroup chess-ics1 nil
  26   "The ICS1 style ASCII display."
  27   :group 'chess-display)
  28
  29 (defface chess-ics1-black-face
  30   '((((class color) (background light)) (:foreground "Green"))
  31     (((class color) (background dark)) (:foreground "Green"))
  32     (t (:bold t)))
  33   "*The face used for black pieces on the ASCII display."
  34   :group 'chess-ics1)
  35
  36 (defface chess-ics1-white-face
  37   '((((class color) (background light)) (:foreground "Yellow"))
  38     (((class color) (background dark)) (:foreground "Yellow"))
  39     (t (:bold t)))
  40   "*The face used for white pieces on the ASCII display."
  41   :group 'chess-ics1)
  42
  43 (defface chess-ics1-highlight-face
  44   '((((class color) (background light)) (:background "#add8e6"))
  45     (((class color) (background dark)) (:background "#add8e6")))
  46   "Face to use for highlighting pieces that have been selected."
  47   :group 'chess-ics1)
  48
  49 (defcustom chess-ics1-popup-function 'chess-ics1-popup
  50   "The function used to popup a chess-ics1 display."
  51   :type 'function
  52   :group 'chess-ics1)
  53
  54 (defcustom chess-ics1-separate-frame nil
  55   "If non-nil, display the chessboard in its own frame."
  56   :type 'boolean
  57   :group 'chess-ics1)
  58
  59 ;;; Code:
  60
  61 (defun chess-ics1-handler (event &rest args)
  62   (cond
  63    ((eq event 'initialize) t)
  64
  65    ((eq event 'popup)
  66     (funcall chess-ics1-popup-function))
  67
  68    ((eq event 'draw)
  69     (apply 'chess-ics1-draw args))
  70
  71    ((eq event 'draw-square)
  72     (apply 'chess-ics1-draw-square args))
  73
  74    ((eq event 'highlight)
  75     (apply 'chess-ics1-highlight args))))
  76
  77 (defun chess-ics1-popup ()
  78   (if chess-ics1-separate-frame
  79       (chess-display-popup-in-frame 21 43 nil nil t)
  80     (chess-display-popup-in-window)))
  81
  82 (defsubst chess-ics1-piece-text (piece)
  83   (let ((p (char-to-string piece)))
  84     (add-text-properties 0 1 (list 'face (if (> piece ?a)
  85                                              'chess-ics1-black-face
  86                                            'chess-ics1-white-face)) p)
  87     p))
  88
  89 (defsubst chess-ics1-draw-square (pos piece index)
  90   "Draw a piece image at point on an already drawn display."
  91   (save-excursion
  92     (let ((inhibit-redisplay t))
  93       (goto-char pos)
  94       (delete-char 3)
  95       (insert ?  (chess-ics1-piece-text piece) ? )
  96       (add-text-properties pos (point) (list 'chess-coord index)))))
  97
  98 (defun chess-ics1-draw (position perspective)
  99   "Draw the given POSITION from PERSPECTIVE's point of view.
 100 PERSPECTIVE is t for white or nil for black."
 101   (let ((inhibit-redisplay t)
 102         (pos (point)))
 103     (erase-buffer)
 104     (let* ((inverted (not perspective))
 105            (rank (if inverted 7 0))
 106            (file (if inverted 7 0)))
 107       (insert "\n      +---+---+---+---+---+---+---+---+\n")
 108       (while (if inverted (>= rank 0) (< rank 8))
 109         (if (/= rank (if inverted 7 0))
 110             (insert "      +---+---+---+---+---+---+---+---+\n"))
 111         (while (if inverted (>= file 0) (< file 8))
 112           (let ((piece (chess-pos-piece position
 113                                         (chess-rf-to-index rank file)))
 114                 begin)
 115             (if (= file (if inverted 7 0))
 116                 (insert (format "    %d " (1+ (- 7 rank)))))
 117             (insert "| ")
 118             (setq begin (1- (point)))
 119             (insert (chess-ics1-piece-text piece) ? )
 120             (add-text-properties begin (point)
 121                                  (list 'chess-coord
 122                                        (chess-rf-to-index rank file))))
 123           (setq file (if inverted (1- file) (1+ file))))
 124         (insert "|\n")
 125         (setq file (if inverted 7 0)
 126               rank (if inverted (1- rank) (1+ rank))))
 127       (insert "      +---+---+---+---+---+---+---+---+\n")
 128       (if inverted
 129           (insert "        h   g   f   e   d   c   b   a\n\n")
 130         (insert "        a   b   c   d   e   f   g   h\n\n")))
 131     (set-buffer-modified-p nil)
 132     (goto-char pos)))
 133
 134 (defun chess-ics1-highlight (index &optional mode)
 135   (let ((pos (chess-display-index-pos nil index)))
 136     (put-text-property pos (save-excursion
 137                              (goto-char pos)
 138                              (skip-chars-forward "^|")
 139                              (point))
 140                        'face (cond
 141                               ((eq mode :selected)
 142                                'chess-ics1-highlight-face)
 143                               (t
 144                                (chess-display-get-face mode))))))
 145
 146 (defun chess-debug-position (&optional position)
 147   "This is a debugging function, and not meant from general use."
 148   (interactive)
 149   (let ((pos (or position (chess-engine-position nil))))
 150     (with-current-buffer (get-buffer-create "*scratch*")
 151       (chess-ics1-draw pos t)
 152       (funcall chess-ics1-popup-function))))
 153
 154 (provide 'chess-ics1)
 155
 156 ;;; chess-ics1.el ends here