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