CIL Toolkit: code snippets: move generation

[sje]

The main set of bitboard manipulation routines has gotten an update. Semantics have not changed; rather, type information has been added in the hope that a typical Lisp compiler might generate faster code. These and other changes have improved the basic speed of the generate, execute, and retract routines by about eighty percent.

There is still some room for improvement, but it comes as diminishing returns and with added complexity. I'll think I'll leave this code as it is for now and maybe forever.

Code: Select all

;;; Bitboard representation

(defconstant board-word-limit (/ sq-limit word-bit-limit))

(deftype type-bb () '(simple-vector 4))

(declaim (type (function () type-bb) mk-bb))
(defun mk-bb () (vector 0 0 0 0))


;;; Bitboard square set/reset/test

(declaim (type (function (type-bb fixnum) t) set-sq))
(defun set-sq (my-bb my-sq)
  "Set a square in a bitboard."
  (declare (type type-bb my-bb) (type fixnum my-sq))
  (let ((wi (ash my-sq -4)))
    (declare (type fixnum wi))
    (setf
      (svref my-bb wi)
      (the fixnum
        (logior
          (the fixnum (svref my-bb wi))
          (the fixnum (ash 1 (the fixnum (logand my-sq #x0f)))))))))

(declaim (type (function (type-bb fixnum) t) reset-sq))
(defun reset-sq (my-bb my-sq)
  "Reset a square in a bitboard."
  (declare (type type-bb my-bb) (type fixnum my-sq))
  (let ((wi (ash my-sq -4)))
    (declare (type fixnum wi))
    (setf
      (svref my-bb wi)
      (the fixnum
        (logandc2
          (the fixnum (svref my-bb wi))
          (the fixnum (ash 1 (the fixnum (logand my-sq #x0f)))))))))

(declaim (type (function (type-bb fixnum) t) sq-set?))
(defun sq-set? (my-bb my-sq)
  "Test a square in a bitboard."
  (declare (type type-bb my-bb) (type fixnum my-sq))
  (bit?
    (the fixnum (logand my-sq #x0f))
    (the fixnum (svref my-bb (the fixnum (ash my-sq -4))))))

(declaim (type (function (type-bb fixnum) t) sq-reset?))
(defun sq-reset? (my-bb my-sq)
  "Test a square in a bitboard; return inverted sense."
  (declare (type type-bb my-bb) (type fixnum my-sq))
  (not
    (bit?
      (the fixnum (logand my-sq #x0f))
      (the fixnum (svref my-bb (the fixnum (ash my-sq -4)))))))


;;; Bitboard boolean operations

(declaim (type (function (type-bb) type-bb) bb-not))
(defun bb-not (my-bb)
  (declare (type type-bb my-bb))
  "Perform boolean complement of a single bitboard."
  (let ((result (mk-bb)))
    (declare (type type-bb result))
    (setf (svref result 0) (logxor (the fixnum (svref my-bb 0)) #xffff))
    (setf (svref result 1) (logxor (the fixnum (svref my-bb 1)) #xffff))
    (setf (svref result 2) (logxor (the fixnum (svref my-bb 2)) #xffff))
    (setf (svref result 3) (logxor (the fixnum (svref my-bb 3)) #xffff))
    result))

(declaim (type (function (type-bb type-bb) type-bb) bb-or2))
(defun bb-or2 (my-bb0 my-bb1)
  "Perform boolean sum of two bitboards."
  (declare (type type-bb my-bb0) (type type-bb my-bb1))
  (let ((result (mk-bb)))
    (declare (type type-bb result))
    (setf (svref result 0) (logior (the fixnum (svref my-bb0 0)) (the fixnum (svref my-bb1 0))))
    (setf (svref result 1) (logior (the fixnum (svref my-bb0 1)) (the fixnum (svref my-bb1 1))))
    (setf (svref result 2) (logior (the fixnum (svref my-bb0 2)) (the fixnum (svref my-bb1 2))))
    (setf (svref result 3) (logior (the fixnum (svref my-bb0 3)) (the fixnum (svref my-bb1 3))))
    result))

(declaim (type (function (type-bb type-bb) type-bb) bb-or2d))
(defun bb-or2d (my-bb0 my-bb1)
  "Perform boolean sum of two bitboards; store result into the first."
  (declare (type type-bb my-bb0) (type type-bb my-bb1))
  (progn
    (setf (svref my-bb0 0) (logior (the fixnum (svref my-bb0 0)) (the fixnum (svref my-bb1 0))))
    (setf (svref my-bb0 1) (logior (the fixnum (svref my-bb0 1)) (the fixnum (svref my-bb1 1))))
    (setf (svref my-bb0 2) (logior (the fixnum (svref my-bb0 2)) (the fixnum (svref my-bb1 2))))
    (setf (svref my-bb0 3) (logior (the fixnum (svref my-bb0 3)) (the fixnum (svref my-bb1 3))))
    my-bb0))

(declaim (type (function (type-bb type-bb) type-bb) bb-and2))
(defun bb-and2 (my-bb0 my-bb1)
  "Perform boolean product of two bitboards."
  (declare (type type-bb my-bb0) (type type-bb my-bb1))
  (let ((result (mk-bb)))
    (declare (type type-bb result))
    (setf (svref result 0) (logand (the fixnum (svref my-bb0 0)) (the fixnum (svref my-bb1 0))))
    (setf (svref result 1) (logand (the fixnum (svref my-bb0 1)) (the fixnum (svref my-bb1 1))))
    (setf (svref result 2) (logand (the fixnum (svref my-bb0 2)) (the fixnum (svref my-bb1 2))))
    (setf (svref result 3) (logand (the fixnum (svref my-bb0 3)) (the fixnum (svref my-bb1 3))))
    result))

(declaim (type (function (type-bb type-bb) type-bb) bb-and2d))
(defun bb-and2d (my-bb0 my-bb1)
  "Perform boolean product of two bitboards; store result into the first."
  (declare (type type-bb my-bb0) (type type-bb my-bb1))
  (progn
    (setf (svref my-bb0 0) (logand (the fixnum (svref my-bb0 0)) (the fixnum (svref my-bb1 0))))
    (setf (svref my-bb0 1) (logand (the fixnum (svref my-bb0 1)) (the fixnum (svref my-bb1 1))))
    (setf (svref my-bb0 2) (logand (the fixnum (svref my-bb0 2)) (the fixnum (svref my-bb1 2))))
    (setf (svref my-bb0 3) (logand (the fixnum (svref my-bb0 3)) (the fixnum (svref my-bb1 3))))
    my-bb0))

(declaim (type (function (type-bb type-bb) type-bb) bb-and2c2))
(defun bb-and2c2 (my-bb0 my-bb1)
  "Perform boolean product of two bitboards (complement 2nd)."
  (declare (type type-bb my-bb0) (type type-bb my-bb1))
  (let ((result (mk-bb)))
    (declare (type type-bb result))
    (setf (svref result 0) (logandc2 (the fixnum (svref my-bb0 0)) (the fixnum (svref my-bb1 0))))
    (setf (svref result 1) (logandc2 (the fixnum (svref my-bb0 1)) (the fixnum (svref my-bb1 1))))
    (setf (svref result 2) (logandc2 (the fixnum (svref my-bb0 2)) (the fixnum (svref my-bb1 2))))
    (setf (svref result 3) (logandc2 (the fixnum (svref my-bb0 3)) (the fixnum (svref my-bb1 3))))
    result))

(declaim (type (function (type-bb type-bb) type-bb) bb-and2c2d))
(defun bb-and2c2d (my-bb0 my-bb1)
  "Perform boolean product of two bitboards (complement 2nd); store result into the first."
  (declare (type type-bb my-bb0) (type type-bb my-bb1))
  (progn
    (setf (svref my-bb0 0) (logandc2 (the fixnum (svref my-bb0 0)) (the fixnum (svref my-bb1 0))))
    (setf (svref my-bb0 1) (logandc2 (the fixnum (svref my-bb0 1)) (the fixnum (svref my-bb1 1))))
    (setf (svref my-bb0 2) (logandc2 (the fixnum (svref my-bb0 2)) (the fixnum (svref my-bb1 2))))
    (setf (svref my-bb0 3) (logandc2 (the fixnum (svref my-bb0 3)) (the fixnum (svref my-bb1 3))))
    my-bb0))

(declaim (type (function (type-bb type-bb type-bb) type-bb) bb-and3))
(defun bb-and3 (my-bb0 my-bb1 my-bb2)
  "Perform boolean product of three bitboards."
  (declare (type type-bb my-bb0) (type type-bb my-bb1) (type type-bb my-bb2))
  (let ((result (mk-bb)))
    (declare (type type-bb result))
    (setf
      (svref result 0)
      (logand
        (the fixnum (svref my-bb0 0))
        (the fixnum (svref my-bb1 0))
        (the fixnum (svref my-bb2 0))))
    (setf
      (svref result 1)
      (logand
        (the fixnum (svref my-bb0 1))
        (the fixnum (svref my-bb1 1))
        (the fixnum (svref my-bb2 1))))
    (setf
      (svref result 2)
      (logand
        (the fixnum (svref my-bb0 2))
        (the fixnum (svref my-bb1 2))
        (the fixnum (svref my-bb2 2))))
    (setf
      (svref result 3)
      (logand
        (the fixnum (svref my-bb0 3))
        (the fixnum (svref my-bb1 3))
        (the fixnum (svref my-bb2 3))))
    result))

(declaim (type (function (type-bb type-bb type-bb) type-bb) bb-and3d))
(defun bb-and3d (my-bb0 my-bb1 my-bb2)
  "Perform boolean product of three bitboards; store result into the first."
  (declare (type type-bb my-bb0) (type type-bb my-bb1) (type type-bb my-bb2))
  (progn
    (setf
      (svref my-bb0 0)
      (logand
        (the fixnum (svref my-bb0 0))
        (the fixnum (svref my-bb1 0))
        (the fixnum (svref my-bb2 0))))
    (setf
      (svref my-bb0 1)
      (logand
        (the fixnum (svref my-bb0 1))
        (the fixnum (svref my-bb1 1))
        (the fixnum (svref my-bb2 1))))
    (setf
      (svref my-bb0 2)
      (logand
        (the fixnum (svref my-bb0 2))
        (the fixnum (svref my-bb1 2))
        (the fixnum (svref my-bb2 2))))
    (setf
      (svref my-bb0 3)
      (logand
        (the fixnum (svref my-bb0 3))
        (the fixnum (svref my-bb1 3))
        (the fixnum (svref my-bb2 3))))
    my-bb0))


;;; Bitboard square scanning

(declaim (type (function (type-bb) t) first-sq))
(defun first-sq (my-bb)
  "Return the index of the first bit in a bitboard; return nil if none."
  (declare (type type-bb my-bb))
  (let ((result nil) (index nil))
    (setf index (first-bit-in-word (the fixnum (svref my-bb 0))))
    (if index
      (setf result (the fixnum index))
      (progn
        (setf index (first-bit-in-word (the fixnum (svref my-bb 1))))
        (if index
          (setf result (the fixnum (+ (the fixnum index) 16)))
          (progn
            (setf index (first-bit-in-word (the fixnum (svref my-bb 2))))
            (if index
              (setf result (the fixnum (+ (the fixnum index) 32)))
              (progn
                (setf index (first-bit-in-word (the fixnum (svref my-bb 3))))
                (if index
                  (setf result (the fixnum (+ (the fixnum index) 48))))))))))
    result))

(declaim (type (function (type-bb) t) next-sq))
(defun next-sq (my-bb)
  "Return the index of the first bit in a bitboard and clear; return nil if none."
  (declare (type type-bb my-bb))
  (let ((result (first-sq my-bb)))
    (when result
      (reset-sq my-bb result))
    result))


;;; Iteration

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


;;; Reset and reset tests

(declaim (type (function (type-bb) t) reset-bb))
(defun reset-bb (my-bb)
  (declare (type type-bb my-bb))
  "Reset a bitboard."
  (progn
    (setf (svref my-bb 0) 0)
    (setf (svref my-bb 1) 0)
    (setf (svref my-bb 2) 0)
    (setf (svref my-bb 3) 0)))

(declaim (type (function (type-bb) t) bb-empty?))
(defun bb-empty? (my-bb)
  "Return t if the given bitboard is reset (e.g. empty)."
  (declare (type type-bb my-bb))
  (and
    (zero? (the fixnum (svref my-bb 0)))
    (zero? (the fixnum (svref my-bb 1)))
    (zero? (the fixnum (svref my-bb 2)))
    (zero? (the fixnum (svref my-bb 3)))))

(declaim (type (function (type-bb) t) bb-not-empty?))
(defun bb-not-empty? (my-bb)
  "Return t if the given bitboard is not empty."
  (declare (type type-bb my-bb))
  (or
    (nonzero? (the fixnum (svref my-bb 0)))
    (nonzero? (the fixnum (svref my-bb 1)))
    (nonzero? (the fixnum (svref my-bb 2)))
    (nonzero? (the fixnum (svref my-bb 3)))))

(declaim (type (function (type-bb type-bb) t) bb-ni2?))
(defun bb-ni2? (my-bb0 my-bb1)
  "Return t if the two given bitboards form a null intersection."
  (declare (type type-bb my-bb0) (type type-bb my-bb1))
  (and
    (zero? (logand (the fixnum (svref my-bb0 0)) (the fixnum (svref my-bb1 0))))
    (zero? (logand (the fixnum (svref my-bb0 1)) (the fixnum (svref my-bb1 1))))
    (zero? (logand (the fixnum (svref my-bb0 2)) (the fixnum (svref my-bb1 2))))
    (zero? (logand (the fixnum (svref my-bb0 3)) (the fixnum (svref my-bb1 3))))))

(declaim (type (function (type-bb type-bb type-bb) t) bb-ni3?))
(defun bb-ni3? (my-bb0 my-bb1 my-bb2)
  "Return t if the three given bitboards form a null intersection."
  (declare (type type-bb my-bb0) (type type-bb my-bb1) (type type-bb my-bb2))
  (and
    (zero?
      (logand
        (the fixnum (svref my-bb0 0))
        (the fixnum (svref my-bb1 0))
        (the fixnum (svref my-bb2 0))))
    (zero?
      (logand
        (the fixnum (svref my-bb0 1))
        (the fixnum (svref my-bb1 1))
        (the fixnum (svref my-bb2 1))))
    (zero?
      (logand
        (the fixnum (svref my-bb0 2))
        (the fixnum (svref my-bb1 2))
        (the fixnum (svref my-bb2 2))))
    (zero?
      (logand
        (the fixnum (svref my-bb0 3))
        (the fixnum (svref my-bb1 3))
        (the fixnum (svref my-bb2 3))))))


;;; Bitboard cardinality

(declaim (type (function (type-bb) fixnum) bb-card))
(defun bb-card (my-bb)
  "Cardinality: count the number of squares set in a bitboard."
  (declare (type type-bb my-bb))
  (+
    (the fixnum (count-bits-in-word (the fixnum (svref my-bb 0))))
    (the fixnum (count-bits-in-word (the fixnum (svref my-bb 1))))
    (the fixnum (count-bits-in-word (the fixnum (svref my-bb 2))))
    (the fixnum (count-bits-in-word (the fixnum (svref my-bb 3))))))


;;; Bitboard equality

(declaim (type (function (type-bb type-bb) t) bb-equal?))
(defun bb-equal? (my-bb0 my-bb1)
  "Return t if the given bitboards are equal (e.g. same squares)."
  (declare (type type-bb my-bb0) (type type-bb my-bb1))
  (and
    (= (svref my-bb0 0) (svref my-bb1 0))
    (= (svref my-bb0 1) (svref my-bb1 1))
    (= (svref my-bb0 2) (svref my-bb1 2))
    (= (svref my-bb0 3) (svref my-bb1 3))))

(declaim (type (function (type-bb type-bb) t) bb-not-equal?))
(defun bb-not-equal? (my-bb0 my-bb1)
  "Return t if the given bitboards are not equal (e.g. different squares)."
  (declare (type type-bb my-bb0) (type type-bb my-bb1))
  (or
    (/= (svref my-bb0 0) (svref my-bb1 0))
    (/= (svref my-bb0 1) (svref my-bb1 1))
    (/= (svref my-bb0 2) (svref my-bb1 2))
    (/= (svref my-bb0 3) (svref my-bb1 3))))


;;; Cloning and copying

(declaim (type (function (type-bb) type-bb) clone-bb))
(defun clone-bb (my-bb)
  "Return a clone of the given bitboard."
  (declare (type type-bb my-bb))
  (vector (svref my-bb 0) (svref my-bb 1) (svref my-bb 2) (svref my-bb 3)))

(defun copy-bb (my-target-bb my-source-bb)
  "Copy the given bitboard."
  (declare (type type-bb my-target-bb) (type type-bb my-source-bb))
  (setf (svref my-target-bb 0) (svref my-source-bb 0))
  (setf (svref my-target-bb 1) (svref my-source-bb 1))
  (setf (svref my-target-bb 2) (svref my-source-bb 2))
  (setf (svref my-target-bb 3) (svref my-source-bb 3)))


;;; Bitboard color reversal

(declaim (type (function (type-bb) type-bb) flip-bb))
(defun flip-bb (my-bb)
  "Return a color reversed bitboard."
  (declare (type type-bb my-bb))
  (let ((result (mk-bb)))
    (declare (type type-bb result))
    (dosqs (sq)
      (when (sq-set? my-bb (flip-sq sq))
        (set-sq result sq)))
    result))

(defun flip-bbs (my-bbs) (mapcar #'flip-bb my-bbs))


;;; Reset vectors of bitboards

(defun reset-bb-vec (my-bb-vec)
  "Reset a bitboard vector."
  (let ((limit (array-total-size my-bb-vec)))
    (dotimes (index limit)
      (reset-bb (svref my-bb-vec index)))))


;;; Bitboard encoding

(defun encode-bb (my-stream my-bb)
  "Encode a bitboard on a stream."
  (declare (type type-bb my-bb))
  (dosqs (sq)
    (put-integer my-stream (if (sq-set? my-bb sq) 1 0)))
  (values))

(defun encode-bb-alt (my-stream my-bb)
  "Encode a bitboard on a stream with brackets and square names."
  (declare (type type-bb my-bb))
  (let ((needspace nil))
    (fmt-brack-l my-stream)
    (dosqs (sq)
      (when (sq-set? my-bb sq)
        (when needspace
          (blank my-stream))
        (encode-sq my-stream sq)
        (setf needspace t)))
    (fmt-brack-r my-stream))
  (values))

(defun encode-bb-big (my-stream my-bb)
  "Encode a bitboard on a stream with brackets and square names or spaces."
  (declare (type type-bb my-bb))
  (fmt-brack-l my-stream)
  (dosqs (sq)
    (if (sq-set? my-bb sq)
      (encode-sq my-stream sq)
      (put-string my-stream "  ")))
  (fmt-brack-r my-stream)
  (values))


;;; Bitboard/square list conversions

(defun map-bb-to-sqs (my-bb)
  "Generate a square list (ordered) from a bitboard."
  (declare (type type-bb my-bb))
  (let ((result nil) (bb (clone-bb my-bb)))
    (declare (type type-bb bb))
    (loop-bb (bb sq)
      (push sq result))
    (nreverse result)))

(defun map-sqs-to-bb (my-sqs)
  "Generate a bitboard from a square list."
  (let ((result (mk-bb)))
    (declare (type type-bb result))
    (dolist (sq my-sqs)
      (set-sq result sq))
  result))


;;; Bitboard vector construction

(defun mk-bb-vec (my-limit)
  "Return a bitboard vector with all elements reset."
  (let ((result (make-array my-limit)))
    (dotimes (index my-limit)
      (setf (svref result index) (mk-bb)))
    result))

(defun clone-bb-vec (my-bb-vec)
  "Return a clone of the given bitboard vector."
  (let* ((limit (array-total-size my-bb-vec)) (result (make-array limit)))
    (dotimes (index (array-total-size my-bb-vec))
      (setf (svref result index) (clone-bb (svref my-bb-vec index))))
    result))

(defun clone-bb-vecs (my-bb-vecs) (mapcar #'clone-bb-vec my-bb-vecs))

[sje]

Given a list of moves with each move having some set of associated flags, one task is to set the check flags of checking moves. The obvious way of doing this is to loop through the moves and perform an execute / test / retract operation on each one. Simple but slow.

Here's how the new CIL Toolkit does the task; note that the full code for en passant and promotion moves isn't at its final version (but it still works):

Code: Select all

;;; SAN check and checkmate marking routines

(defun mark-check-flags (my-moves my-pos)
  "Calculate/apply SAN check flag on a list of legal moves."
  (let*
    (
      (act-color        (pos-act-color my-pos))
      (act-king-sq      (svref (pos-king-sq-vec my-pos) act-color))
      (pas-color        (pos-pas-color my-pos))
      (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))
      (act-sweep-bb     (bb-and2 act-loc-bb loc-sweep-bb))
      (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-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))))
;;
;; Scan the moves and handle according to special case
;;
    (dolist (move my-moves)
      (cond
;;
;; Regular move check detection dispatch
;;
        ((is-move-regular? move)
          (let*
            (
              (fr-sq         (move-fr-sq move))
              (to-sq         (move-to-sq move))
              (memo-fr-sq    nil)
              (memo-fr-man   nil)
              (memo-fr-piece nil)
              (memo-inline   nil)
              (memo-beam-bb  nil)
            )
            (when (or (not memo-fr-sq) (/= memo-fr-sq fr-sq))
              (setf memo-fr-sq    fr-sq)
              (setf memo-fr-man   (move-fr-man move))
              (setf memo-fr-piece (svref mc-man-to-piece-vec memo-fr-man))
              (setf memo-inline   (sq-set? inline-bb memo-fr-sq))
              (setf memo-beam-bb  (when memo-inline (fetch-beamer-bb pas-king-sq memo-fr-sq))))
            (cond
;;
;; Regular move pawn checks
;;
              ((= memo-fr-piece piece-pawn)
                (when
                  (or
                    (sq-set? prw-bb to-sq)
                    (and memo-inline (sq-reset? memo-beam-bb to-sq)))
                  (set-mf move mf-chck)))
;;

;; Regular move: knight checks
;;
              ((= memo-fr-piece piece-knight)
                (when (or memo-inline (sq-set? crw-bb to-sq))
                  (set-mf move mf-chck)))
;;
;; Regular move: bishop checks
;;
              ((= memo-fr-piece piece-bishop)
                (when (or memo-inline (sq-set? drw-bb to-sq))
                  (set-mf move mf-chck)))
;;
;; Regular move: rook checks
;;
              ((= memo-fr-piece piece-rook)
                (when (or memo-inline (sq-set? orw-bb to-sq))
                  (set-mf move mf-chck)))
;;
;; Regular move: queen checks
;;
              ((= memo-fr-piece piece-queen)
                (when (sq-set? srw-bb to-sq)
                  (set-mf move mf-chck)))
;;
;; Regular move: king checks
;;
              ((= memo-fr-piece piece-king)
                (when (and memo-inline (sq-reset? memo-beam-bb to-sq))
                  (set-mf move mf-chck)))
;;
;; Regular move: per piece cond fault
;;
              (t (error "mark-check-flags: cond fault/1")))))
;;
;; En passant capture check detection
;;
        ((is-move-en-passant? move) ; TBD
          (when (is-move-checking? move my-pos)
            (set-mf move mf-chck)))
;;
;; Castling move check detection
;;
        ((is-move-castling? move)
          (let*
            (
              (castling (aref mc-msc-color-to-castling-vec (move-msc move) act-color))
              (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)
                  (set-mf move mf-chck)))
              ((same-rank? pas-king-sq act-king-sq)
                (when (clear-path? pas-king-sq act-king-sq loc-merge-bb)
                  (set-mf move mf-chck)))
              (t nil))))
;;
;; Pawn promotion check detection
;;
        ((is-move-promotion? move) ; TBD
          (when (is-move-checking? move my-pos)
            (set-mf move mf-chck)))
;;
        (t (error "mark-check-flags: cond fault")))))
  my-moves)

(defun mark-checkmate-flags (my-moves my-pos)
  "Calculate/apply SAN checkmate flags on a legal move list (checks must be already marked)."
  (dolist (move my-moves)
    (when (is-move-check? move)
      (execute-move move my-pos)
      (when (no-moves? my-pos)
        (set-mf move mf-mate)
        (set-mf move mf-cert))
      (retract-move my-pos)))
  my-moves)

[sje]

A little mistake in the prior post: the memoization symbol bindings are misplaced; they should be in the outermost let binding list. This doesn't affect the output, only the efficiency.

I don't have the exact timing results, but I'd guess that the above marking process is about ten times faster than the simpler execute / test / retract approach.

Places where the move list check marker can be used:

1) Generating SAN flags for moves that need to be displayed; speed is not critical here, but it's nice to have.

2) Generating SAN flags for moves needing parsing; here speed is quite useful when parsing thousands of games during opening book construction.

3) For filtering during search; for example, trying only checking captures or only checking quiet moves.

4) Better speed for determining checkmate status for moves in a list of moves.

[sje]

In the checking move marker routine, I've fixed the memoized variable bindings placement and added full fast support for pawn promotion.

There is still the yet to be coded fast support for en passant captures. This lackitude isn't too bad as not only en passant captures relatively rare, but when they do occur they don't change the bitboard database too much and so are quite fast.

First, a couple of helper routines:

Code: Select all

;;; Clear path predicates

(defun clear-path? (my-sq0 my-sq1 my-merge-bb)
  "Return t if there is a clear pathway between the two squares."
  (bb-ni2? (fetch-pathway-bb my-sq0 my-sq1) my-merge-bb))

(defun clear-inline-sweep-path? (my-sq0 my-sq1 my-sq2 my-merge-bb)
  "Return t if three squares are inline and a clear pathway between the first two squares."
  (let ((dir0 (fetch-dir my-sq0 my-sq1)))
    (when (and dir0 (is-dir-sweep? dir0))
      (let ((dir1 (fetch-dir my-sq1 my-sq2)))
        (when (and dir1 (is-dir-sweep? dir1) (= dir0 dir1))
          (bb-ni2? (fetch-pathway-bb my-sq0 my-sq1) my-merge-bb))))))

And now the revised move list check marker:

Code: Select all

(defun mark-check-flags (my-moves my-pos)
  "Calculate/apply SAN check flag on a list of legal moves."
  (let*
    (
      (act-color        (pos-act-color my-pos))
      (act-king-sq      (svref (pos-king-sq-vec my-pos) act-color))
      (pas-color        (pos-pas-color my-pos))
      (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))
      (act-sweep-bb     (bb-and2 act-loc-bb loc-sweep-bb))
      (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-to-sq-bb-vec (pos-atk-to-sq-bb-vec my-pos))
      (memo-fr-sq       nil)
      (memo-fr-man      nil)
      (memo-fr-piece    nil)
      (memo-inline      nil)
      (memo-beam-bb     nil)
    )
;;
;;  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))))
;;
;; Scan the moves and handle according to special case
;;
    (dolist (move my-moves)
      (let ((fr-sq (move-fr-sq move)) (to-sq (move-to-sq move)))
        (when (or (not memo-fr-sq) (/= memo-fr-sq fr-sq))
          (setf memo-fr-sq    fr-sq)
          (setf memo-fr-man   (move-fr-man move))
          (setf memo-fr-piece (svref mc-man-to-piece-vec memo-fr-man))
          (setf memo-inline   (sq-set? inline-bb memo-fr-sq))
          (setf memo-beam-bb  (when memo-inline (fetch-beamer-bb pas-king-sq memo-fr-sq))))
        (cond
;;
;; Regular move check detection
;;
          ((is-move-regular? move)
            (cond
;;
;; Regular move: pawn checks
;;
              ((= memo-fr-piece piece-pawn)
                (when
                  (or
                    (sq-set? prw-bb to-sq)
                    (and memo-inline (sq-reset? memo-beam-bb to-sq)))
                  (set-mf move mf-chck)))
;;
;; Regular move: knight checks
;;
              ((= memo-fr-piece piece-knight)
                (when (or memo-inline (sq-set? crw-bb to-sq))
                  (set-mf move mf-chck)))
;;
;; Regular move: bishop checks
;;
              ((= memo-fr-piece piece-bishop)
                (when (or memo-inline (sq-set? drw-bb to-sq))
                  (set-mf move mf-chck)))
;;
;; Regular move: rook checks
;;
              ((= memo-fr-piece piece-rook)
                (when (or memo-inline (sq-set? orw-bb to-sq))
                  (set-mf move mf-chck)))
;;
;; Regular move: queen checks
;;
              ((= memo-fr-piece piece-queen)
                (when (sq-set? srw-bb to-sq)
                  (set-mf move mf-chck)))
;;
;; Regular move: king checks
;;
              ((= memo-fr-piece piece-king)
                (when (and memo-inline (sq-reset? memo-beam-bb to-sq))
                  (set-mf move mf-chck)))
;;
;; Regular move: per piece cond fault
;;
              (t (error "mark-check-flags: cond fault/1"))))
;;
;; En passant capture check detection
;;
        ((is-move-en-passant? move) ; TBD
          (when (is-move-checking? move my-pos)
            (set-mf move mf-chck)))
;;
;; Castling move check detection
;;
        ((is-move-castling? move)
          (let*
            (
              (castling (aref mc-msc-color-to-castling-vec (move-msc move) act-color))
              (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)
                  (set-mf move mf-chck)))
              ((same-rank? pas-king-sq act-king-sq)
                (when (clear-path? pas-king-sq act-king-sq loc-merge-bb)
                  (set-mf move mf-chck)))
              (t nil))))
;;
;; Pawn promotion check detection
;;
        ((is-move-promotion? move)
          (cond
;;
;; Pawn promotion check detection (promotion to a knight)
;;
            ((is-move-prom-knight? move)
              (when (or memo-inline (sq-set? crw-bb to-sq))
                (set-mf move mf-chck)))
;;
;; Pawn promotion check detection (promotion to a bishop)
;;
            ((is-move-prom-bishop? move)
              (if (or memo-inline (sq-set? drw-bb to-sq))
                (set-mf move mf-chck)
                (when
                  (and
                    (is-man-nonvac? (move-to-man move))
                    (clear-inline-sweep-path? pas-king-sq fr-sq to-sq loc-merge-bb))
                  (set-mf move mf-chck))))
;;
;; Pawn promotion check detection (promotion to a rook)
;;
            ((is-move-prom-rook? move)
              (if (or memo-inline (sq-set? orw-bb to-sq))
                (set-mf move mf-chck)
                (when
                  (and
                    (is-man-vacant? (move-to-man move))
                    (clear-inline-sweep-path? pas-king-sq fr-sq to-sq loc-merge-bb))
                  (set-mf move mf-chck))))
;;
;; Pawn promotion check detection (promotion to a queen)
;;
            ((is-move-prom-queen? move)
              (when
                (or
                  memo-inline
                  (sq-set? srw-bb to-sq)
                  (clear-inline-sweep-path? pas-king-sq fr-sq to-sq loc-merge-bb))
                (set-mf move mf-chck)))
;;
            (t (error "mark-check-flags: cond fault/2"))))
;;
        (t (error "mark-check-flags: cond fault"))))))
  my-moves)

[sje]

The typical Lisp hacker plays with a program by typing Lisp expressions into the interpreter and seeing the expression evaluations.

Alas, in the real world not all input is formed as Lisp expressions, and sometimes there's a need for a "main program". For the new CIL Toolkit, the answer to this is presented as three different command processors: a UCI interface, an xboard interface, and a plain interactive console command interface. And none of these have to be used; a coder can go without or write their own.

The names for the three command processors:

Code: Select all

;;; Command processor identification

(defconstant cpid-icp    (enum-init) "Interactive command processor")
(defconstant cpid-uci    (enum-next) "UCI command processor")
(defconstant cpid-xboard (enum-next) "Xboard command processor")

(defconstant cpid-limit (enum-limit))

(defmacro docpids ((my-cpid-var) &body my-body)
  "Construct a per command processor ID iteration loop."
  `(dotimes (,my-cpid-var cpid-limit) (declare (type fixnum ,my-cpid-var)) ,@my-body))

(defconstant as-cpid-vec
  (make-array cpid-limit :initial-contents (vector "ICP" "UCI" "Xboard")))

To reduce code duplicated among the different command processor interfaces, a helper structure is defined: the CPC (Command Processor Context). It's used to store context data for a command processor interface and also to maintain good style, no global variables, and basic thread safety.

Here's the CPC (early version):

Code: Select all

;;; CPC: Command Processor Context

(defstruct
  (cpc
    (:print-function
      (lambda (my-cpc my-stream my-level)
        (declare (ignore my-level))
        (encode-cpc my-stream my-cpc))))
  (cpid   nil)  ; Command processor identification enmeration constant
  (args   nil)  ; Command line arguments
  (cmdstr nil)  ; Current command string input
  (game   nil)  ; The current game
  (pse    nil)) ; The current PSE (Persistent Search Environment)
  
(defun mk-cpc (my-cpid my-args)
  "Return a new Command Processor Context object for the given command processor kind."
  (make-cpc
    :cpid   my-cpid
    :args   my-args
    :cmdstr ""
    :game   (mk-game)
    :pse    (mk-pse)))

(defun encode-cpc (my-stream my-cpc)
  "Encode a CPC on a stream."
  (fmt-brack-l my-stream)
  (put-string my-stream "CP:")
  (put-string my-stream (svref as-cpid-vec (cpc-cpid my-cpc)))
  (fmt-brack-r my-stream)
  (values))

And here's the very, very early version of the ICP (Interactive Command Processor; the console interface):

Code: Select all

;;; Greeting and farewell

(defun emit-greeting (my-stream)
  "Emit the greeting banner."
  (put-string my-stream "Welcome to the Chess In Lisp Toolkit Interactive Command Processor")
  (newline my-stream)
  (newline my-stream)
  (put-string my-stream "Revised: 2008.09.21")
  (newline my-stream)
  (newline my-stream)
  (values))

(defun emit-farewell (my-stream)
  "Emit the farewell banner."
  (newline my-stream)
  (put-string my-stream "Thank you for using the Chess In Lisp Toolkit")
  (newline my-stream)
  (values))


;;; Prompt

(defun emit-prompt (my-stream)
  "Emit the greeting banner."
  (put-string my-stream "[] ")
  (finish-output my-stream)
  (values))


;;; Initialization and termination

(defun icp-init (my-cpc)
  "Initialize ICP operations."
  (declare (ignore my-cpc))
  (values))

(defun icp-term (my-cpc)
  "Terminate ICP operations."
  (declare (ignore my-cpc))
  (values))


;;; Interactive command processor

(defun icp (&rest args)
  "Interactive command processor for interaction with the CIL toolkit."
  (let
    (
      (is-done   nil)
      (io-stream *terminal-io*)
      (cpc       (mk-cpc cpid-icp args))
    )
    (icp-init cpc)
    (emit-greeting io-stream)
    (dowhile (not is-done)
      (emit-prompt io-stream)
      (setf (cpc-cmdstr cpc) (read-line io-stream nil nil))
      (when (null? (cpc-cmdstr cpc))
        (setf (cpc-cmdstr cpc) "exit"))
      (cond
        ((equal (cpc-cmdstr cpc) "")
          nil)
        ((equal (cpc-cmdstr cpc) "db") ; Display board
          (encode-pos-graphic io-stream (game-pos (cpc-game cpc))))
        ((equal (cpc-cmdstr cpc) "df") ; Display FEN
          (put-string io-stream (pos-string (game-pos (cpc-game cpc))))
          (newline io-stream))
        ((equal (cpc-cmdstr cpc) "dg") ; Display game
          (put-string io-stream (game-string (cpc-game cpc))))
        ((equal (cpc-cmdstr cpc) "dm") ; Display moves
          (format io-stream "~A~%" (generate-canon (game-pos (cpc-game cpc)))))
        ((equal (cpc-cmdstr cpc) "exit")
          (setf is-done t))
        ((equal (cpc-cmdstr cpc) "noop")
          nil)
        (t
          (put-string io-stream "Unknown command")
          (newline io-stream))))
    (emit-farewell io-stream)
    (icp-term cpc))
  (values))

[sje]

With the goal of making the command processing tasks as simple as possible, the command strings are stored in tables to help implement data driven code.

So here is some simple stuff for the command strings for each of the three command processors in the new CIL Toolkit:

Code: Select all

;;; Commands for the console interactive command processor

(defconstant icp-cmd-db   (enum-init) "Display board")
(defconstant icp-cmd-df   (enum-next) "Display FEN")
(defconstant icp-cmd-dg   (enum-next) "Display game")
(defconstant icp-cmd-dm   (enum-next) "Display moves")
(defconstant icp-cmd-exit (enum-next) "Exit the command processor")
(defconstant icp-cmd-noop (enum-next) "No operation")

(defconstant icp-cmd-limit (enum-limit))

(defmacro doicp-cmds ((my-icp-cmd-var) &body my-body)
  "Construct a per icp command iteration loop."
  `(dotimes
    (,my-icp-cmd-var icp-cmd-limit)
    (declare (type fixnum ,my-icp-cmd-var))
    ,@my-body))

(defconstant as-icp-cmd-vec
  (make-array icp-cmd-limit
    :initial-contents
      (vector
        "db"
        "df"
        "dg"
        "dm"
        "exit"
        "noop")))


;;; Commands for the UCI command processor

(defconstant uci-cmd-debug      (enum-init))
(defconstant uci-cmd-go         (enum-next))
(defconstant uci-cmd-isready    (enum-next))
(defconstant uci-cmd-ponderhit  (enum-next))
(defconstant uci-cmd-position   (enum-next))
(defconstant uci-cmd-quit       (enum-next))
(defconstant uci-cmd-register   (enum-next))
(defconstant uci-cmd-setoption  (enum-next))
(defconstant uci-cmd-stop       (enum-next))
(defconstant uci-cmd-uci        (enum-next))
(defconstant uci-cmd-ucinewgame (enum-next))

(defconstant uci-cmd-limit (enum-limit))

(defmacro douci-cmds ((my-uci-cmd-var) &body my-body)
  "Construct a per uci command iteration loop."
  `(dotimes
    (,my-uci-cmd-var uci-cmd-limit)
    (declare (type fixnum ,my-uci-cmd-var))
    ,@my-body))

(defconstant as-uci-cmd-vec
  (make-array uci-cmd-limit
    :initial-contents
      (vector
        "debug"
        "go"
        "isready"
        "ponderhit"
        "position"
        "quit"
        "register"
        "setoption"
        "stop"
        "uci"
        "ucinewgame")))


;;; Commands for the xboard command processor

(defconstant xboard-cmd-?         (enum-init))
(defconstant xboard-cmd-accepted  (enum-next))
(defconstant xboard-cmd-bk        (enum-next))
(defconstant xboard-cmd-computer  (enum-next))
(defconstant xboard-cmd-draw      (enum-next))
(defconstant xboard-cmd-easy      (enum-next))
(defconstant xboard-cmd-force     (enum-next))
(defconstant xboard-cmd-go        (enum-next))
(defconstant xboard-cmd-hard      (enum-next))
(defconstant xboard-cmd-hint      (enum-next))
(defconstant xboard-cmd-ics       (enum-next))
(defconstant xboard-cmd-level     (enum-next))
(defconstant xboard-cmd-name      (enum-next))
(defconstant xboard-cmd-new       (enum-next))
(defconstant xboard-cmd-nopost    (enum-next))
(defconstant xboard-cmd-otim      (enum-next))
(defconstant xboard-cmd-pause     (enum-next))
(defconstant xboard-cmd-ping      (enum-next))
(defconstant xboard-cmd-playother (enum-next))
(defconstant xboard-cmd-post      (enum-next))
(defconstant xboard-cmd-protover  (enum-next))
(defconstant xboard-cmd-quit      (enum-next))
(defconstant xboard-cmd-random    (enum-next))
(defconstant xboard-cmd-rating    (enum-next))
(defconstant xboard-cmd-rejected  (enum-next))
(defconstant xboard-cmd-remove    (enum-next))
(defconstant xboard-cmd-result    (enum-next))
(defconstant xboard-cmd-resume    (enum-next))
(defconstant xboard-cmd-sd        (enum-next))
(defconstant xboard-cmd-setboard  (enum-next))
(defconstant xboard-cmd-st        (enum-next))
(defconstant xboard-cmd-time      (enum-next))
(defconstant xboard-cmd-undo      (enum-next))
(defconstant xboard-cmd-usermove  (enum-next))
(defconstant xboard-cmd-variant   (enum-next))
(defconstant xboard-cmd-xboard    (enum-next))

(defconstant xboard-cmd-limit (enum-limit))

(defmacro doxboard-cmds ((my-xboard-cmd-var) &body my-body)
  "Construct a per xboard command iteration loop."
  `(dotimes
    (,my-xboard-cmd-var xboard-cmd-limit)
    (declare (type fixnum ,my-xboard-cmd-var))
    ,@my-body))

(defconstant as-xboard-cmd-vec
  (make-array xboard-cmd-limit
    :initial-contents
      (vector
        "?"
        "accepted"
        "bk"
        "computer"
        "draw"
        "easy"
        "force"
        "go"
        "hard"
        "hint"
        "ics"
        "level"
        "name"
        "new"
        "nopost"
        "otim"
        "pause"
        "ping"
        "playother"
        "post"
        "protover"
        "quit"
        "random"
        "rating"
        "rejected"
        "remove"
        "result"
        "resume"
        "sd"
        "setboard"
        "st"
        "time"
        "undo"
        "usermove"
        "variant"
        "xboard")))

[sje]

With the command name string constants stored in lexical order in vectors, it seems natural to take advantage of the ordering when searching for a match.

Here's some simple Lisp code that performs a recursive search of an ordered string vector in O(log N) time:

Code: Select all

;;; String location in ordered string vector

(defun locate-string-aux (my-string my-string-vec my-index0 my-index1)
  "Return a string index within an ordered string array via divide and conquer."
  (cond
    ((> my-index0 my-index1)
      nil)
    ((= my-index0 my-index1)
      (if (string= my-string (svref my-string-vec my-index0)) my-index0 nil))
    (t
      (let*
        (
          (middle (truncate (2/ (+ my-index0 my-index1))))
          (midstr (svref my-string-vec middle))
        )
        (if (string= my-string midstr)
          middle
          (if (string< my-string midstr)
            (locate-string-aux my-string my-string-vec my-index0 (1- middle))
            (locate-string-aux my-string my-string-vec (1+ middle) my-index1)))))))
  

(defun locate-string (my-string my-string-vec)
  "Return the index of a string in an ordered vector of strings."
  (locate-string-aux my-string my-string-vec 0 (1- (array-total-size my-string-vec))))

[sje]

Actually, that code was a little sloppy. My sorry excuse is that I was taking care of a couple of barking dogs while writing. Lest they take away my License to Lisp, I have to post the better and fully tail recursive version:

Code: Select all

;;; String location in ordered string vector

(defun locate-string-aux (my-string my-string-vec my-index0 my-index1)
  "Return a string index within an ordered string array via divide and conquer."
  (declare (type fixnum my-index0))
  (declare (type fixnum my-index1))
  (when (<= my-index0 my-index1)
    (let*
      (
        (middle (truncate (2/ (+ my-index0 my-index1))))
        (midstr (svref my-string-vec middle))
      )
      (declare (type fixnum middle))
      (cond
        ((string= my-string midstr)
          middle)
        ((string< my-string midstr)
          (locate-string-aux my-string my-string-vec my-index0 (1- middle)))
        ((string> my-string midstr)
          (locate-string-aux my-string my-string-vec (1+ middle) my-index1))
        (t (error "locate-string-aux: cond fault"))))))  

(defun locate-string (my-string my-string-vec)
  "Return the index of a string in an ordered vector of strings."
  (locate-string-aux my-string my-string-vec 0 (1- (array-total-size my-string-vec))))

[sje]

Some command line inputs to a command processor will have multiple tokens, and so it's necessary to be able to look at these tokens one by one. In particular, each command processor will (usually) interpret the first token on each line as a command name.

Here's a simple string tokenizer. It doesn't yet handle quoted strings or escape sequences, but it's enough to get things started.

Code: Select all

;;; Token list generation

(defun tokenizer (my-string)
  "Return a list of string tokens from the input string."
  (let ((result nil) (index 0) (limit (length my-string)) (ch nil))
    (if (< index limit)
      (progn (setf ch (elt my-string index)) (incf index))
      (setf ch nil))
    (dowhile ch
      (dowhile (and ch (is-whitespace? ch))
        (if (< index limit)
          (progn (setf ch (elt my-string index)) (incf index))
          (setf ch nil)))
      (when ch
        (let ((str ""))
          (dowhile (and ch (not (is-whitespace? ch)))
            (setf str (concatenate 'string str (string ch)))
            (if (< index limit)
              (progn (setf ch (elt my-string index)) (incf index))
              (setf ch nil)))
          (push str result))))
    (nreverse result)))

Sample calls:

Code: Select all

> (tokenizer "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1")
("rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR" "w" "KQkq" "-" "0" "1")

> (tokenizer "TalkChess.com Forum Index  -> Computer Chess Club: Programming and Technical Discussions")
("TalkChess.com" "Forum" "Index" "->" "Computer" "Chess" "Club:" "Programming" "and" "Technical" "Discussions")

[sje]

The revised CPC (Command Processor Context) structure has now taken on command line parsing and assists with per command dispatch.

First, the revised CPC structure:

Code: Select all

;;; CPC: Command Processor Context

(defstruct
  (cpc
    (:print-function
      (lambda (my-cpc my-stream my-level)
        (declare (ignore my-level))
        (encode-cpc my-stream my-cpc))))
  (cpid     nil)  ; Command processor identification enumeration constant
  (args     nil)  ; Progarm command line arguments
  (stin     nil)  ; Input stream
  (stout    nil)  ; Output stream
  (cmdord   nil)  ; Current command ordinal
  (cmdstr   nil)  ; Current command string input
  (cmdtkns  nil)  ; Tokens from command string input
  (cmd-vec  nil)  ; Constant command string vector
  (is-done  nil)  ; Exiting flag
  (is-pass  nil)  ; Empty command input flag
  (pgn      nil)  ; The current PGN; includes the game object that includes the position
  (pse      nil)) ; The current PSE (Persistent Search Environment)
  
(defun mk-cpc (my-cpid my-cmd-vec my-args)
  "Return a new Command Processor Context object for the given command processor kind."
  (make-cpc
    :cpid    my-cpid
    :args    my-args
    :stin    *standard-input*
    :stout   *standard-output*
    :cmdord  nil
    :cmdstr  ""
    :cmdtkns nil
    :cmd-vec my-cmd-vec
    :is-done nil
    :is-pass nil
    :pgn     (mk-pgn)
    :pse     (mk-pse)))

Here's the command line initial processing routine. Note the use of the tokenizer and the string locator; also, how an EOF activates the kill switch:

Code: Select all

;;; Command dispatch assistant

(defun command-line-cpc (my-string my-cpc)
  "Set up the various command fields in a CPC based on a command line input string."
  (setf (cpc-cmdord  my-cpc) nil)
  (setf (cpc-cmdstr  my-cpc) my-string)
  (setf (cpc-cmdtkns my-cpc) nil)
  (setf (cpc-is-pass my-cpc) nil)
  (if (null? my-string)
    (setf (cpc-is-done my-cpc) t)
    (progn
      (setf (cpc-cmdtkns my-cpc) (tokenizer my-string))
      (if (null? (cpc-cmdtkns my-cpc))
        (setf (cpc-is-pass my-cpc) t)
        (setf (cpc-cmdord my-cpc)
          (locate-string (first (cpc-cmdtkns my-cpc)) (cpc-cmd-vec my-cpc)))))))

And here's the revised main line code for the Interactive Command Processor; the xboard and UCI command processors are almost the same but lack banners and prompting.

Code: Select all

;;; Interactive command processor

(defun icp (&rest args)
  "Interactive command processor for console interaction with the Chess In Lisp toolkit."
  (let ((cpc (mk-cpc cpid-icp as-icp-cmd-vec args)))
    (icp-init cpc)
    (icp-emit-greeting cpc)
    (dowhile (not (cpc-is-done cpc))
      (icp-emit-prompt cpc)
      (command-line-cpc (read-line (cpc-stin cpc) nil nil) cpc)
      (unless (or (cpc-is-done cpc) (cpc-is-pass cpc))
        (if (cpc-cmdord cpc)
          (funcall (svref icp-dispatch-vec (cpc-cmdord cpc)) cpc)
          (progn
            (warn "Move input not yet implemented.")))))
     (icp-emit-farewell cpc)
    (icp-term cpc))
  (values))

The ICP main line references a vector of function symbols; each entry identifies the handler for the command kind associated with the entry index:

Code: Select all

;;; Command dispatch routine vector

(defconstant icp-dispatch-vec
  (make-array icp-cmd-limit
    :initial-contents
      (vector
        #'icp-do-ao
        #'icp-do-db
        #'icp-do-df
        #'icp-do-dg
        #'icp-do-dm
        #'icp-do-do
        #'icp-do-dp
        #'icp-do-ef
        #'icp-do-em
        #'icp-do-et
        #'icp-do-exit
        #'icp-do-g
        #'icp-do-help
        #'icp-do-lf
        #'icp-do-lp
        #'icp-do-ng
        #'icp-do-noop
        #'icp-do-po
        #'icp-do-sf
        #'icp-do-sp
        #'icp-do-tb)))

And finally, here are some of the ICP display command handlers:

Code: Select all

(defun icp-do-db (my-cpc)
  "Handle the ICP db command."
  (encode-pos-graphic (cpc-stout my-cpc) (cpc-pos my-cpc)))

(defun icp-do-df (my-cpc)
  "Handle the ICP df command."
  (format (cpc-stout my-cpc) "~A~%" (pos-string (cpc-pos my-cpc))))

(defun icp-do-dg (my-cpc)
  "Handle the ICP dg command."
  (format (cpc-stout my-cpc) "~A" (game-string (cpc-game my-cpc))))

(defun icp-do-dm (my-cpc)
  "Handle the ICP dm command."
  (format (cpc-stout my-cpc) "~A~%" (generate-canon (cpc-pos my-cpc))))

(defun icp-do-do (my-cpc)
  "Handle the ICP dm command."
  (declare (ignore my-cpc))
  (warn "Command not yet implemented"))

(defun icp-do-dp (my-cpc)
  "Handle the ICP dp command."
  (format (cpc-stout my-cpc) "~A" (pgn-string (cpc-pgn my-cpc))))