CIL Toolkit: code snippets: move generation

[sje]

FEN position structure and basic routines:

Code: Select all

(defstruct
  (fenpos
    (:print-function
      (lambda (my-fenpos my-stream my-level)
        (declare (ignore my-level))
        (encode-fenpos my-stream my-fenpos))))
  (board-vec nil)  ; The chessman placement data (see FEN specification)
  (act-color nil)  ; The color (side) on the move (see FEN specification)
  (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)

(defun mk-fenpos ()
  "Return a cleared FEN position."
  (make-fenpos
    :board-vec (mk-board-vec)
    :act-color color-white
    :castbits  castbits-none
    :ep-sq     nil
    :hmvc      0
    :fmvn      1))

(defun clone-fenpos (my-fenpos)
  "Return a clone of the given FEN position."
  (make-fenpos
    :board-vec (clone-board-vec (fenpos-board-vec my-fenpos))
    :act-color (fenpos-act-color my-fenpos)
    :castbits  (fenpos-castbits  my-fenpos)
    :ep-sq     (fenpos-ep-sq     my-fenpos)
    :hmvc      (fenpos-hmvc      my-fenpos)
    :fmvn      (fenpos-fmvn      my-fenpos)))

(defun create-initial-array-fenpos ()
  "Create a FEN position that contains the initial chess position."
  (make-fenpos
    :board-vec (create-initial-array-board-vec)
    :act-color color-white
    :castbits  castbits-all
    :ep-sq     nil
    :hmvc      0
    :fmvn      1))

Convert a position to a FEN position:

Code: Select all

(defun calc-fenpos-from-pos (my-pos)
  "Calculate and return a new FEN position from a legal position."
  (make-fenpos
    :board-vec (clone-board-vec (pos-board-vec my-pos))
    :act-color (pos-act-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)))

Convert a FEN position to a position:

Code: Select all

(defun calc-pos-from-fenpos (my-fenpos)
  "Calculate and return a new position from a legal FEN position."
  (let*
    (
      (result        nil)
      (act-color     (fenpos-act-color my-fenpos))
      (board-vec     (clone-board-vec (fenpos-board-vec my-fenpos)))
      (castbits      (fenpos-castbits  my-fenpos))
      (ep-sq         (fenpos-ep-sq     my-fenpos))
    )
    (setf
      result
      (make-pos
        :act-color           act-color
        :pas-color           (flip-color act-color)
        :castbits            castbits
        :ep-sq               ep-sq
        :hmvc                (fenpos-hmvc my-fenpos)
        :fmvn                (fenpos-fmvn my-fenpos)
        :main-hash           (calc-main-hash board-vec castbits ep-sq)
        :pawn-hash           (calc-pawn-hash board-vec)
        :pinned-bb-vec       nil
        :frozen-bb-vec       nil
        :castbits-stack      nil
        :ep-sq-stack         nil
        :hmvc-stack          nil
        :main-hash-stack     nil
        :pawn-hash-stack     nil
        :pinned-bb-vec-stack nil
        :frozen-bb-vec-stack nil
        :move-stack          nil
        :bbdb                (calc-bbdb         board-vec)
        :board-vec           board-vec
        :census              (calc-census       board-vec)
        :king-sq-vec         (calc-king-sq-vec  board-vec)
        :material-vec        (calc-material-vec board-vec)
        :tkr                 (calc-tkr          board-vec)))
      (setf (pos-pinned-bb-vec result) (calc-pinned result))
      (setf (pos-frozen-bb-vec result) (calc-frozen result))
    result))

FEN position encoding:

Code: Select all

(defun encode-fen-scalars (my-stream my-act-color my-castbits my-ep-sq my-hmvc my-fmvn)
  "Encode a set of FEN position scalar components to a stream."
  (put-char my-stream (svref ac-color-vec my-act-color))
  (blank my-stream)
  (encode-castbits my-stream my-castbits)
  (blank my-stream)
  (encode-ep-sq my-stream my-ep-sq)
  (blank my-stream)
  (put-numeric my-stream my-hmvc)
  (blank my-stream)
  (put-numeric my-stream my-fmvn))

(defun encode-fen (my-stream my-board-vec my-act-color my-castbits my-ep-sq my-hmvc my-fmvn)
  "Encode a FEN position to a stream via components."
  (encode-ppd-board-vec my-stream my-board-vec)
  (blank my-stream)
  (encode-fen-scalars my-stream my-act-color my-castbits my-ep-sq my-hmvc my-fmvn))

(defun encode-fenpos (my-stream my-fenpos)
  "Encode a FEN position to a stream."
  (encode-fen
    my-stream
    (fenpos-board-vec my-fenpos)
    (fenpos-act-color my-fenpos)
    (fenpos-castbits  my-fenpos)
    (fenpos-ep-sq     my-fenpos)
    (fenpos-hmvc      my-fenpos)
    (fenpos-fmvn      my-fenpos)))

(defun fenpos-string (my-fenpos)
  "Return the FEN string for a FEN position."
  (let ((result nil) (stream (make-string-output-stream)))
    (encode-fenpos stream my-fenpos)
    (setf result (get-output-stream-string stream))
    (close stream)
  result))

[sje]

The move execute/retract routine pair had to be modified to allow for he new "smart" position structure that tracks history.

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))
      (board-vec     (pos-board-vec my-pos))
      (tkr           (pos-tkr       my-pos))
      (fr-piece      (svref mc-man-to-piece-vec fr-man))
    )
;;
;; Save the castling availability bits
;;
    (push castbits (pos-castbits-stack my-pos))
;;
;; Save the en passant target square
;;
    (push ep-sq (pos-ep-sq-stack my-pos))
;;
;; Save the half move clock
;;
    (push (pos-hmvc my-pos) (pos-hmvc-stack my-pos))
;;
;; Save the main and pawn hashes
;;
    (push (clone-hash (pos-main-hash my-pos)) (pos-main-hash-stack my-pos))
    (push (clone-hash (pos-pawn-hash my-pos)) (pos-pawn-hash-stack my-pos))
;;
;; Save the pinned and frozen bitboard vectors
;;
    (push (clone-bb-vec (pos-pinned-bb-vec my-pos)) (pos-pinned-bb-vec-stack my-pos))
    (push (clone-bb-vec (pos-frozen-bb-vec my-pos)) (pos-frozen-bb-vec-stack my-pos))
;;
;; Save the move
;;
    (push (clone-move my-move) (pos-move-stack my-pos))
;;
;; Execute the move
;;
    (when not-null-flag
      (cond
;;
;; Regular move execution
;;
        ((is-msc-regular? msc)
          (when (is-man-nonvac? to-man)
            (hash-man-sq to-man to-sq my-pos)
            (track-push to-sq tkr)
            (del-material to-man my-pos)
            (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)
          (when (= fr-piece piece-king)
            (setf (svref (pos-king-sq-vec my-pos) act-color) to-sq)))

;;
;; En passant capture move execution
;;
        ((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))
            )
            (hash-man-sq victim-man victim-sq my-pos)
            (track-push victim-sq tkr)
            (del-material victim-man my-pos)
            (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 move execution
;;
        ((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)
          (setf (svref (pos-king-sq-vec my-pos) act-color) to-sq)
          (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 move execution
;;
        ((is-msc-promotion? msc)
          (when (is-man-nonvac? to-man)
            (hash-man-sq to-man to-sq my-pos)
            (track-push to-sq tkr)
            (del-material to-man my-pos)
            (del-man to-man to-sq my-pos))
          (hash-man-sq fr-man fr-sq my-pos)
          (track-tran fr-sq to-sq tkr)
          (del-material fr-man my-pos)
          (del-man fr-man fr-sq my-pos)
          (let ((prom-man (synth-man act-color (svref mc-msc-to-piece-vec msc))))
            (hash-man-sq prom-man to-sq my-pos)
            (add-material prom-man 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: 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-pos)
  "Retract a move on the given position."
  (let*
    (
      (move      (pop (pos-move-stack my-pos)))
      (fr-sq     (move-fr-sq  move))
      (to-sq     (move-to-sq  move))
      (fr-man    (move-fr-man move))
      (to-man    (move-to-man move))
      (msc       (move-msc    move))
      (act-color (pos-pas-color my-pos))
      (pas-color (pos-act-color my-pos))
      (tkr       (pos-tkr       my-pos))
    )
;;
;; Environment restore: colors
;;
    (setf (pos-act-color my-pos) act-color)
    (setf (pos-pas-color my-pos) pas-color)
;;
;; Environment restore: castling bits
;;
    (setf (pos-castbits my-pos) (pop (pos-castbits-stack my-pos)))
;;
;; Environment restore: en passant target square
;;
    (setf (pos-ep-sq my-pos) (pop (pos-ep-sq-stack my-pos)))
;;
;; Environment restore: half move clock
;;
    (setf (pos-hmvc my-pos) (pop (pos-hmvc-stack my-pos)))
;;
;; Environment restore: full move number
;;
    (when (= color-black act-color)
      (decf (pos-fmvn my-pos)))
;;
;; Environment restore: main and pawn hashes
;;
    (setf (pos-main-hash my-pos) (pop (pos-main-hash-stack my-pos)))
    (setf (pos-pawn-hash my-pos) (pop (pos-pawn-hash-stack my-pos)))
;;
;; Environment restore: pinned and frozen bitboard vectors
;;
    (setf (pos-pinned-bb-vec my-pos) (pop (pos-pinned-bb-vec-stack my-pos)))
    (setf (pos-frozen-bb-vec my-pos) (pop (pos-frozen-bb-vec-stack my-pos)))
;;
;; Retract the move
;;
    (unless (is-move-null? move)
      (cond
;;
;; Regular move retraction
;;
        ((is-msc-regular? msc)
          (track-tran to-sq fr-sq tkr)
          (move-man fr-man to-sq fr-sq my-pos)
          (when (= (svref mc-man-to-piece-vec fr-man) piece-king)
            (setf (svref (pos-king-sq-vec my-pos) act-color) fr-sq))
          (when (is-man-nonvac? to-man)
            (track-pop tkr)
            (add-material to-man my-pos)
            (add-man to-man to-sq my-pos)))
;;
;; En passant capture move retraction
;;
        ((is-msc-en-passant? msc)
          (track-tran to-sq fr-sq tkr)
          (move-man fr-man to-sq fr-sq my-pos)
          (let
            (
              (victim-sq  (+ to-sq (svref pawn-retreat-delta-vec act-color)))
              (victim-man (synth-man pas-color piece-pawn))
            )
            (track-pop tkr)
            (add-material victim-man my-pos)
            (add-man victim-man victim-sq my-pos)))
;;
;; Castling move retraction
;;
        ((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)
          (setf (svref (pos-king-sq-vec my-pos) act-color) fr-sq))

;;
;; Pawn promotion move retraction
;;
        ((is-msc-promotion? msc)
          (let ((prom-man (synth-man act-color (svref mc-msc-to-piece-vec msc))))
            (del-material prom-man my-pos)
            (del-man prom-man to-sq my-pos)
            (track-tran to-sq fr-sq tkr)
            (add-material fr-man my-pos)
            (add-man fr-man fr-sq my-pos))
          (when (is-man-nonvac? to-man)
            (track-pop tkr)
            (add-material to-man my-pos)
            (add-man to-man to-sq my-pos)))
;;
        (t (error "cond fault: retract-move"))))
    move))

[sje]

This is game structure in the new CIL Toolkit; it's used to hold a game that's in progress or has just terminated. The structure does not include PGN tag pairs or other refinements.

Code: Select all

;;; Game score results

(defconstant gsr-drawn          (enum-init) "Drawn result; half point to each color")
(defconstant gsr-double-forfeit (enum-next) "Double forfeit; no points to either color")
(defconstant gsr-unterminated   (enum-next) "Unterminated game; no points to either color")
(defconstant gsr-win-by-black   (enum-next) "Black won; one point to Black, no points to White")
(defconstant gsr-win-by-white   (enum-next) "White won; one point to White, no points to Black")

(defconstant gsr-limit (enum-limit))

(defconstant as-gsr-vec
  (make-array gsr-limit :initial-contents (vector "1/2-1/2" "0-0" "*" "0-1" "1-0")))


;;; Symmetric game terminations

(defconstant sgt-agreed-draw    (enum-init) "Players agree to a draw")
(defconstant sgt-checkmate      (enum-next) "Game ended in a checkmate")
(defconstant sgt-double-forfeit (enum-next) "Game was a double forfeit")
(defconstant sgt-draw           (enum-next) "Game ended in a draw of unspecified cause")
(defconstant sgt-fifty-moves    (enum-next) "Game ended in a draw by the fifty move rule")
(defconstant sgt-no-material    (enum-next) "Game ended in a draw by insufficent material")
(defconstant sgt-repetition     (enum-next) "Game ended in a draw by position repetition")
(defconstant sgt-resign         (enum-next) "Game ended by resignation")
(defconstant sgt-resign-pas     (enum-next) "Game ended by resignation by passive player")
(defconstant sgt-stalemate      (enum-next) "Game ended in a stalemate")
(defconstant sgt-unterminated   (enum-next) "Game is not terminated")
(defconstant sgt-win-by-black   (enum-next) "Game won by Black by unspecifed cause")
(defconstant sgt-win-by-white   (enum-next) "Game won by White by unspecifed cause")

(defconstant sgt-limit (enum-limit))

(defmacro dosgts ((my-sgt-var) &body my-body)
  "Construct a per symmetric game termination iteration loop."
  `(dotimes (,my-sgt-var sgt-limit) ,@my-body))

(defconstant as-sgt-vec
  (make-array sgt-limit
    :initial-contents
      (vector
        "agreed draw"
        "checkmate"
        "double forfeit"
        "draw"
        "fifty moves draw"
        "insufficient material draw"
        "position repetition draw"
        "resignation"
        "resignation by passive"
        "stalemate"
        "unterminated"
        "win by black"
        "win by white")))

(defun is-sgt-draw? (my-sgt)
  "Return t if the given symmetric game termination is a draw."
  (or
    (= my-sgt sgt-agreed-draw)
    (= my-sgt sgt-draw)
    (= my-sgt sgt-fifty-moves)
    (= my-sgt sgt-no-material)
    (= my-sgt sgt-repetition)
    (= my-sgt sgt-stalemate)))


;;; Game structure

(defstruct (game)
  (base-fenpos nil)  ; The FEN position at the start of the game
  (current-pos nil)  ; The current position; contains history
  (gsr         nil)  ; The game status result indicator
  (sgt         nil)) ; The symmetric game termination indicator

(defun mk-game ()
  "Return an initialized new game structure."
  (make-game
    :base-fenpos (create-initial-array-fenpos)
    :current-pos (create-initial-array-pos)
    :gsr         gsr-unterminated
    :sgt         sgt-unterminated))


;;; Game cloning

(defun clone-game (my-game)
  "Return a clone fo the given game."
  (make-game
    :base-fenpos (clone-fenpos (game-base-fenpos my-game))
    :current-pos (clone-pos    (game-current-pos my-game))
    :gsr         (game-gsr my-game)
    :sgt         (game-sgt my-game)))
    

;;; Game move play/unplay

(defun game-play (my-move my-game)
  "Play the given move in the given game."
  (let ((gen-move (find-move my-move (generate-marked (game-current-pos my-game)))))
    (unless gen-move
      (error "game-play: can't find move"))
    (execute-move gen-move (game-current-pos my-game))
    (let
      (
        (sgt       (calc-game-termination (game-current-pos my-game)))
        (act-color (pos-act-color (game-current-pos my-game)))
      )
      (setf (game-sgt my-game) sgt)
      (cond
        ((= sgt sgt-unterminated)
          (setf (game-gsr my-game) gsr-unterminated))
        ((= sgt sgt-double-forfeit)
          (setf (game-gsr my-game) gsr-double-forfeit))
        ((is-sgt-draw? sgt)
          (setf (game-gsr my-game) gsr-drawn))
        ((= sgt sgt-win-by-black)
          (setf (game-gsr my-game) gsr-win-by-black))
        ((= sgt sgt-win-by-white)
          (setf (game-gsr my-game) gsr-win-by-white))
        ((or (= sgt sgt-checkmate) (= sgt sgt-resign))
          (setf
            (game-gsr my-game)
            (if (= act-color color-white) gsr-win-by-black gsr-win-by-white)))
        ((= sgt sgt-resign-pas)
          (setf
            (game-gsr my-game)
            (if (= act-color color-white) gsr-win-by-white gsr-win-by-black)))
        (t (error "cond fault: game-play"))))))

(defun game-unplay (my-game)
  "Unplay a move in the given game."
  (when (null? (pos-move-stack (game-current-pos my-game)))
    (error "game-unplay: no move to unplay"))
  (retract-move (game-current-pos my-game))
  (setf (game-sgt my-game) sgt-unterminated)
  (setf (game-gsr my-game) gsr-unterminated))


;;; Position game termination

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

[sje]

The self testing, random game production feature of the new CIL Toolkit has been revised to use the new game structure.

Code: Select all

;;; Random game production

(defun select-random-move (my-pos)
  "Select and return a random move; include extended diagnostics."
  (let ((result nil) (moves (generate my-pos)))
    ;(super-position-verify my-pos)
    (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 ((game (mk-game)) (count 0))
    (dowhile (= (game-sgt game) sgt-unterminated)
      (let ((move (select-random-move (game-current-pos game))))
        (game-play move game)
        (incf count)))
    (list (game-sgt game) (pos-act-color (game-current-pos game)) count)))

(defun play-multiple-random-games (my-limit)
  "Play multiple random games and return a summary vector."
  (setf *random-state* (make-random-state t))
  (let
    (
      (result (make-array (list sgt-limit color-rlimit) :initial-element 0))
      (move-count 0)
    )
    (dotimes (index my-limit)
      (let ((sac (play-random-game)))
        (incf (aref result (first sac) (second sac)))
        (incf move-count (third sac))))
    (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)))
    (format t "Game termination            White Black Total  Rate  ~%")
    (format t "--------------------------- ----- ----- -----  ------~%")
    (dosgts (sgt)
      (let*
        (
          (wc (aref result sgt color-white))
          (bc (aref result sgt color-black))
          (tc (+ wc bc))
        )
        (when (positive? tc)
          (format t "~A~27T~6D~6D~6D~47T~6,4F~%"
            (svref as-sgt-vec sgt)
            wc bc tc
            (float (/ tc my-limit))))))))

[sje]

The simple mate search has become even simpler with the integration of the new, history tracking position structure.

Code: Select all

;;; Simple mate search (version 0): defender routine

(defun sms0-defend (my-window my-depth my-pos)
  "Defend against checkmate."
  (let ((sar (make-sar)))
    (cond
      ((zero? my-depth)
        (if (is-checkmate? my-pos)
          (setf (sar-expect sar) checkmated-score)
          (setf (sar-expect sar) draw-score)))
      (t
        (let ((moves (generate my-pos)) (new-depth (1- my-depth)))
          (dowhile (and (not (is-cutoff? my-window)) (negative? (sar-expect sar)) moves)
            (let ((move (pop moves)) (d-sar nil))
              (execute-move move my-pos)
              (setf d-sar (sms0-attack (downshift-window my-window) new-depth my-pos))
              (retract-move my-pos)
              (negamax move my-window sar d-sar))))))
    sar))


;;; Simple mate search (version 0): attacker routine

(defun sms0-attack (my-window my-depth my-pos)
  "Attack towards checkmate."
  (let
    (
      (moves     (if (one? my-depth) (generate-checks my-pos) (generate my-pos)))
      (sar       (make-sar))
      (new-depth (1- my-depth))
    )
    (dowhile (and (not (is-cutoff? my-window)) (not (is-mating-score? (sar-expect sar))) moves)
      (let ((move (pop moves)) (d-sar nil))
        (execute-move move my-pos)
        (setf d-sar (sms0-defend (downshift-window my-window) new-depth my-pos))
        (retract-move my-pos)
        (negamax move my-window sar d-sar)))
    sar))


;;; Simple mate search (version 0): top level driver

(defun sms0-driver (my-fmvc my-pos-str)
  "Search for a fixed depth mate."
  (let ((pos (calc-pos-from-str my-pos-str)) (sar nil) (window (calc-widest-window)))
    (unless pos
      (error "Broken position string, try again."))
    (setf sar (sms0-attack window (1- (2* my-fmvc)) pos))
    (if (is-mating-score? (sar-expect sar))
      (progn
        (format t "Mate in ~R found: " (calc-mate-distance (sar-expect sar)))
        (encode-variation-pos t (sar-pv sar) pos)
        (newline t))
      (progn
        (setf (sar-pv sar) nil)
        (format t "No mate located.~%")))
    sar))

[sje]

The game structure definition and its associated routines in the new CIL Toolkit have been revised to include bidirectional game scrolling and better formatted output.

Code: Select all

;;; Game structure

(defstruct
  (game
    (:print-function
      (lambda (my-game my-stream my-level)
        (declare (ignore my-level))
        (encode-game my-stream my-game))))
  (base-fenpos nil)  ; FEN position at the start of the game
  (current-pos nil)  ; Current position; contains history
  (gsr         nil)  ; Game status result indicator
  (move-queue  nil)  ; Scrolled back moves, if any
  (pc-saved    nil)  ; Ply count of saved (scrolled back) moves
  (pc-total    nil)  ; Ply count total
  (sgt         nil)) ; The symmetric game termination indicator

(defun mk-game ()
  "Return an initialized new game structure."
  (make-game
    :base-fenpos (create-initial-array-fenpos)
    :current-pos (create-initial-array-pos)
    :gsr         gsr-unterminated
    :move-queue  nil
    :pc-saved    0
    :pc-total    0
    :sgt         sgt-unterminated))


;;; Game cloning

(defun clone-game (my-game)
  "Return a clone for the given game."
  (make-game
    :base-fenpos (clone-fenpos (game-base-fenpos my-game))
    :current-pos (clone-pos (game-current-pos my-game))
    :gsr         (game-gsr my-game)
    :move-queue  (clone-moves (game-move-queue my-game))
    :pc-saved    (game-pc-saved my-game)
    :pc-total    (game-pc-total my-game)
    :sgt         (game-sgt my-game)))


;;; Position based game termination

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


;;; Game termination marking

(defun establish-game-termination (my-game)
  "Establish the game termination information based on the current game position."
  (let* ((pos (game-current-pos my-game)) (sgt (calc-game-termination pos)))
    (setf (game-sgt my-game) sgt)
    (cond
      ((= sgt sgt-unterminated)
        (setf (game-gsr my-game) gsr-unterminated))
      ((is-sgt-draw? sgt)
        (setf (game-gsr my-game) gsr-drawn))
      ((= sgt sgt-checkmate)
        (setf
          (game-gsr my-game)
          (if (= (pos-act-color pos) color-white) gsr-win-by-black gsr-win-by-white)))
      (t (error "cond fault: establish-game-termination")))))


;;; Game truncation

(defun truncate-game (my-game)
  "Truncate a game to its current position by removing any scrolled back moves."
  (when (positive? (game-pc-saved my-game))
    (decf (game-pc-total my-game) (game-pc-saved my-game))
    (setf (game-pc-saved my-game) 0)
    (setf (game-move-queue my-game) nil)
    (establish-game-termination my-game)))


;;; Game move play/unplay

(defun play-move (my-move my-game)
  "Play the given move in the given game."
  (truncate-game my-game)
  (execute-move my-move (game-current-pos my-game))
  (incf (game-pc-total my-game))
  (establish-game-termination my-game))

(defun unplay-move (my-game)
  "Unplay a move in the given game."
  (when (null? (pos-move-stack (game-current-pos my-game)))
    (error "unplay-move: no move to unplay"))
  (truncate-game my-game)
  (retract-move (game-current-pos my-game))
  (decf (game-pc-total my-game))
  (establish-game-termination my-game))


;;; Game scrolling

(defun scroll-game-forward (my-game)
  "Scroll the game forward one move."
  (unless (positive? (game-pc-saved my-game))
    (error "scroll-game-forward: no move to replay"))
  (let ((move (pop (game-move-queue my-game))))
    (decf (game-pc-saved my-game))
    (execute-move move (game-current-pos my-game))
    (establish-game-termination my-game)))

(defun scroll-game-backward (my-game)
  "Scroll the game backward one move."
  (unless (positive? (- (game-pc-total my-game) (game-pc-saved my-game)))
    (error "scroll-game-backward: already at start position"))
  (let* ((pos (game-current-pos my-game)) (move (first (pos-move-stack pos))))
    (push move (game-move-queue my-game))
    (incf (game-pc-saved my-game))
    (retract-move pos)
    (establish-game-termination my-game)))


;;; Move marking

(defun mark-san-game (my-game)
  "Ensure SAN move marking for all moves in the game."
  (let ((count 0))
    (dowhile (pos-move-stack (game-current-pos my-game))
      (let ((move (first (pos-move-stack (game-current-pos my-game)))))
        (push move (game-move-queue my-game))
        (incf (game-pc-saved my-game))
        (retract-move (game-current-pos my-game))
        (incf count)))
    (mark-san-flags-sequence (game-move-queue my-game) (game-current-pos my-game))
    (dowhile (positive? count)
      (let ((move (pop (game-move-queue my-game))))
        (decf (game-pc-saved my-game))
        (execute-move move (game-current-pos my-game))
        (decf count)))))


;;; Encoding

(defun encode-game (my-stream my-game)
  "Encode a game on a stream."
  (let ((pos (game-current-pos my-game)))
    (format my-stream "BaseFEN: ~A~%" (game-base-fenpos my-game))
    (format my-stream "Current: ~A~%" (pos-string pos))
    (format my-stream "Total ply: ~D   Saved ply: ~D   SGT: ~A   GSR: ~A~%"
      (game-pc-total my-game)
      (game-pc-saved my-game)
      (svref as-sgt-vec (game-sgt my-game))
      (svref as-gsr-vec (game-gsr my-game)))
    (encode-pos-graphic my-stream pos)
    (encode-pos-history my-stream pos)))

[sje]

The random game factory has been slightly revised; it now makes better use of the revised game structure.

The old play-random-game function has been replaced with a calc-random-game function that returns the newly calculated game object. This has been useful for testing purposes.

The call to make-random-state that seeds the random number generator does not conform to standard Common Lisp. But is accepted under GNU clisp and CMU cmucl. Seeding the generator prior to each random game calculation ensures different games. However, this works here only because enough time elapses between calls to get different seeds with the seed values based in part on the system time. Many years ago I wrote a game program with a similar random game generator; it didn't work quite right as several identical random games could be generated prior to a different seed value.

Code: Select all

;;; Random game production

(defun select-random-move (my-pos)
  "Select and return a random move; include extended diagnostics as needed."
  (let ((result nil) (moves (generate my-pos)))
    ;(super-position-verify my-pos)
    (when moves
      (setf result (elt moves (random (length moves)))))
    result))

(defun calc-random-game ()
  "Calculate a game using randomly selected moves; include extended diagnostics as needed."
  (setf *random-state* (make-random-state t))
  (let ((game (mk-game)))
    (dowhile (= (game-sgt game) sgt-unterminated)
      (play-move (select-random-move (game-current-pos game)) game))
    game))

(defun play-multiple-random-games (my-limit)
  "Play multiple random games and return a summary vector."
  (let
    (
      (result (make-array (list sgt-limit color-rlimit) :initial-element 0))
      (move-count 0)
    )
    (dotimes (index my-limit)
      (let* ((game (calc-random-game)) (pos (game-current-pos game)))
        (incf (aref result (calc-game-termination pos) (pos-act-color pos)))
        (incf move-count (game-pc-total game))))
    (format t "Total move count: ~D~%" move-count)
    result))

[sje]

The call to make-random-state that seeds the random number generator does not conform to standard Common Lisp. But is accepted under GNU clisp and CMU cmucl. Seeding the generator prior to each random game calculation ensures different games. However, this works here only because enough time elapses between calls to get different seeds with the seed values based in part on the system time. Many years ago I wrote a game program with a similar random game generator; it didn't work quite right as several identical random games could be generated prior to a different seed value.

Well, I just tried the weekly port to GNU gcl and the random seed bad behavior showed up again. So now the seeding is done once at start up time.

GNU gcl also has an unusual idea on how to handle the "~C" (character output) format specification, and this is different from clisp and cmucl. So that gets a workaround, too.

Next up: simple position factors evaluation. Basically, that's material balance, mobility, and pawn advancement. Just enough to play passable chess with the simplest possible fixed depth A/B searcher.

I had hoped to get a beta version of the toolkit done by the end of last month; it looks like the end of this month has a 50/50 chance of seeing this.

[sje]

Here's the very first attempt at a simple position evaluation. It should be just enough to demonstrate a very basic A/B search.

Code: Select all

;;; Pawn advancement weights

(defun initialize-pawn-advancement-vec ()
  "Provide the constant value of the pawn advancement vector."
  (let ((result (make-array (list color-rlimit sq-limit) :initial-element 0)))
    (docolors (color)
      (dosqs (sq)
        (let ((rank (map-sq-to-rank sq)) (r-delta nil))
          (if (= color color-white)
            (setf r-delta (- rank rank-2))
            (setf r-delta (- rank-7 rank)))
          (setf (aref result color sq) (* 16 (square-numeric r-delta))))))
    result))

(defconstant pawn-advancement-vec (initialize-pawn-advancement-vec))


;;; Knight mobility weights

(defun initialize-knight-mobility-vec ()
  "Provide the constant value of the knight mobility vector."
  (let ((result (make-array sq-limit :initial-element 0)))
    (dosqs (sq)
      (setf (svref result sq) (* 4 (bb-card (svref crook-attack-bb-vec sq)))))
    result))

(defconstant knight-mobility-vec (initialize-knight-mobility-vec))


;;; Mobility scoring for a color

(defun calc-mobility-score (my-color my-pos)
  "Return a crude mobility score for the given color and position."
  (let ((result 0))
    (dopieces (piece)
      (let*
        (
          (man              (synth-man my-color piece))
          (bb               (clone-bb (svref (pos-loc-man-bb-vec my-pos) man)))
          (atk-fr-sq-bb-vec (pos-atk-fr-sq-bb-vec my-pos))
        )
        (loop-bb (bb sq)
          (cond
            ((= piece piece-pawn)
              (incf result (aref pawn-advancement-vec my-color sq)))
            ((= piece piece-knight)
              (incf result (svref knight-mobility-vec sq)))
            ((= piece piece-bishop)
              (incf result (* 3 (bb-card (svref atk-fr-sq-bb-vec sq)))))
            ((= piece piece-rook)
              (incf result (* 2 (bb-card (svref atk-fr-sq-bb-vec sq)))))
            ((= piece piece-queen)
              (incf result (* 1 (bb-card (svref atk-fr-sq-bb-vec sq)))))
            ((= piece piece-king)
              nil)
            (t (error "cond fault: calc-mobility-score"))))))
    result))

(defun calc-total-score (my-pos)
  "Return a crude total score for the active color."
  (let
    (
      (result even-score)
      (act-color (pos-act-color my-pos))
      (pas-color (pos-pas-color my-pos))
    )
    (incf result
      (-
        (calc-mobility-score act-color my-pos)
        (calc-mobility-score pas-color my-pos)))
    (incf result
      (-
        (pos-act-material my-pos)
        (pos-pas-material my-pos)))
    result))

[sje]

Here is the very first version of a traditional A/B search in the new CIL Toolkit. It has been written as a tutorial of sorts and so has none of the usual techniques of move ordering, transposition tables, futility pruning, or anything else that might overburden the neophyte chess coder. Not surprisingly, the node counts are very high. But it works.

Code: Select all

;;; Simple traditional alpha-beta search

(defun stabs0-node-full (my-window my-ply my-depth my-pos)
  "Process a full node (all moves and not in check)."
  (let
    (
      (sar       (make-sar))
      (moves     (generate my-pos))
      (new-ply   (1+ my-ply))
      (new-depth (1- my-depth))
      (best-move nil)
    )
    (dowhile (and (not (is-cutoff? my-window)) moves)
      (let ((move (pop moves)) (d-sar nil))
        (execute-move move my-pos)
        (setf d-sar (stabs0-node (downshift-window my-window) new-ply new-depth my-pos))
        (when (> (upshift-score (sar-expect d-sar)) (sar-expect sar))
          (setf best-move move))
        (retract-move my-pos)
        (negamax move my-window sar d-sar)))
    (unless best-move
      (setf (sar-expect sar) draw-score))
  sar))


(defun stabs0-node-evad (my-window my-ply my-depth my-pos)
  "Process a check evasion node (all moves)."
  (let
    (
      (sar       (make-sar))
      (moves     (generate-check-evasion my-pos))
      (new-ply   (1+ my-ply))
      (best-move nil)
    )
    (dowhile (and (not (is-cutoff? my-window)) moves)
      (let ((move (pop moves)) (d-sar nil))
        (execute-move move my-pos)
        (setf d-sar (stabs0-node (downshift-window my-window) new-ply my-depth my-pos))
        (when (> (upshift-score (sar-expect d-sar)) (sar-expect sar))
          (setf best-move move))
        (retract-move my-pos)
        (negamax move my-window sar d-sar)))
    (unless best-move
      (setf (sar-expect sar) checkmated-score))
  sar))


(defun stabs0-node-gain (my-window my-ply my-depth my-pos)
  "Process a gainer node (all gainer moves and not in check)."
  (let
    (
      (sar       (make-sar))
      (moves     (generate-gainers my-pos))
      (new-ply   (1+ my-ply))
    )
    (setf (sar-expect sar) (calc-total-score my-pos))
    (when (> (sar-expect sar) (window-alfa my-window))
      (setf (window-alfa my-window) (sar-expect sar)))
    (dowhile (and (not (is-cutoff? my-window)) moves)
      (let ((move (pop moves)) (d-sar nil))
        (execute-move move my-pos)
        (setf d-sar (stabs0-node (downshift-window my-window) new-ply my-depth my-pos))
        (retract-move my-pos)
        (negamax move my-window sar d-sar)))
  sar))


(defun stabs0-node (my-window my-ply my-depth my-pos)
  "Process a node in a  fixed depth traditional alpha-beta search."
  (cond
    ((is-act-king-in-check? my-pos)
      (stabs0-node-evad my-window my-ply my-depth my-pos))
    ((positive? my-depth)
      (stabs0-node-full my-window my-ply my-depth my-pos))
    (t
      (stabs0-node-gain my-window my-ply my-depth my-pos))))


;;; Simple traditional alhpa-beta search (version 0): top level driver

(defun stabs0-driver (my-depth my-pos-str)
  "Perform a fixed depth traditional alpha-beta search."
  (let ((pos (calc-pos-from-str my-pos-str)) (sar nil) (window (calc-widest-window)))
    (unless pos
      (error "Broken position string, try again."))
    (setf sar (stabs0-node window 0 my-depth pos))
    (mark-san-flags-sequence (sar-pv sar) pos)
    sar))