diff options
| -rw-r--r-- | chess-ply.el | 85 | ||||
| -rw-r--r-- | chess-pos.el | 57 |
2 files changed, 100 insertions, 42 deletions
diff --git a/chess-ply.el b/chess-ply.el index 643c60c..01208ea 100644 --- a/chess-ply.el +++ b/chess-ply.el @@ -66,6 +66,12 @@ (apply 'chess-pos-move (chess-pos-copy (chess-ply-pos ply)) (chess-ply-changes ply))) +(defconst chess-piece-name-table + '(("queen" . ?q) + ("rook" . ?r) + ("knight" . ?n) + ("bishop" . ?b))) + (defun chess-ply-create (position &rest changes) "Create a ply from the given POSITION by applying the suppiled CHANGES. This function will guarantee the resulting ply is legal, and will also @@ -98,37 +104,54 @@ maneuver." (list (chess-rf-to-index (if color 7 0) 0) (chess-rf-to-index (if color 7 0) 3))))))) - ;; is the opponent's king in check/mate or stalemate now, as a - ;; result of the changes? NOTE: engines, whom we should - ;; trust, may already have determine if check/checkmate - ;; applies. - (unless (or (memq :check changes) - (memq :checkmate changes)) - (let* ((next-pos (chess-ply-next-pos ply)) - (color (chess-pos-side-to-move next-pos)) - (can-move (catch 'can-move - (dotimes (rank 8) - (dotimes (file 8) - (let* ((to (chess-rf-to-index rank file)) - (piece (chess-pos-piece next-pos to))) - (when (or (eq piece ? ) - (if color - (> piece ?a) - (< piece ?a))) - (if (chess-search-position next-pos - to color) - (throw 'can-move t))))))))) - (if (chess-search-position next-pos - (car (chess-pos-search - next-pos (if color ?K ?k))) - (not color)) - ;; yes, well is in he in checkmate? - (if can-move - (nconc changes (list :check)) - (nconc changes (list :checkmate))) - ;; no, but is he in stalemate? - (unless can-move - (nconc changes (list :stalemate)))))) + (let* ((next-pos (chess-ply-next-pos ply)) + (color (chess-pos-side-to-move next-pos))) + ;; is the opponent's king in check/mate or stalemate now, as + ;; a result of the changes? NOTE: engines, whom we should + ;; trust, may already have determine if check/checkmate + ;; applies. + (unless (or (memq :check changes) + (memq :checkmate changes)) + (let ((can-move (catch 'can-move + (dotimes (rank 8) + (dotimes (file 8) + (let* ((to (chess-rf-to-index rank file)) + (piece (chess-pos-piece next-pos to))) + (when (or (eq piece ? ) + (if color + (> piece ?a) + (< piece ?a))) + (if (chess-search-position next-pos + to color) + (throw 'can-move t))))))))) + (if (chess-search-position next-pos + (car (chess-pos-search + next-pos (if color ?K ?k))) + (not color)) + ;; yes, well is in he in checkmate? + (if can-move + (nconc changes (list :check)) + (nconc changes (list :checkmate))) + ;; no, but is he in stalemate? + (unless can-move + (nconc changes (list :stalemate)))))) + + ;; is this a pawn move to the ultimate rank? if so, and we + ;; haven't already been told, ask for the piece to promote + ;; it to + (unless (memq :promote changes) + (if (and (= ?p (downcase (chess-pos-piece next-pos + (cadr changes)))) + (= (if color 0 7) + (chess-index-rank (cadr changes)))) + (let ((new-piece (completing-read + "Promote pawn to queen/rook/knight/bishop? " + chess-piece-name-table nil t "queen"))) + (setq new-piece + (cdr (assoc new-piece chess-piece-name-table))) + (if color + (setq new-piece (upcase new-piece))) + (nconc changes (list :promote new-piece)))))) ;; return the annotated ply ply)))) diff --git a/chess-pos.el b/chess-pos.el index c558531..46f61f2 100644 --- a/chess-pos.el +++ b/chess-pos.el @@ -232,21 +232,56 @@ color will do." This function does not check any rules, it only makes sure you are not trying to move a blank square." (while changes - (unless (symbolp (car changes)) + (if (symbolp (car changes)) + (setq changes nil) (let* ((from (car changes)) (to (cadr changes)) (piece (chess-pos-piece position from))) (if (= piece ? ) (error "Attempted piece move from blank square %s" from)) (chess-pos-set-piece position from ? ) - (chess-pos-set-piece position to piece))) - (setq changes (cddr changes))) - ;; once a piece is moved, en passant is no longer available - (chess-pos-set-en-passant position nil) - ;; toggle the side whose move it is - (chess-pos-set-side-to-move position - (not (chess-pos-side-to-move position))) - position) + (chess-pos-set-piece position to piece)) + (setq changes (cddr changes)))) + (let ((color (chess-pos-side-to-move position))) + + ;; once a piece is moved, en passant is no longer available + (chess-pos-set-en-passant position nil) + + ;; if a king or rook moves, no more castling; also, if a pawn + ;; jumps ahead two, mark it en-passantable + (let ((piece (downcase (car changes)))) + (cond + ((and (= piece ?k) + (equal (car changes) + (chess-rf-to-index (if color 7 0) 4))) + (chess-pos-set-can-castle position (if color ?K ?k) nil) + (chess-pos-set-can-castle position (if color ?Q ?q) nil)) + + ((and (= piece ?r) + (equal (car changes) + (chess-rf-to-index (if color 7 0) 0))) + (chess-pos-set-can-castle position (if color ?Q ?q) nil)) + + ((and (= piece ?r) + (equal (car changes) + (chess-rf-to-index (if color 7 0) 7))) + (chess-pos-set-can-castle position (if color ?K ?k) nil)) + + ((and (= piece ?p) + (> (abs (- (chess-index-rank (cadr changes)) + (chess-index-rank (car changes)))) 1)) + (chess-pos-set-en-passant position (cadr changes))))) + + ;; toggle the side whose move it is + (chess-pos-set-side-to-move position (not color)) + + ;; promote the piece if we were meant to + (let ((new-piece (cadr (assq :promote changes)))) + (if new-piece + (chess-pos-set-piece position (cadr changes) new-piece))) + + ;; return the final position + position)) (defun chess-search-position (position target piece) "Look on POSITION from TARGET for a PIECE that can move there. @@ -286,8 +321,8 @@ indices which indicate where a piece may have moved from." (and (= (chess-index-rank target) (if color 2 5)) (setq pos (chess-add-index target bias 0)) (chess-pos-piece-p position pos (if color ?p ?P)) - (and (chess-pos-en-passant position) - (= (chess-pos-en-passant position) target)) + ;; make this fail if no en-passant is possible + (= (or (chess-pos-en-passant position) 100) target) (setq candidates (list pos))) (if color (> p ?a) (< p ?a))) (let ((cands (list t))) |