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

   1 ;;; chess-input.el --- Keyboard entry of algebraic notation, using shortcut notation
   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 is free software; you can redistribute it and/or modify it under
  10 ;; the terms of the GNU General Public License as published by the Free
  11 ;; Software Foundation; either version 3, or (at your option) any later
  12 ;; version.
  13 ;;
  14 ;; This is distributed in the hope that it will be useful, but WITHOUT
  15 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 ;; for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; This scheme was adapted from the way SCID (<http://scid.sourceforge.net/>),
  25 ;; by Shane Hudson, behaves.  It is based on standard algebraic notation.
  26 ;; You do not need to type all characters from the corresponding SAN of a move,
  27 ;; chess-input will automatically pick the move once it is unambiguous.
  28 ;;
  29 ;; Additionally, optional characters from SAN are treated as such.
  30 ;; You do not need to type x or =, although you can, if you prefer to.
  31 ;; For instance, "bxc8=N#" can be selected by typing `b c 8 n'.
  32
  33 ;;; Code:
  34
  35 (require 'chess-algebraic)
  36 (require 'chess-ply)
  37 (require 'chess-pos)
  38
  39 (defvar chess-input-move-string "")
  40 (defvar chess-input-moves-pos nil)
  41 (defvar chess-input-moves nil)
  42 (defvar chess-input-position-function nil)
  43 (defvar chess-input-move-function nil)
  44
  45 (make-variable-buffer-local 'chess-input-move-string)
  46 (make-variable-buffer-local 'chess-input-moves-pos)
  47 (make-variable-buffer-local 'chess-input-moves)
  48 (make-variable-buffer-local 'chess-input-position-function)
  49 (make-variable-buffer-local 'chess-input-move-function)
  50
  51 (defgroup chess-input nil
  52   "Move input related otpions."
  53   :group 'chess)
  54
  55 (defcustom chess-input-notation-type :san
  56   "Define the notation type to use for move input."
  57   :group 'chess-input
  58   :type '(choice (const :tag "Standard (short) algebraic notation" :san)
  59                  (const :tag "Numeric notation" :numeric)))
  60
  61 (defun chess-input-test-move (ply)
  62   "Return the given PLY if it matches the user's current input."
  63   (let* ((move (chess-ply-to-algebraic ply chess-input-notation-type))
  64          (i 0) (x 0) (l (length move))
  65          (xl (length chess-input-move-string)))
  66     (unless (or (and (equal (downcase chess-input-move-string) "ok")
  67                      (chess-ply-keyword ply :castle))
  68                 (and (equal (downcase chess-input-move-string) "oq")
  69                      (chess-ply-keyword ply :long-castle)))
  70       (while (and (< i l) (< x xl))
  71         (let ((move-char (aref move i))
  72               (entry-char (aref chess-input-move-string x)))
  73           (cond ((or (and (= move-char ?x) (/= entry-char ?x))
  74                      (and (= move-char ?=) (/= entry-char ?=)))
  75                  (setq i (1+ i)))
  76                 ((/= entry-char (if (< entry-char ?a)
  77                                     move-char
  78                                   (downcase move-char)))
  79                  (setq ply nil i l))
  80                 (t (setq i (1+ i) x (1+ x)))))))
  81     ply))
  82
  83 (defvar chess-display-highlight-legal nil)
  84 (declare-function chess-display-redraw "chess-display" (&optional display))
  85 (declare-function chess-display-highlight "chess-display" (display &rest args))
  86
  87 (defun chess-input-display-moves (&optional move-list)
  88   (unless move-list
  89     (setq move-list
  90           (delq nil (mapcar #'chess-input-test-move (cdr chess-input-moves)))))
  91   (when chess-display-highlight-legal
  92     (chess-display-redraw nil))
  93   (when (> (length chess-input-move-string) 0)
  94     (when chess-display-highlight-legal
  95       (apply #'chess-display-highlight
  96              nil (delete-dups (mapcar #'chess-ply-target move-list))))
  97     (message "[%s] %s" chess-input-move-string
  98              (mapconcat (lambda (ply)
  99                           (chess-ply-to-algebraic ply chess-input-notation-type))
 100                         move-list " "))))
 101
 102 (defun chess-input-shortcut-delete ()
 103   (interactive)
 104   (when (and chess-input-move-string
 105              (stringp chess-input-move-string)
 106              (> (length chess-input-move-string) 0))
 107     (setq chess-input-move-string
 108           (substring chess-input-move-string 0 (1- (length chess-input-move-string))))
 109     (chess-input-display-moves)))
 110
 111 (defun chess-input-shortcut (&optional display-only)
 112   (interactive)
 113   (let* ((position (funcall chess-input-position-function))
 114          (color (chess-pos-side-to-move position))
 115          char)
 116     (unless (memq last-command '(chess-input-shortcut
 117                                  chess-input-shortcut-delete))
 118       (setq chess-input-move-string nil))
 119     (unless display-only
 120       (setq chess-input-move-string
 121             (concat chess-input-move-string
 122                     (char-to-string last-command-event))))
 123     (unless (and chess-input-moves
 124                  (eq position chess-input-moves-pos)
 125                  (or (> (length chess-input-move-string) 1)
 126                      (eq (car chess-input-moves) last-command-event)))
 127       (setq char (if (eq (downcase last-command-event) ?o)
 128                      ?k
 129                    last-command-event))
 130       (if (or (memq (upcase char) '(?K ?Q ?N ?B ?R ?P))
 131               (and (>= char ?a) (<= char ?h))
 132               (and (>= char ?1) (<= char ?8)))
 133           (setq chess-input-moves-pos position
 134                 chess-input-moves
 135                 (cons
 136                  char
 137                  (sort
 138                   (cond ((eq char ?b)
 139                          (nconc (chess-legal-plies
 140                                  position :piece (if color ?P ?p) :file 1)
 141                                 (chess-legal-plies
 142                                  position :piece (if color ?B ?b))))
 143                         ((and (>= char ?a) (<= char ?h))
 144                          (chess-legal-plies
 145                           position :piece (if color ?P ?p)
 146                           :file (chess-file-from-char char)))
 147                         ((and (>= char ?1) (<= char ?8))
 148                          (chess-legal-plies
 149                           position :color color :file (- char ?1)))
 150                         (t (chess-legal-plies
 151                             position :piece (if color
 152                                                 (upcase char)
 153                                               (downcase char)))))
 154                   (lambda (left right)
 155                     (string-lessp (chess-ply-to-algebraic left)
 156                                   (chess-ply-to-algebraic right)))))))))
 157   (let ((moves (delq nil (mapcar #'chess-input-test-move
 158                                  (cdr chess-input-moves)))))
 159     (cond ((or (= (length moves) 1)
 160                ;; if there is an exact match except for case, it must be an
 161                ;; abiguity between a bishop and a b-pawn move.  In this
 162                ;; case, always take the b-pawn move; to select the bishop
 163                ;; move, use B to begin the keyboard shortcut
 164                (and (= (length moves) 2)
 165                     (string= (downcase (chess-ply-to-algebraic (car moves)))
 166                              (downcase (chess-ply-to-algebraic (cadr moves))))
 167                     (setq moves (cdr moves))))
 168            (funcall chess-input-move-function nil (car moves))
 169            (when chess-display-highlight-legal
 170              (chess-display-redraw nil))
 171            (setq chess-input-move-string nil
 172                  chess-input-moves nil
 173                  chess-input-moves-pos nil))
 174
 175           ((null moves)
 176            (chess-input-shortcut-delete))
 177
 178           (t (chess-input-display-moves moves)))))
 179
 180 (provide 'chess-input)
 181
 182 ;;; chess-input.el ends here