CIL Toolkit: code snippets: move generation

[sje]

Code: Select all

;;; Position repetition counting

(defun count-repetitions (my-pos my-mh-stack my-limit)
  "Return the count of position repetitions in the given position and main hash stack."
  (let
    (
      (result    0)
      (hmvc      (pos-hmvc my-pos))
      (main-hash (pos-main-hash my-pos))
    )
    (do ((index 0 (1+ index))) ((or (= index hmvc) (null my-mh-stack) (= result my-limit)))
      (let ((prior-main-hash (pop my-mh-stack)))
        (when (and (odd? index) (hash-equal? main-hash prior-main-hash))
          (incf result))))
    result))


;;; Single repetition detection

(defun is-repeated? (my-pos my-mh-stack)
  "Return t if there is a position repetition in the given position and main hash stack."
  (one? (count-repetitions my-pos my-mh-stack 1)))


;;; Drawing status determination

(defun is-fifty-moves-draw? (my-pos)
  "Return t if there a fifty move rule draw in the given position."
  (>= (pos-hmvc my-pos) 100))

(defun is-insufficient-material-draw? (my-pos)
  "Return t if there is insufficent mating material draw in the given position."
  (insufficient-material? (pos-census my-pos)))

(defun is-repetition-draw? (my-pos my-mh-stack)
  "Return t if there is position repetition draw in the given position and main hash stack."
  (two? (count-repetitions my-pos my-mh-stack 2)))


;;; Checkmate/stalemate status determination

(defun is-checkmate? (my-pos)
  "Return t if the active king is checkmated in the given position."
  (and (is-act-king-in-check? my-pos) (no-moves? my-pos)))

(defun is-stalemate? (my-pos)
  "Return t if the active king is checkmated in the given position."
  (and (not (is-act-king-in-check? my-pos)) (no-moves? my-pos)))

[sje]

Code: Select all

;;; Position game termination

(defun calc-game-termination (my-pos my-mh-stack)
  "Determine the game termination value for the given position."
  (cond
    ((is-insufficient-material-draw? my-pos)  sgt-no-material)
    ((is-fifty-moves-draw? my-pos)            sgt-fifty-moves)
    ((is-repetition-draw? my-pos my-mh-stack) sgt-repetition)
    ((is-checkmate? my-pos)                   sgt-checkmate)
    ((is-stalemate? my-pos)                   sgt-stalemate)
    (t                                        sgt-unterminated)))

(defun select-random-move (my-pos)
  "Select and return a random move."
  (let ((result nil) (moves (generate my-pos)))
    (when moves
      (setf result (elt moves (random (length moves)))))
    result))

(defun play-random-game ()
  (let
    (
      (result    sgt-unterminated)
      (pos       (create-initial-array-pos))
      (mhc-stack nil)
    )
    (do () ((/= result sgt-unterminated))
      (let ((move (select-random-move pos)))
        (push (clone-hash (pos-main-hash pos)) mhc-stack)
        (execute-move move pos)
        (setf result (calc-game-termination pos mhc-stack))))
    ;(format t "~A : ~A~%" (pos-string pos) (svref as-sgt-vec result))
    result))

(defun play-multiple-random-games (my-limit)
  "Play multiple random games and return a summary vector."
  (let ((result (make-array sgt-limit :initial-element 0)))
    (dotimes (index my-limit)
      (let ((sgt (play-random-game)))
        (incf (svref result sgt))))
    result))

(defun report-multiple-random-game-terminations (my-limit)
  (let ((result (play-multiple-random-games my-limit)))
    (dotimes (sgt sgt-limit)
      (let ((count (svref result sgt)))
        (when (plus? count)
          (format t "~A~22T~5D~29T~6,4F~%"
            (svref as-sgt-vec sgt)
            count
            (float (/ count my-limit))))))))

Some results:

Code: Select all

> (report-multiple-random-game-terminations 1000)
checkmate               154  0.1540
fifty moves             202  0.2020
insufficient material   544  0.5440
position repetition      30  0.0300
stalemate                70  0.0700
NIL

[sje]

More results (running with a bytecode interpreter):

Code: Select all

> (time (report-multiple-random-game-terminations 10000))
checkmate              1535  0.1535
fifty moves            1984  0.1984
insufficient material  5617  0.5617
position repetition     247  0.0247
stalemate               617  0.0617

Real time: 1247.502 sec.
Run time: 1245.9521 sec.
Space: 6048678432 Bytes
GC: 5256, GC time: 65.42527 sec.

[sje]

Here's a Lisp macro definition for a bitboard scanning loop:

Code: Select all

(defmacro loop-bb ((my-bb my-sq) &rest my-body)
  "Destructively iterate through the set squares in a bitboard."
  `(do ((,my-sq (next-sq ,my-bb) (next1-sq ,my-bb ,my-sq))) ((not ,my-sq))
    ,@my-body))

The above macro calls two other user defined macros:

Code: Select all

(defmacro next-sq (my-bb)
  "Return the index of the first bit in a bitboard and clear; return nil if none."
  `(let ((result (position 1 ,my-bb)))
    (when result
      (setf (sbit ,my-bb result) 0))
    result))

(defmacro next1-sq (my-bb my-start-sq)
  "Same as next-sq, but with a starting index."
  `(let ((result (position 1 ,my-bb :start ,my-start-sq)))
    (when result
      (setf (sbit ,my-bb result) 0))
    result))

Here's an example first level expansion of the above scanning loop macro:

Code: Select all

> (macroexpand-1 '(loop-bb (bb sq) (print sq) (speak-square sq)))
(DO ((SQ (NEXT-SQ BB) (NEXT1-SQ BB SQ))) ((NOT SQ)) (PRINT SQ) (SPEAK-SQUARE SQ))

Note that the Lisp "do" construct is itself a macro. Here's the full expansion (does not include the expansion of the next-sq and next1-sq macros):

Code: Select all

> (macroexpand '(loop-bb (bb sq) (print sq) (speak-square sq)))
(BLOCK NIL
 (LET ((SQ (NEXT-SQ BB)))
  (TAGBODY #:LOOP-13404 (IF (NOT SQ) (GO #:END-13405)) (PRINT SQ) (SPEAK-SQUARE SQ) (PSETQ SQ (NEXT1-SQ BB SQ)) (GO #:LOOP-13404) #:END-13405
   (RETURN-FROM NIL (PROGN)))))

Fortunately, the evil tagbody (label), go (go-to), and return-from (break) function calls are all hidden from the programmer.

[sje]

One common bug attractor in a chess program is the move execute/retract routine pair. Anyone who has written a wholly bitboard program can vouch for this.

The new CIL Toolkit has the typical bitboard database structure, along with other structures for a position. One way of testing the execute/retract routine pair is to take a position and a move sequence playable from that position and seeing if, after executing and then retracting the sequence, the resulting position matches the initial position. Other consistency tests can be run on all the positions in both the forward and backward directions.

Here's the execute/retract test routine in the toolkit:

Code: Select all

(defun execute-retract-sequence-test (my-moves my-pos)
  "Verify that a position is correctly preserved across sequence execution and retraction."
  (let ((result t) (pos (clone-pos my-pos)) (move-stack nil) (posenv-stack nil))
    (dolist (move my-moves)
      (let* ((gen-moves (generate pos)) (gen-move (find-move move gen-moves)))
        (when (not gen-move)
          (error "execute-retract-sequence-test: can't find move"))
        (push move move-stack)
        (push (clone-posenv (pos-posenv pos)) posenv-stack)
        (execute-move move pos)
        (when (is-pas-king-in-check? pos)
          (error "execute-retract-sequence-test: passive king in check after execute"))))
    (dowhile move-stack
      (setf (pos-posenv pos) (pop posenv-stack))
      (retract-move (pop move-stack) pos)
      (when (is-pas-king-in-check? pos)
        (error "execute-retract-sequence-test: passive king in check after retract")))
    (when (not (equalp pos my-pos))
      (error "execute-retract-sequence-test: position mismatch"))
    result))

[sje]

A random game is a game produced by playing randomly selected moves until some game termination condition is met. Random game production is somewhat useful for program testing.

Here are the random game routines form the toolkit:

Code: Select all

;;; Random game production

(defun select-random-move (my-pos my-rcv)
  "Select and return a random move; include extended diagnostics."
  (let
    (
      (result nil)
      (moves (generate my-pos))
      (move-count (count-moves my-pos))
      (no-move-flag (no-moves? my-pos))
    )
    (when (/= (length moves) move-count)
      (format t "CV: ~A~%" (reverse my-rcv))
      (error "select-random-move: move count mismatch."))
    (when (and no-move-flag (nonzero? move-count))
      (format t "CV: ~A~%" (reverse my-rcv))
      (error "select-random-move: no-moves fault 1."))
    (when (and (not no-move-flag) (zero? move-count))
      (format t "CV: ~A~%" (reverse my-rcv))
      (error "select-random-move: no-moves fault 2."))
    (when moves
      (setf result (elt moves (random (length moves)))))
    result))

(defun play-random-game ()
  "Play a game using randomly selected moves; include extended diagnostics."
  (let*
    (
      (sgt       sgt-unterminated)
      (ia-pos    (create-initial-array-pos))
      (pos       (clone-pos ia-pos))
      (cv        nil)
      (rcv       nil)
      (mhc-stack nil)
    )
    (do () ((/= sgt sgt-unterminated))
      (let ((move (select-random-move pos rcv)))
        (push move rcv)
        (push (clone-hash (pos-main-hash pos)) mhc-stack)
        (execute-move move pos)
        (when (is-pas-king-in-check? pos)
          (format t "CV: ~A~%" (reverse rcv))
          (error "play-random-game: passive king in check."))
        (setf sgt (calc-game-termination pos mhc-stack))))
    (setf cv (reverse rcv))
    (mark-san-flags-sequence cv ia-pos)
    (execute-retract-sequence-test cv ia-pos)
    (list sgt (length cv))))

(defun play-multiple-random-games (my-limit)
  "Play multiple random games and return a summary vector."
  (let ((result (make-array sgt-limit :initial-element 0)) (move-count 0))
    (dotimes (index my-limit)
      (let ((sgt-and-count (play-random-game)))
        (incf (svref result (first sgt-and-count)))
        (incf move-count (second sgt-and-count))))
    (format t "Total move count: ~D~%" move-count)
    result))

(defun report-multiple-random-game-terminations (my-limit)
  "Play multiple random games and produce a summary report."
  (let ((result (play-multiple-random-games my-limit)))
    (dotimes (sgt sgt-limit)
      (let ((count (svref result sgt)))
        (when (plus? count)
          (format t "~A~27T~5D~34T~6,4F~%"
            (svref as-sgt-vec sgt)
            count
            (float (/ count my-limit))))))))

[sje]

The CIL Toolkit, like my much earlier program Spector, uses integer millipawns as the basic score unit. Unlike Spector, the toolkit correctly knows how to move scores up and down in a search tree. (Hint: simple negation is not enough when changing ply.)

Most of this was stolen from Symbolic:

Code: Select all

;;; All scores are in millipawns

(defconstant score-scale       1000)
(defconstant score-float-scale (float score-scale))


;;; Upper/lower bounds based on 24 bit two's complement arithmetic

(defconstant score-bit-width 24)


;;; Special scores: the broken score (illegal position) and the infinities

(defconstant broken-score (- (ash 1 score-bit-width)))
(defconstant posinf-score (1- (ash 1 score-bit-width)))
(defconstant neginf-score (1+ (- (ash 1 score-bit-width))))


;;; The even score and some synonyms

(defconstant even-score       0)
(defconstant draw-score       even-score)
(defconstant stalemated-score even-score)


;;; The score margin limit allows out of range mate/lose distances deep in a search tree

(defconstant score-margin-limit 1024)


;;; Who knows what the longest possible mate might be?

(defconstant longest-mate-move-limit 8192)


;;;  Extrema points for the mate and lose score ranges, and a synonym

(defconstant mate-in-1-score (1- (- posinf-score score-margin-limit)))
(defconstant lose-in-0-score (+ neginf-score score-margin-limit))

(defconstant checkmated-score lose-in-0-score)


;;; Mate/lose score synthesis macros

(defmacro synth-mate-in-n (my-fmvc)
  "Synthesize a mate in N score given the full move count."
  `(- mate-in-1-score (1- ,my-fmvc)))

(defmacro synth-lose-in-n (my-fmvc)
  "Synthesize a lose in N score given the full move count."
  `(+ lose-in-0-score ,my-fmvc))


;;; Some more synonyms

(defconstant lose-in-1-score (synth-lose-in-n 1))
(defconstant mate-in-2-score (synth-mate-in-n 2))
(defconstant lose-in-2-score (synth-lose-in-n 2))
(defconstant mate-in-3-score (synth-mate-in-n 3))


;;; Longest mate/longest lose scores

(defconstant longest-mate-score (synth-mate-in-n longest-mate-move-limit))
(defconstant longest-lose-score (synth-lose-in-n (1- longest-mate-move-limit)))


;;; Range testing macros for mate/lose scores

(defmacro is-mating-score? (my-score)
  "Return t if the score is a mating score."
  `(and (/= ,my-score broken-score) (>= ,my-score longest-mate-score)))

(defmacro is-losing-score? (my-score)
  "Return t if the score is a losing score."
  `(and (/= ,my-score broken-score) (<= ,my-score longest-lose-score)))


;;; Macros to calculate full move counts for mate/lose scores

(defmacro calc-mate-distance (my-score)
  "Calculate the mating distance in full moves for the given mating score."
  `(1+ (- mate-in-1-score ,my-score)))

(defmacro calc-lose-distance (my-score)
  "Calculate the losing distance in full moves for the given losing score."
  `(- ,my-score lose-in-0-score))


;;; Routines to adjust scores for moving down or up in a search tree

(defun downshift-score (my-score)
  "Adjust a score moving down one ply."
  (cond
    ((= my-score broken-score) my-score)
    ((= my-score even-score)   my-score)
    ((= my-score posinf-score) neginf-score)
    ((= my-score neginf-score) posinf-score)
    ((is-mating-score? my-score) (synth-lose-in-n (1- (calc-mate-distance my-score))))
    ((is-losing-score? my-score) (synth-mate-in-n (1- (calc-lose-distance my-score))))
    ((> my-score even-score) (1- (- my-score)))
    ((< my-score even-score) (1+ (- my-score)))
    (t (error "cond fault: downshift-score"))))

(defun upshift-score (my-score)
  "Adjust a score moving up one ply."
  (cond
    ((= my-score broken-score) my-score)
    ((= my-score posinf-score) neginf-score)
    ((= my-score neginf-score) posinf-score)
    ((= my-score even-score)   my-score)
    ((is-mating-score? my-score) (synth-lose-in-n (1+ (calc-mate-distance my-score))))
    ((is-losing-score? my-score) (synth-mate-in-n (1+ (calc-lose-distance my-score))))
    ((> my-score even-score) (1+ (- my-score)))
    ((< my-score even-score) (1- (- my-score)))
    (t (error "cond fault: upshift-score"))))


;;; Conversion

(defun convert-pawn-score (my-pawn-score)
  "Convert a pawn score, either integer or float, into integer millipawns."
  (cond
    ((integer? my-pawn-score) (* my-pawn-score score-scale))
    ((float?   my-pawn-score) (truncate (* my-pawn-score score-float-scale)))
    (t (error "cond fault: convert-pawn-score"))))


;;; Score encoding

(defun encode-score (my-stream my-score)
  "Produce a formatted score on the given stream."
  (cond
    ((= my-score broken-score)
      (format my-stream "Broken"))
    ((= my-score posinf-score)
      (format my-stream "PosInf"))
    ((= my-score neginf-score)
      (format my-stream "NegInf"))
    ((= my-score even-score)
      (format my-stream "Even"))
    ((= my-score checkmated-score)
      (format my-stream "Checkmated"))
    ((is-mating-score? my-score)
      (format my-stream "MateIn~D" (calc-mate-distance my-score)))
    ((is-losing-score? my-score)
      (format my-stream "LoseIn~D" (calc-lose-distance my-score)))
    ((> my-score even-score)
      (format my-stream "+~5,3F" (/ my-score score-float-scale)))
    ((< my-score even-score)
      (format my-stream "-~5,3F" (/ (- my-score) score-float-scale)))
    (t (error "cond fault: encode-score"))))

(defun score-string (my-score)
  "Produce a string with the given score."
  (let ((result nil) (stream (make-string-output-stream)))
    (encode-score stream my-score)
    (setf result (get-output-stream-string stream))
  result))


;;; Material scores

(defconstant pawn-score   (convert-pawn-score 1.000))
(defconstant knight-score (convert-pawn-score 3.250))
(defconstant bishop-score (convert-pawn-score 3.333))
(defconstant rook-score   (convert-pawn-score 5.000))
(defconstant queen-score  (convert-pawn-score 9.000))
(defconstant king-score   (convert-pawn-score 0.000))
(defconstant vacant-score (convert-pawn-score 0.000))
(defconstant extra-score  (convert-pawn-score 0.000))

(defconstant mc-piece-to-score-vec
  (make-array piece-limit
    :initial-contents
      (list
        pawn-score knight-score bishop-score rook-score queen-score king-score
        vacant-score extra-score)))

(defconstant mc-man-to-score-vec
  (make-array man-limit
    :initial-contents
      (list
        pawn-score knight-score bishop-score rook-score queen-score king-score
        pawn-score knight-score bishop-score rook-score queen-score king-score
        vacant-score extra-score)))


;;; Material score summation

(defun calc-material-vec (my-board-vec)
  "Return a vector of total material scores indexed by color."
  (let ((result (make-array color-rlimit :initial-element even-score)))
    (dotimes (sq sq-limit)
      (let ((man (svref my-board-vec sq)))
        (when (is-man-nonvac? man)
          (incf
            (svref result (svref mc-man-to-color-vec man))
            (svref mc-man-to-score-vec man)))))
    result))


;;; Material score per side for the initial array

(defconstant start-score (svref (calc-material-vec initial-array-board-vec) color-white))

[Jan Brouwer]

((> my-score even-score) (1- (- my-score)))
((< my-score even-score) (1+ (- my-score)))

If I have translated this correctly into C (I don't know Lisp):

Code: Select all

if (my_score > even_score)
{
  my_score = -my_score - 1;
}
else if (my_score < even_score)
{
  my_score = -my_score + 1;
}

then why is the 1 added / subtracted?

[sje]

then why is the 1 added / subtracted?

The idea is that the scores generated away the root are drawn towards the draw score as the analysis moves towards the root.

This is not strictly needed for non-mate/non-lose scores.

[sje]

Without using bitboards for calculation, here are the routines that generate a bitboard vector of pinned pieces (one element per color) and a a bitboard vector of frozen pieces (one element per color). Note: Frozen pieces are pinned and have absolutely no moves; a pinned knight is always frozen, but a pinned queen is never frozen.

Code: Select all

;;; Frozen pawn checking

(defconstant frozen-pawn-color-dir-vec
  (make-array (list color-rlimit dir-slimit)
    :initial-contents
      (list
        (list t   nil t   nil t   t   nil nil)
        (list t   nil t   nil nil nil t   t  ))))


;;; Pinned/frozen bitboard calculation using a board vector as input

(defun does-pinner-exist? (my-color my-dir my-scan-sqs my-board-vec)
  "Return t if a pinning man exists according to the input parameters."
  (let ((result nil))
    (when my-scan-sqs
      (let ((cand-sq nil) (other-color (flip-color my-color)) (scan-man nil))
        (do ((scan-sq nil) (stop-flag nil)) ((or (null? my-scan-sqs) stop-flag))
          (setf scan-sq (pop my-scan-sqs))
          (setf scan-man (svref my-board-vec scan-sq))
          (let ((scan-color (svref mc-man-to-color-vec scan-man)))
            (cond
              ((= scan-color color-vacant)
                nil)
              ((= scan-color my-color)
                (setf stop-flag t))
              ((= scan-color other-color)
                (setf cand-sq scan-sq)
                (setf stop-flag t))
              (t
                (error "cond fault: does-pinner-exist?")))))
        (when (and cand-sq (man-dir-sweep-capable? scan-man (flip-dir my-dir)))
          (setf result t))))
    result))

(defun find-pin-sq (my-color my-king-sq my-dir my-board-vec)
  "Find a pin square (if any) according to the input parameters."
  (let ((result nil) (scan-sqs (aref open-ray-sqs-vec my-king-sq my-dir)))
    (when scan-sqs
      (let ((cand-sq nil) (other-color (flip-color my-color)))
        (do ((scan-sq nil) (stop-flag nil)) ((or (null? scan-sqs) stop-flag))
          (setf scan-sq (pop scan-sqs))
          (let ((scan-color (svref mc-man-to-color-vec (svref my-board-vec scan-sq))))
            (cond
              ((= scan-color color-vacant)
                nil)
              ((= scan-color my-color)
                (setf cand-sq scan-sq)
                (setf stop-flag t))
              ((= scan-color other-color)
                (setf stop-flag t))
              (t
                (error "cond fault: find-pin-sq")))))
        (when (and cand-sq (does-pinner-exist? my-color my-dir scan-sqs my-board-vec))
          (setf result cand-sq))))
    result))

(defun calc-pinned-bb-vec (my-king-sq-vec my-board-vec)
  "Return a new pinned bitboard vector calculated from the given board vector."
  (let ((result (mk-bb-vector color-rlimit)))
    (dotimes (color color-rlimit)
      (let ((king-sq (svref my-king-sq-vec color)))
        (dolist (dir sweep-dir-list)
          (let ((pin-sq (find-pin-sq color king-sq dir my-board-vec)))
            (when pin-sq
              (set-sq (svref result color) pin-sq))))))
    result))

(defun calc-frozen-bb-vec (my-king-sq-vec my-pinned-bb-vec my-board-vec)
  "Return a new frozen bitboard vector calculated from the given board vector."
  (let ((result (mk-bb-vector color-rlimit)))
    (dotimes (color color-rlimit)
      (let
        (
          (king-sq (svref my-king-sq-vec color))
          (cand-bb (clone-bb (svref my-pinned-bb-vec color)))
        )
        (loop-bb (cand-bb cand-sq)
          (let
            (
              (piece (svref mc-man-to-piece-vec (svref my-board-vec cand-sq)))
              (dir (aref intersquare-dir-vec cand-sq king-sq))
            )
            (cond
              ((= piece piece-pawn)
                (when (aref frozen-pawn-color-dir-vec color dir)
                  (set-sq (svref result color) cand-sq)))
              ((= piece piece-knight)
                (set-sq (svref result color) cand-sq))
              ((= piece piece-bishop)
                (when (is-dir-ortho? dir)
                  (set-sq (svref result color) cand-sq)))
              ((= piece piece-rook)
                (when (is-dir-diago? dir)
                  (set-sq (svref result color) cand-sq)))
              ((= piece piece-queen)
                nil)
              ((= piece piece-king)
                nil)
              (t
                (error "cond fault: calc-frozen-bb-vec")))))))
    result))