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                   (chess-pos-legal-candidates position color pos (list king)))
 154         (setq pos (chess-incr-index pos 0 bias)))
 155       (if (equal pos rook)
 156           (list king (chess-rf-to-index (if color 7 0) (if long 2 6))
 157                 rook (chess-rf-to-index (if color 7 0) (if long 3 5))
 158                 (if long :long-castle :castle))))))
 159
 160 (chess-message-catalog 'english
 161   '((pawn-promote-query . "Promote to queen? ")))
 162
 163 (defvar chess-ply-checking-mate nil)
 164
 165 (defsubst chess-ply-create* (position)
 166   (assert (vectorp position))
 167   (list position))
 168
 169 (defun chess-ply-create (position &optional valid-p &rest changes)
 170   "Create a ply from the given POSITION by applying the suppiled CHANGES.
 171 This function will guarantee the resulting ply is legal, and will also
 172 annotate the ply with :check or other modifiers as necessary.  It will
 173 also extend castling, and will prompt for a promotion piece.
 174
 175 Note: Do not pass in the rook move if CHANGES represents a castling
 176 maneuver."
 177   (assert (vectorp position))
 178   (let* ((ply (cons position changes))
 179          (color (chess-pos-side-to-move position))
 180          piece)
 181     (if (or (null changes) (symbolp (car changes)))
 182         ply
 183       ;; validate that `changes' can be legally applied to the given
 184       ;; position
 185       (when (or valid-p
 186                 (chess-legal-plies position :any :index (car changes)
 187                                    :target (cadr changes)))
 188         (unless chess-ply-checking-mate
 189           (setq piece (chess-pos-piece position (car changes)))
 190
 191           ;; is this a castling maneuver?
 192           (if (and (= piece (if color ?K ?k))
 193                    (not (or (memq :castle changes)
 194                             (memq :long-castle changes))))
 195               (let* ((target (cadr changes))
 196                      (file (chess-index-file target))
 197                      (long (= 2 file))
 198                      new-changes)
 199                 (if (and (or (and (= file 6)
 200                                   (chess-pos-can-castle position
 201                                                         (if color ?K ?k)))
 202                              (and long
 203                                   (chess-pos-can-castle position
 204                                                         (if color ?Q ?q))))
 205                          (setq new-changes
 206                                (chess-ply-castling-changes position long
 207                                                            (car changes))))
 208                     (setcdr ply new-changes))))
 209
 210           (when (= piece (if color ?P ?p))
 211             ;; is this a pawn move to the ultimate rank?  if so, and
 212             ;; we haven't already been told, ask for the piece to
 213             ;; promote it to
 214             (when (and (not (memq :promote changes))
 215                        (= (if color 0 7) (chess-index-rank (cadr changes))))
 216               ;; jww (2002-05-15): This does not always clear ALL
 217               ;; input events
 218               (discard-input) (sit-for 0) (discard-input)
 219               (let ((new-piece (if (yes-or-no-p
 220                                     (chess-string 'pawn-promote-query))
 221                                    ?Q ?N)))
 222                 (nconc changes (list :promote (upcase new-piece)))))
 223
 224             ;; is this an en-passant capture?
 225             (if (= (or (chess-pos-en-passant position) 100)
 226                    (or (chess-incr-index (cadr changes)
 227                                          (if color 1 -1) 0) 200))
 228                 (nconc changes (list :en-passant))))
 229
 230           ;; we must determine whether this ply results in a check,
 231           ;; checkmate or stalemate
 232           (unless (or chess-pos-always-white
 233                       (memq :check changes)
 234                       (memq :checkmate changes)
 235                       (memq :stalemate changes))
 236             (let* ((chess-ply-checking-mate t)
 237                    ;; jww (2002-04-17): this is a memory waste?
 238                    (next-pos (chess-ply-next-pos ply))
 239                    (next-color (not color))
 240                    (king (chess-pos-king-index next-pos next-color))
 241                    (in-check (catch 'in-check
 242                                (chess-search-position next-pos king
 243                                                       (not next-color) t))))
 244               ;; first, see if the moves leaves the king in check.
 245               ;; This is tested by seeing if any of the opponent's
 246               ;; pieces can reach the king in the position that will
 247               ;; result from this ply.  If the king is in check, we
 248               ;; will then test for checkmate by seeing if any of his
 249               ;; subjects can move or not.  That test will also
 250               ;; confirm stalemate for us.
 251               (if (or in-check
 252                       (null (chess-legal-plies next-pos :any :index king)))
 253                   ;; is the opponent's king in check/mate or stalemate
 254                   ;; now, as a result of the changes?
 255                   (if (chess-legal-plies next-pos :any :color next-color)
 256                       (if in-check
 257                           (nconc changes (list (chess-pos-set-status
 258                                                 next-pos :check))))
 259                     (nconc changes (list (chess-pos-set-status
 260                                           next-pos
 261                                           (if in-check
 262                                               :checkmate
 263                                             :stalemate)))))))))
 264         ;; return the annotated ply
 265         ply))))
 266
 267 (defsubst chess-ply-final-p (ply)
 268   "Return non-nil if this is the last ply of a game/variation."
 269   (or (chess-ply-any-keyword ply :drawn :perpetual :repetition
 270                              :flag-fell :resign :aborted)
 271       (chess-ply-any-keyword (chess-pos-preceding-ply
 272                               (chess-ply-pos ply)) :stalemate :checkmate)))
 273
 274 (eval-when-compile
 275   (defvar position)
 276   (defvar candidate)
 277   (defvar color)
 278   (defvar plies)
 279   (defvar specific-target))
 280
 281 (defvar chess-ply-throw-if-any nil)
 282
 283 (defsubst chess-ply--add (rank-adj file-adj &optional pos)
 284   "This is totally a shortcut."
 285   (let ((target (or pos (chess-incr-index* candidate rank-adj file-adj))))
 286     (if (and (or (not specific-target)
 287                  (= target specific-target))
 288              (chess-pos-legal-candidates position color target
 289                                          (list candidate)))
 290         (if chess-ply-throw-if-any
 291             (throw 'any-found t)
 292           (let ((ply (chess-ply-create position t candidate target)))
 293             (if ply
 294                 (push ply plies)))))))
 295
 296 (defun chess-legal-plies (position &rest keywords)
 297   "Return a list of all legal plies in POSITION.
 298 KEYWORDS allowed are:
 299
 300   :any   return t if any piece can move at all
 301   :color <t or nil>
 302   :piece <piece character>
 303   :file <number 0 to 7> [can only be used if :piece is present]
 304   :index <coordinate index>
 305   :target <specific target index>
 306
 307 These will constrain the plies generated to those matching the above
 308 criteria.
 309
 310 NOTE: All of the returned plies will reference the same copy of the
 311 position object passed in."
 312   (assert (vectorp position))
 313   (cond
 314    ((null keywords)
 315     (let ((plies (list t)))
 316       (dolist (p '(?P ?R ?N ?B ?K ?Q ?p ?r ?n ?b ?k ?q))
 317         (nconc plies (chess-legal-plies position :piece p)))
 318       (cdr plies)))
 319    ((memq :any keywords)
 320     (let ((chess-ply-throw-if-any t))
 321       (catch 'any-found
 322         (apply 'chess-legal-plies position (delq :any keywords)))))
 323    ((memq :color keywords)
 324     (let ((plies (list t))
 325           (color (cadr (memq :color keywords))))
 326       (dolist (p '(?P ?R ?N ?B ?K ?Q))
 327         (nconc plies (chess-legal-plies position
 328                                         :piece (if color p
 329                                                  (downcase p)))))
 330       (cdr plies)))
 331    (t
 332     (let* ((piece (cadr (memq :piece keywords)))
 333            (color (if piece (< piece ?a)
 334                     (chess-pos-side-to-move position)))
 335            (specific-target (cadr (memq :target keywords)))
 336            (test-piece
 337             (upcase (or piece
 338                         (chess-pos-piece position
 339                                          (cadr (memq :index keywords))))))
 340            pos plies file)
 341       ;; since we're looking for moves of a particular piece, do a
 342       ;; more focused search
 343       (dolist (candidate
 344                (cond
 345                 ((setq pos (cadr (memq :index keywords)))
 346                  (list pos))
 347                 ((setq file (cadr (memq :file keywords)))
 348                  (let (candidates)
 349                    (dotimes (rank 8)
 350                      (setq pos (chess-rf-to-index rank file))
 351                      (if (chess-pos-piece-p position pos piece)
 352                          (push pos candidates)))
 353                    candidates))
 354                 (t
 355                  (chess-pos-search position piece))))
 356         (cond
 357          ;; pawn movement, which is diagonal 1 when taking, but forward
 358          ;; 1 or 2 when moving (the most complex piece, actually)
 359          ((= test-piece ?P)
 360           (let* ((bias  (if color -1 1))
 361                  (ahead (chess-incr-index candidate bias 0))
 362                  (2ahead (chess-incr-index candidate (if color -2 2) 0)))
 363             (when (chess-pos-piece-p position ahead ? )
 364               (chess-ply--add bias 0 ahead)
 365               (if (and (= (if color 6 1) (chess-index-rank candidate))
 366                        2ahead (chess-pos-piece-p position 2ahead ? ))
 367                   (chess-ply--add (if color -2 2) 0 2ahead)))
 368             (when (setq pos (chess-incr-index candidate bias -1))
 369               (if (chess-pos-piece-p position pos (not color))
 370                   (chess-ply--add nil nil pos))
 371               ;; check for en passant capture toward queenside
 372               (if (= (or (chess-pos-en-passant position) 100)
 373                      (or (chess-incr-index pos (if color 1 -1) 0) 200))
 374                   (chess-ply--add nil nil pos)))
 375             (when (setq pos (chess-incr-index candidate bias 1))
 376               (if (chess-pos-piece-p position pos (not color))
 377                   (chess-ply--add nil nil pos))
 378               ;; check for en passant capture toward kingside
 379               (if (= (or (chess-pos-en-passant position) 100)
 380                      (or (chess-incr-index pos (if color 1 -1) 0) 200))
 381                   (chess-ply--add nil nil pos)))))
 382
 383          ;; the rook, bishop and queen are the easiest; just look along
 384          ;; rank and file and/or diagonal for the nearest pieces!
 385          ((memq test-piece '(?R ?B ?Q))
 386           (dolist (dir (cond
 387                         ((= test-piece ?R)
 388                          '(        (-1 0)
 389                            (0 -1)          (0 1)
 390                                    (1 0)))
 391                         ((= test-piece ?B)
 392                          '((-1 -1)        (-1 1)
 393
 394                            (1 -1)         (1 1)))
 395                         ((= test-piece ?Q)
 396                          '((-1 -1) (-1 0) (-1 1)
 397                            (0 -1)         (0 1)
 398                            (1 -1)  (1 0)  (1 1)))))
 399             (setq pos (apply 'chess-incr-index candidate dir))
 400             (while pos
 401               (if (chess-pos-piece-p position pos ? )
 402                   (progn
 403                     (chess-ply--add nil nil pos)
 404                     (setq pos (apply 'chess-incr-index pos dir)))
 405                 (if (chess-pos-piece-p position pos (not color))
 406                     (chess-ply--add nil nil pos))
 407                 (setq pos nil)))
 408
 409             (when (= test-piece ?R)
 410               (if (eq candidate
 411                       (chess-pos-can-castle position (if color ?K ?k)))
 412                   (let ((changes (chess-ply-castling-changes position)))
 413                     (if changes
 414                         (if chess-ply-throw-if-any
 415                             (throw 'any-found t)
 416                           (push (cons position changes) plies)))))
 417
 418               (if (eq candidate
 419                       (chess-pos-can-castle position (if color ?Q ?q)))
 420                   (let ((changes (chess-ply-castling-changes position t)))
 421                     (if changes
 422                         (if chess-ply-throw-if-any
 423                             (throw 'any-found t)
 424                           (push (cons position changes) plies))))))))
 425
 426          ;; the king is a trivial case of the queen, except when castling
 427          ((= test-piece ?K)
 428           (dolist (dir '((-1 -1) (-1 0) (-1 1)
 429                          (0 -1)         (0 1)
 430                          (1 -1)  (1 0)  (1 1)))
 431             (setq pos (apply 'chess-incr-index candidate dir))
 432             (if (and pos (or (chess-pos-piece-p position pos ? )
 433                              (chess-pos-piece-p position pos (not color))))
 434                 (chess-ply--add nil nil pos)))
 435
 436           (if (chess-pos-can-castle position (if color ?K ?k))
 437               (let ((changes (chess-ply-castling-changes position nil
 438                                                          candidate)))
 439                 (if changes
 440                     (if chess-ply-throw-if-any
 441                         (throw 'any-found t)
 442                       (push (cons position changes) plies)))))
 443
 444           (if (chess-pos-can-castle position (if color ?Q ?q))
 445               (let ((changes (chess-ply-castling-changes position t
 446                                                          candidate)))
 447                 (if changes
 448                     (if chess-ply-throw-if-any
 449                         (throw 'any-found t)
 450                       (push (cons position changes) plies))))))
 451
 452          ;; the knight is a zesty little piece; there may be more than
 453          ;; one, but at only one possible square in each direction
 454          ((= test-piece ?N)
 455           (dolist (dir '((-2 -1) (-2 1)
 456                          (-1 -2) (-1 2)
 457                          (1 -2)  (1 2)
 458                          (2 -1)  (2 1)))
 459             ;; up the current file
 460             (if (and (setq pos (apply 'chess-incr-index candidate dir))
 461                      (or (chess-pos-piece-p position pos ? )
 462                          (chess-pos-piece-p position pos (not color))))
 463                 (chess-ply--add nil nil pos))))
 464
 465          (t (chess-error 'piece-unrecognized))))
 466
 467       (delq nil plies)))))
 468
 469 (provide 'chess-ply)
 470
 471 ;;; chess-ply.el ends here