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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Routines for manipulating chess positions
   4 ;;
   5 ;; $Revision$
   6
   7 ;;; Commentary:
   8
   9 ;; A chess `position' is a vector that starts with sixty-four
  10 ;; characters, representing the 8x8 grid of a chess position.  Each
  11 ;; position may contain p, r, n, b, k, q or <space>, or any of the
  12 ;; previous letters in uppercase.  Uppercase signifies white, and
  13 ;; lowercase means black.
  14 ;;
  15 ;; Creating a new position can be done with:
  16 ;;
  17 ;;   (chess-pos-create)
  18 ;;   (chess-pos-copy POSITION)
  19 ;;
  20 ;; To setup the chess board at an aritrary position, manipulate the
  21 ;; position that has been returned to you, or use a position input
  22 ;; module.
  23
  24 ;; Once you have a chess position, there are several things you can do
  25 ;; with i.  First of all, a coordinate system of octal indices is
  26 ;; used, where ?\044 signifies rank 4 file 4 (i.e., "e4").  Rank is
  27 ;; numbered 0 to 7, top to bottom, and file is 0 to 7, left to right.
  28 ;; For those who wish to use ASCII coordinates, such as "e4", there
  29 ;; are two conversion functions:
  30 ;;
  31 ;;    (chess-coord-to-index STRING)
  32 ;;    (chess-index-to-coord INDEX)
  33
  34 ;; With an octal index value, you can look up what's on a particular
  35 ;; square, or set that square's value:
  36 ;;
  37 ;;    (chess-pos-piece POSITION INDEX)
  38 ;;    (chess-pos-set-piece POSITION INDEX PIECE)
  39 ;;
  40 ;; PIECE must be one of the letters mentioned above (in upper or
  41 ;; lowercase), or a space to represent a blank square.
  42 ;;
  43 ;; To test whether a piece is at a particular position, use:
  44 ;;
  45 ;;    (chess-pos-piece-p POSITION INDEX PIECE)
  46 ;;
  47 ;; PIECE may also be t for any white piece, nil for any black piece,
  48 ;; or the symbol `any', which returns t if the square is not empty.
  49
  50 ;; You can hunt for all occurances of a certain piece using:
  51 ;;
  52 ;;    (chess-pos-search POSITION PIECE)
  53 ;;
  54 ;; You might also try the `search' event, which employs the
  55 ;; intelligence of listening rules modules to search out your piece
  56 ;; according to legal piece movements.
  57
  58 ;; Once you have a pair of indices, you can move a piece around:
  59 ;;
  60 ;;    (chess-pos-move POSITION FROM-INDEX TO-INDEX)
  61 ;;
  62 ;; NOTE This is not the safe way for users to move pieces around!
  63 ;; This function moves pieces DIRECTLY, without checking for legality,
  64 ;; or informing listening modules of the move.  To make an "official"
  65 ;; move, use:
  66 ;;
  67 ;;    (chess-move FROM-INDEX TO-INDEX)
  68 ;;
  69 ;; This will publish the move to all listening modules, which can then
  70 ;; handle the move event as they wish.
  71
  72 ;;; Code:
  73
  74 (defgroup chess-pos nil
  75   "Routines for manipulating chess positions."
  76   :group 'chess)
  77
  78 (defconst chess-starting-position
  79   [;; the eight ranks and files of the chess position
  80    ?r ?n ?b ?q ?k ?b ?n ?r
  81    ?p ?p ?p ?p ?p ?p ?p ?p
  82    ?  ?  ?  ?  ?  ?  ?  ?   ; spaces are blanks!
  83    ?  ?  ?  ?  ?  ?  ?  ?   ; here too
  84    ?  ?  ?  ?  ?  ?  ?  ?   ; protect from whitespace-cleanup
  85    ?  ?  ?  ?  ?  ?  ?  ?   ; so have a comment afterwards
  86    ?P ?P ?P ?P ?P ?P ?P ?P
  87    ?R ?N ?B ?Q ?K ?B ?N ?R
  88    ;; index of pawn that can be captured en passant
  89    nil
  90    ;; can white and black castle on king or queen side?
  91    t t t t
  92    ;; is the side to move in: `check', `checkmate', `stalemate'
  93    nil
  94    ;; which color is it to move next?
  95    t
  96    ;; list of annotations for this position.  Textual annotations are
  97    ;; simply that, while lists represent interesting variations.
  98    nil]
  99   "Starting position of a chess position.")
 100
 101 (defsubst chess-pos-piece (position index)
 102   "Return the piece on POSITION at INDEX."
 103   (aref position index))
 104
 105 (defsubst chess-pos-set-piece (position index piece)
 106   "Set the piece on POSITION at INDEX to PIECE."
 107   (aset position index piece))
 108
 109 (defsubst chess-pos-can-castle (position side)
 110   "Return whether the king can castle on SIDE.
 111 SIDE must be either ?q or ?k (case determines color)."
 112   (aref position (+ 65 (if (< side ?a)
 113                         (if (= side ?K) 0 1)
 114                       (if (= side ?k) 2 3)))))
 115
 116 (defsubst chess-pos-set-can-castle (position side value)
 117   "Set whether the king can castle on SIDE.
 118 SIDE must be either ?q or ?k (case determines color)."
 119   (aset position (+ 65 (if (< side ?a)
 120                         (if (= side ?K) 0 1)
 121                       (if (= side ?k) 2 3))) value))
 122
 123 (defsubst chess-pos-en-passant (position)
 124   "Return index of pawn that can be captured en passant, or nil."
 125   (aref position 64))
 126
 127 (defsubst chess-pos-set-en-passant (position index)
 128   "Set index of pawn that can be captured en passant."
 129   (aset position 64 index))
 130
 131 (defsubst chess-pos-status (position)
 132   "Return whether the side to move is in a special state.
 133 The symbols allowed are: `check', `checkmate', `stalemate'."
 134   (aref position 69))
 135
 136 (defsubst chess-pos-set-status (position value)
 137   "Set whether the side to move is in a special state."
 138   (aset position 69 value))
 139
 140 (defsubst chess-pos-side-to-move (position)
 141   "Return the color whose move it is in POSITION."
 142   (aref position 70))
 143
 144 (defsubst chess-pos-set-side-to-move (position color)
 145   "Set the color whose move it is in POSITION."
 146   (aset position 70 color))
 147
 148 (defsubst chess-pos-annotations (position)
 149   "Return the list of annotations for this position."
 150   (aref position 71))
 151
 152 (defun chess-pos-add-annotation (position annotation)
 153   "Add an annotation for this position."
 154   (let ((ann (chess-pos-annotations position)))
 155     (if ann
 156         (nconc ann (list annotation))
 157       (aset position 71 (list annotation)))))
 158
 159 (defun chess-pos-copy (position)
 160   "Create a new chess position, set at the starting position.
 161 If BLANK is non-nil, all of the squares will be empty.
 162 The current side-to-move is always white."
 163   (let ((copy (make-vector 72 nil)) elem)
 164     (dotimes (i 71)
 165       (setq elem (aref position i))
 166       (aset copy i
 167             (cond
 168              ((listp elem) (copy-alist elem))
 169              ((vectorp elem) (vconcat elem))
 170              (t elem))))
 171     copy))
 172
 173 (defun chess-pos-create (&optional blank)
 174   "Create a new chess position, set at the starting position.
 175 If BLANK is non-nil, all of the squares will be empty.
 176 The current side-to-move is always white."
 177   (if blank
 178       (vconcat (make-vector 64 ? )
 179                [nil t t t t nil t nil])
 180     (chess-pos-copy chess-starting-position)))
 181
 182 (defsubst chess-rf-to-index (rank file)
 183   "Convert RANK and FILE coordinates into an octal index."
 184   (+ (* 8 rank) file))
 185
 186 (defsubst chess-coord-to-index (coord)
 187   "Convert a COORD (ex. e2, f3) into a chess.el index."
 188   (+ (* 8 (- 7 (- (aref coord 1) ?1)))
 189      (- (aref coord 0) ?a)))
 190
 191 (defsubst chess-index-to-coord (index)
 192   "Convert a COORD (ex. e2, f3) into a chess position index."
 193   (concat (char-to-string (+ (mod index 8) ?a))
 194           (char-to-string (+ (- 7 (/ index 8)) ?1))))
 195
 196 (defsubst chess-index-rank (index) (/ index 8))
 197 (defsubst chess-index-file (index) (mod index 8))
 198
 199 (defun chess-add-index (index rank-move file-move)
 200   "Create a new INDEX from an old one, by adding rank-move and file-move."
 201   (let* ((rank (chess-index-rank index))
 202          (file (chess-index-file index))
 203          (newrank (+ rank rank-move))
 204          (newfile (+ file file-move)))
 205     (if (and (>= newrank 0) (< newrank 8)
 206              (>= newfile 0) (< newfile 8))
 207         (chess-rf-to-index newrank newfile))))
 208
 209 (defun chess-pos-piece-p (position index piece-or-color)
 210   "Return non-nil if at POSITION/INDEX there is the given PIECE-OR-COLOR.
 211 If PIECE-OR-COLOR is t for white or nil for black, any piece of that
 212 color will do."
 213   (let ((p (chess-pos-piece position index)))
 214     (cond
 215      ((= p ? ) (= p piece-or-color))
 216      ((eq piece-or-color t) (< p ?a))
 217      ((eq piece-or-color nil) (> p ?a))
 218      (t (= p piece-or-color)))))
 219
 220 (defun chess-pos-search (position piece-or-color)
 221   "Look on POSITION anywhere for PIECE-OR-COLOR, returning all coordinates.
 222 If PIECE-OR-COLOR is t for white or nil for black, any piece of that
 223 color will do."
 224   (let (found)
 225     (dotimes (i 64)
 226       (if (chess-pos-piece-p position i piece-or-color)
 227           (push i found)))
 228     found))
 229
 230 (defun chess-pos-move (position &rest changes)
 231   "Move a piece on the POSITION directly, using the indices FROM and TO.
 232 This function does not check any rules, it only makes sure you are not
 233 trying to move a blank square."
 234   (while changes
 235     (if (symbolp (car changes))
 236         (setq changes nil)
 237       (let* ((from (car changes))
 238              (to (cadr changes))
 239              (piece (chess-pos-piece position from)))
 240         (if (= piece ? )
 241             (error "Attempted piece move from blank square %s" from))
 242         (chess-pos-set-piece position from ? )
 243         (chess-pos-set-piece position to piece))
 244       (setq changes (cddr changes))))
 245   (let ((color (chess-pos-side-to-move position)))
 246
 247     ;; once a piece is moved, en passant is no longer available
 248     (chess-pos-set-en-passant position nil)
 249
 250     ;; if a king or rook moves, no more castling; also, if a pawn
 251     ;; jumps ahead two, mark it en-passantable
 252     (let ((piece (downcase (car changes))))
 253       (cond
 254        ((and (= piece ?k)
 255              (equal (car changes)
 256                     (chess-rf-to-index (if color 7 0) 4)))
 257         (chess-pos-set-can-castle position (if color ?K ?k) nil)
 258         (chess-pos-set-can-castle position (if color ?Q ?q) nil))
 259
 260        ((and (= piece ?r)
 261              (equal (car changes)
 262                     (chess-rf-to-index (if color 7 0) 0)))
 263         (chess-pos-set-can-castle position (if color ?Q ?q) nil))
 264
 265        ((and (= piece ?r)
 266              (equal (car changes)
 267                     (chess-rf-to-index (if color 7 0) 7)))
 268         (chess-pos-set-can-castle position (if color ?K ?k) nil))
 269
 270        ((and (= piece ?p)
 271              (> (abs (- (chess-index-rank (cadr changes))
 272                         (chess-index-rank (car changes)))) 1))
 273         (chess-pos-set-en-passant position (cadr changes)))))
 274
 275     ;; toggle the side whose move it is
 276     (chess-pos-set-side-to-move position (not color))
 277
 278     ;; promote the piece if we were meant to
 279     (let ((new-piece (cadr (assq :promote changes))))
 280       (if new-piece
 281           (chess-pos-set-piece position (cadr changes) new-piece)))
 282
 283     ;; return the final position
 284     position))
 285
 286 (defun chess-search-position (position target piece)
 287   "Look on POSITION from TARGET for a PIECE that can move there.
 288 This routine looks along legal paths of movement for PIECE.  It
 289 differs from `chess-pos-search', which is a more basic function that
 290 doesn't take piece movement into account.
 291
 292 If PIECE is t or nil, legal piece movements for any piece of that
 293 color will be considered (t for white, nil for black).  Otherwise, the
 294 case of the PIECE determines color.
 295
 296 The return value is a list of candidates, which means a list of
 297 indices which indicate where a piece may have moved from."
 298   (let* ((color (if (char-valid-p piece)
 299                     (< piece ?a)
 300                   piece))
 301          (bias (if color -1 1))
 302          p pos candidates)
 303     (cond
 304      ;; if the piece is `t', it means to find the candidates resulting
 305      ;; from any piece movement.  This is useful for testing whether a
 306      ;; king is in check, for example.
 307      ((memq piece '(t nil))
 308       (setq candidates (list t))
 309       (dolist (p '(?P ?R ?N ?B ?K ?Q))
 310         (nconc candidates
 311                (chess-search-position position target
 312                                       (if piece p (downcase p)))))
 313       (setq candidates (cdr candidates)))
 314
 315      ;; pawn movement, which is diagonal 1 when taking, but forward
 316      ;; 1 or 2 when moving (the most complex piece, actually)
 317      ((= (upcase piece) ?P)
 318       (let ((p (chess-pos-piece position target)))
 319         (if (if (= p ? )
 320                 ;; check for en passant
 321                 (and (= (chess-index-rank target) (if color 2 5))
 322                      (setq pos (chess-add-index target bias 0))
 323                      (chess-pos-piece-p position pos (if color ?p ?P))
 324                      ;; make this fail if no en-passant is possible
 325                      (= (or (chess-pos-en-passant position) 100) target)
 326                      (setq candidates (list pos)))
 327               (if color (> p ?a) (< p ?a)))
 328             (let ((cands (list t)))
 329               (setq pos (chess-add-index target (- bias) -1))
 330               (if (and pos (chess-pos-piece-p position pos piece))
 331                   (nconc cands (list pos)))
 332               (setq pos (chess-add-index target (- bias) 1))
 333               (if (and pos (chess-pos-piece-p position pos piece))
 334                   (nconc cands (list pos)))
 335               (if candidates
 336                   (nconc candidates (cdr cands))
 337                 (setq candidates (cdr cands))))
 338           (if (setq pos (chess-add-index target (- bias) 0))
 339               (if (chess-pos-piece-p position pos piece)
 340                   (setq candidates (list pos))
 341                 (when (and (= ?  (chess-pos-piece position pos))
 342                            (= (if color 4 3) (chess-index-rank target)))
 343                   (setq pos (chess-add-index pos (- bias) 0))
 344                   (if (and pos (chess-pos-piece-p position pos piece))
 345                       (setq candidates (list pos)))))))))
 346
 347      ;; the rook, bishop and queen are the easiest; just look along
 348      ;; rank and file and/or diagonal for the nearest pieces!
 349      ((memq (upcase piece) '(?R ?B ?Q))
 350       (setq candidates (list t))
 351       (dolist (dir (cond
 352                     ((= (upcase piece) ?R)
 353                      '(        (-1 0)
 354                        (0 -1)          (0 1)
 355                                (1 0)))
 356                     ((= (upcase piece) ?B)
 357                      '((-1 -1)        (-1 1)
 358
 359                        (1 -1)         (1 1)))
 360                     ((= (upcase piece) ?Q)
 361                      '((-1 -1) (-1 0) (-1 1)
 362                         (0 -1)         (0 1)
 363                         (1 -1)  (1 0)  (1 1)))))
 364         ;; up the current file
 365         (setq pos (apply 'chess-add-index target dir))
 366         (while pos
 367           (if (chess-pos-piece-p position pos piece)
 368               (progn
 369                 (nconc candidates (list pos))
 370                 (setq pos nil))
 371             (if (/= (chess-pos-piece position pos) ? )
 372                 (setq pos nil)
 373               (setq pos (apply 'chess-add-index pos dir))))))
 374       (setq candidates (cdr candidates)))
 375
 376      ;; the king is a trivial case of the queen, except when castling
 377      ((= (upcase piece) ?K)
 378       (let ((dirs '((-1 -1) (-1 0) (-1 1)
 379                      (0 -1)         (0 1)
 380                      (1 -1)  (1 0)  (1 1))))
 381         (while dirs
 382           ;; up the current file
 383           (setq pos (apply 'chess-add-index target (car dirs)))
 384           (if (and pos (chess-pos-piece-p position pos piece))
 385               (setq candidates (list pos) dirs nil)
 386             (setq dirs (cdr dirs)))))
 387       (let ((rank (if color 7 0)))
 388         ;; if we can still castle, then the king and rook are in their
 389         ;; squares; also, make sure that the user is not attempting to
 390         ;; castle through check
 391         (if (and
 392              (null candidates)
 393              (or (and (equal target (chess-rf-to-index rank 6))
 394                       (= (chess-pos-piece position (chess-rf-to-index rank 4))
 395                          (if color ?K ?k))
 396                       (chess-pos-can-castle position (if color ?K ?k))
 397                       (setq pos (chess-rf-to-index rank 5))
 398                       (chess-pos-piece-p position pos ? )
 399                       (not (chess-search-position position pos (not color)))
 400                       (setq pos (chess-rf-to-index rank 6))
 401                       (chess-pos-piece-p position pos ? )
 402                       (not (chess-search-position position pos (not color))))
 403                  (and (equal target (chess-rf-to-index rank 2))
 404                       (= (chess-pos-piece position (chess-rf-to-index rank 4))
 405                          (if color ?K ?k))
 406                       (chess-pos-can-castle position (if color ?Q ?q))
 407                       (setq pos (chess-rf-to-index rank 1))
 408                       (chess-pos-piece-p position pos ? )
 409                       (not (chess-search-position position pos (not color)))
 410                       (setq pos (chess-rf-to-index rank 2))
 411                       (chess-pos-piece-p position pos ? )
 412                       (not (chess-search-position position pos (not color)))
 413                       (setq pos (chess-rf-to-index rank 3))
 414                       (chess-pos-piece-p position pos ? )
 415                       (not (chess-search-position position pos (not color))))))
 416             (setq candidates (list (chess-rf-to-index rank 4))))))
 417
 418      ;; the knight is a zesty little piece; there may be more than
 419      ;; one, but at only one possible square in each direction
 420      ((= (upcase piece) ?N)
 421       (setq candidates (list t))
 422       (dolist (dir '((-2 -1) (-2 1)
 423                      (-1 -2) (-1 2)
 424                       (1 -2)  (1 2)
 425                       (2 -1)  (2 1)))
 426         ;; up the current file
 427         (if (and (setq pos (apply 'chess-add-index target dir))
 428                  (chess-pos-piece-p position pos piece))
 429             (nconc candidates (list pos))))
 430       (setq candidates (cdr candidates)))
 431
 432      (t (error "Unrecognized piece identifier")))
 433
 434     ;; prune from the discovered candidates list any moves which would
 435     ;; leave the king in check; castling through check has already
 436     ;; been eliminated.
 437     (if (char-valid-p piece)
 438         (let ((cand candidates) last-cand pos king-pos)
 439           (while cand
 440             ;; determine the resulting position
 441             (setq pos (chess-pos-move (chess-pos-copy position)
 442                                       (car cand) target))
 443             ;; find the king (only once if the king isn't moving)
 444             (if (or (null king-pos)
 445                     (eq (downcase piece) ?k))
 446                 (setq king-pos (chess-pos-search pos (if color ?K ?k))))
 447             ;; can anybody from the opposite side reach him?  if so,
 448             ;; drop the candidate
 449             (if (or (null king-pos)
 450                     (chess-search-position pos (car king-pos) (not color)))
 451                 (if last-cand
 452                     (setcdr last-cand (cdr cand))
 453                   (setq candidates (cdr candidates)))
 454               (setq last-cand cand))
 455             (setq cand (cdr cand)))))
 456
 457     ;; return the final list of candidate moves
 458     candidates))
 459
 460 (provide 'chess-pos)
 461
 462 ;;; chess-pos.el ends here