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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Routines for manipulating chess plies
   4 ;;
   5
   6 ;;; Commentary:
   7
   8 ;; A ply is the differential between two positions.  Or, it is the
   9 ;; coordinate transformations applied to one position in order to
  10 ;; arrive at the following position.  It is also informally called "a
  11 ;; move".
  12 ;;
  13 ;; A ply is represented in Lisp using a cons cell of the form:
  14 ;;
  15 ;;   (BASE-POSITION .
  16 ;;    (FROM-COORD1 TO-COORD1 [FROM-COORD2 TO-COORD2] [KEYWORDS]))
  17 ;;
  18 ;; The KEYWORDS indicate special actions that are not really chess
  19 ;; moves:
  20 ;;
  21 ;;   :promote PIECE     ; promote pawn to PIECE on arrival
  22 ;;   :resign            ; a resignation causes the game to end
  23 ;;   :stalemate
  24 ;;   :repetition
  25 ;;   :perpetual
  26 ;;   :check             ; check is announced
  27 ;;   :checkmate
  28 ;;   :draw              ; a draw was offered and accepted
  29 ;;   :draw-offered      ; a draw was offered but not accepted
  30 ;;
  31 ;; A ply may be represented in ASCII by printing the FEN string of the
  32 ;; base position, and then printing the positional transformation in
  33 ;; algebraic notation.  Since the starting position is usually known,
  34 ;; the FEN string is optional.  A ply may be represented graphically
  35 ;; by moving the chess piece(s) involved.  It may be rendered verbally
  36 ;; by voicing which piece is to move, where it will move to, and what
  37 ;; will happen a result of the move (piece capture, check, etc).
  38 ;;
  39 ;; Plies may be sent over network connections, postal mail, e-mail,
  40 ;; etc., so long as the current position is maintained at both sides.
  41 ;; Transmitting the base position's FEN string along with the ply
  42 ;; offers a form of confirmation during the course of a game.
  43
  44 ;;; Code:
  45
  46 (require 'chess-pos)
  47 (require 'chess-algebraic)
  48
  49 (defgroup chess-ply nil
  50   "Routines for manipulating chess plies."
  51   :group 'chess)
  52
  53 (defsubst chess-ply-pos (ply)
  54   "Returns the base position associated with PLY."
  55   (assert (listp ply))
  56   (car ply))
  57
  58 (defsubst chess-ply-set-pos (ply position)
  59   "Set the base position of PLY."
  60   (assert (listp ply))
  61   (assert (vectorp position))
  62   (setcar ply position))
  63
  64 (defsubst chess-ply-changes (ply)
  65   (assert (listp ply))
  66   (cdr ply))
  67
  68 (defsubst chess-ply-set-changes (ply changes)
  69   (assert (listp ply))
  70   (assert (listp changes))
  71   (setcdr ply changes))
  72
  73 (defun chess-ply-any-keyword (ply &rest keywords)
  74   (assert (listp ply))
  75   (catch 'found
  76     (dolist (keyword keywords)
  77       (if (memq keyword (chess-ply-changes ply))
  78           (throw 'found keyword)))))
  79
  80 (defun chess-ply-keyword (ply keyword)
  81   (assert (listp ply))
  82   (assert (symbolp keyword))
  83   (let ((item (memq keyword (chess-ply-changes ply))))
  84     (if item
  85         (if (eq item (last (chess-ply-changes ply)))
  86             t
  87           (cadr item)))))
  88
  89 (defun chess-ply-set-keyword (ply keyword &optional value)
  90   (assert (listp ply))
  91   (assert (symbolp keyword))
  92   (let* ((changes (chess-ply-changes ply))
  93          (item (memq keyword changes)))
  94     (if item
  95         (if value
  96             (setcar (cdr item) value))
  97       (nconc changes (if value
  98                          (list keyword value)
  99                        (list keyword))))
 100     value))
 101
 102 (defsubst chess-ply-source (ply)
 103   "Returns the source square index value of PLY."
 104   (assert (listp ply))
 105   (let ((changes (chess-ply-changes ply)))
 106     (and (listp changes) (not (symbolp (car changes)))
 107          (car changes))))
 108
 109 (defsubst chess-ply-target (ply)
 110   "Returns the target square index value of PLY."
 111   (assert (listp ply))
 112   (let ((changes (chess-ply-changes ply)))
 113     (and (listp changes) (not (symbolp (car changes)))
 114          (cadr changes))))
 115
 116 (defsubst chess-ply-next-pos (ply)
 117   (assert (listp ply))
 118   (or (chess-ply-keyword ply :next-pos)
 119       (let ((position (apply 'chess-pos-move
 120                              (chess-pos-copy (chess-ply-pos ply))
 121                              (chess-ply-changes ply))))
 122         (chess-pos-set-preceding-ply position ply)
 123         (chess-ply-set-keyword ply :next-pos position))))
 124
 125 (defsubst chess-ply-to-string (ply &optional long)
 126   (assert (listp ply))
 127   (chess-ply-to-algebraic ply long))
 128
 129 (defsubst chess-ply-from-string (position move)
 130   (assert (vectorp position))
 131   (assert (stringp move))
 132   (chess-algebraic-to-ply position move))
 133
 134 (defconst chess-piece-name-table
 135   '(("queen"  . ?q)
 136     ("rook"   . ?r)
 137     ("knight" . ?n)
 138     ("bishop" . ?b)))
 139
 140 (defun chess-ply-castling-changes (position &optional long king-index)
 141   "Create castling changes; this function supports Fischer Random castling."
 142   (assert (vectorp position))
 143   (let* ((color (chess-pos-side-to-move position))
 144          (king (or king-index (chess-pos-king-index position color)))
 145          (rook (chess-pos-can-castle position (if color
 146                                                   (if long ?Q ?K)
 147                                                 (if long ?q ?k))))
 148          (bias (if long -1 1)) pos)
 149     (when rook
 150       (setq pos (chess-incr-index king 0 bias))
 151       (while (and pos (not (equal pos rook))
 152                   (chess-pos-piece-p position pos ? )
 153                   (or (and long (< (chess-index-file pos) 2))
 154                       (chess-pos-legal-candidates
 155                        position color pos (list king))))
 156         (setq pos (chess-incr-index pos 0 bias)))
 157       (if (equal pos rook)
 158           (list king (chess-rf-to-index (if color 7 0) (if long 2 6))
 159                 rook (chess-rf-to-index (if color 7 0) (if long 3 5))
 160                 (if long :long-castle :castle))))))
 161
 162 (chess-message-catalog 'english
 163   '((pawn-promote-query . "Promote to queen? ")))
 164
 165 (defvar chess-ply-checking-mate nil)
 166
 167 (defsubst chess-ply-create* (position)
 168   (assert (vectorp position))
 169   (list position))
 170
 171 (defun chess-ply-create (position &optional valid-p &rest changes)
 172   "Create a ply from the given POSITION by applying the supplied CHANGES.
 173 This function will guarantee the resulting ply is legal, and will also
 174 annotate the ply with :check or other modifiers as necessary.  It will
 175 also extend castling, and will prompt for a promotion piece.
 176
 177 Note: Do not pass in the rook move if CHANGES represents a castling
 178 maneuver."
 179   (assert (vectorp position))
 180   (let* ((ply (cons position changes))
 181          (color (chess-pos-side-to-move position))
 182          piece)
 183     (if (or (null changes) (symbolp (car changes)))
 184         ply
 185       ;; validate that `changes' can be legally applied to the given
 186       ;; position
 187       (when (or valid-p
 188                 (chess-legal-plies position :any :index (car changes)
 189                                    :target (cadr changes)))
 190         (unless chess-ply-checking-mate
 191           (setq piece (chess-pos-piece position (car changes)))
 192
 193           ;; is this a castling maneuver?
 194           (if (and (= piece (if color ?K ?k))
 195                    (not (or (memq :castle changes)
 196                             (memq :long-castle changes))))
 197               (let* ((target (cadr changes))
 198                      (file (chess-index-file target))
 199                      (long (= 2 file))
 200                      new-changes)
 201                 (if (and (or (and (= file 6)
 202                                   (chess-pos-can-castle position
 203                                                         (if color ?K ?k)))
 204                              (and long
 205                                   (chess-pos-can-castle position
 206                                                         (if color ?Q ?q))))
 207                          (setq new-changes
 208                                (chess-ply-castling-changes position long
 209                                                            (car changes))))
 210                     (setcdr ply new-changes))))
 211
 212           (when (= piece (if color ?P ?p))
 213             ;; is this a pawn move to the ultimate rank?  if so, and
 214             ;; we haven't already been told, ask for the piece to
 215             ;; promote it to
 216             (when (and (not (memq :promote changes))
 217                        (= (if color 0 7) (chess-index-rank (cadr changes))))
 218               ;; jww (2002-05-15): This does not always clear ALL
 219               ;; input events
 220               (discard-input) (sit-for 0) (discard-input)
 221               (let ((new-piece (if (yes-or-no-p
 222                                     (chess-string 'pawn-promote-query))
 223                                    ?Q ?N)))
 224                 (nconc changes (list :promote (upcase new-piece)))))
 225
 226             ;; is this an en-passant capture?
 227             (if (= (or (chess-pos-en-passant position) 100)
 228                    (or (chess-incr-index (cadr changes)
 229                                          (if color 1 -1) 0) 200))
 230                 (nconc changes (list :en-passant))))
 231
 232           ;; we must determine whether this ply results in a check,
 233           ;; checkmate or stalemate
 234           (unless (or chess-pos-always-white
 235                       (memq :check changes)
 236                       (memq :checkmate changes)
 237                       (memq :stalemate changes))
 238             (let* ((chess-ply-checking-mate t)
 239                    ;; jww (2002-04-17): this is a memory waste?
 240                    (next-pos (chess-ply-next-pos ply))
 241                    (next-color (not color))
 242                    (king (chess-pos-king-index next-pos next-color))
 243                    (in-check (catch 'in-check
 244                                (chess-search-position next-pos king
 245                                                       (not next-color) t))))
 246               ;; first, see if the moves leaves the king in check.
 247               ;; This is tested by seeing if any of the opponent's
 248               ;; pieces can reach the king in the position that will
 249               ;; result from this ply.  If the king is in check, we
 250               ;; will then test for checkmate by seeing if any of his
 251               ;; subjects can move or not.  That test will also
 252               ;; confirm stalemate for us.
 253               (if (or in-check
 254                       (null (chess-legal-plies next-pos :any :index king)))
 255                   ;; is the opponent's king in check/mate or stalemate
 256                   ;; now, as a result of the changes?
 257                   (if (chess-legal-plies next-pos :any :color next-color)
 258                       (if in-check
 259                           (nconc changes (list (chess-pos-set-status
 260                                                 next-pos :check))))
 261                     (nconc changes (list (chess-pos-set-status
 262                                           next-pos
 263                                           (if in-check
 264                                               :checkmate
 265                                             :stalemate)))))))))
 266         ;; return the annotated ply
 267         ply))))
 268
 269 (defsubst chess-ply-final-p (ply)
 270   "Return non-nil if this is the last ply of a game/variation."
 271   (or (chess-ply-any-keyword ply :drawn :perpetual :repetition
 272                              :flag-fell :resign :aborted)
 273       (chess-ply-any-keyword (chess-pos-preceding-ply
 274                               (chess-ply-pos ply)) :stalemate :checkmate)))
 275
 276 (eval-when-compile
 277   (defvar position)
 278   (defvar candidate)
 279   (defvar color)
 280   (defvar plies)
 281   (defvar specific-target))
 282
 283 (defvar chess-ply-throw-if-any nil)
 284
 285 (defsubst chess-ply--add (rank-adj file-adj &optional pos)
 286   "This is totally a shortcut."
 287   (let ((target (or pos (chess-incr-index* candidate rank-adj file-adj))))
 288     (if (and (or (not specific-target)
 289                  (= target specific-target))
 290              (chess-pos-legal-candidates position color target
 291                                          (list candidate)))
 292         (if chess-ply-throw-if-any
 293             (throw 'any-found t)
 294           (let ((ply (chess-ply-create position t candidate target)))
 295             (if ply
 296                 (push ply plies)))))))
 297
 298 (defun chess-legal-plies (position &rest keywords)
 299   "Return a list of all legal plies in POSITION.
 300 KEYWORDS allowed are:
 301
 302   :any   return t if any piece can move at all
 303   :color <t or nil>
 304   :piece <piece character>
 305   :file <number 0 to 7> [can only be used if :piece is present]
 306   :index <coordinate index>
 307   :target <specific target index>
 308   :candidates <list of inddices>
 309
 310 These will constrain the plies generated to those matching the above
 311 criteria.
 312
 313 NOTE: All of the returned plies will reference the same copy of the
 314 position object passed in."
 315   (assert (vectorp position))
 316   (cond
 317    ((null keywords)
 318     (let ((plies (list t)))
 319       (dolist (p '(?P ?R ?N ?B ?K ?Q ?p ?r ?n ?b ?k ?q))
 320         (nconc plies (chess-legal-plies position :piece p)))
 321       (cdr plies)))
 322    ((memq :any keywords)
 323     (let ((chess-ply-throw-if-any t))
 324       (catch 'any-found
 325         (apply 'chess-legal-plies position (delq :any keywords)))))
 326    ((memq :color keywords)
 327     (let ((plies (list t))
 328           (color (cadr (memq :color keywords))))
 329       (dolist (p '(?P ?R ?N ?B ?K ?Q))
 330         (nconc plies (chess-legal-plies position
 331                                         :piece (if color p
 332                                                  (downcase p)))))
 333       (cdr plies)))
 334    (t
 335     (let* ((piece (cadr (memq :piece keywords)))
 336            (color (if piece (< piece ?a)
 337                     (chess-pos-side-to-move position)))
 338            (specific-target (cadr (memq :target keywords)))
 339            (test-piece
 340             (upcase (or piece
 341                         (chess-pos-piece position
 342                                          (cadr (memq :index keywords))))))
 343            pos plies file)
 344       ;; since we're looking for moves of a particular piece, do a
 345       ;; more focused search
 346       (dolist (candidate
 347                (cond
 348                 ((cadr (memq :candidates keywords))
 349                  (cadr (memq :candidates keywords)))
 350                 ((setq pos (cadr (memq :index keywords)))
 351                  (list pos))
 352                 ((setq file (cadr (memq :file keywords)))
 353                  (let (candidates)
 354                    (dotimes (rank 8)
 355                      (setq pos (chess-rf-to-index rank file))
 356                      (if (chess-pos-piece-p position pos piece)
 357                          (push pos candidates)))
 358                    candidates))
 359                 (t
 360                  (chess-pos-search position piece))))
 361         (cond
 362          ;; pawn movement, which is diagonal 1 when taking, but forward
 363          ;; 1 or 2 when moving (the most complex piece, actually)
 364          ((= test-piece ?P)
 365           (let* ((bias  (if color -1 1))
 366                  (ahead (chess-incr-index candidate bias 0))
 367                  (2ahead (chess-incr-index candidate (if color -2 2) 0)))
 368             (when (chess-pos-piece-p position ahead ? )
 369               (chess-ply--add bias 0 ahead)
 370               (if (and (= (if color 6 1) (chess-index-rank candidate))
 371                        2ahead (chess-pos-piece-p position 2ahead ? ))
 372                   (chess-ply--add (if color -2 2) 0 2ahead)))
 373             (when (setq pos (chess-incr-index candidate bias -1))
 374               (if (chess-pos-piece-p position pos (not color))
 375                   (chess-ply--add nil nil pos))
 376               ;; check for en passant capture toward queenside
 377               (if (= (or (chess-pos-en-passant position) 100)
 378                      (or (chess-incr-index pos (if color 1 -1) 0) 200))
 379                   (chess-ply--add nil nil pos)))
 380             (when (setq pos (chess-incr-index candidate bias 1))
 381               (if (chess-pos-piece-p position pos (not color))
 382                   (chess-ply--add nil nil pos))
 383               ;; check for en passant capture toward kingside
 384               (if (= (or (chess-pos-en-passant position) 100)
 385                      (or (chess-incr-index pos (if color 1 -1) 0) 200))
 386                   (chess-ply--add nil nil pos)))))
 387
 388          ;; the rook, bishop and queen are the easiest; just look along
 389          ;; rank and file and/or diagonal for the nearest pieces!
 390          ((memq test-piece '(?R ?B ?Q))
 391           (dolist (dir (cond
 392                         ((= test-piece ?R)
 393                          '(        (-1 0)
 394                            (0 -1)          (0 1)
 395                                    (1 0)))
 396                         ((= test-piece ?B)
 397                          '((-1 -1)        (-1 1)
 398
 399                            (1 -1)         (1 1)))
 400                         ((= test-piece ?Q)
 401                          '((-1 -1) (-1 0) (-1 1)
 402                            (0 -1)         (0 1)
 403                            (1 -1)  (1 0)  (1 1)))))
 404             (setq pos (apply 'chess-incr-index candidate dir))
 405             (while pos
 406               (if (chess-pos-piece-p position pos ? )
 407                   (progn
 408                     (chess-ply--add nil nil pos)
 409                     (setq pos (apply 'chess-incr-index pos dir)))
 410                 (if (chess-pos-piece-p position pos (not color))
 411                     (chess-ply--add nil nil pos))
 412                 (setq pos nil)))
 413
 414             (when (= test-piece ?R)
 415               (if (eq candidate
 416                       (chess-pos-can-castle position (if color ?K ?k)))
 417                   (let ((changes (chess-ply-castling-changes position)))
 418                     (if changes
 419                         (if chess-ply-throw-if-any
 420                             (throw 'any-found t)
 421                           (push (cons position changes) plies)))))
 422
 423               (if (eq candidate
 424                       (chess-pos-can-castle position (if color ?Q ?q)))
 425                   (let ((changes (chess-ply-castling-changes position t)))
 426                     (if changes
 427                         (if chess-ply-throw-if-any
 428                             (throw 'any-found t)
 429                           (push (cons position changes) plies))))))))
 430
 431          ;; the king is a trivial case of the queen, except when castling
 432          ((= test-piece ?K)
 433           (dolist (dir '((-1 -1) (-1 0) (-1 1)
 434                          (0 -1)         (0 1)
 435                          (1 -1)  (1 0)  (1 1)))
 436             (setq pos (apply 'chess-incr-index candidate dir))
 437             (if (and pos (or (chess-pos-piece-p position pos ? )
 438                              (chess-pos-piece-p position pos (not color))))
 439                 (chess-ply--add nil nil pos)))
 440
 441           (if (chess-pos-can-castle position (if color ?K ?k))
 442               (let ((changes (chess-ply-castling-changes position nil
 443                                                          candidate)))
 444                 (if changes
 445                     (if chess-ply-throw-if-any
 446                         (throw 'any-found t)
 447                       (push (cons position changes) plies)))))
 448
 449           (if (chess-pos-can-castle position (if color ?Q ?q))
 450               (let ((changes (chess-ply-castling-changes position t
 451                                                          candidate)))
 452                 (if changes
 453                     (if chess-ply-throw-if-any
 454                         (throw 'any-found t)
 455                       (push (cons position changes) plies))))))
 456
 457          ;; the knight is a zesty little piece; there may be more than
 458          ;; one, but at only one possible square in each direction
 459          ((= test-piece ?N)
 460           (dolist (dir '((-2 -1) (-2 1)
 461                          (-1 -2) (-1 2)
 462                          (1 -2)  (1 2)
 463                          (2 -1)  (2 1)))
 464             ;; up the current file
 465             (if (and (setq pos (apply 'chess-incr-index candidate dir))
 466                      (or (chess-pos-piece-p position pos ? )
 467                          (chess-pos-piece-p position pos (not color))))
 468                 (chess-ply--add nil nil pos))))
 469
 470          (t (chess-error 'piece-unrecognized))))
 471
 472       (delq nil plies)))))
 473
 474 (provide 'chess-ply)
 475
 476 ;;; chess-ply.el ends here