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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Keyboard entry of algebraic notation, using shortcut notation
   4 ;;
   5 ;; This scheme was adapted from the way SCID
   6 ;; (http://scid.sourceforge.net), by Shane Hudson, behaves.  It's the
   7 ;; only way to move your pieces around!
   8 ;;
   9
  10 (defvar chess-input-move-string "")
  11 (defvar chess-input-moves-pos nil)
  12 (defvar chess-input-moves nil)
  13 (defvar chess-input-position-function nil)
  14 (defvar chess-input-move-function nil)
  15
  16 (make-variable-buffer-local 'chess-input-move-string)
  17 (make-variable-buffer-local 'chess-input-moves-pos)
  18 (make-variable-buffer-local 'chess-input-moves)
  19 (make-variable-buffer-local 'chess-input-position-function)
  20 (make-variable-buffer-local 'chess-input-move-function)
  21
  22 (defun chess-input-test-move (move-ply)
  23   "Return the given MOVE if it matches the user's current input."
  24   (let* ((move (cdr move-ply))
  25          (i 0) (x 0) (l (length move))
  26          (xl (length chess-input-move-string))
  27          (match t))
  28     (unless (or (and (equal (downcase chess-input-move-string) "ok")
  29                      (string-match "\\`O-O[+#]?\\'" move))
  30                 (and (equal (downcase chess-input-move-string) "oq")
  31                      (string-match "\\`O-O-O[+#]?\\'" move)))
  32       (while (and (< i l) (< x xl))
  33         (let ((move-char (aref move i))
  34               (entry-char (aref chess-input-move-string x)))
  35           (if (and (= move-char ?x)
  36                    (/= entry-char ?x))
  37               (setq i (1+ i))
  38             (if (/= entry-char (if (< entry-char ?a)
  39                                    move-char
  40                                  (downcase move-char)))
  41                 (setq match nil i l)
  42               (setq i (1+ i) x (1+ x)))))))
  43     (if match
  44         move-ply)))
  45
  46 (defsubst chess-input-display-moves (&optional move-list)
  47   (if (> (length chess-input-move-string) 0)
  48       (message "[%s] %s" chess-input-move-string
  49                (mapconcat 'cdr
  50                           (or move-list
  51                               (delq nil (mapcar 'chess-input-test-move
  52                                                 (cdr chess-input-moves))))
  53                           " "))))
  54
  55 (defun chess-input-shortcut-delete ()
  56   (interactive)
  57   (when (and chess-input-move-string
  58              (stringp chess-input-move-string)
  59              (> (length chess-input-move-string) 0))
  60     (setq chess-input-move-string
  61           (substring chess-input-move-string 0 (1- (length chess-input-move-string))))
  62     (chess-input-display-moves)))
  63
  64 (defun chess-input-shortcut (&optional display-only)
  65   (interactive)
  66   (let* ((position (funcall chess-input-position-function))
  67          (color (chess-pos-side-to-move position))
  68          char)
  69     (unless (memq last-command '(chess-input-shortcut
  70                                  chess-input-shortcut-delete))
  71       (setq chess-input-move-string nil))
  72     (unless display-only
  73       (setq chess-input-move-string
  74             (concat chess-input-move-string (char-to-string last-command-char))))
  75     (unless (and chess-input-moves
  76                  (eq position chess-input-moves-pos)
  77                  (or (> (length chess-input-move-string) 1)
  78                      (eq (car chess-input-moves) last-command-char)))
  79       (setq char (if (eq (downcase last-command-char) ?o) ?k
  80                    last-command-char)
  81             chess-input-moves-pos position
  82             chess-input-moves
  83             (cons char
  84                   (sort
  85                    (mapcar
  86                     (function
  87                      (lambda (ply)
  88                        (cons ply (chess-ply-to-algebraic ply))))
  89                     (if (eq char ?b)
  90                         (append (chess-legal-plies
  91                                  position :piece (if color ?P ?p) :file 1)
  92                                 (chess-legal-plies
  93                                  position :piece (if color ?B ?b)))
  94                       (if (and (>= char ?a)
  95                                (<= char ?h))
  96                           (chess-legal-plies position
  97                                              :piece (if color ?P ?p)
  98                                              :file (- char ?a))
  99                         (chess-legal-plies position
 100                                            :piece (if color
 101                                                       (upcase char)
 102                                                     (downcase char))))))
 103                    (function
 104                     (lambda (left right)
 105                       (string-lessp (cdr left) (cdr right)))))))))
 106   (let ((moves (delq nil (mapcar 'chess-input-test-move
 107                                  (cdr chess-input-moves)))))
 108     (cond
 109      ((or (= (length moves) 1)
 110           ;; if there is an exact match except for case, it must be an
 111           ;; abiguity between a bishop and a b-pawn move.  In this
 112           ;; case, always take the b-pawn move; to select the bishop
 113           ;; move, use B to begin the keyboard shortcut
 114           (and (= (length moves) 2)
 115                (string= (downcase (cdr (car moves)))
 116                         (downcase (cdr (cadr moves))))
 117                (setq moves (cdr moves))))
 118       (funcall chess-input-move-function nil (caar moves))
 119       (setq chess-input-move-string nil
 120             chess-input-moves nil
 121             chess-input-moves-pos nil))
 122      ((null moves)
 123       (chess-input-shortcut-delete))
 124      (t
 125       (chess-input-display-moves moves)))))
 126
 127 (provide 'chess-input)
 128
 129 ;;; chess-input.el ends here