CIL Toolkit: code snippets: move generation

[sje]

Simple mate/lose predicates are small routines that quickly check for short distance mate/lose positions. They do not employ any advanced search heuristics as the functions are fast and the ply depth is small.

These routines can be employed in several areas in a chess program:

1) At the beginning of a search before any time consuming complex initialization, the quick mate/lose recognizers can be run on all the ply one positions to either find a fast and certain win or to exclude quick and certain losses. If nothing else, it can greatly reduce embarrassment due to possible inadequacies in the primary search.

2) The "is-lose-in-1? predicate can be used to implement the Capablanca resignation facility; this is named after Jose Capablanca who was never checkmated in professional play. Symbolic has used this from its beginning; more recently, the program has been using the "is-lose-in-2?" predicate as a resignation trigger as it assumes the opponent can see a mate in two.

Note the different move generator calls that impose a mild enhancement of move ordering:

Code: Select all

;;; Basic mate/lose predicates

(defun is-mate-in-1? (my-pos)
  "Return t if the position is a mate in one; else return nil."
  (let ((result nil) (moves (generate-checks my-pos)) (best-move nil))
    (dountil (or result (null? moves))
      (let ((move (pop moves)))
        (advance-pos my-pos move)
        (when (no-moves? my-pos)
          (setf best-move move)
          (set-mf best-move mf-mate)
          (setf result t))
        (retreat-pos my-pos)))
    (values result best-move)))

(defun is-lose-in-1? (my-pos)
  "Return t if the position is a lose in one; else return nil."
  (let ((result t) (moves (generate-gainers-first my-pos)) (best-move nil))
    (dowhile (and result moves)
      (let ((move (pop moves)))
        (advance-pos my-pos move)
        (unless (is-mate-in-1? my-pos)
          (setf best-move move)
          (setf result nil))
        (retreat-pos my-pos)))
    (values result best-move)))

(defun is-mate-in-2? (my-pos)
  "Return t if the position is a mate in two; else return nil."
  (let ((result nil) (moves (generate-gainer-checks-first my-pos)) (best-move nil))
    (dountil (or result (null? moves))
      (let ((move (pop moves)))
        (advance-pos my-pos move)
        (when (is-lose-in-1? my-pos)
          (setf best-move move)
          (setf result t))
        (retreat-pos my-pos)))
    (values result best-move)))

(defun is-lose-in-2? (my-pos)
  "Return t if the position is a lose in two; else return nil."
  (let ((result t) (moves (generate-gainers-first my-pos)) (best-move nil))
    (dowhile (and result moves)
      (let ((move (pop moves)))
        (advance-pos my-pos move)
        (unless (is-mate-in-2? my-pos)
          (setf best-move move)
          (setf result nil))
        (retreat-pos my-pos)))
    (values result best-move)))

(defun is-mate-in-3? (my-pos)
  "Return t if the position is a mate in three; else return nil."
  (let ((result nil) (moves (generate-gainer-checks-first my-pos)) (best-move nil))
    (dountil (or result (null? moves))
      (let ((move (pop moves)))
        (advance-pos my-pos move)
        (when (is-lose-in-2? my-pos)
          (setf best-move move)
          (setf result t))
        (retreat-pos my-pos)))
    (values result best-move)))

Sample calls:

Code: Select all

> (setf p (calc-pos-from-str "r1b1k2r/pp2bppp/8/3N2q1/2p5/8/PPP2PPP/R2QR1K1 w kq - 0 1"))

> (is-mate-in-1? p)
NIL ;
NIL

> (is-mate-in-2? p)
NIL ;
NIL

> (is-mate-in-3? p)
T ;
Nc7+

[sje]

An augmented move is a structure that includes a move plus some extended calculations for that move. A list of augmented moves can be helpful at ply zero, and possibly at PV nodes if the machine is fast or the node count is restricted.

Code: Select all

;;; Augmented chess move structure

(defstruct
  (augmove
    (:print-function
      (lambda (my-augmove my-stream my-level)
        (declare (ignore my-level))
        (encode-augmove my-stream my-augmove))))
  (move     nil)  ; The move of interest
  (pos      nil)  ; Position after move is played
  (bk-flag  nil)  ; True if resulting position located in an opening book
  (tb-flag  nil)  ; True if resulting position located in a tablebase
  (wld      nil)  ; Win/lose/draw accumulator when located in an opening book
  (score    nil)) ; Score when certain

(defun mk-augmove (my-bks my-tbs my-pos my-move)
  "Initialize an augmented move structure."
  (let ((result (make-augmove)) (pos (clone-pos my-pos)) (score nil))
    (advance-pos pos my-move)
    (setf (augmove-move result) my-move)
    (setf (augmove-pos  result) pos)
    (when my-bks
      (let ((bkp (bks-probe my-bks pos)))
        (when bkp
         (setf (augmove-bk-flag result) t)
         (setf (augmove-wld     result) bkp))))
    (when my-tbs
      (let ((tbp (tbs-probe my-tbs pos)))
        (when tbp
         (setf (augmove-tb-flag result) t)
         (setf score tbp))))
    (unless score
      (when (is-draw? pos)
        (setf score even-score)))
    (unless score
      (when (is-checkmate? pos)
        (setf score mate-in-1-score)))
    (unless score
      (when (is-mate-in-1? pos)
        (setf score lose-in-1-score)))
    (unless score
      (when (is-lose-in-1? pos)
        (setf score mate-in-2-score)))
    (setf (augmove-score result) score)
    result))


;; Augmented move list construction

(defun mk-augmovelist (my-bks my-tbs my-pos)
  "Return the augmented move list for a position."
  (let ((result nil) (moves (generate-canon my-pos)))
    (dolist (move moves)
      (push (mk-augmove my-bks my-tbs my-pos move) result))
    (nreverse result)))

[sje]

The Novag Citrine outputs game data in a two move per line form. Here's an example game fragment (after manually removing some header text):

Code: Select all

.   1  d2-d4       g8-f6
.   2  c2-c4       e7-e6
.   3  g1-f3       b7-b6
.   4  a2-a3       c8-b7
.   5  b1-c3       d7-d5
.   6  c4xd5       f6xd5
.   7  d1-c2       d5xc3
.   8  b2xc3       d8-d5
.   9  e2-e3       b8-d7
.  10  f1-d3       d7-f6

Here's the Lisp routine that takes the above and makes a PGN object for the above example:

Code: Select all

;;; Citrine game translation

(defun calc-pgn-from-citrine-game (my-ncg-str)
  "Make a PGN game from a Novag Citrine game string."
  (let ((result (mk-pgn)) (tkns (tokenize my-ncg-str)) (count 0) (rtkns nil) (moves nil))
    (dolist (tkn tkns)
      (when (> (mod count 4) 1)
        (push tkn rtkns))
      (incf count))
    (setf moves (translate-nan-variation (create-initial-array-pos) (reverse rtkns)))
    (dolist (move moves)
      (advance-pgn result move))
    result))

For the above example:

Code: Select all

[Event "Unnamed event"]
[Site "gail"]
[Date "2008.10.17"]
[Round "-"]
[White "Unnamed player"]
[Black "Unnamed player"]
[Result "*"]

1. d4 Nf6 2. c4 e6 3. Nf3 b6 4. a3 Bb7 5. Nc3 d5 6. cxd5 Nxd5 7. Qc2 Nxc3 8.
bxc3 Qd5 9. e3 Nd7 10. Bd3 Nf6 *

Note that some of the PGN tag values require manual setting.

The Citrine's game memory is limited to 112 full moves. For longer games, the link to the Citrine needs to be monitored from the beginning of a game with the moves recorded as they are played.

[sje]

Code: Select all

;;; Augmented chess move structure

(defstruct
  (augmove
    (:print-function
      (lambda (my-augmove my-stream my-level)
        (declare (ignore my-level))
        (encode-augmove my-stream my-augmove))))
  (move     nil)  ; The move of interest
  (bk-flag  nil)  ; True if resulting position located in an opening book
  (bk-wld   nil)  ; Win/lose/draw accumulator when located in an opening book
  (bk-sigma nil)  ; Win/lose/draw count total when located in an opening book
  (bk-grexp nil)  ; Game result expectation (0.0-1.0) when located in an opening book
  (cs-flag  nil)  ; True if the move has a certain score
  (qd-flag  nil)  ; True if the move leads to a quick draw
  (ql-flag  nil)  ; True if the move leads to a quick lose
  (qm-flag  nil)  ; True if the move leads to a quick mate
  (tb-flag  nil)  ; True if resulting position located in a tablebase
  (score    nil)) ; Score when certain

(defun mk-augmove (my-bks my-tbs my-pos my-move)
  "Initialize an augmented move structure."
  (let ((result (make-augmove)) (pos (clone-pos my-pos)) (score nil))
    (advance-pos pos my-move)
    (setf (augmove-move result) my-move)
    (when my-bks
      (let ((bkp (bks-probe my-bks pos)))
        (when bkp
         (setf (augmove-bk-flag  result) t)
         (setf (augmove-bk-wld   result) bkp)
         (setf (augmove-bk-sigma result) (calc-sigma-wld bkp))
         (setf (augmove-bk-grexp result) (calc-grexp-wld bkp)))))
    (when my-tbs
      (let ((tbp (tbs-probe my-tbs pos)))
        (when tbp
          (setf (augmove-cs-flag result) t)
          (setf (augmove-tb-flag result) t)
          (setf score tbp))))
    (when (and (not score) (is-draw? pos))
      (setf (augmove-cs-flag result) t)
      (setf (augmove-qd-flag result) t)
      (setf score even-score))
    (when (and (not score) (is-checkmate? pos))
      (setf (augmove-cs-flag result) t)
      (setf (augmove-qm-flag result) t)
      (setf score mate-in-1-score))
    (when (and (not score) (is-mate-in-1? pos))
      (setf (augmove-cs-flag result) t)
      (setf (augmove-ql-flag result) t)
      (setf score lose-in-1-score))
    (when (and (not score) (is-lose-in-1? pos))
      (setf (augmove-cs-flag result) t)
      (setf (augmove-qm-flag result) t)
      (setf score mate-in-2-score))
    (when (and (not score) (is-mate-in-2? pos))
      (setf (augmove-cs-flag result) t)
      (setf (augmove-ql-flag result) t)
      (setf score lose-in-2-score))
    (setf (augmove-score result) score)
    result))

[sje]

Code: Select all

;;; Augmented move list construction

(defun mk-augmoves (my-bks my-tbs my-pos)
  "Return the augmented move list for a position."
  (let ((result nil) (moves (generate-canon my-pos)))
    (dolist (move moves)
      (push (mk-augmove my-bks my-tbs my-pos move) result))
    (nreverse result)))


;;; Augmented move location

(defun find-augmove (my-augmoves my-move)
  "Locate a move in an augmove list; flags unchecked; return entry on match."
  (let ((result nil))
    (do ((augmove)) ((or result (null? my-augmoves)))
      (setf augmove (pop my-augmoves))
      (when (same-move? my-move (augmove-move augmove))
        (setf result augmove)))
    result))

(defun find-augmove-no-fail (my-augmoves my-move)
  "Locate a move in an augmove list; flags unchecked; return entry on match; no match is error."
  (let ((result (find-augmove my-augmoves my-move)))
    (unless result
      (error "find-augmove-no-fail: unlocated move"))
    result))

And more scanning:

Code: Select all

;;;  Score scanning

(defun count-certain-augmoves (my-augmoves)
  "Return a count of all augmented moves that have a certain score."
  (let ((result 0))
    (dolist (augmove my-augmoves)
      (when (augmove-cs-flag augmove)
        (incf result)))
    result))

(defun are-all-augmoves-certain? (my-augmoves)
  "Return t if all the augmented moves have certain scores."
  (let ((result t))
    (dowhile (and result my-augmoves)
      (unless (augmove-cs-flag (pop my-augmoves))
        (setf result nil)))
    result))

(defun best-certain-augmove-score (my-augmoves)
  "Return the best certain augmested move score if any, else nil."
  (let ((result nil))
    (dolist (augmove my-augmoves)
      (when (augmove-cs-flag augmove)
        (let ((score (augmove-score augmove)))
          (when (or (not result) (< result score))
            (setf result score)))))
    result))

(defun collect-certain-augmoves-by-score (my-augmoves my-score)
  "Return a list of augmented moves with a matching certain score."
  (let ((result nil))
    (dolist (augmove my-augmoves)
      (when (and (augmove-cs-flag augmove) (= (augmove-score augmove) my-score))
        (push augmove result)))
    (nreverse result)))

And also, the quick pick logic:

Code: Select all

;;; Quick pick move selection

(defun quick-pick-singleton (my-augmoves)
  "Return a move based on singleton selection."
  (let ((result nil))
    (when (one? (length my-augmoves))
      (setf result (augmove-move (first my-augmoves))))
    result))

(defun quick-pick-mate (my-augmoves)
  "Return a certain mate move selection."
  (let ((result nil) (best-score (best-certain-augmove-score my-augmoves)))
    (when (and best-score (is-mating-score? best-score))
      (let ((best-augmoves (collect-certain-augmoves-by-score my-augmoves best-score)))
        (setf result (augmove-move (elt best-augmoves (random (length best-augmoves)))))))
    result))

(defun quick-pick-all-certain (my-augmoves)
  "Return a move based on all certain scores selection."
  (let ((result nil))
    (when (and my-augmoves (are-all-augmoves-certain? my-augmoves))
      (let*
        (
          (best-score (best-certain-augmove-score my-augmoves))
          (best-augmoves (collect-certain-augmoves-by-score my-augmoves best-score))
        )
        (setf result (augmove-move (elt best-augmoves (random (length best-augmoves)))))))
    result))

(defun quick-pick-all-bad-but-one (my-augmoves)
  "Return a move based on all bad but one selection."
  (let ((result nil) (mc (length my-augmoves)) (cmc (count-certain-augmoves my-augmoves)))
    (when
      (and
        (= (1+ cmc) mc)
        (positive? cmc)
        (is-losing-score? (best-certain-augmove-score my-augmoves)))
      (dountil result
        (if (augmove-cs-flag (first my-augmoves))
          (pop my-augmoves)
          (setf result (augmove-move (first my-augmoves))))))
    result))

(defun quick-pick (my-augmoves)
  "Return a quick pick move, if any."
  (or
    (quick-pick-singleton       my-augmoves)
    (quick-pick-mate            my-augmoves)
    (quick-pick-all-certain     my-augmoves)
    (quick-pick-all-bad-but-one my-augmoves)))

[sje]

Code: Select all

;;; English Descriptive Notation (EDN) move encoding

(defun encode-edn-sq (my-stream my-color my-sq my-bit0 my-bit1 my-bit2) 
  "Encode an EDN square using mover color, royalty disambiguation bit, file bit, and rank bit."
  (when my-bit0
    (put-char my-stream (svref acuc-flank-vec (map-sq-to-flank my-sq))))
  (when my-bit1
    (put-char my-stream (svref ac-edn-file-vec (map-sq-to-file my-sq))))
  (when my-bit2
    (let*
      (
        (rank     (map-sq-to-rank my-sq))
        (adj-rank (if (= my-color color-white) rank (flip-rank rank)))
      )
      (put-char my-stream (svref ac-rank-vec adj-rank))))
  (values))

(defun encode-edn-fr-sq (my-stream my-move) 
  "Encode an EDN from-square."
  (let
    (
      (b0 (mfbit-set? my-move mfbit-dnf0))
      (b1 (mfbit-set? my-move mfbit-dnf1))
      (b2 (mfbit-set? my-move mfbit-dnf2))
    )
    (when (or b0 b1 b2)
      (put-char my-stream ascii-slash)
      (encode-edn-sq my-stream (calc-mover-color my-move) (move-fr-sq my-move) b0 b1 b2)))
  (values))

(defun encode-edn-to-sq (my-stream my-move) 
  "Encode an EDN to-square."
  (let
    (
      (b0 (mfbit-set? my-move mfbit-dnt0))
      (b1 (mfbit-set? my-move mfbit-dnt1))
      (b2 (mfbit-set? my-move mfbit-dnt2))
    )
    (when (or b0 b1 b2)
      (when (is-move-capture? my-move)
        (put-char my-stream ascii-slash))
      (encode-edn-sq my-stream (calc-mover-color my-move) (move-to-sq my-move) b0 b1 b2)))
  (values))

(defun encode-edn-separator (my-stream my-move) 
  "Encode an EDN separator."
  (if (is-move-capture? my-move)
    (put-char my-stream #\x)
    (put-char my-stream #\-))
  (values))

(defun encode-edn-simple (my-stream my-move) 
  "Encode an EDN move's simple parts."
  (put-char my-stream (svref acuc-piece-vec (calc-mover-piece my-move)))
  (encode-edn-fr-sq my-stream my-move)
  (encode-edn-separator my-stream my-move)
  (when (is-move-capture? my-move)
    (put-char my-stream (svref acuc-piece-vec (calc-victim-piece my-move))))
  (encode-edn-to-sq my-stream my-move)
  (values))

(defun encode-edn (my-stream my-move)
  "Encode a move in English Descriptive Notation (EDN); this is here for amusement purposes."
  (cond
;;
    ((is-move-null? my-move)
      (put-string my-stream "<null>"))
;;
    ((is-move-regular? my-move)
      (encode-edn-simple my-stream my-move))
;;
    ((is-move-en-passant? my-move)
      (encode-edn-simple my-stream my-move)
      (put-string my-stream "e.p."))
;;
    ((is-move-castling? my-move)
     (put-string my-stream (svref mc-msc-to-castling-san-vec (move-msc my-move))))
;;
    ((is-move-promotion? my-move)
      (encode-edn-simple my-stream my-move)
      (put-char my-stream ascii-paren-l)
      (put-char my-stream (svref acuc-piece-vec (svref mc-msc-to-piece-vec (move-msc my-move))))
      (put-char my-stream ascii-paren-r))
;;
    (t (error "encode-edn: cond fault")))
;;
  (if (is-move-checkmate? my-move)
    (put-string my-stream "mate")
    (when (is-move-check? my-move)
      (put-string my-stream "ch")))
  (when (is-move-illegal? my-move)
    (put-char my-stream  #\*))
  (values))

(declaim (type (function (move) simple-base-string) edn-string))
(defun edn-string (my-move)
  "Encode an English Descritve Notation (EDN) move on a string."
  (let ((result nil) (str-stream (make-string-output-stream)))
    (encode-edn str-stream my-move)
    (setf result (get-output-stream-string str-stream))
    (close str-stream)
  result))

[sje]

[d]r1b2rk1/pp1p1pp1/1b1p2B1/n1qQ2p1/8/5N2/P3RPPP/4R1K1 w - - 0 1

Code: Select all

> (setf ml (generate-canon pos2))
(Bb1 Bc2 Bd3 Be4 Bf5 Bh5 Bh7+ Bxf7+ Kf1 Kh1 Nd2 Nd4 Ne5 Nh4 Nxg5 Qb3 Qc4 Qc6 Qd1 Qd2 Qd3 Qd4
 Qe4 Qe5 Qe6 Qf5 Qxb7 Qxc5 Qxd6 Qxf7+ Qxg5 Ra1 Rb1 Rb2 Rc1 Rc2 Rd1 Rd2 Re3 Re4 Re5 Re6 Re7
 Re8 Rf1 a3 a4 g3 g4 h3 h4)

> (apply-edn-movelist-markings ml)
(Bb1 Bc2 Bd3 Be4 Bf5 Bh5 Bh7+ Bxf7+ Kf1 Kh1 Nd2 Nd4 Ne5 Nh4 Nxg5 Qb3 Qc4 Qc6 Qd1 Qd2 Qd3 Qd4
 Qe4 Qe5 Qe6 Qf5 Qxb7 Qxc5 Qxd6 Qxf7+ Qxg5 Ra1 Rb1 Rb2 Rc1 Rc2 Rd1 Rd2 Re3 Re4 Re5 Re6 Re7
 Re8 Rf1 a3 a4 g3 g4 h3 h4)

> (mapcar #'edn-string ml)
("B-N1" "B-B2" "B-Q3" "B-K4" "B-B5" "B-R5" "B-R7ch" "BxPch" "K-B1" "K-R1" "N-Q2" "N-Q4"
 "N-K5" "N-R4" "NxP" "Q-N3" "Q-B4" "Q-B6" "Q-Q1" "Q-Q2" "Q-Q3" "Q-Q4" "Q-K4" "Q-K5" "Q-K6"
 "Q-B5" "QxP/N7" "QxQ" "QxP/6" "QxP/Bch" "QxP/5" "R-R1" "R-N1" "R-N2" "R-QB1" "R-B2" "R-Q1"
 "R-Q2" "R-K3" "R-K4" "R-K5" "R-K6" "R-K7" "R-K8" "R-KB1" "P-QR3" "P-QR4" "P-N3" "P-N4"
 "P-KR3" "P-KR4")

[sje]

Please note that the EDN syntax tables have been shamelessly stolen from the Chess 0.5 program source.

Code: Select all

;;; English Descriptive Notation (EDN) move encoding

(defconstant edn-capture-limit 36)

(defconstant edn-capture-syntax-vec
  (make-array edn-capture-limit
    :initial-contents
      (vector
        (vector nil nil nil nil nil nil)
        (vector nil nil nil nil nil t  )
        (vector nil nil t   nil nil nil)
        (vector nil nil nil nil t   nil)
        (vector nil t   nil nil nil nil)
        (vector nil nil nil nil t   t  )
        (vector nil t   t   nil nil nil)
        (vector nil nil nil t   t   nil)
        (vector t   t   nil nil nil nil)
        (vector nil nil nil t   t   t  )
        (vector t   t   t   nil nil nil)
        (vector nil nil t   nil nil t  )
        (vector nil t   nil nil t   nil)
        (vector nil nil t   nil t   nil)
        (vector nil t   nil nil nil t  )
        (vector nil t   t   nil nil t  )
        (vector nil nil t   nil t   t  )
        (vector nil t   t   nil t   nil)
        (vector nil t   nil nil t   t  )
        (vector t   t   nil nil nil t  )
        (vector nil nil t   t   t   nil)
        (vector t   t   nil nil t   nil)
        (vector nil t   nil t   t   nil)
        (vector nil nil t   t   t   t  )
        (vector t   t   t   nil nil t  )
        (vector nil t   nil t   t   t  )
        (vector t   t   t   nil t   nil)
        (vector nil t   t   nil t   t  )
        (vector t   t   nil nil t   t  )
        (vector nil t   t   t   t   nil)
        (vector t   t   nil t   t   nil)
        (vector t   t   t   nil t   t  )
        (vector nil t   t   t   t   t  )
        (vector t   t   t   t   t   nil)
        (vector t   t   nil t   t   t  )
        (vector t   t   t   t   t   t  ))))

(defconstant edn-noncapt-limit 11)

(defconstant edn-noncapt-syntax-vec
  (make-array edn-noncapt-limit
    :initial-contents
      (vector
        (vector nil nil nil nil t   t  )
        (vector nil nil nil t   t   t  )
        (vector nil nil t   nil t   t  )
        (vector nil t   nil nil t   t  )
        (vector nil nil t   t   t   t  )
        (vector nil t   nil t   t   t  )
        (vector nil t   t   nil t   t  )
        (vector t   t   nil nil t   t  )
        (vector nil t   t   t   t   t  )
        (vector t   t   nil t   t   t  )
        (vector t   t   t   t   t   t  ))))

(defun apply-edn-syntax-vector (my-move my-syntax-vec)
  "Apply the data in an EDN syntax vector to a move."
  (if (svref my-syntax-vec 0) (set-mfbit my-move mfbit-dnf0) (reset-mfbit my-move mfbit-dnf0))
  (if (svref my-syntax-vec 1) (set-mfbit my-move mfbit-dnf1) (reset-mfbit my-move mfbit-dnf1))
  (if (svref my-syntax-vec 2) (set-mfbit my-move mfbit-dnf2) (reset-mfbit my-move mfbit-dnf2))
  (if (svref my-syntax-vec 3) (set-mfbit my-move mfbit-dnt0) (reset-mfbit my-move mfbit-dnt0))
  (if (svref my-syntax-vec 4) (set-mfbit my-move mfbit-dnt1) (reset-mfbit my-move mfbit-dnt1))
  (if (svref my-syntax-vec 5) (set-mfbit my-move mfbit-dnt2) (reset-mfbit my-move mfbit-dnt2))
  my-move)

(defun similar-edn? (my-move0 my-move1)
  "Return t if the two moves have a similar EDN."
  (and
    (= (move-fr-man my-move0) (move-fr-man my-move1))
    (= (move-msc my-move0) (move-msc my-move1))
    (= (calc-victim-piece my-move0) (calc-victim-piece my-move1))))

(defun encode-edn-sq (my-stream my-color my-sq my-bit0 my-bit1 my-bit2)
  "Encode an EDN square using mover color, royalty disambiguation bit, file bit, and rank bit."
  (when my-bit0
    (put-char my-stream (svref acuc-flank-vec (map-sq-to-flank my-sq))))
  (when my-bit1
    (put-char my-stream (svref ac-edn-file-vec (map-sq-to-file my-sq))))
  (when my-bit2
    (let*
      (
        (rank     (map-sq-to-rank my-sq))
        (adj-rank (if (= my-color color-white) rank (flip-rank rank)))
      )
      (put-char my-stream (svref ac-rank-vec adj-rank))))
  (values))

(defun encode-edn-fr-sq (my-stream my-move)
  "Encode an EDN from-square."
  (let
    (
      (b0 (mfbit-set? my-move mfbit-dnf0))
      (b1 (mfbit-set? my-move mfbit-dnf1))
      (b2 (mfbit-set? my-move mfbit-dnf2))
    )
    (when (or b0 b1 b2)
      (put-char my-stream ascii-slash)
      (encode-edn-sq my-stream (calc-mover-color my-move) (move-fr-sq my-move) b0 b1 b2)))
  (values))

(defun encode-edn-to-sq (my-stream my-move)
  "Encode an EDN to-square."
  (let
    (
      (b0 (mfbit-set? my-move mfbit-dnt0))
      (b1 (mfbit-set? my-move mfbit-dnt1))
      (b2 (mfbit-set? my-move mfbit-dnt2))
    )
    (when (or b0 b1 b2)
      (when (is-move-capture? my-move)
        (put-char my-stream ascii-slash))
      (encode-edn-sq my-stream (calc-mover-color my-move) (move-to-sq my-move) b0 b1 b2)))
  (values))

(defun encode-edn-separator (my-stream my-move)
  "Encode an EDN separator."
  (if (is-move-capture? my-move)
    (put-char my-stream #\x)
    (put-char my-stream #\-))
  (values))

(defun encode-edn-simple (my-stream my-move)
  "Encode an EDN move's simple parts."
  (put-char my-stream (svref acuc-piece-vec (calc-mover-piece my-move)))
  (encode-edn-fr-sq my-stream my-move)
  (encode-edn-separator my-stream my-move)
  (when (is-move-capture? my-move)
    (put-char my-stream (svref acuc-piece-vec (calc-victim-piece my-move))))
  (encode-edn-to-sq my-stream my-move)
  (values))

(defun encode-edn-no-suffix (my-stream my-move)
  "Encode a move in English Descriptive Notation (EDN) without suffix additions."
  (cond
;;
    ((is-move-null? my-move)
      (put-string my-stream "<null>"))
;;
    ((is-move-regular? my-move)
      (encode-edn-simple my-stream my-move))
;;
    ((is-move-en-passant? my-move)
      (encode-edn-simple my-stream my-move)
      (put-string my-stream "e.p."))
;;
    ((is-move-castling? my-move)
     (put-string my-stream (svref mc-msc-to-castling-san-vec (move-msc my-move))))
;;
    ((is-move-promotion? my-move)
      (encode-edn-simple my-stream my-move)
      (put-char my-stream ascii-paren-l)
      (put-char my-stream (svref acuc-piece-vec (svref mc-msc-to-piece-vec (move-msc my-move))))
      (put-char my-stream ascii-paren-r))
;;
    (t (error "encode-edn: cond fault")))
  (values))

(defun encode-edn (my-stream my-move)
  "Encode a move in English Descriptive Notation (EDN); this is here for amusement purposes."
  (encode-edn-no-suffix my-stream my-move)
  (if (is-move-checkmate? my-move)
    (put-string my-stream "mate")
    (when (is-move-check? my-move)
      (put-string my-stream "ch")))
  (when (is-move-illegal? my-move)
    (put-char my-stream  #\*))
  (values))

(declaim (type (function (move) simple-base-string) edn-wsv-string))
(defun edn-wsv-string (my-move my-syntax-vec)
  "Encode an English Descritve Notation (EDN) move on a string with a syntax vector."
  (let ((result nil) (move (clone-move my-move)) (str-stream (make-string-output-stream)))
    (apply-edn-syntax-vector move my-syntax-vec)
    (encode-edn-no-suffix str-stream move)
    (setf result (get-output-stream-string str-stream))
    (close str-stream)
  result))

(declaim (type (function (move) simple-base-string) edn-no-suffix-string))
(defun edn-no-suffix-string (my-move)
  "Encode an English Descritve Notation (EDN) move on a string without suffix additions."
  (let ((result nil) (str-stream (make-string-output-stream)))
    (encode-edn-no-suffix str-stream my-move)
    (setf result (get-output-stream-string str-stream))
    (close str-stream)
  result))

(declaim (type (function (move) simple-base-string) edn-string))
(defun edn-string (my-move)
  "Encode an English Descritve Notation (EDN) move on a string."
  (let ((result nil) (str-stream (make-string-output-stream)))
    (encode-edn str-stream my-move)
    (setf result (get-output-stream-string str-stream))
    (close str-stream)
  result))

[sje]

Code: Select all

;;; English Descriptive Notation (EDN) move list operations

(defun calc-similar-edn-moves (my-move my-moves)
  "Return a list of similar EDN moves."
  (let ((result nil))
    (dolist (move my-moves)
      (when (similar-edn? my-move move)
        (push move result)))
    result))

(defun apply-edn-move-markings (my-move my-similar-moves)
  "Apply EDN markings to a move using the given (similar, inclusive) list of moves."
  (let*
    (
      (done-flag nil)
      (capt-flag (is-move-capture? my-move))
      (msyn-vec  (if capt-flag edn-capture-syntax-vec edn-noncapt-syntax-vec))
      (index     0)
    )
    (dountil done-flag
      (let*
        (
          (syn-vec     (svref msyn-vec index))
          (nominal-edn (edn-wsv-string my-move syn-vec))
          (match-count 0)
        )
        (dolist (move my-similar-moves)
          (when (string= (edn-wsv-string move syn-vec) nominal-edn)
            (incf match-count)))
        (if (> match-count 1)
          (incf index)
          (progn
            (apply-edn-syntax-vector my-move syn-vec)
            (setf done-flag t))))))
  my-move)

(defun apply-edn-movelist-markings (my-moves)
  "Apply EDN markings to each of moves in the given (complete) list of moves."
  (dolist (move my-moves)
    (apply-edn-move-markings move (calc-similar-edn-moves move my-moves)))
  my-moves)

[mhull]

Code: Select all

;;; English Descriptive Notation (EDN) move list operations

(defun calc-similar-edn-moves (my-move my-moves)
  "Return a list of similar EDN moves."
  (let ((result nil))
    (dolist (move my-moves)
      (when (similar-edn? my-move move)
        (push move result)))
    result))

(defun apply-edn-move-markings (my-move my-similar-moves)
  "Apply EDN markings to a move using the given (similar, inclusive) list of moves."
  (let*
    (
      (done-flag nil)
      (capt-flag (is-move-capture? my-move))
      (msyn-vec  (if capt-flag edn-capture-syntax-vec edn-noncapt-syntax-vec))
      (index     0)
    )
    (dountil done-flag
      (let*
        (
          (syn-vec     (svref msyn-vec index))
          (nominal-edn (edn-wsv-string my-move syn-vec))
          (match-count 0)
        )
        (dolist (move my-similar-moves)
          (when (string= (edn-wsv-string move syn-vec) nominal-edn)
            (incf match-count)))
        (if (> match-count 1)
          (incf index)
          (progn
            (apply-edn-syntax-vector my-move syn-vec)
            (setf done-flag t))))))
  my-move)

(defun apply-edn-movelist-markings (my-moves)
  "Apply EDN markings to each of moves in the given (complete) list of moves."
  (dolist (move my-moves)
    (apply-edn-move-markings move (calc-similar-edn-moves move my-moves)))
  my-moves)

Is there some code that will convert EDN to SAN?