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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; Routines for manipulating chess plies
   4 ;;
   5 ;; $Revision$
   6
   7 ;;; Commentary:
   8
   9 ;; A ply is the differential between two positions.  Or, it is the
  10 ;; coordinate transformations applied to one position in order to
  11 ;; arrive at the following position.  It is also informally called "a
  12 ;; move".
  13 ;;
  14 ;; A ply is represented in Lisp using a cons cell of the form:
  15 ;;
  16 ;;   (BASE-POSITION .
  17 ;;    (FROM-COORD1 TO-COORD1 [FROM-COORD2 TO-COORD2] [KEYWORDS]))
  18 ;;
  19 ;; The KEYWORDS indicate special actions that are not really chess
  20 ;; moves:
  21 ;;
  22 ;;   :promote PIECE     ; promote pawn to PIECE on arrival
  23 ;;   :resign            ; a resignation causes the game to end
  24 ;;   :stalemate
  25 ;;   :repetition
  26 ;;   :perpetual
  27 ;;   :check             ; check is announced
  28 ;;   :checkmate
  29 ;;   :draw              ; a draw was offered and accepted
  30 ;;   :draw-offered      ; a draw was offered but not accepted
  31 ;;
  32 ;; A ply may be represented in ASCII by printing the FEN string of the
  33 ;; base position, and then printing the positional transformation in
  34 ;; algebraic notation.  Since the starting position is usually known,
  35 ;; the FEN string is optional.  A ply may be represented graphically
  36 ;; by moving the chess piece(s) involved.  It may be rendered verbally
  37 ;; by voicing which piece is to move, where it will move to, and what
  38 ;; will happen a result of the move (piece capture, check, etc).
  39 ;;
  40 ;; Plies may be sent over network connections, postal mail, e-mail,
  41 ;; etc., so long as the current position is maintained at both sides.
  42 ;; Transmitting the base position's FEN string along with the ply
  43 ;; offers a form of confirmation during the course of a game.
  44
  45 ;;; Code:
  46
  47 (require 'chess-pos)
  48
  49 (defgroup chess-ply nil
  50   "Routines for manipulating chess plies."
  51   :group 'chess)
  52
  53 (defsubst chess-ply-pos (ply)
  54   (car ply))
  55
  56 (defsubst chess-ply-set-pos (ply position)
  57   (setcar ply position))
  58
  59 (defsubst chess-ply-changes (ply)
  60   (cdr ply))
  61
  62 (defsubst chess-ply-set-changes (ply changes)
  63   (setcdr ply changes))
  64
  65 (defun chess-ply-has-keyword (ply &rest keywords)
  66   (let (found)
  67     (dolist (keyword keywords)
  68       (if (memq keyword (chess-ply-changes ply))
  69           (setq found t)))
  70     found))
  71
  72 (defsubst chess-ply-source (ply)
  73   (car (chess-ply-changes ply)))
  74
  75 (defsubst chess-ply-target (ply)
  76   (cadr (chess-ply-changes ply)))
  77
  78 (defsubst chess-ply-next-pos (ply)
  79   (apply 'chess-pos-move (chess-pos-copy (chess-ply-pos ply))
  80          (chess-ply-changes ply)))
  81
  82 (defconst chess-piece-name-table
  83   '(("queen"  . ?q)
  84     ("rook"   . ?r)
  85     ("knight" . ?n)
  86     ("bishop" . ?b)))
  87
  88 (defun chess-ply-create-castle (position &optional long)
  89   "Create a castling ply; this function supports Fischer Random castling."
  90   (let* ((color (chess-pos-side-to-move position))
  91          (king (chess-pos-search position (if color ?K ?k)))
  92          (king-target (chess-rf-to-index rank (if long 2 6)))
  93          (king-file (chess-index-file king))
  94          (file (if long 0 7))
  95          rook)
  96     (while (funcall (if long '< '>) file king-file)
  97       (let ((index (chess-rf-to-index (if color 7 0) file)))
  98         (if (chess-pos-piece-p position index (if color ?R ?r))
  99             (setq rook index file king-file)
 100           (setq file (funcall (if long '1+ '1-) file)))))
 101     (if (and rook
 102              (chess-search-position position king-target (if color ?K ?k)))
 103         (cons (chess-pos-copy position)
 104               (list king king-target rook
 105                     (chess-rf-to-index rank (if long 3 5))
 106                     (if long :long-castle :castle))))))
 107
 108 (defun chess-ply-create (position &rest changes)
 109   "Create a ply from the given POSITION by applying the suppiled CHANGES.
 110 This function will guarantee the resulting ply is legal, and will also
 111 annotate the ply with :check or other modifiers as necessary.  It will
 112 also extend castling, and will prompt for a promotion piece.
 113
 114 Note: Do not pass in the rook move if CHANGES represents a castling
 115 maneuver."
 116   (let ((ply (cons (chess-pos-copy position) changes)))
 117     (if (null changes)
 118         ply
 119       ;; validate that `changes' can be legally applied to the given
 120       ;; position
 121       (when (member (car changes)
 122                     (chess-search-position position (cadr changes)
 123                                            (chess-pos-piece position
 124                                                             (car changes))))
 125         ;; is this a castling maneuver?
 126         (let ((color (chess-pos-side-to-move position)))
 127           (when (and (eq (if color ?K ?k)
 128                          (chess-pos-piece position (car changes)))
 129                      (> (abs (- (chess-index-file (cadr changes))
 130                                 (chess-index-file (car changes)))) 1))
 131             (let ((kingside (> (chess-index-file (cadr changes))
 132                                (chess-index-file (car changes)))))
 133               ;; if so, add the rook moves
 134               (nconc changes (if kingside
 135                                  (list (chess-rf-to-index (if color 7 0) 7)
 136                                        (chess-rf-to-index (if color 7 0) 5)
 137                                        :castle)
 138                                (list (chess-rf-to-index (if color 7 0) 0)
 139                                      (chess-rf-to-index (if color 7 0) 3)
 140                                      :long-castle))))))
 141
 142         (let* ((next-pos (chess-ply-next-pos ply))
 143                (color (chess-pos-side-to-move next-pos)))
 144           ;; is the opponent's king in check/mate or stalemate now, as
 145           ;; a result of the changes?  NOTE: engines, whom we should
 146           ;; trust, may already have determine if check/checkmate
 147           ;; applies.
 148           (let ((can-move (catch 'can-move
 149                             (dotimes (rank 8)
 150                               (dotimes (file 8)
 151                                 (let* ((to (chess-rf-to-index rank file))
 152                                        (piece (chess-pos-piece next-pos to)))
 153                                   (when (or (eq piece ? )
 154                                             (if color
 155                                                 (> piece ?a)
 156                                               (< piece ?a)))
 157                                     (if (chess-search-position next-pos
 158                                                                to color)
 159                                         (throw 'can-move t)))))))))
 160             (if (chess-search-position next-pos
 161                                        (car (chess-pos-search
 162                                              next-pos (if color ?K ?k)))
 163                                        (not color))
 164                 ;; yes, well is in he in checkmate?
 165                 (if can-move
 166                     (nconc changes (list :check))
 167                   (nconc changes (list :checkmate)))
 168               ;; no, but is he in stalemate?
 169               (unless can-move
 170                 (nconc changes (list :stalemate)))))
 171
 172           ;; is this a pawn move to the ultimate rank?  if so, and we
 173           ;; haven't already been told, ask for the piece to promote
 174           ;; it to; NOTE: 'color' has the inverse meaning at this
 175           ;; point...
 176           (if (and (= ?p (downcase (chess-pos-piece next-pos
 177                                                     (cadr changes))))
 178                    (= (if color 7 0)
 179                       (chess-index-rank (cadr changes))))
 180               (let ((new-piece (completing-read
 181                                 "Promote pawn to queen/rook/knight/bishop? "
 182                                 chess-piece-name-table nil t "queen")))
 183                 (setq new-piece
 184                       (cdr (assoc new-piece chess-piece-name-table)))
 185                 (unless color
 186                   (setq new-piece (upcase new-piece)))
 187                 (nconc changes (list :promote new-piece)))))
 188
 189         ;; return the annotated ply
 190         ply))))
 191
 192 (defsubst chess-ply-final-p (ply)
 193   "Return non-nil if this is the last ply of a game/variation."
 194   (chess-ply-has-keyword ply :draw :perpetual :repetition :stalemate
 195                          :resign :checkmate))
 196
 197 (defun chess-legal-plies (position)
 198   "Return a list of all legal plies in POSITION."
 199   (let ((color (chess-pos-side-to-move position)) plies)
 200     (dotimes (rank 8)
 201       (dotimes (file 8)
 202         (let* ((to (chess-rf-to-index rank file))
 203                (piece (chess-pos-piece position to)))
 204           (when (or (eq piece ? )
 205                     (if color
 206                         (> piece ?a)
 207                       (< piece ?a)))
 208             (dolist (candidate (chess-search-position position to color))
 209               (push (chess-ply-create position candidate to) plies))))))
 210     plies))
 211
 212 (provide 'chess-ply)
 213
 214 ;;; chess-ply.el ends here