diff options
| -rw-r--r-- | chess-pos.el | 305 |
1 files changed, 154 insertions, 151 deletions
diff --git a/chess-pos.el b/chess-pos.el index 2b2a913..8dba92e 100644 --- a/chess-pos.el +++ b/chess-pos.el @@ -73,8 +73,8 @@ (require 'chess-message) (require 'chess-fen) (eval-when-compile - (require 'cl) - (setq cl-optimize-speed 9)) + (require 'cl-lib) + (cl-proclaim '(optimize (speed 3) (safety 2)))) (defgroup chess-pos nil "Routines for manipulating chess positions." @@ -257,35 +257,113 @@ This variable automatically becomes buffer-local when changed.") (defsubst chess-pos-piece (position index) "Return the piece on POSITION at INDEX." - (assert (vectorp position)) - (assert (and (>= index 0) (< index 64))) + (cl-assert (vectorp position)) + (cl-assert (and (>= index 0) (< index 64))) (aref position index)) +(defsubst chess-pos-piece-p (position index piece-or-color) + "Return non-nil if at POSITION/INDEX there is the given PIECE-OR-COLOR. +If PIECE-OR-COLOR is t for white or nil for black, any piece of that +color will do." + (cl-assert (vectorp position)) + (cl-assert (and (>= index 0) (< index 64))) + (cl-assert (memq piece-or-color + '(t nil ? ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p))) + (let ((p (chess-pos-piece position index))) + (cond + ((= p ? ) (eq p piece-or-color)) + ((eq piece-or-color t) (< p ?a)) + ((eq piece-or-color nil) (> p ?a)) + (t (= p piece-or-color))))) + +(defsubst chess-rf-to-index (rank file) + "Convert RANK and FILE coordinates into an octal index." + (cl-assert (or (>= rank 0) (< rank 8))) + (cl-assert (or (>= file 0) (< file 8))) + (+ (* 8 rank) file)) + +(defsubst chess-coord-to-index (coord) + "Convert a COORD string into an index value." + (cl-assert (stringp coord)) + (cl-assert (= (length coord) 2)) + (+ (* 8 (- 7 (- (aref coord 1) ?1))) + (- (aref coord 0) ?a))) + +(defsubst chess-index-to-coord (index) + "Convert the chess position INDEX into a coord string." + (cl-assert (and (>= index 0) (< index 64))) + (concat (char-to-string (+ (mod index 8) ?a)) + (char-to-string (+ (- 7 (/ index 8)) ?1)))) + +(defsubst chess-index-rank (index) + "Return the rank component of the given INDEX." + (cl-assert (and (>= index 0) (< index 64))) + (/ index 8)) + +(defsubst chess-index-file (index) + "Return the file component of the given INDEX." + (cl-assert (and (>= index 0) (< index 64))) + (mod index 8)) + +(defsubst chess-incr-index (index rank-move file-move) + "Create a new INDEX from an old one, by adding RANK-MOVE and FILE-MOVE." + (cl-assert (and (>= index 0) (< index 64))) + (cl-assert (and (>= rank-move -7) (<= rank-move 7))) + (cl-assert (and (>= file-move -7) (<= file-move 7))) + (let ((newrank (+ (chess-index-rank index) rank-move)) + (newfile (+ (chess-index-file index) file-move))) + (if (and (>= newrank 0) (< newrank 8) + (>= newfile 0) (< newfile 8)) + (chess-rf-to-index newrank newfile)))) + +(defsubst chess-incr-index* (index rank-move file-move) + "Create a new INDEX from an old one, by adding RANK-MOVE and FILE-MOVE. +This differs from `chess-incr-index' by performing no safety checks, +in order to execute faster." + (cl-assert (and (>= index 0) (< index 64))) + (cl-assert (and (>= rank-move -7) (<= rank-move 7))) + (cl-assert (and (>= file-move -7) (<= file-move 7))) + (chess-rf-to-index (+ (chess-index-rank index) rank-move) + (+ (chess-index-file index) file-move))) + +(defsubst chess-pos-search (position piece-or-color) + "Look on POSITION anywhere for PIECE-OR-COLOR, returning all coordinates. +If PIECE-OR-COLOR is t for white or nil for black, any piece of that +color will do." + (cl-assert (vectorp position)) + (cl-assert (memq piece-or-color + '(t nil ? ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p))) + (let (found) + (dotimes (i 64) + (if (chess-pos-piece-p position i piece-or-color) + (push i found))) + found)) + +(defsubst chess-pos-set-king-index (position color index) + "Set the known index of the king on POSITION for COLOR, to INDEX. +It is never necessary to call this function." + (cl-assert (vectorp position)) + (cl-assert (memq color '(nil t))) + (cl-assert (and (>= index 0) (< index 64))) + (aset position (if color 72 73) index)) + (defsubst chess-pos-king-index (position color) "Return the index on POSITION of the king. If COLOR is non-nil, return the position of the white king, otherwise return the position of the black king." - (assert (vectorp position)) - (assert (memq color '(nil t))) + (cl-assert (vectorp position)) + (cl-assert (memq color '(nil t))) (or (aref position (if color 72 73)) (chess-pos-set-king-index position color (chess-pos-search position (if color ?K ?k))))) -(defsubst chess-pos-set-king-index (position color index) - "Set the known index of the king on POSITION for COLOR, to INDEX. -It is never necessary to call this function." - (assert (vectorp position)) - (assert (memq color '(nil t))) - (assert (and (>= index 0) (< index 64))) - (aset position (if color 72 73) index)) - (defsubst chess-pos-set-piece (position index piece) "Set the piece on POSITION at INDEX to PIECE. PIECE must be one of K Q N B R or P. Use lowercase to set black pieces." - (assert (vectorp position)) - (assert (and (>= index 0) (< index 64))) - (assert (memq piece '(? ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p))) + (cl-assert (vectorp position)) + (cl-assert (and (>= index 0) (< index 64))) + (cl-assert (memq piece '(? ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p))) (aset position index piece) (if (= piece ?K) (chess-pos-set-king-index position t index) @@ -296,8 +374,8 @@ pieces." "Return whether the king on POSITION can castle on SIDE. SIDE must be either ?K for the kingside, or ?Q for the queenside (use lowercase to query if black can castle)." - (assert (vectorp position)) - (assert (memq side '(?K ?Q ?k ?q))) + (cl-assert (vectorp position)) + (cl-assert (memq side '(?K ?Q ?k ?q))) (let* ((index (+ 65 (if (< side ?a) (if (= side ?K) 0 1) (if (= side ?k) 2 3)))) @@ -327,9 +405,9 @@ It is only necessary to call this function if setting up a position manually. Note that all newly created positions have full castling priveleges set, unless the position is created blank, in which case castling priveleges are unset. See `chess-pos-copy'." - (assert (vectorp position)) - (assert (memq side '(?K ?Q ?k ?q))) - (assert (memq value '(nil t))) + (cl-assert (vectorp position)) + (cl-assert (memq side '(?K ?Q ?k ?q))) + (cl-assert (memq value '(nil t))) (aset position (+ 65 (if (< side ?a) (if (= side ?K) 0 1) (if (= side ?k) 2 3))) value)) @@ -337,13 +415,13 @@ castling priveleges are unset. See `chess-pos-copy'." (defsubst chess-pos-en-passant (position) "Return the index of any pawn on POSITION that can be captured en passant. Returns nil if en passant is unavailable." - (assert (vectorp position)) + (cl-assert (vectorp position)) (aref position 64)) (defsubst chess-pos-set-en-passant (position index) "Set the index of any pawn on POSITION that can be captured en passant." - (assert (vectorp position)) - (assert (or (eq index nil) + (cl-assert (vectorp position)) + (cl-assert (or (eq index nil) (and (>= index 0) (< index 64)))) (aset position 64 index)) @@ -351,43 +429,43 @@ Returns nil if en passant is unavailable." "Return whether the side to move in the POSITION is in a special state. nil is returned if not, otherwise one of the symbols: `check', `checkmate', `stalemate'." - (assert (vectorp position)) + (cl-assert (vectorp position)) (aref position 69)) (defsubst chess-pos-set-status (position value) "Set whether the side to move in POSITION is in a special state. VALUE should either be nil, to indicate that the POSITION is normal, or one of the symbols: `check', `checkmate', `stalemate'." - (assert (vectorp position)) - (assert (or (eq value nil) (symbolp value))) + (cl-assert (vectorp position)) + (cl-assert (or (eq value nil) (symbolp value))) (aset position 69 value)) (defsubst chess-pos-side-to-move (position) "Return the color whose move it is in POSITION." - (assert (vectorp position)) + (cl-assert (vectorp position)) (aref position 70)) (defsubst chess-pos-set-side-to-move (position color) "Set the color whose move it is in POSITION." - (assert (vectorp position)) - (assert (memq color '(nil t))) + (cl-assert (vectorp position)) + (cl-assert (memq color '(nil t))) (aset position 70 color)) (defsubst chess-pos-annotations (position) "Return the list of annotations for this position." - (assert (vectorp position)) + (cl-assert (vectorp position)) (aref position 71)) (defsubst chess-pos-set-annotations (position annotations) "Return the list of annotations for this position." - (assert (vectorp position)) - (assert (listp annotations)) + (cl-assert (vectorp position)) + (cl-assert (listp annotations)) (aset position 71 annotations)) (defun chess-pos-add-annotation (position annotation) "Add an annotation for this position." - (assert (vectorp position)) - (assert (or (stringp annotation) (listp annotation))) + (cl-assert (vectorp position)) + (cl-assert (or (stringp annotation) (listp annotation))) (let ((ann (chess-pos-annotations position))) (if ann (nconc ann (list annotation)) @@ -395,14 +473,14 @@ or one of the symbols: `check', `checkmate', `stalemate'." (defsubst chess-pos-epd (position opcode) "Return the value of the given EPD OPCODE, or nil if not set." - (assert (vectorp position)) - (assert opcode) + (cl-assert (vectorp position)) + (cl-assert opcode) (cdr (assq opcode (chess-pos-annotations position)))) (defun chess-pos-set-epd (position opcode &optional value) "Set the given EPD OPCODE to VALUE, or t if VALUE is not specified." - (assert (vectorp position)) - (assert opcode) + (cl-assert (vectorp position)) + (cl-assert opcode) (let ((entry (assq opcode (chess-pos-annotations position)))) (if entry (setcdr entry (or value t)) @@ -410,27 +488,27 @@ or one of the symbols: `check', `checkmate', `stalemate'." (defun chess-pos-del-epd (position opcode) "Delete the given EPD OPCODE." - (assert (vectorp position)) - (assert opcode) + (cl-assert (vectorp position)) + (cl-assert opcode) (chess-pos-set-annotations position (assq-delete-all opcode (chess-pos-annotations position)))) (defun chess-pos-preceding-ply (position) "Delete the given EPD OPCODE." - (assert (vectorp position)) + (cl-assert (vectorp position)) (aref position 74)) (defun chess-pos-set-preceding-ply (position ply) "Delete the given EPD OPCODE." - (assert (vectorp position)) - (assert (listp ply)) + (cl-assert (vectorp position)) + (cl-assert (listp ply)) (aset position 74 ply)) (defsubst chess-pos-copy (position) "Copy the given chess POSITION. If there are annotations or EPD opcodes set, these lists are copied as well, so that the two positions do not share the same lists." - (assert (vectorp position)) + (cl-assert (vectorp position)) (let ((copy (vconcat position)) i) (setq i (chess-pos-annotations position)) (if i (chess-pos-set-annotations copy (copy-alist i))) @@ -445,95 +523,17 @@ The current side-to-move is always white." [nil nil nil nil nil nil t nil nil nil nil]) (chess-pos-copy chess-starting-position))) -(defsubst chess-rf-to-index (rank file) - "Convert RANK and FILE coordinates into an octal index." - (assert (or (>= rank 0) (< rank 8))) - (assert (or (>= file 0) (< file 8))) - (+ (* 8 rank) file)) - -(defsubst chess-coord-to-index (coord) - "Convert a COORD string into an index value." - (assert (stringp coord)) - (assert (= (length coord) 2)) - (+ (* 8 (- 7 (- (aref coord 1) ?1))) - (- (aref coord 0) ?a))) - -(defsubst chess-index-to-coord (index) - "Convert the chess position INDEX into a coord string." - (assert (and (>= index 0) (< index 64))) - (concat (char-to-string (+ (mod index 8) ?a)) - (char-to-string (+ (- 7 (/ index 8)) ?1)))) - -(defsubst chess-index-rank (index) - "Return the rank component of the given INDEX." - (assert (and (>= index 0) (< index 64))) - (/ index 8)) - -(defsubst chess-index-file (index) - "Return the file component of the given INDEX." - (assert (and (>= index 0) (< index 64))) - (mod index 8)) - -(defsubst chess-incr-index (index rank-move file-move) - "Create a new INDEX from an old one, by adding RANK-MOVE and FILE-MOVE." - (assert (and (>= index 0) (< index 64))) - (assert (and (>= rank-move -7) (<= rank-move 7))) - (assert (and (>= file-move -7) (<= file-move 7))) - (let ((newrank (+ (chess-index-rank index) rank-move)) - (newfile (+ (chess-index-file index) file-move))) - (if (and (>= newrank 0) (< newrank 8) - (>= newfile 0) (< newfile 8)) - (chess-rf-to-index newrank newfile)))) - -(defsubst chess-incr-index* (index rank-move file-move) - "Create a new INDEX from an old one, by adding RANK-MOVE and FILE-MOVE. -This differs from `chess-incr-index' by performing no safety checks, -in order to execute faster." - (assert (and (>= index 0) (< index 64))) - (assert (and (>= rank-move -7) (<= rank-move 7))) - (assert (and (>= file-move -7) (<= file-move 7))) - (chess-rf-to-index (+ (chess-index-rank index) rank-move) - (+ (chess-index-file index) file-move))) - -(defsubst chess-pos-piece-p (position index piece-or-color) - "Return non-nil if at POSITION/INDEX there is the given PIECE-OR-COLOR. -If PIECE-OR-COLOR is t for white or nil for black, any piece of that -color will do." - (assert (vectorp position)) - (assert (and (>= index 0) (< index 64))) - (assert (memq piece-or-color - '(t nil ? ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p))) - (let ((p (chess-pos-piece position index))) - (cond - ((= p ? ) (eq p piece-or-color)) - ((eq piece-or-color t) (< p ?a)) - ((eq piece-or-color nil) (> p ?a)) - (t (= p piece-or-color))))) - -(defsubst chess-pos-search (position piece-or-color) - "Look on POSITION anywhere for PIECE-OR-COLOR, returning all coordinates. -If PIECE-OR-COLOR is t for white or nil for black, any piece of that -color will do." - (assert (vectorp position)) - (assert (memq piece-or-color - '(t nil ? ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p))) - (let (found) - (dotimes (i 64) - (if (chess-pos-piece-p position i piece-or-color) - (push i found))) - found)) - (defsubst chess-pos-to-string (position &optional full) "Convert the given POSITION into a string. The returned string can be converted back to a position using `chess-pos-from-string'." - (assert (vectorp position)) + (cl-assert (vectorp position)) (chess-pos-to-fen position full)) (defsubst chess-pos-from-string (string) "Convert the given STRING to a chess position. This string should have been created by `chess-pos-to-string'." - (assert (stringp string)) + (cl-assert (stringp string)) (chess-fen-to-pos string)) (defconst chess-pos-piece-values @@ -546,8 +546,8 @@ This string should have been created by `chess-pos-to-string'." (defun chess-pos-material-value (position color) "Return the aggregate material value in POSITION for COLOR." - (assert (vectorp position)) - (assert (memq color '(nil t))) + (cl-assert (vectorp position)) + (cl-assert (memq color '(nil t))) (let ((pieces (chess-pos-search position color)) (value 0)) (dolist (index pieces) @@ -597,9 +597,9 @@ on an adjoining file is called a passed Pawn." "Move a piece on the POSITION directly, using the indices in CHANGES. This function does not check any rules, it only makes sure you are not trying to move a blank square." - (assert (vectorp position)) - (assert (listp changes)) - (assert (> (length changes) 0)) + (cl-assert (vectorp position)) + (cl-assert (listp changes)) + (cl-assert (> (length changes) 0)) ;; apply the piece movements listed in `changes' (let ((ch changes)) @@ -610,9 +610,9 @@ trying to move a blank square." (to (cadr ch)) (piece (chess-pos-piece position from))) (if (= piece ? ) - (chess-error 'move-from-blank (chess-index-to-coord from))) - (chess-pos-set-piece position from ? ) - (chess-pos-set-piece position to piece)) + (chess-error 'move-from-blank (chess-index-to-coord from)) + (chess-pos-set-piece position from ? ) + (chess-pos-set-piece position to piece))) (setq ch (cddr ch))))) ;; now fix up the resulting position @@ -636,16 +636,19 @@ trying to move a blank square." (chess-pos-set-can-castle position (if color ?Q ?q) nil)) ((= piece ?r) - (if (and (chess-pos-can-castle position (if color ?Q ?q)) - (= (car changes) (chess-pos-can-castle position (if color ?Q ?q)))) - (chess-pos-set-can-castle position (if color ?Q ?q) nil) - (if (and (chess-pos-can-castle position (if color ?K ?k)) - (= (car changes) (chess-pos-can-castle position - (if color ?K ?k)))) - (chess-pos-set-can-castle position (if color ?K ?k) nil)))) + (let* ((side (if color ?Q ?q)) + (can-castle (chess-pos-can-castle position side))) + (if (and can-castle (= (car changes) can-castle)) + (chess-pos-set-can-castle position side nil) + (setq side (if color ?K ?k) + can-castle (chess-pos-can-castle position side)) + (if (and can-castle (= (car changes) can-castle)) + (chess-pos-set-can-castle position side nil))))) + ((let ((can-castle (chess-pos-can-castle position (if color ?q ?Q)))) (and can-castle (= (cadr changes) can-castle))) (chess-pos-set-can-castle position (if color ?q ?Q) nil)) + ((let ((can-castle (chess-pos-can-castle position (if color ?k ?K)))) (and can-castle (= (cadr changes) can-castle))) (chess-pos-set-can-castle position (if color ?k ?K) nil)) @@ -668,14 +671,14 @@ trying to move a blank square." (downcase new-piece))))) ;; did we leave the position in check, mate or stalemate? - (chess-pos-set-status position nil) (cond ((memq :check changes) (chess-pos-set-status position :check)) ((memq :checkmate changes) (chess-pos-set-status position :checkmate)) ((memq :stalemate changes) - (chess-pos-set-status position :stalemate))) + (chess-pos-set-status position :stalemate)) + (t (chess-pos-set-status position nil))) ;; return the final position position)) @@ -709,9 +712,9 @@ indices which indicate where a piece may have moved from. If CHECK-ONLY is non-nil and PIECE is either t or nil, only consider pieces which can give check (not the opponents king). If NO-CASTLING is non-nil, do not consider castling moves." - (assert (vectorp position)) - (assert (and (>= target 0) (< target 64))) - (assert (memq piece '(t nil ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p))) + (cl-assert (vectorp position)) + (cl-assert (and (>= target 0) (< target 64))) + (cl-assert (memq piece '(t nil ?K ?Q ?N ?B ?R ?P ?k ?q ?n ?b ?r ?p))) (let* ((color (if (characterp piece) (< piece ?a) piece)) @@ -871,11 +874,11 @@ type. Also, it is the callers responsibility to ensure that the piece can legally reach the square in question. This function merely assures that the resulting position is valid (the move does not leave the king in check)." - (assert (vectorp position)) - (assert (memq color '(nil t))) - (assert (and (>= target 0) (< target 64))) - (assert (listp candidates)) - (assert (> (length candidates) 0)) + (cl-assert (vectorp position)) + (cl-assert (memq color '(nil t))) + (cl-assert (and (>= target 0) (< target 64))) + (cl-assert (listp candidates)) + (cl-assert (> (length candidates) 0)) (let ((cand candidates) (piece (chess-pos-piece position (car candidates))) other-piece en-passant-square last-cand king-pos) |