1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;; Routines for manipulating chess positions
8 ;; A chess `position' is a vector that starts with sixty-four
9 ;; characters, representing the 8x8 grid of a chess position. Each
10 ;; position may contain p, r, n, b, k, q or <space>, or any of the
11 ;; previous letters in uppercase. Uppercase signifies white, and
12 ;; lowercase means black.
14 ;; Creating a new position can be done with:
17 ;; (chess-pos-copy POSITION)
19 ;; To setup the chess board at an aritrary position, manipulate the
20 ;; position that has been returned to you, or use a position input
23 ;; Once you have a chess position, there are several things you can do
24 ;; with it. First of all, a coordinate system of octal indices is
25 ;; used, where ?\044 signifies rank 4 file 4 (i.e., "e4"). Rank is
26 ;; numbered 0 to 7, top to bottom, and file is 0 to 7, left to right.
27 ;; For those who wish to use ASCII coordinates, such as "e4", there
28 ;; are two conversion functions:
30 ;; (chess-coord-to-index STRING)
31 ;; (chess-index-to-coord INDEX)
33 ;; With an octal index value, you can look up what's on a particular
34 ;; square, or set that square's value:
36 ;; (chess-pos-piece POSITION INDEX)
37 ;; (chess-pos-set-piece POSITION INDEX PIECE)
39 ;; PIECE must be one of the letters mentioned above (in upper or
40 ;; lowercase), or a space to represent a blank square.
42 ;; To test whether a piece is at a particular position, use:
44 ;; (chess-pos-piece-p POSITION INDEX PIECE)
46 ;; PIECE may also be t for any white piece, nil for any black piece,
47 ;; or the symbol `any', which returns t if the square is not empty.
49 ;; You can hunt for all occurances of a certain piece using:
51 ;; (chess-pos-search POSITION PIECE)
53 ;; You might also try the `search' event, which employs the
54 ;; intelligence of listening rules modules to search out your piece
55 ;; according to legal piece movements.
57 ;; Once you have a pair of indices, you can move a piece around:
59 ;; (chess-pos-move POSITION FROM-INDEX TO-INDEX)
61 ;; NOTE This is not the safe way for users to move pieces around!
62 ;; This function moves pieces DIRECTLY, without checking for legality,
63 ;; or informing listening modules of the move. To make an "official"
66 ;; (chess-move FROM-INDEX TO-INDEX)
68 ;; This will publish the move to all listening modules, which can then
69 ;; handle the move event as they wish.
73 (require 'chess-message)
77 (cl-proclaim '(optimize (speed 3) (safety 2))))
79 (defgroup chess-pos nil
80 "Routines for manipulating chess positions."
83 (defvar chess-pos-always-white nil
84 "When set, it is assumed that white is always on move.
85 This is really only useful when setting up training positions.
86 This variable automatically becomes buffer-local when changed.")
88 (make-variable-buffer-local 'chess-pos-always-white)
90 (defconst chess-starting-position
91 [;; the eight ranks and files of the chess position
92 ?r ?n ?b ?q ?k ?b ?n ?r
93 ?p ?p ?p ?p ?p ?p ?p ?p
94 ? ? ? ? ? ? ? ? ; spaces are blanks!
95 ? ? ? ? ? ? ? ? ; here too
96 ? ? ? ? ? ? ? ? ; protect from whitespace-cleanup
97 ? ? ? ? ? ? ? ? ; so have a comment afterwards
98 ?P ?P ?P ?P ?P ?P ?P ?P
99 ?R ?N ?B ?Q ?K ?B ?N ?R
100 ;; index of pawn that can be captured en passant
102 ;; can white and black castle on king or queen side?
103 ?\077 ?\070 ?\007 ?\000
104 ;; is the side to move in: `check', `checkmate', `stalemate'
106 ;; which color is it to move next?
108 ;; list of annotations for this position. Textual annotations are
109 ;; simply that, while lists represent interesting variations.
111 ;; where are the kings?
113 ;; a pointer to the ply which led to this position
115 "Starting position of a regular chess game.")
117 (chess-message-catalog 'english
118 '((chess-nag-1 . "good move [traditional \"!\"]")
119 (chess-nag-2 . "poor move [traditional \"?\"]")
120 (chess-nag-3 . "very good move (traditional \"!!\"")
121 (chess-nag-4 . "very poor move (traditional \"??\")")
122 (chess-nag-5 . "speculative move (traditional \"!?\")")
123 (chess-nag-6 . "questionable move (traditional \"?!\")")
124 (chess-nag-7 . "forced move (all others lose quickly)")
125 (chess-nag-8 . "singular move (no reasonable alternatives)")
126 (chess-nag-9 . "worst move")
127 (chess-nag-10 . "drawish position")
128 (chess-nag-11 . "equal chances, quiet position")
129 (chess-nag-12 . "equal chances, active position")
130 (chess-nag-13 . "unclear position")
131 (chess-nag-14 . "White has a slight advantage")
132 (chess-nag-15 . "Black has a slight advantage")
133 (chess-nag-16 . "White has a moderate advantage")
134 (chess-nag-17 . "Black has a moderate advantage")
135 (chess-nag-18 . "White has a decisive advantage")
136 (chess-nag-19 . "Black has a decisive advantage")
137 (chess-nag-20 . "White has a crushing advantage (Black should resign)")
138 (chess-nag-21 . "Black has a crushing advantage (White should resign)")
139 (chess-nag-22 . "White is in zugzwang")
140 (chess-nag-23 . "Black is in zugzwang")
141 (chess-nag-24 . "White has a slight space advantage")
142 (chess-nag-25 . "Black has a slight space advantage")
143 (chess-nag-26 . "White has a moderate space advantage")
144 (chess-nag-27 . "Black has a moderate space advantage")
145 (chess-nag-28 . "White has a decisive space advantage")
146 (chess-nag-29 . "Black has a decisive space advantage")
147 (chess-nag-30 . "White has a slight time (development) advantage")
148 (chess-nag-31 . "Black has a slight time (development) advantage")
149 (chess-nag-32 . "White has a moderate time (development) advantage")
150 (chess-nag-33 . "Black has a moderate time (development) advantage")
151 (chess-nag-34 . "White has a decisive time (development) advantage")
152 (chess-nag-35 . "Black has a decisive time (development) advantage")
153 (chess-nag-36 . "White has the initiative")
154 (chess-nag-37 . "Black has the initiative")
155 (chess-nag-38 . "White has a lasting initiative")
156 (chess-nag-39 . "Black has a lasting initiative")
157 (chess-nag-40 . "White has the attack")
158 (chess-nag-41 . "Black has the attack")
159 (chess-nag-42 . "White has insufficient compensation for material deficit")
160 (chess-nag-43 . "Black has insufficient compensation for material deficit")
161 (chess-nag-44 . "White has sufficient compensation for material deficit")
162 (chess-nag-45 . "Black has sufficient compensation for material deficit")
163 (chess-nag-46 . "White has more than adequate compensation for material deficit")
164 (chess-nag-47 . "Black has more than adequate compensation for material deficit")
165 (chess-nag-48 . "White has a slight center control advantage")
166 (chess-nag-49 . "Black has a slight center control advantage")
167 (chess-nag-50 . "White has a moderate center control advantage")
168 (chess-nag-51 . "Black has a moderate center control advantage")
169 (chess-nag-52 . "White has a decisive center control advantage")
170 (chess-nag-53 . "Black has a decisive center control advantage")
171 (chess-nag-54 . "White has a slight kingside control advantage")
172 (chess-nag-55 . "Black has a slight kingside control advantage")
173 (chess-nag-56 . "White has a moderate kingside control advantage")
174 (chess-nag-57 . "Black has a moderate kingside control advantage")
175 (chess-nag-58 . "White has a decisive kingside control advantage")
176 (chess-nag-59 . "Black has a decisive kingside control advantage")
177 (chess-nag-60 . "White has a slight queenside control advantage")
178 (chess-nag-61 . "Black has a slight queenside control advantage")
179 (chess-nag-62 . "White has a moderate queenside control advantage")
180 (chess-nag-63 . "Black has a moderate queenside control advantage")
181 (chess-nag-64 . "White has a decisive queenside control advantage")
182 (chess-nag-65 . "Black has a decisive queenside control advantage")
183 (chess-nag-66 . "White has a vulnerable first rank")
184 (chess-nag-67 . "Black has a vulnerable first rank")
185 (chess-nag-68 . "White has a well protected first rank")
186 (chess-nag-69 . "Black has a well protected first rank")
187 (chess-nag-70 . "White has a poorly protected king")
188 (chess-nag-71 . "Black has a poorly protected king")
189 (chess-nag-72 . "White has a well protected king")
190 (chess-nag-73 . "Black has a well protected king")
191 (chess-nag-74 . "White has a poorly placed king")
192 (chess-nag-75 . "Black has a poorly placed king")
193 (chess-nag-76 . "White has a well placed king")
194 (chess-nag-77 . "Black has a well placed king")
195 (chess-nag-78 . "White has a very weak pawn structure")
196 (chess-nag-79 . "Black has a very weak pawn structure")
197 (chess-nag-80 . "White has a moderately weak pawn structure")
198 (chess-nag-81 . "Black has a moderately weak pawn structure")
199 (chess-nag-82 . "White has a moderately strong pawn structure")
200 (chess-nag-83 . "Black has a moderately strong pawn structure")
201 (chess-nag-84 . "White has a very strong pawn structure")
202 (chess-nag-85 . "Black has a very strong pawn structure")
203 (chess-nag-86 . "White has poor knight placement")
204 (chess-nag-87 . "Black has poor knight placement")
205 (chess-nag-88 . "White has good knight placement")
206 (chess-nag-89 . "Black has good knight placement")
207 (chess-nag-90 . "White has poor bishop placement")
208 (chess-nag-91 . "Black has poor bishop placement")
209 (chess-nag-92 . "White has good bishop placement")
210 (chess-nag-93 . "Black has good bishop placement")
211 (chess-nag-84 . "White has poor rook placement")
212 (chess-nag-85 . "Black has poor rook placement")
213 (chess-nag-86 . "White has good rook placement")
214 (chess-nag-87 . "Black has good rook placement")
215 (chess-nag-98 . "White has poor queen placement")
216 (chess-nag-99 . "Black has poor queen placement")
217 (chess-nag-100 . "White has good queen placement")
218 (chess-nag-101 . "Black has good queen placement")
219 (chess-nag-102 . "White has poor piece coordination")
220 (chess-nag-103 . "Black has poor piece coordination")
221 (chess-nag-104 . "White has good piece coordination")
222 (chess-nag-105 . "Black has good piece coordination")
223 (chess-nag-106 . "White has played the opening very poorly")
224 (chess-nag-107 . "Black has played the opening very poorly")
225 (chess-nag-108 . "White has played the opening poorly")
226 (chess-nag-109 . "Black has played the opening poorly")
227 (chess-nag-110 . "White has played the opening well")
228 (chess-nag-111 . "Black has played the opening well")
229 (chess-nag-112 . "White has played the opening very well")
230 (chess-nag-113 . "Black has played the opening very well")
231 (chess-nag-114 . "White has played the middlegame very poorly")
232 (chess-nag-115 . "Black has played the middlegame very poorly")
233 (chess-nag-116 . "White has played the middlegame poorly")
234 (chess-nag-117 . "Black has played the middlegame poorly")
235 (chess-nag-118 . "White has played the middlegame well")
236 (chess-nag-119 . "Black has played the middlegame well")
237 (chess-nag-120 . "White has played the middlegame very well")
238 (chess-nag-121 . "Black has played the middlegame very well")
239 (chess-nag-122 . "White has played the ending very poorly")
240 (chess-nag-123 . "Black has played the ending very poorly")
241 (chess-nag-124 . "White has played the ending poorly")
242 (chess-nag-125 . "Black has played the ending poorly")
243 (chess-nag-126 . "White has played the ending well")
244 (chess-nag-127 . "Black has played the ending well")
245 (chess-nag-128 . "White has played the ending very well")
246 (chess-nag-129 . "Black has played the ending very well")
247 (chess-nag-130 . "White has slight counterplay")
248 (chess-nag-131 . "Black has slight counterplay")
249 (chess-nag-132 . "White has moderate counterplay")
250 (chess-nag-133 . "Black has moderate counterplay")
251 (chess-nag-134 . "White has decisive counterplay")
252 (chess-nag-135 . "Black has decisive counterplay")
253 (chess-nag-136 . "White has moderate time control pressure")
254 (chess-nag-137 . "Black has moderate time control pressure")
255 (chess-nag-138 . "White has severe time control pressure")
256 (chess-nag-139 . "Black has severe time control pressure")))
258 (defsubst chess-pos-piece (position index)
259 "Return the piece on POSITION at INDEX."
260 (cl-assert (vectorp position))
261 (cl-assert (and (>= index 0) (< index 64)))
262 (aref position index))
264 (defsubst chess-pos-piece-p (position index piece-or-color)
265 "Return non-nil if at POSITION/INDEX there is the given PIECE-OR-COLOR.
266 If PIECE-OR-COLOR is t for white or nil for black, any piece of that
268 (cl-assert (vectorp position))
269 (cl-assert (and (>= index 0) (< index 64)))
270 (cl-assert (memq piece-or-color
271 '(t nil ? ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p)))
272 (let ((p (chess-pos-piece position index)))
274 ((= p ? ) (eq p piece-or-color))
275 ((eq piece-or-color t) (< p ?a))
276 ((eq piece-or-color nil) (> p ?a))
277 (t (= p piece-or-color)))))
279 (defsubst chess-rf-to-index (rank file)
280 "Convert RANK and FILE coordinates into an octal index."
281 (cl-check-type rank (integer 0 7))
282 (cl-check-type file (integer 0 7))
285 (defsubst chess-coord-to-index (coord)
286 "Convert a COORD string into an index value."
287 (cl-assert (stringp coord))
288 (cl-assert (= (length coord) 2))
289 (+ (* 8 (- 7 (- (aref coord 1) ?1)))
290 (- (aref coord 0) ?a)))
292 (defsubst chess-index-to-coord (index)
293 "Convert the chess position INDEX into a coord string."
294 (cl-assert (and (>= index 0) (< index 64)))
295 (concat (char-to-string (+ (mod index 8) ?a))
296 (char-to-string (+ (- 7 (/ index 8)) ?1))))
298 (defsubst chess-index-rank (index)
299 "Return the rank component of the given INDEX."
300 (cl-assert (and (>= index 0) (< index 64)))
303 (defsubst chess-index-file (index)
304 "Return the file component of the given INDEX."
305 (cl-assert (and (>= index 0) (< index 64)))
308 (defsubst chess-incr-index (index rank-move file-move)
309 "Create a new INDEX from an old one, by adding RANK-MOVE and FILE-MOVE."
310 (cl-assert (and (>= index 0) (< index 64)))
311 (cl-assert (and (>= rank-move -7) (<= rank-move 7)))
312 (cl-assert (and (>= file-move -7) (<= file-move 7)))
313 (let ((newrank (+ (chess-index-rank index) rank-move))
314 (newfile (+ (chess-index-file index) file-move)))
315 (if (and (>= newrank 0) (< newrank 8)
316 (>= newfile 0) (< newfile 8))
317 (chess-rf-to-index newrank newfile))))
319 (defsubst chess-incr-index* (index rank-move file-move)
320 "Create a new INDEX from an old one, by adding RANK-MOVE and FILE-MOVE.
321 This differs from `chess-incr-index' by performing no safety checks,
322 in order to execute faster."
323 (cl-assert (and (>= index 0) (< index 64)))
324 (cl-assert (and (>= rank-move -7) (<= rank-move 7)))
325 (cl-assert (and (>= file-move -7) (<= file-move 7)))
326 (chess-rf-to-index (+ (chess-index-rank index) rank-move)
327 (+ (chess-index-file index) file-move)))
329 (defsubst chess-pos-search (position piece-or-color)
330 "Look on POSITION anywhere for PIECE-OR-COLOR, returning all coordinates.
331 If PIECE-OR-COLOR is t for white or nil for black, any piece of that
333 (cl-assert (vectorp position))
334 (cl-assert (memq piece-or-color
335 '(t nil ? ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p)))
338 (if (chess-pos-piece-p position i piece-or-color)
342 (defsubst chess-pos-set-king-index (position color index)
343 "Set the known index of the king on POSITION for COLOR, to INDEX.
344 It is never necessary to call this function."
345 (cl-assert (vectorp position))
346 (cl-assert (memq color '(nil t)))
347 (cl-assert (and (>= index 0) (< index 64)))
348 (aset position (if color 72 73) index))
350 (defsubst chess-pos-king-index (position color)
351 "Return the index on POSITION of the king.
352 If COLOR is non-nil, return the position of the white king, otherwise
353 return the position of the black king."
354 (cl-assert (vectorp position))
355 (cl-assert (memq color '(nil t)))
356 (or (aref position (if color 72 73))
357 (chess-pos-set-king-index position color
358 (chess-pos-search position (if color ?K ?k)))))
360 (defsubst chess-pos-set-piece (position index piece)
361 "Set the piece on POSITION at INDEX to PIECE.
362 PIECE must be one of K Q N B R or P. Use lowercase to set black
364 (cl-assert (vectorp position))
365 (cl-assert (and (>= index 0) (< index 64)))
366 (cl-assert (memq piece '(? ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p)))
367 (aset position index piece)
369 (chess-pos-set-king-index position t index)
371 (chess-pos-set-king-index position nil index))))
373 (defun chess-pos-can-castle (position side)
374 "Return whether the king on POSITION can castle on SIDE.
375 SIDE must be either ?K for the kingside, or ?Q for the queenside (use
376 lowercase to query if black can castle)."
377 (cl-assert (vectorp position))
378 (cl-assert (memq side '(?K ?Q ?k ?q)))
379 (let* ((index (+ 65 (if (< side ?a)
381 (if (= side ?k) 2 3))))
382 (value (aref position index)))
383 (if (or (eq value nil) (integerp value))
385 (when (chess-pos-king-index position (< side ?a))
386 (let* ((color (< side ?a))
387 (long (= ?Q (upcase side)))
389 (king-file (chess-index-file
390 (chess-pos-king-index position color)))
392 (while (funcall (if long '< '>) file king-file)
393 (let ((index (chess-rf-to-index (if color 7 0) file)))
394 (if (chess-pos-piece-p position index (if color ?R ?r))
395 (setq rook index file king-file)
396 (setq file (funcall (if long '1+ '1-) file)))))
397 (aset position index rook))))))
399 (defsubst chess-pos-set-can-castle (position side value)
400 "Set whether the king can castle on the given POSITION on SIDE.
402 See `chess-pos-can-castle'.
404 It is only necessary to call this function if setting up a position
405 manually. Note that all newly created positions have full castling
406 priveleges set, unless the position is created blank, in which case
407 castling priveleges are unset. See `chess-pos-copy'."
408 (cl-assert (vectorp position))
409 (cl-assert (memq side '(?K ?Q ?k ?q)))
410 (cl-assert (memq value '(nil t)))
411 (aset position (+ 65 (if (< side ?a)
413 (if (= side ?k) 2 3))) value))
415 (defsubst chess-pos-en-passant (position)
416 "Return the index of any pawn on POSITION that can be captured en passant.
417 Returns nil if en passant is unavailable."
418 (cl-assert (vectorp position))
421 (defsubst chess-pos-set-en-passant (position index)
422 "Set the index of any pawn on POSITION that can be captured en passant."
423 (cl-assert (vectorp position))
424 (cl-assert (or (eq index nil)
425 (and (>= index 0) (< index 64))))
426 (aset position 64 index))
428 (defsubst chess-pos-status (position)
429 "Return whether the side to move in the POSITION is in a special state.
430 nil is returned if not, otherwise one of the symbols: `check',
431 `checkmate', `stalemate'."
432 (cl-assert (vectorp position))
435 (defsubst chess-pos-set-status (position value)
436 "Set whether the side to move in POSITION is in a special state.
437 VALUE should either be nil, to indicate that the POSITION is normal,
438 or one of the symbols: `check', `checkmate', `stalemate'."
439 (cl-assert (vectorp position))
440 (cl-assert (or (eq value nil) (symbolp value)))
441 (aset position 69 value))
443 (defsubst chess-pos-side-to-move (position)
444 "Return the color whose move it is in POSITION."
445 (cl-assert (vectorp position))
448 (defsubst chess-pos-set-side-to-move (position color)
449 "Set the color whose move it is in POSITION."
450 (cl-assert (vectorp position))
451 (cl-assert (memq color '(nil t)))
452 (aset position 70 color))
454 (defsubst chess-pos-annotations (position)
455 "Return the list of annotations for this position."
456 (cl-assert (vectorp position))
459 (defsubst chess-pos-set-annotations (position annotations)
460 "Return the list of annotations for this position."
461 (cl-assert (vectorp position))
462 (cl-assert (listp annotations))
463 (aset position 71 annotations))
465 (defun chess-pos-add-annotation (position annotation)
466 "Add an annotation for this position."
467 (cl-assert (vectorp position))
468 (cl-assert (or (stringp annotation) (listp annotation)))
469 (let ((ann (chess-pos-annotations position)))
471 (nconc ann (list annotation))
472 (aset position 71 (list annotation)))))
474 (defsubst chess-pos-epd (position opcode)
475 "Return the value of the given EPD OPCODE, or nil if not set."
476 (cl-assert (vectorp position))
478 (cdr (assq opcode (chess-pos-annotations position))))
480 (defun chess-pos-set-epd (position opcode &optional value)
481 "Set the given EPD OPCODE to VALUE, or t if VALUE is not specified."
482 (cl-assert (vectorp position))
484 (let ((entry (assq opcode (chess-pos-annotations position))))
486 (setcdr entry (or value t))
487 (chess-pos-add-annotation position (cons opcode (or value t))))))
489 (defun chess-pos-del-epd (position opcode)
490 "Delete the given EPD OPCODE."
491 (cl-assert (vectorp position))
493 (chess-pos-set-annotations
494 position (assq-delete-all opcode (chess-pos-annotations position))))
496 (defun chess-pos-preceding-ply (position)
497 "Delete the given EPD OPCODE."
498 (cl-assert (vectorp position))
501 (defun chess-pos-set-preceding-ply (position ply)
502 "Delete the given EPD OPCODE."
503 (cl-assert (vectorp position))
504 (cl-assert (listp ply))
505 (aset position 74 ply))
507 (defsubst chess-pos-copy (position)
508 "Copy the given chess POSITION.
509 If there are annotations or EPD opcodes set, these lists are copied as
510 well, so that the two positions do not share the same lists."
511 (cl-assert (vectorp position))
512 (let ((copy (vconcat position)) i)
513 (setq i (chess-pos-annotations position))
514 (if i (chess-pos-set-annotations copy (copy-alist i)))
517 (defsubst chess-pos-create (&optional blank)
518 "Create a new chess position, set at the starting position.
519 If BLANK is non-nil, all of the squares will be empty.
520 The current side-to-move is always white."
522 (vconcat (make-vector 64 ? )
523 [nil nil nil nil nil nil t nil nil nil nil])
524 (chess-pos-copy chess-starting-position)))
526 (defsubst chess-pos-to-string (position &optional full)
527 "Convert the given POSITION into a string.
528 The returned string can be converted back to a position using
529 `chess-pos-from-string'."
530 (cl-assert (vectorp position))
531 (chess-pos-to-fen position full))
533 (defsubst chess-pos-from-string (string)
534 "Convert the given STRING to a chess position.
535 This string should have been created by `chess-pos-to-string'."
536 (cl-assert (stringp string))
537 (chess-fen-to-pos string))
539 (defconst chess-pos-piece-values
547 (defun chess-pos-material-value (position color)
548 "Return the aggregate material value in POSITION for COLOR."
549 (cl-assert (vectorp position))
550 (cl-assert (memq color '(nil t)))
551 (let ((pieces (chess-pos-search position color))
553 (dolist (index pieces)
555 (+ value (cdr (assq (downcase (chess-pos-piece position index))
556 chess-pos-piece-values)))))
559 (defun chess-pos-passed-pawns (position color &optional pawn-indices)
560 "If COLOR has Passed Pawns in POSITION, return a list of their indices.
561 Optionally, if INDICES is non-nil those indices are considered as candidates.
563 A Pawn whose advance to the eighth rank is not blocked by an
564 opposing Pawn in the same file and who does not have to pass one
565 on an adjoining file is called a passed Pawn."
566 (let ((seventh (if color 1 6)) (bias (if color -1 1)) (pawn (if color ?p ?P))
568 (dolist (index (or pawn-indices
569 (chess-pos-search position (if color ?P ?p))) pawns)
570 (if (= (chess-index-rank index) seventh)
572 (let ((file (chess-index-file index)))
573 (if (catch 'passed-pawn
574 (let ((test (chess-incr-index index (if color -1 1) 0)))
575 (while (funcall (if color '>= '<=)
576 (chess-index-rank test) seventh)
577 (if (if (and (> file 0) (< file 7))
578 (or (chess-pos-piece-p position test pawn)
580 position (chess-incr-index test 0 1) pawn)
582 position (chess-incr-index test 0 -1) pawn))
583 (or (chess-pos-piece-p position test pawn)
586 (chess-incr-index test 0 (if (zerop file) 1 -1))
588 (throw 'passed-pawn nil)
589 (setq test (chess-incr-index test (if color -1 1) 0))))
591 (push index pawns)))))))
593 (chess-message-catalog 'english
594 '((move-from-blank . "Attempted piece move from blank square %s")))
596 (defun chess-pos-move (position &rest changes)
597 "Move a piece on the POSITION directly, using the indices in CHANGES.
598 This function does not check any rules, it only makes sure you are not
599 trying to move a blank square."
600 (cl-assert (vectorp position))
601 (cl-assert (listp changes))
602 (cl-assert (> (length changes) 0))
604 (let* ((color (chess-pos-side-to-move position))
605 (can-castle-kingside (chess-pos-can-castle position (if color ?K ?k)))
606 (can-castle-queenside (chess-pos-can-castle position (if color ?Q ?q))))
608 ;; apply the piece movements listed in `changes'
611 (if (symbolp (car ch))
613 (let* ((from (car ch))
615 (piece (chess-pos-piece position from)))
617 (chess-error 'move-from-blank (chess-index-to-coord from))
618 (chess-pos-set-piece position from ? )
619 (chess-pos-set-piece position to piece)))
620 (setq ch (cddr ch)))))
622 ;; now fix up the resulting position
624 ;; if the move was en-passant, remove the captured pawn
625 (if (memq :en-passant changes)
626 (chess-pos-set-piece position
627 (chess-incr-index (cadr changes)
628 (if color 1 -1) 0) ? ))
630 ;; once a piece is moved, en passant is no longer available
631 (chess-pos-set-en-passant position nil)
633 ;; if a king or rook moves, no more castling; also, if a pawn
634 ;; jumps ahead two, mark it en-passantable
635 (unless (symbolp (car changes))
636 (let ((piece (downcase (chess-pos-piece position (cadr changes)))))
639 (chess-pos-set-can-castle position (if color ?K ?k) nil)
640 (chess-pos-set-can-castle position (if color ?Q ?q) nil))
643 (if (and can-castle-queenside
645 can-castle-queenside))
646 (chess-pos-set-can-castle position (if color ?Q ?q) nil)
647 (if (and can-castle-kingside
649 can-castle-kingside))
650 (chess-pos-set-can-castle position (if color ?K ?k) nil))))
652 ((let ((can-castle (chess-pos-can-castle position (if color ?q ?Q))))
653 (and can-castle (= (cadr changes) can-castle)))
654 (chess-pos-set-can-castle position (if color ?q ?Q) nil))
656 ((let ((can-castle (chess-pos-can-castle position (if color ?k ?K))))
657 (and can-castle (= (cadr changes) can-castle)))
658 (chess-pos-set-can-castle position (if color ?k ?K) nil))
661 (> (abs (- (chess-index-rank (cadr changes))
662 (chess-index-rank (car changes)))) 1))
663 (chess-pos-set-en-passant position (cadr changes))))))
665 ;; toggle the side whose move it is
666 (unless chess-pos-always-white
667 (chess-pos-set-side-to-move position (not color)))
669 ;; promote the piece if we were meant to
670 (let ((new-piece (cadr (memq :promote changes))))
672 (chess-pos-set-piece position (cadr changes)
675 (downcase new-piece)))))
677 ;; did we leave the position in check, mate or stalemate?
679 ((memq :check changes)
680 (chess-pos-set-status position :check))
681 ((memq :checkmate changes)
682 (chess-pos-set-status position :checkmate))
683 ((memq :stalemate changes)
684 (chess-pos-set-status position :stalemate))
685 (t (chess-pos-set-status position nil)))
687 ;; return the final position
690 (chess-message-catalog 'english
691 '((piece-unrecognized . "Unrecognized piece identifier")))
697 (defsubst chess--add-candidate (candidate)
700 (push candidate candidates)))
702 (defun chess-search-position (position target piece &optional
703 check-only no-castling)
704 "Look on POSITION from TARGET for a PIECE that can move there.
705 This routine looks along legal paths of movement for PIECE. It
706 differs from `chess-pos-search', which is a more basic function that
707 doesn't take piece movement into account.
709 If PIECE is t or nil, legal piece movements for any piece of that
710 color will be considered (t for white, nil for black). Otherwise, the
711 case of the PIECE determines color.
713 The return value is a list of candidates, which means a list of
714 indices which indicate where a piece may have moved from.
716 If CHECK-ONLY is non-nil and PIECE is either t or nil, only consider
717 pieces which can give check (not the opponents king).
718 If NO-CASTLING is non-nil, do not consider castling moves."
719 (cl-assert (vectorp position))
720 (cl-assert (and (>= target 0) (< target 64)))
721 (cl-assert (memq piece '(t nil ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p)))
722 (let* ((color (if (characterp piece)
725 (bias (if color -1 1))
726 (test-piece (and (characterp piece)
730 ;; if the piece is `t', it means to find the candidates resulting
731 ;; from any piece movement. This is useful for testing whether a
732 ;; king is in check, for example.
733 ((memq piece '(t nil))
734 (dolist (p (if piece '(?P ?R ?N ?B ?Q ?K) '(?p ?r ?n ?b ?q ?k)))
735 (mapc 'chess--add-candidate
736 (chess-search-position position target p check-only))))
738 ;; skip erroneous space requests
741 ;; pawn movement, which is diagonal 1 when taking, but forward
742 ;; 1 or 2 when moving (the most complex piece, actually)
744 (let ((p (chess-pos-piece position target)))
746 ;; check for en passant
747 (and (= (chess-index-rank target) (if color 2 5))
748 ;; make this fail if no en-passant is possible
749 (= (or (chess-pos-en-passant position) 100)
750 (or (chess-incr-index target (if color 1 -1) 0) 200))
751 (or (and (setq pos (chess-incr-index target
753 (chess-pos-piece-p position pos
755 (and (setq pos (chess-incr-index target
757 (chess-pos-piece-p position pos
759 (if color (> p ?a) (< p ?a)))
761 (if (and (setq pos (chess-incr-index target (- bias) -1))
762 (chess-pos-piece-p position pos piece))
763 (chess--add-candidate pos))
764 (if (and (setq pos (chess-incr-index target (- bias) 1))
765 (chess-pos-piece-p position pos piece))
766 (chess--add-candidate pos)))
767 (if (setq pos (chess-incr-index target (- bias) 0))
768 (if (chess-pos-piece-p position pos piece)
769 (chess--add-candidate pos)
770 (if (and (chess-pos-piece-p position pos ? )
771 (= (if color 4 3) (chess-index-rank target))
772 (setq pos (chess-incr-index pos (- bias) 0))
773 (chess-pos-piece-p position pos piece))
774 (chess--add-candidate pos)))))))
776 ;; the rook, bishop and queen are the easiest; just look along
777 ;; rank and file and/or diagonal for the nearest pieces!
778 ((memq test-piece '(?R ?B ?Q))
789 '((-1 -1) (-1 0) (-1 1)
791 (1 -1) (1 0) (1 1)))))
792 ;; up the current file
793 (setq pos (apply 'chess-incr-index target dir))
795 (if (chess-pos-piece-p position pos piece)
797 (chess--add-candidate pos)
799 (setq pos (and (chess-pos-piece-p position pos ? )
800 (apply 'chess-incr-index pos dir)))))
802 ;; test whether the rook can move to the target by castling
803 (if (and (= test-piece ?R) (not no-castling))
805 (if (and (= target (if color ?\075 ?\005))
806 (setq rook (chess-pos-can-castle position
808 (chess-ply-castling-changes position))
809 (chess--add-candidate rook)
810 (if (and (= target (if color ?\073 ?\003))
811 (setq rook (chess-pos-can-castle position
813 (chess-ply-castling-changes position t))
814 (chess--add-candidate rook)))))))
816 ;; the king is a trivial case of the queen, except when castling
818 (let ((dirs '((-1 -1) (-1 0) (-1 1)
820 (1 -1) (1 0) (1 1))))
822 ;; up the current file
823 (setq pos (apply 'chess-incr-index target (car dirs)))
824 (if (and pos (chess-pos-piece-p position pos piece))
826 (chess--add-candidate pos)
828 (setq dirs (cdr dirs))))
830 ;; test whether the king can move to the target by castling
831 (if (and (not no-castling)
832 (or (and (equal target (chess-rf-to-index (if color 7 0) 6))
833 (chess-pos-can-castle position (if color ?K ?k))
834 (chess-ply-castling-changes position))
835 (and (equal target (chess-rf-to-index (if color 7 0) 2))
836 (chess-pos-can-castle position (if color ?Q ?q))
837 (chess-ply-castling-changes position t))))
838 (chess--add-candidate (chess-pos-king-index position color)))))
840 ;; the knight is a zesty little piece; there may be more than
841 ;; one, but at only one possible square in each direction
843 (dolist (dir '((-2 -1) (-2 1)
847 ;; up the current file
848 (if (and (setq pos (apply 'chess-incr-index target dir))
849 (chess-pos-piece-p position pos piece))
850 (chess--add-candidate pos))))
852 (t (chess-error 'piece-unrecognized)))
854 ;; prune from the discovered candidates list any moves which would
855 ;; leave the king in check; castling through check has already
857 (if (and candidates (characterp piece))
859 (chess-pos-legal-candidates position color target
862 ;; return the final list of candidate moves
865 (defun chess-pos-legal-candidates (position color target candidates)
866 "Test if TARGET can legally be reached by any of CANDIDATES.
867 Return the list of candidates that can reach it.
869 CANDIDATES is a list of position indices which indicate the piece to
870 be moved, and TARGET is the index of the location to be moved to.
872 Note: All of the pieces specified by CANDIDATES must be of the same
873 type. Also, it is the callers responsibility to ensure that the piece
874 can legally reach the square in question. This function merely
875 assures that the resulting position is valid (the move does not leave the king
877 (cl-assert (vectorp position))
878 (cl-assert (memq color '(nil t)))
879 (cl-assert (and (>= target 0) (< target 64)))
880 (cl-assert (listp candidates))
881 (cl-assert (> (length candidates) 0))
882 (let ((cand candidates)
883 (piece (chess-pos-piece position (car candidates)))
884 other-piece en-passant-square last-cand king-pos)
888 ;; determine the resulting position
889 (chess-pos-set-piece position (car cand) ? )
890 (setq other-piece (chess-pos-piece position target))
891 (chess-pos-set-piece position target piece)
892 (when (and (= piece (if color ?P ?p))
893 (chess-pos-en-passant position)
894 (= (chess-pos-en-passant position)
895 (chess-incr-index target (if color 1 -1) 0)))
896 (chess-pos-set-piece position
897 (setq en-passant-square
898 (chess-incr-index target
902 ;; find the king (only once if the king isn't moving)
903 (if (or (null king-pos)
904 (memq piece '(?K ?k)))
905 (setq king-pos (chess-pos-king-index position color)))
906 ;; can anybody from the opposite side reach him? if so,
907 ;; drop the candidate
910 (chess-search-position position king-pos
913 (setcdr last-cand (cdr cand))
914 (setq candidates (cdr candidates)))
915 (setq last-cand cand)))
916 ;; return the position to its original state
917 (chess-pos-set-piece position target other-piece)
918 (chess-pos-set-piece position (car cand) piece)
919 (when en-passant-square
920 (chess-pos-set-piece position en-passant-square (if color ?p ?P))))
921 ;; try the next candidate
922 (setq cand (cdr cand)))
927 ;;; chess-pos.el ends here