CIL Toolkit: code snippets: move generation

[sje]

Code for determining castling capability and for pawn capture squares has been factored out of the various move generation routines.

Neither routine actually generates moves. Instead, each routine returns a list telling the caller which moves need to be generated.

Code: Select all

;;; Castling list determination

(defun calc-castling-list (my-pos)
  "Return a list of available castlings; works only for the current active color."
  (let ((result nil))
    (dolist (castling (svref mc-color-to-castling-list-vec (pos-act-color my-pos)))
      (when
        (and
          (logbit? castling (pos-castbits my-pos))
          (bb-ni2? (pos-loc-merge-bb my-pos) (svref castling-vacant-bb-vec castling))
          (bb-ni2?
            (svref (pos-atk-by-color-bb-vec my-pos) (pos-pas-color my-pos))
            (svref castling-attack-bb-vec castling)))
        (push castling result)))
    result))

Code: Select all

;;; Pawn capture target square list construction

(defun calc-pc-sqs (my-act-color my-fr-sq my-rstrct-dir my-pas-loc-bb)
  "Return a list of pawn capture target squares; works only for the current active color."
  (let ((result nil) (e-capt-sq nil) (w-capt-sq nil) (fr-file (map-sq-to-file my-fr-sq)))
    (if (= my-act-color color-white)
      (progn
        (when (and (< fr-file file-h) (or (not my-rstrct-dir) (= my-rstrct-dir dir-ne)))
          (setf e-capt-sq (+ my-fr-sq delta-ne))
          (when (sq-set? my-pas-loc-bb e-capt-sq)
            (push e-capt-sq result)))
        (when (and (> fr-file file-a) (or (not my-rstrct-dir) (= my-rstrct-dir dir-nw)))
          (setf w-capt-sq (+ my-fr-sq delta-nw))
          (when (sq-set? my-pas-loc-bb w-capt-sq)
            (push w-capt-sq result))))
      (progn
        (when (and (< fr-file file-h) (or (not my-rstrct-dir) (= my-rstrct-dir dir-se)))
          (setf e-capt-sq (+ my-fr-sq delta-se))
          (when (sq-set? my-pas-loc-bb e-capt-sq)
            (push e-capt-sq result)))
        (when (and (> fr-file file-a) (or (not my-rstrct-dir) (= my-rstrct-dir dir-sw)))
          (setf w-capt-sq (+ my-fr-sq delta-sw))
          (when (sq-set? my-pas-loc-bb w-capt-sq)
            (push w-capt-sq result)))))
    result))

[sje]

Code: Select all

;;; Distances

(defmacro calc-file-delta (my-sq0 my-sq1)
  "Calculate the file delta from the first square to the second."
  `(- (map-sq-to-file ,my-sq1) (map-sq-to-file ,my-sq0)))

(defmacro calc-rank-delta (my-sq0 my-sq1)
  "Calculate the rank delta from the first square to the second."
  `(- (map-sq-to-rank ,my-sq1) (map-sq-to-rank ,my-sq0)))

(defun calc-taxicab-distance (my-sq0 my-sq1)
  "Calculate the taxicab distance between the first square and the second."
  (+ (abs (calc-file-delta my-sq0 my-sq1)) (abs (calc-rank-delta my-sq0 my-sq1))))

(defun calc-king-step-distance (my-sq0 my-sq1)
  "Calculate the king-step distance between the first square and the second."
  (let
    (
      (abs-file-delta (abs (calc-file-delta my-sq0 my-sq1)))
      (abs-rank-delta (abs (calc-rank-delta my-sq0 my-sq1)))
    )
    (max abs-file-delta abs-rank-delta)))


;;; Millisquare distances

(defun calc-sq-center (my-sq)
  "Return a list of the floating point coordinates of a square."
  (list (+ (map-sq-to-file my-sq) 0.5) (+ (map-sq-to-rank my-sq) 0.5)))

(defun calc-ms-distance (my-sq0 my-sq1)
  "Calculate the distance in linear millisquares between the centers of two squares."
  (truncate
    (* 1000.0
      (sqrt
        (+
          (square-numeric (calc-file-delta my-sq0 my-sq1))
          (square-numeric (calc-rank-delta my-sq0 my-sq1)))))))

(defun initialize-ms-distance-vec ()
  "Provide the initial value of millisquare intersquare distance vector."
  (let ((result (make-array (list sq-limit sq-limit))))
    (dosqs (sq0)
      (dosqs (sq1)
        (setf (aref result sq0 sq1) (calc-ms-distance sq0 sq1))))
    result))

(defconstant ms-distance-vec (initialize-ms-distance-vec))

(defun calc-ms-center-distance (my-sq)
  "Calculate the distance in linear millisquares between a square and the board center."
  (let ((coordinates (calc-sq-center my-sq)))
    (truncate
      (* 1000.0
        (sqrt
          (+
            (square-numeric (- 4.0 (first  coordinates)))
            (square-numeric (- 4.0 (second coordinates)))))))))

(defun initialize-ms-center-distance-vec ()
  "Provide the initial value of millisquare center distance vector."
  (let ((result (make-array sq-limit)))
    (dosqs (sq)
      (setf (aref result sq) (calc-ms-center-distance sq)))
    result))

(defconstant ms-center-distance-vec (initialize-ms-center-distance-vec))

(defun initialize-ms-center-distance-delta-vec ()
  "Provide the initial value of millisquare center delta distance vector."
  (let ((result (make-array (list sq-limit sq-limit))))
    (dosqs (sq0)
      (dosqs (sq1)
        (setf
          (aref result sq0 sq1)
          (- (svref ms-center-distance-vec sq1) (svref ms-center-distance-vec sq0)))))
    result))

(defconstant ms-center-distance-delta-vec (initialize-ms-center-distance-delta-vec))

[sje]

Yes, it's possible to put comments in Lisp.

Code: Select all

(defun calc-pinned (my-pos)
  "Calculate the bitboard vector of the pinned men for the given position."
  (let
    (
      (result              (mk-bb-vector color-rlimit))      ; A vector of two empty bitboards; one per color
      (loc-merge-bb        (pos-loc-merge-bb my-pos))        ; All pieces merged bitboard
      (loc-sweep-bb        (pos-loc-sweep-bb my-pos))        ; All sweeper pieces bitboard
      (loc-color-bb-vec    (pos-loc-color-bb-vec my-pos))    ; Pieces by color bitboard vector
      (atk-by-color-bb-vec (pos-atk-by-color-bb-vec my-pos)) ; Attacks by color bitboard vector
      (atk-to-sq-bb-vec    (pos-atk-to-sq-bb-vec my-pos))    ; Attacks to square bitboard vector
      (king-sq-vec         (pos-king-sq-vec my-pos))         ; King location square vector
    )
    (docolors (color) ; Produce two pinned piece bitboards, one per color
      (let*
        (
          (other-color    (flip-color color))                        ; The other color
          (other-loc-bb   (svref loc-color-bb-vec other-color))      ; The other color pieces bitboard
          (other-sweep-bb (bb-and2 loc-sweep-bb other-loc-bb))       ; The other color sweep pieces bitboard
          (king-sq        (svref king-sq-vec color))                 ; The king square
          (cand-bb        (clone-bb (svref loc-color-bb-vec color))) ; Pinned pieces candidate bitboard
        )
        (bb-and2d cand-bb (svref sweep-attack-bb-vec king-sq))     ; Remove not in line candidates
        (bb-and2d cand-bb (svref atk-by-color-bb-vec other-color)) ; Remove unattacked candidates
        (loop-bb (cand-bb cand-sq)                         ; For each cadidate square in the candidate bitboard
          (when (clear-path? king-sq cand-sq loc-merge-bb) ; A clear path from the king to the candidate?
            (unless
              (bb-ni3?                                     ; Test for the null intersection of 3 bitboards
                other-sweep-bb                             ; Other color sweepers
                (svref atk-to-sq-bb-vec cand-sq)           ; Attackers to the candidate square
                (fetch-beyond-bb king-sq cand-sq))         ; The squares beyond the candidate in line with king
              (set-sq (svref result color) cand-sq))))))   ; Set candidate square in the result bitboard
    result)) ; Function return value is a bitboard vector indexed by color

[sje]

Code: Select all

;;; Character constants

(defconstant ascii-brack-l (code-char 91))
(defconstant ascii-brack-r (code-char 93))
(defconstant ascii-cr      (code-char 13))
(defconstant ascii-esc     (code-char 27))
(defconstant ascii-nl      (code-char 10))
(defconstant ascii-paren-l (code-char 40))
(defconstant ascii-paren-r (code-char 41))
(defconstant ascii-space   (code-char 32))
(defconstant ascii-tab     (code-char  9))


;;; ANSI terminal colors

(defconstant ansi-color-black   0)
(defconstant ansi-color-red     1)
(defconstant ansi-color-green   2)
(defconstant ansi-color-yellow  3)
(defconstant ansi-color-blue    4)
(defconstant ansi-color-magneta 5)
(defconstant ansi-color-cyan    6)
(defconstant ansi-color-white   7)


;;; Simple character formatting routines

(defun put-char (my-stream my-char)
  "Format a cahracter on the given stream."
  (format my-stream "~C" my-char))

(defun newline (my-stream)
  "Format a newline on the given stream."
  (put-char my-stream ascii-nl))

(defun blank (my-stream)
  "Format a blank on the given stream."
  (put-char my-stream ascii-space))


;;; More character formatting routines

(defun fmt-escape (my-stream)
  "Format an escape character on the given stream."
  (put-char my-stream ascii-esc))

(defun fmt-brack-l (my-stream)
  "Format a left bracket character on the given stream."
  (put-char my-stream ascii-brack-l))

(defun fmt-brack-r (my-stream)
  "Format a right bracket character on the given stream."
  (put-char my-stream ascii-brack-r))

(defun fmt-paren-l (my-stream)
  "Format a left parenthesis character on the given stream."
  (put-char my-stream ascii-paren-l))

(defun fmt-paren-r (my-stream)
  "Format a right parenthesis character on the given stream."
  (put-char my-stream ascii-paren-r))


;;; ANSI terminal escape sequences

(defun ansi-escape-base (my-stream)
  "Format the base characters for an ANSI escape sequence."
  (fmt-escape  my-stream)
  (fmt-brack-l my-stream))
  
(defun ansi-fc-bc-bold (my-stream my-fore-color my-back-color my-bold-flag)
  "Set the ANSI color and bold attributes on the given stream."
  (ansi-escape-base my-stream)
  (if my-bold-flag
    (put-char my-stream #\1)
    (put-char my-stream #\0))
  (put-char my-stream #\;)
  (put-char my-stream #\3)
  (put-char my-stream (code-char (+ my-fore-color 48)))
  (put-char my-stream #\;)
  (put-char my-stream #\4)
  (put-char my-stream (code-char (+ my-back-color 48)))
  (put-char my-stream #\m))
  
(defun ansi-reset (my-stream)
  "Reset the ANSI terminal attributes on the given stream."
  (ansi-escape-base my-stream)
  (put-char my-stream #\0)
  (put-char my-stream #\m))

(defun encode-board-vec (my-stream my-board-vec)
  "Encode a simple color graphic of a board vector to a stream."
  (doranks (alt-rank)
    (let ((rank (flip-rank alt-rank)))
      (dofiles (file)
        (let*
          (
            (sq         (map-file-rank-to-sq file rank))
            (man        (get-man my-board-vec sq))
            (back-color (if (is-sq-white? sq) ansi-color-white ansi-color-green))
          )
          (if (is-man-vacant? man)
            (progn
              (ansi-fc-bc-bold my-stream ansi-color-black back-color nil)
              (format my-stream "  "))
            (progn
              (if (is-man-white? man)
                (ansi-fc-bc-bold my-stream ansi-color-red  back-color nil)
                (ansi-fc-bc-bold my-stream ansi-color-blue back-color nil))
              (format my-stream "~A" (svref as-man-vec man))))
          (ansi-reset my-stream))))
      (newline my-stream)))

[sje]

I've managed to get the new CIL Toolkit to output moves using FAN (Figurine Algebraic Notation) via the chess piece figurines in the Unicode standard.

However, it doesn't come out all that well on a typical display unless the font size is set way too big. And even then there are spacing issues.

So I disconnected the FAN encoder. But here are the Unicode chess figurine codes if anyone else would like to attempt something similar in their program:

Code: Select all

(defconstant unicode-wp (code-char 9817))
(defconstant unicode-wn (code-char 9816))
(defconstant unicode-wb (code-char 9815))
(defconstant unicode-wr (code-char 9814))
(defconstant unicode-wq (code-char 9813))
(defconstant unicode-wk (code-char 9812))
(defconstant unicode-bp (code-char 9823))
(defconstant unicode-bn (code-char 9822))
(defconstant unicode-bb (code-char 9821))
(defconstant unicode-br (code-char 9820))
(defconstant unicode-bq (code-char 9819))
(defconstant unicode-bk (code-char 9818))

(defconstant man-unicode-vec
  (make-array man-rlimit
    :initial-contents
      (vector
        unicode-wp unicode-wn unicode-wb unicode-wr unicode-wq unicode-wk
        unicode-bp unicode-bn unicode-bb unicode-br unicode-bq unicode-bk)))

[sje]

Here is the second version of the move generator routine used to output all legal checking moves for the moving color not in check. Unlike the first version, the pawn logic is much more efficient, rather longer, and a bit more difficult to write.

Code: Select all

;;; Move generation: all legal checking moves when not in check

(defun generate-checks (my-pos)
  "Return a list of all checking moves for the given position with the king not in check."
  (let*
    (
      (result           nil)
      (act-color        (pos-act-color my-pos))
      (pas-color        (pos-pas-color my-pos))
      (act-king-sq      (svref (pos-king-sq-vec my-pos) act-color))
      (pas-king-sq      (svref (pos-king-sq-vec my-pos) pas-color))
      (act-loc-bb       (svref (pos-loc-color-bb-vec my-pos) act-color))
      (pas-loc-bb       (svref (pos-loc-color-bb-vec my-pos) pas-color))
      (loc-merge-bb     (pos-loc-merge-bb my-pos))
      (loc-sweep-bb     (pos-loc-sweep-bb my-pos))
      (target-bb        (bb-not act-loc-bb))
      (act-sweep-bb     (bb-and2 act-loc-bb loc-sweep-bb))
      (ep-sq            (pos-ep-sq my-pos))
      (adv-delta        (svref pawn-advance-delta-vec act-color))
      (pinned-bb        (svref (pos-pinned-bb-vec my-pos) act-color))
      (frozen-bb        (svref (pos-frozen-bb-vec my-pos) act-color))
      (rstrct-bb        (bb-and2c2 pinned-bb frozen-bb))
      (fr-bb            (bb-and2c2 act-loc-bb frozen-bb))
      (board-vec        (pos-board-vec my-pos))
      (inline-bb        (mk-bb))
      (orw-bb           (mk-bb))
      (drw-bb           (mk-bb))
      (srw-bb           (mk-bb))
      (crw-bb           (bb-and2c2 (svref crook-attack-bb-vec pas-king-sq) act-loc-bb))
      (prw-bb           (bb-and2c2 (aref pawn-attack-bb-vec pas-color pas-king-sq) act-loc-bb))
      (atk-fr-sq-bb-vec (pos-atk-fr-sq-bb-vec my-pos))
      (atk-to-sq-bb-vec (pos-atk-to-sq-bb-vec my-pos))
    )
;;
;;  Calculate runways: orthogonals
;;
    (doorthodirs (dir)
      (let ((scan-sqs (fetch-open-ray-sqs pas-king-sq dir)))
        (do ((scan-sq (pop scan-sqs))) ((not scan-sq))
          (if (sq-reset? loc-merge-bb scan-sq)
            (progn
              (set-sq orw-bb scan-sq)
              (setf scan-sq (pop scan-sqs)))
            (progn
              (if (sq-set? pas-loc-bb scan-sq)
                (set-sq orw-bb scan-sq)
                (set-sq inline-bb scan-sq))
              (setf scan-sq nil))))))
    (bb-or2d srw-bb orw-bb)
;;
;;  Calculate runways: diagonals
;;
    (dodiagodirs (dir)
      (let ((scan-sqs (fetch-open-ray-sqs pas-king-sq dir)))
        (do ((scan-sq (pop scan-sqs))) ((not scan-sq))
          (if (sq-reset? loc-merge-bb scan-sq)
            (progn
              (set-sq drw-bb scan-sq)
              (setf scan-sq (pop scan-sqs)))
            (progn
              (if (sq-set? pas-loc-bb scan-sq)
                (set-sq drw-bb scan-sq)
                (set-sq inline-bb scan-sq))
              (setf scan-sq nil))))))
    (bb-or2d srw-bb drw-bb)
;;
;; Finalize discovery inline bitboard
;;
    (let ((cand-bb (clone-bb inline-bb)))
      (loop-bb (cand-bb cand-sq)
        (when
          (bb-ni3?
            act-sweep-bb
            (svref atk-to-sq-bb-vec cand-sq)
            (fetch-beyond-bb pas-king-sq cand-sq))
          (reset-sq inline-bb cand-sq))))
;;
;; From man scan
;;
    (loop-bb (fr-bb fr-sq)
      (let*
        (
          (fr-man       (get-man board-vec fr-sq))
          (fr-piece     (svref mc-man-to-piece-vec fr-man))
          (to-bb        (bb-and2 (svref atk-fr-sq-bb-vec fr-sq) target-bb))
          (inline-flag  (sq-set? inline-bb fr-sq))
          (rstrct-flag  (sq-set? rstrct-bb fr-sq))
        )
        (cond
;;
;; Pawn checks
;;
          ((= fr-piece piece-pawn)
            (let*
              (
                (fr-rank     (map-sq-to-rank fr-sq))
                (rstrct-dir  (if rstrct-flag (fetch-dir act-king-sq fr-sq)))
                (pk-p-dir    (if inline-flag (fetch-dir pas-king-sq fr-sq)))
                (pk-p-bidir  (if inline-flag (svref mc-sweep-dir-to-bidir-vec pk-p-dir)))
                (adv-ch-flag (if inline-flag (/= pk-p-bidir bidir-n)))
                (r2-flag     (= fr-rank (svref 2nd-rank-vec act-color)))
                (r7-flag     (= fr-rank (svref 7th-rank-vec act-color)))
                (pc-sqs      (calc-pc-sqs act-color fr-sq rstrct-dir pas-loc-bb))
              )
;;
;; Pawn checks (non-captures)
;;
              (when
                (or
                  (not rstrct-flag)
                  (= (svref mc-sweep-dir-to-bidir-vec rstrct-dir) bidir-n))
                (let ((to-sq (+ fr-sq adv-delta)))
                  (when (sq-reset? loc-merge-bb to-sq)
                    (cond
                      (r2-flag
                        (when (or adv-ch-flag (sq-set? prw-bb to-sq))
                          (push (mm-simp fr-sq to-sq fr-man) result))
                        (incf to-sq adv-delta)
                        (when (sq-reset? loc-merge-bb to-sq)
                          (when (or adv-ch-flag (sq-set? prw-bb to-sq))
                            (push (mm-simp fr-sq to-sq fr-man) result))))
                      (r7-flag
                        (if adv-ch-flag
                          (dolist (msc msc-gen-promotion-list)
                            (push (mm-prom fr-sq to-sq fr-man msc) result))
                          (let ((psq-pk-dir (fetch-dir pas-king-sq to-sq)))
                            (when psq-pk-dir
                              (cond
                                ((is-dir-crook? psq-pk-dir)
                                  (push (mm-prom fr-sq to-sq fr-man msc-ppn) result))
                                ((is-dir-diago? psq-pk-dir)
                                  (when (clear-path? pas-king-sq to-sq loc-merge-bb)
                                    (push (mm-prom fr-sq to-sq fr-man msc-ppq) result)
                                    (push (mm-prom fr-sq to-sq fr-man msc-ppb) result)))
                                ((is-dir-ortho? psq-pk-dir)
                                  (if
                                    (and
                                      (same-rank? pas-king-sq to-sq)
                                      (clear-path? pas-king-sq to-sq loc-merge-bb))
                                    (progn
                                      (push (mm-prom fr-sq to-sq fr-man msc-ppq) result)
                                      (push (mm-prom fr-sq to-sq fr-man msc-ppr) result))
                                    (when
                                      (and
                                        (same-file? pas-king-sq fr-sq)
                                        (clear-path? pas-king-sq fr-sq loc-merge-bb))
                                      (push (mm-prom fr-sq to-sq fr-man msc-ppq) result)
                                      (push (mm-prom fr-sq to-sq fr-man msc-ppr) result))))
                                (t (error "cond fault: generate-checks/1")))))))
                      (t
                        (when (or adv-ch-flag (sq-set? prw-bb to-sq))
                          (push (mm-simp fr-sq to-sq fr-man) result)))))))
;;
;; Pawn checks (simple captures)
;;
              (dolist (to-sq pc-sqs)
                (let*
                  (
                    (to-man      (get-man board-vec to-sq))
                    (capt-dir    (fetch-dir fr-sq to-sq))
                    (capt-bidir  (svref mc-sweep-dir-to-bidir-vec capt-dir))
                    (cap-ch-flag (if inline-flag (/= pk-p-bidir capt-bidir)))
                  )
                  (if r7-flag
                    (if cap-ch-flag
                      (dolist (msc msc-gen-promotion-list)
                        (push (mm-prcp fr-sq to-sq fr-man to-man msc) result))
                      (let ((psq-pk-dir (fetch-dir pas-king-sq to-sq)))
                        (when psq-pk-dir
                          (cond
                            ((is-dir-crook? psq-pk-dir)
                              (push (mm-prcp fr-sq to-sq fr-man to-man msc-ppn) result))
                            ((is-dir-diago? psq-pk-dir)
                              (if (clear-path? pas-king-sq to-sq loc-merge-bb)
                                (progn
                                  (push (mm-prcp fr-sq to-sq fr-man to-man msc-ppq) result)
                                  (push (mm-prcp fr-sq to-sq fr-man to-man msc-ppb) result))
                                (when
                                  (and
                                    (clear-path? pas-king-sq fr-sq loc-merge-bb)
                                    (= psq-pk-dir capt-dir)) 
                                  (push (mm-prcp fr-sq to-sq fr-man to-man msc-ppq) result)
                                  (push (mm-prcp fr-sq to-sq fr-man to-man msc-ppb) result))))
                            ((is-dir-ortho? psq-pk-dir)
                              (when (clear-path? pas-king-sq to-sq loc-merge-bb)
                                (push (mm-prcp fr-sq to-sq fr-man to-man msc-ppq) result)
                                (push (mm-prcp fr-sq to-sq fr-man to-man msc-ppr) result)))
                            (t (error "cond fault: generate-checks/2"))))))
                    (when (or cap-ch-flag (sq-set? prw-bb to-sq))
                      (push (mm-capt fr-sq to-sq fr-man to-man) result)))))
;;
;; Pawn checks (en passant captures)
;;
              (when (and ep-sq (find ep-sq (aref pawn-sqs-vec act-color fr-sq)))
                (let ((epcp-move (mm-epcp fr-man fr-sq ep-sq)))
                  (when (is-move-playable-and-checks? epcp-move my-pos)
                    (push epcp-move result))))))
;;
;; Knight checks
;;
          ((= fr-piece piece-knight)
            (unless inline-flag
              (bb-and2d to-bb crw-bb))
            (loop-bb (to-bb to-sq)
              (push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
;;
;; Bishop checks
;;
          ((= fr-piece piece-bishop)
            (when rstrct-flag
              (bb-and2d to-bb (fetch-beamer-bb act-king-sq fr-sq)))
            (unless inline-flag
              (bb-and2d to-bb drw-bb))
            (loop-bb (to-bb to-sq)
              (push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
;;
;; Rook checks
;;
          ((= fr-piece piece-rook)
            (when rstrct-flag
              (bb-and2d to-bb (fetch-beamer-bb act-king-sq fr-sq)))
            (unless inline-flag
              (bb-and2d to-bb orw-bb))
            (loop-bb (to-bb to-sq)
              (push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
;;
;; Queen checks
;;
          ((= fr-piece piece-queen)
            (when rstrct-flag
              (bb-and2d to-bb (fetch-beamer-bb act-king-sq fr-sq)))
            (bb-and2d to-bb srw-bb)
            (loop-bb (to-bb to-sq)
              (push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
;;
;; King checks
;;
          ((= fr-piece piece-king)
            (when inline-flag
              (bb-and2c2d to-bb (fetch-beamer-bb pas-king-sq act-king-sq))
              (bb-and2c2d to-bb (svref (pos-atk-by-color-bb-vec my-pos) pas-color))
              (loop-bb (to-bb to-sq)
                (push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
            (dolist (castling (calc-castling-list my-pos))
              (let ((rook-sq (svref castling-rook-cstl-sq-vec castling)))
                (cond
                  ((same-file? pas-king-sq rook-sq)
                    (when (clear-path? pas-king-sq rook-sq loc-merge-bb)
                      (push (clone-move (svref castling-move-vec castling)) result)))
                  ((same-rank? pas-king-sq act-king-sq)
                    (when (clear-path? pas-king-sq act-king-sq loc-merge-bb)
                      (push (clone-move (svref castling-move-vec castling)) result)))
                  (t nil)))))
;;
          (t (error "cond fault: generate-checks")))))
;;
;; Mark all moves as checks
;;
    (dolist (move result)
      (set-mf move mf-chck))
    result))

[sje]

A target tracker is something like a piece list. Except that it's an array instead of a list. And that it has it's own inverse mapping array. Oh, and it also has a push-down stack for keeping track of captures.

In the new CIL Toolkit, each position contains a tracker object. The tracker is updated incrementally as part of move execution and retraction.

A tracker is not used for move generation or any kind of board scanning. Instead, it's used to help higher level reasoning identify and lock on to a given piece or pieces over the course of a sequence of moves.

Code: Select all

;;; The target tracker associates targets and squares

(defconstant tg-limit 32)

(defstruct tkr
  (pairs  nil)
  (sq-vec nil)
  (tg-vec nil))
  
(defun mk-tkr ()
  "Return a clear tracker."
  (make-tkr
    :pairs  nil
    :sq-vec (make-array tg-limit :initial-element nil)
    :tg-vec (make-array sq-limit :initial-element nil)))

(defun clone-tkr (my-tkr)
  "Return a clone of the given tracker."
  (make-tkr
    :pairs  (copy-seq (tkr-pairs  my-tkr))
    :sq-vec (copy-seq (tkr-sq-vec my-tkr))
    :tg-vec (copy-seq (tkr-tg-vec my-tkr))))

(defun calc-tkr (my-board-vec)
  "Return a tracker initialized from a board vector."
  (let ((result (mk-tkr)) (tg 0))
    (dosqs (sq)
      (when (is-man-nonvac? (get-man my-board-vec sq))
        (setf (svref (tkr-tg-vec result) sq) tg)
        (setf (svref (tkr-sq-vec result) tg) sq)
        (incf tg)))
    result))
    

;;; Tracker updates

(defun track-tran (my-fr-sq my-to-sq my-tkr)
  "Move a target from a square to a square in the given tracker."
  (let ((tg (svref (tkr-tg-vec my-tkr) my-fr-sq)))
    (setf (svref (tkr-tg-vec my-tkr) my-fr-sq) nil)
    (setf (svref (tkr-tg-vec my-tkr) my-to-sq) tg)
    (setf (svref (tkr-sq-vec my-tkr) tg) my-to-sq))
  my-tkr)

(defun track-push (my-sq my-tkr)
  "Remove a target on the given square in the given tracker."
  (let ((tg (svref (tkr-tg-vec my-tkr) my-sq)))
    (setf (svref (tkr-tg-vec my-tkr) my-sq) nil)
    (setf (svref (tkr-sq-vec my-tkr) tg) nil)
    (push (cons my-sq tg) (tkr-pairs my-tkr)))
  my-tkr)

(defun track-pop (my-tkr)
  "Undo a target removal in the given tracker."
  (let* ((pair (pop (tkr-pairs my-tkr))) (sq (first pair)) (tg (rest pair)))
    (setf (svref (tkr-tg-vec my-tkr) sq) tg)
    (setf (svref (tkr-sq-vec my-tkr) tg) sq))
  my-tkr)


;;; Tracker square and target access

(defun get-track-tg (my-sq my-tkr)
  "Return the target for the given square and tracker."
  (svref (tkr-tg-vec my-tkr) my-sq))

(defun get-track-sq (my-tg my-tkr)
  "Return the square for the given target and tracker."
  (svref (tkr-sq-vec my-tkr) my-tg))

[sje]

The move execute/retract routines now handle material score maintenance and target tracking. Also, some minor enhancements.

Code: Select all

;;; Move execution

(defun execute-move (my-move my-pos)
  "Execute the given move on the given position."
  (let*
    (
      (not-null-flag (not (is-move-null? my-move)))
      (fr-sq         (move-fr-sq  my-move))
      (to-sq         (move-to-sq  my-move))
      (fr-man        (move-fr-man my-move))
      (to-man        (move-to-man my-move))
      (msc           (move-msc    my-move))
      (act-color     (pos-act-color   my-pos))
      (pas-color     (pos-pas-color   my-pos))
      (castbits      (pos-castbits    my-pos))
      (ep-sq         (pos-ep-sq       my-pos))
      (king-sq-vec   (pos-king-sq-vec my-pos))
      (board-vec     (pos-board-vec   my-pos))
      (tkr           (pos-tkr         my-pos))
      (fr-piece      (svref mc-man-to-piece-vec fr-man))
    )
    (when not-null-flag
      (cond
;;
;; Regular moves
;;
        ((is-msc-regular? msc)
          (when (is-man-nonvac? to-man)
            (del-material to-man my-pos)
            (hash-man-sq to-man to-sq my-pos)
            (track-push to-sq tkr)
            (del-man to-man to-sq my-pos))
          (hash-man-sq-sq fr-man fr-sq to-sq my-pos)
          (track-tran fr-sq to-sq tkr)
          (move-man fr-man fr-sq to-sq my-pos))
;;
;; En passant capture moves
;;
        ((is-msc-en-passant? msc)
          (let
            (
              (victim-sq  (+ to-sq (svref pawn-retreat-delta-vec act-color)))
              (victim-man (synth-man pas-color piece-pawn))
            )
            (del-material victim-man my-pos)
            (hash-man-sq victim-man victim-sq my-pos)
            (track-push victim-sq tkr)
            (del-man victim-man victim-sq my-pos))
          (hash-man-sq-sq fr-man fr-sq to-sq my-pos)
          (track-tran fr-sq to-sq tkr)
          (move-man fr-man fr-sq to-sq my-pos))
;;
;; Castling moves
;;
        ((is-msc-castling? msc)
          (hash-man-sq-sq fr-man fr-sq to-sq my-pos)
          (track-tran fr-sq to-sq tkr)
          (move-man fr-man fr-sq to-sq my-pos)
          (let*
            (
              (castling   (aref mc-msc-color-to-castling-vec msc act-color))
              (rook-fr-sq (svref castling-rook-home-sq-vec castling))
              (rook-to-sq (svref castling-rook-cstl-sq-vec castling))
              (rook-man   (synth-man act-color piece-rook))
            )
            (hash-man-sq-sq rook-man rook-fr-sq rook-to-sq my-pos)
            (track-tran rook-fr-sq rook-to-sq tkr)
            (move-man rook-man rook-fr-sq rook-to-sq my-pos)))
;;
;; Pawn promotion moves
;;
        ((is-msc-promotion? msc)
          (when (is-man-nonvac? to-man)
            (del-material to-man my-pos)
            (hash-man-sq to-man to-sq my-pos)
            (track-push to-sq tkr)
            (del-man to-man to-sq my-pos))
          (del-material fr-man my-pos)
          (hash-man-sq fr-man fr-sq my-pos)
          (track-tran fr-sq to-sq tkr)
          (del-man fr-man fr-sq my-pos)
          (let ((prom-man (synth-man act-color (svref mc-msc-to-piece-vec msc))))
            (add-material prom-man my-pos)
            (hash-man-sq prom-man to-sq my-pos)
            (add-man prom-man to-sq my-pos)))
;;
        (t (error "cond fault: execute-move"))))
;;
;; Environment update: active/passive colors
;;
    (setf (pos-act-color my-pos) pas-color)
    (setf (pos-pas-color my-pos) act-color)
;;
;; Environment update: castling availability bits
;;
    (when (and not-null-flag (nonzero? castbits))
      (let*
        (
          (pres-fr-castbits (svref castbits-preservation-vec fr-sq))
          (pres-to-castbits (svref castbits-preservation-vec to-sq))
          (new-castbits     (logand castbits (logand pres-fr-castbits pres-to-castbits)))
        )
        (when (/= castbits new-castbits)
          (let ((changed-castbits (logxor castbits new-castbits)))
            (docastlings (castling)
              (when (logbit? castling changed-castbits)
                (hc-xor2d (pos-main-hash my-pos) (fetch-castling-hash castling)))))
          (setf (pos-castbits my-pos) new-castbits))))
;;
;; Environment update: en passant capture square
;;
    (when ep-sq
      (hc-xor2d (pos-main-hash my-pos) (fetch-ep-sq-hash ep-sq))
      (setf (pos-ep-sq my-pos) nil))
    (when (and (= fr-piece piece-pawn) (= (abs (- to-sq fr-sq)) abs-double-adv-delta))
      (setf ep-sq (calc-ep-sq-board-vec act-color to-sq board-vec))
      (when ep-sq
        (hc-xor2d (pos-main-hash my-pos) (fetch-ep-sq-hash ep-sq))
        (setf (pos-ep-sq my-pos) ep-sq)))
;;
;; Environment update: half move clock
;;
    (if (and not-null-flag (or (is-man-nonvac? to-man) (= fr-piece piece-pawn)))
      (setf (pos-hmvc my-pos) 0)
      (incf (pos-hmvc my-pos)))
;;
;; Environment update: full move number
;;
    (when (= color-black act-color)
      (incf (pos-fmvn my-pos)))
;;
;; Environment update: king square vector
;;
    (when (= fr-piece piece-king)
      (setf (svref king-sq-vec act-color) to-sq))
;;
;; Environment update: pinned and frozen bitboard vectors
;;
    (when not-null-flag
      (setf (pos-pinned-bb-vec my-pos) (calc-pinned my-pos))
      (setf (pos-frozen-bb-vec my-pos) (calc-frozen my-pos))))
;;
  my-move)


;;; Move retraction

(defun retract-move (my-move my-pos)
  "Retract the given move on the given position."
  (let
    (
      (fr-sq     (move-fr-sq  my-move))
      (to-sq     (move-to-sq  my-move))
      (fr-man    (move-fr-man my-move))
      (to-man    (move-to-man my-move))
      (msc       (move-msc    my-move))
      (act-color (pos-act-color my-pos))
      (tkr       (pos-tkr       my-pos))
    )
    (unless (is-move-null? my-move)
      (cond
;;
;; Regular moves
;;
        ((is-msc-regular? msc)
          (track-tran to-sq fr-sq tkr)
          (move-man fr-man to-sq fr-sq my-pos)
          (when (is-man-nonvac? to-man)
            (track-pop tkr)
            (add-man to-man to-sq my-pos)))
;;
;; En passant capture moves
;;
        ((is-msc-en-passant? msc)
          (track-tran to-sq fr-sq tkr)
          (move-man fr-man to-sq fr-sq my-pos)
          (track-pop tkr)
          (add-man
            (synth-man (flip-color act-color) piece-pawn)
            (+ to-sq (svref pawn-retreat-delta-vec act-color))
            my-pos))
;;
;; Castling moves
;;
        ((is-msc-castling? msc)
          (let*
            (
              (castling   (aref mc-msc-color-to-castling-vec msc act-color))
              (rook-fr-sq (svref castling-rook-home-sq-vec castling))
              (rook-to-sq (svref castling-rook-cstl-sq-vec castling))
              (rook-man   (synth-man act-color piece-rook))
            )
            (track-tran rook-to-sq rook-fr-sq tkr)
            (move-man rook-man rook-to-sq rook-fr-sq my-pos))
          (track-tran to-sq fr-sq tkr)
          (move-man fr-man to-sq fr-sq my-pos))
;;
;; Pawn promotion moves
;;
        ((is-msc-promotion? msc)
          (track-tran to-sq fr-sq tkr)
          (move-man fr-man to-sq fr-sq my-pos)
          (del-man (synth-man act-color (svref mc-msc-to-piece-vec msc)) to-sq my-pos)
          (add-man fr-man fr-sq my-pos)
          (when (is-man-nonvac? to-man)
            (track-pop tkr)
            (add-man to-man to-sq my-pos)))
;;
        (t (error "cond fault: retract-move")))))
  my-move)

[sje]

After reviewing some of the higher level code, I decided to modify the position data structure to reduce upper level complexity. The position structure now understands about history including prior moves, prior hashes, etc. Alas, this makes the position structure maintenance a bit more complex, but the complexity is encapsulated and so doesn't escape too easily. The only routines that really have to understand the internal history stacks are the move execute/retract pair. (These routines are now up to version three and I'll repost them yet again.)

The one drawback with the new "smart" position structure is that the position flipper routine that changes the position side to move and all other items can't handle flipping saved hashes. Or at least not without unacceptable amounts of computation. But this isn't a problem as the only time a position is flipped is during book operations as the book is stored as all white-to-move data. And book operations aren't concerned with saved hashes; only the position repetition code cares about these.

The old way of doing things:

Code: Select all

(let ((saved-posenv (clone-posenv (pos-posenv pos))))
  (execute-move move pos)
  ; Do something at the next ply
  (setf (pos-posenv pos) saved-posenv)
  (retract-move move pos))

The new way of doing things:

Code: Select all

(execute-move move pos)
; Do something at the next ply
(retract-move pos)

Other accessing code including references to hash history and the current variation are also significantly simplified, and overall parameter usage is generally reduced.

The revised position structure:

Code: Select all

(defstruct
  (pos
    (:print-function
      (lambda (my-pos my-stream my-level)
        (declare (ignore my-level))
        (encode-pos-graphic my-stream my-pos))))
  (act-color           nil)  ; The color (side) on the move (see FEN specification)
  (pas-color           nil)  ; The color (side) not on the move
  (castbits            nil)  ; Castling availability bits (see FEN specification)
  (ep-sq               nil)  ; En passant target square, if any (see FEN specification)
  (hmvc                nil)  ; Half move clock (see FEN specification)
  (fmvn                nil)  ; Full move number (see FEN specification)
  (main-hash           nil)  ; Main hash; uses board-vec, castbits, and ep-sq
  (pawn-hash           nil)  ; Pawn hash; uses board-vec
  (pinned-bb-vec       nil)  ; A vector of bitboards by color with pinned man squares
  (frozen-bb-vec       nil)  ; A vector of bitboards by color with frozen man squares
  (castbits-stack      nil)  ; Previous values of castbits
  (ep-sq-stack         nil)  ; Previous values of ep-sq
  (hmvc-stack          nil)  ; Previous values of hmvc
  (main-hash-stack     nil)  ; Previous values of main-hash
  (pawn-hash-stack     nil)  ; Previous values of pawn-hash
  (pinned-bb-vec-stack nil)  ; Previous values of pinned-bb-vec
  (frozen-bb-vec-stack nil)  ; Previous values of frozen-bb-vec
  (move-stack          nil)  ; Previous values of executed moves
  (bbdb                nil)  ; The bitboard database
  (board-vec           nil)  ; The board vector indexed by square and containing men
  (census              nil)  ; The color/man census
  (king-sq-vec         nil)  ; A vector of squares indexed by color of king locations
  (material-vec        nil)  ; A vector of scores indexed by color of material
  (tkr                 nil)) ; The target tracker

[sje]

Position cloning:

Code: Select all

(defun clone-pos (my-pos)
  "Return a clone of the given position."
  (make-pos
    :act-color           (pos-act-color my-pos)
    :pas-color           (pos-pas-color my-pos)
    :castbits            (pos-castbits  my-pos)
    :ep-sq               (pos-ep-sq     my-pos)
    :hmvc                (pos-hmvc      my-pos)
    :fmvn                (pos-fmvn      my-pos)
    :main-hash           (clone-hash        (pos-main-hash           my-pos))
    :pawn-hash           (clone-hash        (pos-pawn-hash           my-pos))
    :pinned-bb-vec       (clone-pin-bb-vec  (pos-pinned-bb-vec       my-pos))
    :frozen-bb-vec       (clone-pin-bb-vec  (pos-frozen-bb-vec       my-pos))
    :castbits-stack      (copy-seq          (pos-castbits-stack      my-pos))
    :ep-sq-stack         (copy-seq          (pos-ep-sq-stack         my-pos))
    :hmvc-stack          (copy-seq          (pos-hmvc-stack          my-pos))
    :main-hash-stack     (clone-hashes      (pos-main-hash-stack     my-pos))
    :pawn-hash-stack     (clone-hashes      (pos-pawn-hash-stack     my-pos))
    :pinned-bb-vec-stack (clone-pin-bb-vecs (pos-pinned-bb-vec-stack my-pos))
    :frozen-bb-vec-stack (clone-pin-bb-vecs (pos-frozen-bb-vec-stack my-pos))
    :move-stack          (clone-moves       (pos-move-stack          my-pos))
    :bbdb                (clone-bbdb        (pos-bbdb                my-pos))
    :board-vec           (clone-board-vec   (pos-board-vec           my-pos))
    :census              (clone-census      (pos-census              my-pos))
    :king-sq-vec         (copy-seq          (pos-king-sq-vec         my-pos))
    :material-vec        (copy-seq          (pos-material-vec        my-pos))
    :tkr                 (clone-tkr         (pos-tkr                 my-pos))))

Position flipping:

Code: Select all

(defun flip-pos (my-pos)
  "Return a color-reversed position."
  (let*
    (
      (result (make-pos))
      (board-vec (flip-board-vec (pos-board-vec my-pos)))
      (act-color (flip-color (pos-act-color my-pos)))
      (pas-color (flip-color (pos-pas-color my-pos)))
      (castbits  (flip-castbits (pos-castbits my-pos)))
      (ep-sq     (flip-ep-sq (pos-ep-sq my-pos)))
      (hmvc      (pos-hmvc my-pos))
      (fmvn      (pos-fmvn my-pos))
      (main-hash (calc-main-hash board-vec castbits ep-sq))
      (pawn-hash (calc-pawn-hash board-vec))
    )
    (setf (pos-act-color           result) act-color)
    (setf (pos-pas-color           result) pas-color)
    (setf (pos-castbits            result) castbits)
    (setf (pos-ep-sq               result) ep-sq)
    (setf (pos-hmvc                result) hmvc)
    (setf (pos-fmvn                result) fmvn)
    (setf (pos-main-hash           result) main-hash)
    (setf (pos-pawn-hash           result) pawn-hash)
    (setf (pos-pinned-bb-vec       result) (flip-pin-bb-vec (pos-pinned-bb-vec my-pos)))
    (setf (pos-frozen-bb-vec       result) (flip-pin-bb-vec (pos-frozen-bb-vec my-pos)))
    (setf (pos-castbits-stack      result) (flip-castbitses (pos-castbits-stack my-pos)))
    (setf (pos-ep-sq-stack         result) (flip-ep-sqs (pos-ep-sq-stack my-pos)))
    (setf (pos-hmvc-stack          result) (copy-seq (pos-hmvc-stack my-pos)))
    (setf (pos-main-hash-stack     result) nil)
    (setf (pos-pawn-hash-stack     result) nil)
    (setf (pos-pinned-bb-vec-stack result) (flip-pin-bb-vecs (pos-pinned-bb-vec-stack my-pos)))
    (setf (pos-frozen-bb-vec-stack result) (flip-pin-bb-vecs (pos-frozen-bb-vec-stack my-pos)))
    (setf (pos-move-stack          result) (flip-moves (pos-move-stack my-pos)))
    (setf (pos-bbdb                result) (flip-bbdb (pos-bbdb my-pos)))
    (setf (pos-board-vec           result) board-vec)
    (setf (pos-census              result) (flip-census (pos-census my-pos)))
    (setf (pos-king-sq-vec         result) (flip-king-sq-vec (pos-king-sq-vec my-pos)))
    (setf (pos-material-vec        result) (flip-material-vec (pos-material-vec my-pos)))
    (setf (pos-tkr                 result) (calc-tkr board-vec))
    result))