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 (defsubst chess-ply-next-pos (ply)
  66   (apply 'chess-pos-move (chess-pos-copy (chess-ply-pos ply))
  67          (chess-ply-changes ply)))
  68
  69 (defconst chess-piece-name-table
  70   '(("queen"  . ?q)
  71     ("rook"   . ?r)
  72     ("knight" . ?n)
  73     ("bishop" . ?b)))
  74
  75 (defun chess-ply-create (position &rest changes)
  76   "Create a ply from the given POSITION by applying the suppiled CHANGES.
  77 This function will guarantee the resulting ply is legal, and will also
  78 annotate the ply with :check or other modifiers as necessary.  It will
  79 also extend castling, and will prompt for a promotion piece.
  80
  81 Note: Do not pass in the rook move if CHANGES represents a castling
  82 maneuver."
  83   (let ((ply (cons (chess-pos-copy position) changes)))
  84     (if (null changes)
  85         ply
  86       ;; validate that `changes' can be legally applied to the given
  87       ;; position
  88       (when (member (car changes)
  89                     (chess-search-position position (cadr changes)
  90                                            (chess-pos-piece position
  91                                                             (car changes))))
  92         ;; is this a castling maneuver?
  93         (let ((color (chess-pos-side-to-move position)))
  94           (when (and (eq (if color ?K ?k)
  95                          (chess-pos-piece position (car changes)))
  96                      (> (abs (- (chess-index-file (cadr changes))
  97                                 (chess-index-file (car changes)))) 1))
  98             (let ((kingside (> (chess-index-file (cadr changes))
  99                                (chess-index-file (car changes)))))
 100               ;; if so, add the rook moves
 101               (nconc changes (if kingside
 102                                  (list (chess-rf-to-index (if color 7 0) 7)
 103                                        (chess-rf-to-index (if color 7 0) 5)
 104                                        :castle)
 105                                (list (chess-rf-to-index (if color 7 0) 0)
 106                                      (chess-rf-to-index (if color 7 0) 3)
 107                                      :long-castle))))))
 108
 109         (let* ((next-pos (chess-ply-next-pos ply))
 110                (color (chess-pos-side-to-move next-pos)))
 111           ;; is the opponent's king in check/mate or stalemate now, as
 112           ;; a result of the changes?  NOTE: engines, whom we should
 113           ;; trust, may already have determine if check/checkmate
 114           ;; applies.
 115           (unless (or (memq :check changes)
 116                       (memq :checkmate changes))
 117             (let ((can-move (catch 'can-move
 118                               (dotimes (rank 8)
 119                                 (dotimes (file 8)
 120                                   (let* ((to (chess-rf-to-index rank file))
 121                                          (piece (chess-pos-piece next-pos to)))
 122                                     (when (or (eq piece ? )
 123                                               (if color
 124                                                   (> piece ?a)
 125                                                 (< piece ?a)))
 126                                       (if (chess-search-position next-pos
 127                                                                  to color)
 128                                           (throw 'can-move t)))))))))
 129               (if (chess-search-position next-pos
 130                                          (car (chess-pos-search
 131                                                next-pos (if color ?K ?k)))
 132                                          (not color))
 133                   ;; yes, well is in he in checkmate?
 134                   (if can-move
 135                       (nconc changes (list :check))
 136                     (nconc changes (list :checkmate)))
 137                 ;; no, but is he in stalemate?
 138                 (unless can-move
 139                   (nconc changes (list :stalemate))))))
 140
 141           ;; is this a pawn move to the ultimate rank?  if so, and we
 142           ;; haven't already been told, ask for the piece to promote
 143           ;; it to
 144           (unless (memq :promote changes)
 145             (if (and (= ?p (downcase (chess-pos-piece next-pos
 146                                                       (cadr changes))))
 147                      (= (if color 7 0)
 148                         (chess-index-rank (cadr changes))))
 149                 (let ((new-piece (completing-read
 150                                   "Promote pawn to queen/rook/knight/bishop? "
 151                                   chess-piece-name-table nil t "queen")))
 152                   (setq new-piece
 153                         (cdr (assoc new-piece chess-piece-name-table)))
 154                   (if color
 155                       (setq new-piece (upcase new-piece)))
 156                   (nconc changes (list :promote new-piece))))))
 157
 158         ;; return the annotated ply
 159         ply))))
 160
 161 (defun chess-ply-final-p (ply)
 162   "Return non-nil if this is the last ply of a game/variation."
 163   (let ((changes (chess-ply-changes ply)))
 164     (or (memq :draw changes)
 165         (memq :perpetual changes)
 166         (memq :repetition changes)
 167         (memq :stalemate changes)
 168         (memq :resign changes)
 169         (memq :checkmate changes))))
 170
 171 (defun chess-legal-plies (position)
 172   "Return a list of all legal plies in POSITION."
 173   (let ((color (chess-pos-side-to-move position)) plies)
 174     (dotimes (rank 8)
 175       (dotimes (file 8)
 176         (let* ((to (chess-rf-to-index rank file))
 177                (piece (chess-pos-piece position to)))
 178           (when (or (eq piece ? )
 179                     (if color
 180                         (> piece ?a)
 181                       (< piece ?a)))
 182             (dolist (candidate (chess-search-position position to color))
 183               (push (chess-ply-create position candidate to) plies))))))
 184     plies))
 185
 186 (provide 'chess-ply)
 187
 188 ;;; chess-ply.el ends here