Discussion of chess software programming and technical issues.
Moderator: Ras
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Wed Aug 27, 2008 9:51 am
Code: Select all
;;; Board vector attack predicate
(defconstant scan-atk-men-color-dir-vec
(make-array (list color-rlimit dir-slimit)
:initial-contents
(list
(list
(list (list man-wr man-wq man-wk) (list man-wr man-wq))
(list (list man-wr man-wq man-wk) (list man-wr man-wq))
(list (list man-wr man-wq man-wk) (list man-wr man-wq))
(list (list man-wr man-wq man-wk) (list man-wr man-wq))
(list (list man-wb man-wq man-wk) (list man-wb man-wq))
(list (list man-wb man-wq man-wk) (list man-wb man-wq))
(list (list man-wp man-wb man-wq man-wk) (list man-wb man-wq))
(list (list man-wp man-wb man-wq man-wk) (list man-wb man-wq)))
(list
(list (list man-br man-bq man-bk) (list man-br man-bq))
(list (list man-br man-bq man-bk) (list man-br man-bq))
(list (list man-br man-bq man-bk) (list man-br man-bq))
(list (list man-br man-bq man-bk) (list man-br man-bq))
(list (list man-bp man-bb man-bq man-bk) (list man-bb man-bq))
(list (list man-bp man-bb man-bq man-bk) (list man-bb man-bq))
(list (list man-bb man-bq man-bk) (list man-bb man-bq))
(list (list man-bb man-bq man-bk) (list man-bb man-bq))))))
(defun color-attacks-sq-board-vec-aux? (my-color my-sq my-dir my-board-vec)
"Return t if the given color attacks the given square along the direction on a board vector."
(let ((result nil) (sqs (aref open-ray-sqs-vec my-sq my-dir)))
(when sqs
(let*
(
(scan-sq (pop sqs))
(scan-man (svref my-board-vec scan-sq))
(sam-pair (aref scan-atk-men-color-dir-vec my-color my-dir))
)
(if (is-man-nonvac? scan-man)
(when (find scan-man (first sam-pair))
(setf result t))
(progn
(do ((stop-flag nil)) ((or stop-flag (null? sqs)))
(setf scan-sq (pop sqs))
(setf scan-man (svref my-board-vec scan-sq))
(when (is-man-nonvac? scan-man)
(setf stop-flag t)))
(when (find scan-man (second sam-pair))
(setf result t))))))
result))
(defun color-crook-attacks-sq-board-vec? (my-color my-sq my-board-vec)
"Return t if the given color/knight attacks the given square on a given board vector."
(let
(
(result nil)
(sqs (svref crook-sqs-vec my-sq))
(knight-man (synth-man my-color piece-knight))
)
(dowhile (and (not result) sqs)
(when (= (svref my-board-vec (pop sqs)) knight-man)
(setf result t)))
result))
(defun color-sweep-attacks-sq-board-vec? (my-color my-sq my-board-vec)
"Return t if the given color attacks along a sweep to the given square on a given board vector."
(let ((result nil))
(do ((dir 0 (1+ dir))) ((or result (= dir dir-slimit)))
(when (color-attacks-sq-board-vec-aux? my-color my-sq dir my-board-vec)
(setf result t)))
result))
(defun color-attacks-sq-board-vec? (my-color my-sq my-board-vec)
"Return t if the given color attacks the given square on a given board vector."
(or
(color-crook-attacks-sq-board-vec? my-color my-sq my-board-vec)
(color-sweep-attacks-sq-board-vec? my-color my-sq my-board-vec)))
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Wed Aug 27, 2008 9:34 pm
For the FEN parser to be complete, it needs to have a position consistency checking routine to prevent my typing errors from infecting the program with bad data.
Code: Select all
;;; Board vector validation
(defun pawns-on-rank-board-vec? (my-rank my-board-vec)
"Return t if there is at least one pawn on the given rank on the given board vector."
(let ((result nil))
(do ((file file-a (1+ file))) ((or result (= file file-limit)))
(when (is-man-pawn? (svref my-board-vec (map-file-rank-to-sq file my-rank)))
(setf result t)))
result))
(defun find-king-sq (my-color my-board-vec)
"Return the (first) square of the king of the given color in the given board vector."
(let ((result nil) (king-man (synth-man my-color piece-king)))
(do ((sq 0 (1+ sq))) ((or result (= sq sq-limit)))
(when (= (svref my-board-vec sq) king-man)
(setf result sq)))
result))
(defun is-valid-board-vec? (my-board-vec)
"Test for basic validity of a board vector; checks only census and illegal pawn ranks."
(and
(is-census-valid? (calc-census (mk-census) my-board-vec))
(not (pawns-on-rank-board-vec? rank-1 my-board-vec))
(not (pawns-on-rank-board-vec? rank-8 my-board-vec))))
(defun is-valid-act-color? (my-act-color my-board-vec)
"Test for passive king not in check for a active color and board vector."
(not
(color-attacks-sq-board-vec?
my-act-color
(find-king-sq (flip-color my-act-color) my-board-vec)
my-board-vec)))
(defun is-valid-castbits? (my-castbits my-board-vec)
"Test for valid castling availability for a castlings bits and board vector."
(let ((result t))
(do ((castling 0 (1+ castling))) ((or (not result) (= castling castling-limit)))
(when (logbit? castling my-castbits)
(let ((color (svref mc-castling-to-color-vec castling)))
(when
(or
(/=
(svref my-board-vec (svref castling-king-home-sq-vec castling))
(synth-man color piece-king))
(/=
(svref my-board-vec (svref castling-rook-home-sq-vec castling))
(synth-man color piece-rook)))
(setf result nil)))))
result))
(defun is-valid-ep-sq? (my-act-color my-ep-sq my-board-vec)
"Test for valid en passant target for an active color, ep target, and board vector."
(or
(not my-ep-sq)
(and
(= (map-sq-to-rank my-ep-sq) (svref sixth-rank-vec my-act-color))
(=
(svref my-board-vec (+ my-ep-sq (svref pawn-retreat-delta-vec my-act-color)))
(synth-man (flip-color my-act-color) piece-pawn))
(=
(svref my-board-vec (+ my-ep-sq (svref pawn-advance-delta-vec my-act-color)))
man-v0))))
(defun is-valid-combo? (my-board-vec my-act-color my-castbits my-ep-sq my-hmvc my-fmvn)
"Return t if the given position attribute combination is valid."
(and
(is-valid-board-vec? my-board-vec)
(is-valid-act-color? my-act-color my-board-vec)
(is-valid-castbits? my-castbits my-board-vec)
(is-valid-ep-sq? my-act-color my-ep-sq my-board-vec)
(nonnegative? my-hmvc)
(positive? my-fmvn)))
;;; FEN position validity checking
(defun is-valid-fenpos? (my-fenpos)
"Return t if the given FEN position is a legal configuration."
(is-valid-combo?
(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)))
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Sat Aug 30, 2008 5:47 am
Code: Select all
;;; Move generation: all legal non-gaining moves when not in check
(defun generate-holders (my-pos)
"Return a list of all non-gaining moves for the given position with the king not in check."
(let*
(
(result nil)
(act-color (pos-act-color my-pos))
(pas-color (pos-pas-color my-pos))
(act-king-sq (svref (pos-king-sq-vec my-pos) act-color))
(act-loc-bb (svref (pos-loc-color-bb-vec my-pos) act-color))
(loc-merge-bb (pos-loc-merge-bb my-pos))
(adv-delta (svref pawn-advance-delta-vec act-color))
(target-bb (bb-not loc-merge-bb))
(pinned-bb (svref (pos-pinned-bb-vec my-pos) act-color))
(frozen-bb (svref (pos-frozen-bb-vec my-pos) act-color))
(rstrct-bb (bb-and2c2 pinned-bb frozen-bb))
(fr-bb (bb-and2c2 act-loc-bb frozen-bb))
(board-vec (pos-board-vec my-pos))
(atk-fr-sq-bb-vec (pos-atk-fr-sq-bb-vec my-pos))
)
(loop-bb (fr-bb fr-sq)
(let*
(
(fr-man (get-man board-vec fr-sq))
(fr-piece (svref mc-man-to-piece-vec fr-man))
(atk-fr-sq-bb (svref atk-fr-sq-bb-vec fr-sq))
)
(cond
;;
;; Pawn moves
;;
((= fr-piece piece-pawn)
(let*
(
(fr-rank (map-sq-to-rank fr-sq))
(rstrct-flag (sq-set? rstrct-bb fr-sq))
(rstrct-dir (if rstrct-flag (fetch-dir act-king-sq fr-sq)))
(r2-flag (= fr-rank (svref second-rank-vec act-color)))
(r7-flag (= fr-rank (svref seventh-rank-vec act-color)))
)
(when
(and
(not r7-flag)
(or
(not rstrct-flag)
(= bidir-n (svref mc-sweep-dir-to-bidir-vec rstrct-dir))))
(let ((to-sq (+ fr-sq adv-delta)))
(when (sq-reset? loc-merge-bb to-sq)
(push (mm-simp fr-sq to-sq fr-man) result)
(when (and r2-flag (sq-reset? loc-merge-bb (+ to-sq adv-delta)))
(push (mm-simp fr-sq (+ to-sq adv-delta) fr-man) result)))))))
;;
;; Knight moves
;;
((= fr-piece piece-knight)
(let ((to-bb (bb-and2 atk-fr-sq-bb target-bb)))
(loop-bb (to-bb to-sq)
(push (mm-simp fr-sq to-sq fr-man) result))))
;;
;; Sweeper moves
;;
((is-piece-sweeper? fr-piece)
(let ((to-bb (bb-and2 atk-fr-sq-bb target-bb)))
(when (sq-set? rstrct-bb fr-sq)
(bb-and2d
to-bb
(aref open-ray-bb-vec act-king-sq (fetch-dir act-king-sq fr-sq))))
(loop-bb (to-bb to-sq)
(push (mm-simp fr-sq to-sq fr-man) result))))
;;
;; King moves
;;
((= fr-piece piece-king)
(let*
(
(pas-atk-bb (svref (pos-atk-by-color-bb-vec my-pos) pas-color))
(to-bb (bb-and2c2 (bb-and2 atk-fr-sq-bb target-bb) pas-atk-bb))
)
(loop-bb (to-bb to-sq)
(push (mm-simp fr-sq to-sq fr-man) result)))
(let ((castbits (pos-castbits my-pos)))
(when (nonzero? castbits)
(when (nonzero? (logand castbits (svref mc-color-to-castbits-vec act-color)))
(dolist (castling (svref mc-color-to-castlings-vec act-color))
(when (can-castle-castling? castling my-pos)
(push (clone-move (svref castling-move-vec castling)) result)))))))
;;
(t
(error "cond fault: generate-holders")))))
result))
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Sat Aug 30, 2008 4:08 pm
Here's the first version a very basic (but working!) checkmate search:
Code: Select all
;;; Mate search: returned analysis structure
(defstruct mar
(node-count nil)
(pv nil)
(success nil))
;;; Mate search: defender routine
(defun sms-defend (my-ply my-depth my-rcv my-pos)
"Defend against checkmate."
(let ((mar (make-mar :node-count 1)))
(if (zero? my-depth)
(unless (is-checkmate? my-pos)
(setf (mar-success mar) t))
(let
(
(moves (generate my-pos))
(pv-length 0)
(new-ply (1+ my-ply))
(new-depth (1- my-depth))
)
(dowhile (and (not (mar-success mar)) moves)
(let
(
(move (pop moves))
(saved-posenv (clone-posenv (pos-posenv my-pos)))
(new-mar nil)
)
(execute-move move my-pos)
(setf new-mar (sms-attack new-ply new-depth (cons move my-rcv) my-pos))
(incf (mar-node-count mar) (mar-node-count new-mar))
(if (mar-success new-mar)
(when (> (length (mar-pv new-mar)) pv-length)
(setf pv-length (length (mar-pv new-mar)))
(setf (mar-pv mar) (cons move (mar-pv new-mar))))
(setf (mar-success mar) t))
(setf (pos-posenv my-pos) saved-posenv)
(retract-move move my-pos)))))
mar))
;;; Mate search: attacker routine
(defun sms-attack (my-ply my-depth my-rcv my-pos)
"Attack towards checkmate."
(let
(
(mar (make-mar :node-count 1))
(moves (generate my-pos))
(new-ply (1+ my-ply))
(new-depth (1- my-depth))
)
(dowhile (and (not (mar-success mar)) moves)
(let
(
(move (pop moves))
(saved-posenv (clone-posenv (pos-posenv my-pos)))
(new-mar nil)
)
(execute-move move my-pos)
(setf new-mar (sms-defend new-ply new-depth (cons move my-rcv) my-pos))
(incf (mar-node-count mar) (mar-node-count new-mar))
(unless (mar-success new-mar)
(setf (mar-pv mar) (cons move (mar-pv new-mar)))
(setf (mar-success mar) t))
(setf (pos-posenv my-pos) saved-posenv)
(retract-move move my-pos)))
mar))
;;; Mate search: top level driver
(defun sms-driver (my-fmvc my-pos-str)
"Search for a fixed depth mate."
(let ((pos (calc-pos-from-str my-pos-str)) (mar nil))
(if (not pos)
(error "Broken position string, try again."))
(setf mar (sms-attack 0 (1- (2* my-fmvc)) nil pos))
(if (mar-success mar)
(progn
(mark-san-flags-sequence (mar-pv mar) pos)
(format t "Mate in ~R found: " my-fmvc)
(encode-variation
t
(mar-pv mar)
(make-afc :act-color (pos-act-color pos) :fmvn (pos-fmvn pos)))
(format t "~%"))
(format t "No mate located.~%"))
(format t "Node count: ~D~%" (mar-node-count mar))
mar))
Some sample calls:
Code: Select all
> (sms-driver 2 "2r1nr1k/pp1q1p1p/3bpp2/5P2/1P1Q4/P3P3/1B3P1P/R3K1R1 w Q - 0 1")
Mate in two found: 1. Qxf6+ Nxf6 2. Bxf6#
Node count: 103
#S(MAR :NODE-COUNT 103 :PV (Qxf6+ Nxf6 Bxf6#) :SUCCESS T)
> (sms-driver 2 "rnbqkbn1/ppppp3/7r/6pp/3P1p2/3BP1B1/PPP2PPP/RN1QK1NR w KQq - 0 1")
Mate in two found: 1. Qxh5+ Rxh5 2. Bg6#
Node count: 1144
#S(MAR :NODE-COUNT 1144 :PV (Qxh5+ Rxh5 Bg6#) :SUCCESS T)
> (sms-driver 1 "r1b1k2r/pp2bppp/8/3N2q1/2p5/8/PPP2PPP/R2QR1K1 w kq - 0 1")
No mate located.
Node count: 40
#S(MAR :NODE-COUNT 40 :PV NIL :SUCCESS NIL)
> (sms-driver 2 "r1b1k2r/pp2bppp/8/3N2q1/2p5/8/PPP2PPP/R2QR1K1 w kq - 0 1")
No mate located.
Node count: 1665
#S(MAR :NODE-COUNT 1665 :PV NIL :SUCCESS NIL)
> (sms-driver 3 "r1b1k2r/pp2bppp/8/3N2q1/2p5/8/PPP2PPP/R2QR1K1 w kq - 0 1")
Mate in three found: 1. Nc7+ Kf8 2. Qd8+ Bxd8 3. Re8#
Node count: 2884
#S(MAR :NODE-COUNT 2884 :PV (Nc7+ Kf8 Qd8+ Bxd8 Re8#) :SUCCESS T)
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Sun Aug 31, 2008 8:52 am
Differences from a usual transposition table:
1) Grows and grows and grows ...
2) Never forgets an entry
Code: Select all
;;; Hash indexed dictionary: structures for unbalanced binary tree storage
(defstruct hashdict
(count 0)
(root nil))
(defstruct hashentry
(key nil)
(value nil)
(link-l nil)
(link-r nil))
;;; Hash indexed dictionary: probing
(defun hashdict-probe (my-hashdict my-key)
"Return the matching hash dictionary entry, if any."
(if (hashdict-root my-hashdict)
(hashdict-probe-aux (hashdict-root my-hashdict) my-key)))
(defun hashdict-probe-aux (my-hashentry my-key)
"Helper routine for hashdict-probe."
(cond
((hash-lt? (hashentry-key my-hashentry) my-key)
(if (hashentry-link-l my-hashentry)
(hashdict-probe-aux (hashentry-link-l my-hashentry) my-key)))
((hash-gt? (hashentry-key my-hashentry) my-key)
(if (hashentry-link-r my-hashentry)
(hashdict-probe-aux (hashentry-link-r my-hashentry) my-key)))
((hash-eq? (hashentry-key my-hashentry) my-key)
my-hashentry)
(t (error "cond fault: hashdict-probe-aux"))))
(defun hashdict-value (my-hashdict my-key)
"Return the matching hash dictionary entry value; else nil if not found."
(let ((hashentry (hashdict-probe my-hashdict my-key)))
(if hashentry
(hashentry-value hashentry))))
;;; Hash indexed dictionary: insertion
(defun hashdict-insert (my-hashdict my-key my-value)
"Insert/overwrite an entry in a hash dictionary."
(if (not (hashdict-root my-hashdict))
(progn
(setf
(hashdict-root my-hashdict)
(make-hashentry :key (clone-hash my-key) :value my-value))
(incf (hashdict-count my-hashdict)))
(hashdict-insert-aux my-hashdict (hashdict-root my-hashdict) my-key my-value)))
(defun hashdict-insert-aux (my-hashdict my-hashentry my-key my-value)
"Helper routine for hashdict-insert."
(cond
((hash-lt? (hashentry-key my-hashentry) my-key)
(if (hashentry-link-l my-hashentry)
(hashdict-insert-aux my-hashdict (hashentry-link-l my-hashentry) my-key my-value)
(progn
(setf
(hashentry-link-l my-hashentry)
(make-hashentry :key (clone-hash my-key) :value my-value))
(incf (hashdict-count my-hashdict)))))
((hash-gt? (hashentry-key my-hashentry) my-key)
(if (hashentry-link-r my-hashentry)
(hashdict-insert-aux my-hashdict (hashentry-link-r my-hashentry) my-key my-value)
(progn
(setf
(hashentry-link-r my-hashentry)
(make-hashentry :key (clone-hash my-key) :value my-value))
(incf (hashdict-count my-hashdict)))))
((hash-eq? (hashentry-key my-hashentry) my-key)
(setf (hashentry-value my-hashentry) my-value))
(t (error "cond fault: hashdict-insert-aux"))))
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Sun Aug 31, 2008 10:39 am
If the built-in hash table facility in clisp worked, then I wouldn't have to write this:
Code: Select all
;;; Hash indexed fixed length table: structures
(defstruct hashflt
(logcount nil)
(count nil)
(stvec nil))
(defun mk-hashflt (my-logcount)
"Return a fixed length hash table."
(make-hashflt
:logcount my-logcount
:count (ash 1 my-logcount)
:stvec (make-array (ash 1 my-logcount) :initial-element nil)))
;;; Hash indexed fixed length table: index calculation
(defun calc-hashflt-index (my-hash my-logcount)
"Calculate an index in ahash fixed length tabe for a hash key."
(let ((result 0))
(dotimes (bitpos my-logcount)
(setf result (2* result))
(if (hash-bit-set? my-hash bitpos)
(incf result)))
result))
;;; Hash indexed fixed length table: probing
(defun hashflt-probe (my-hashflt my-key)
"Return the requested dotted pair entry, if any."
(let*
(
(pair
(svref
(hashflt-stvec my-hashflt)
(calc-hashflt-index my-key (hashflt-logcount my-hashflt))))
)
(if (and pair (hash-eq? (first pair) my-key))
pair)))
(defun hashflt-value (my-hashflt my-key)
"Return the requested value, if any."
(let ((pair (hashflt-probe my-hashflt my-key)))
(if pair
(rest pair))))
;;; Hash indexed fixed length table: insertion
(defun hashflt-insert (my-hashflt my-key my-value)
"Store the given value."
(setf
(svref
(hashflt-stvec my-hashflt)
(calc-hashflt-index my-key (hashflt-logcount my-hashflt)))
(cons (clone-hash my-key) my-value)))
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Mon Sep 01, 2008 7:29 am
This is revision two of the basic checkmate search. I have incorporated A/B this time although it really doesn't make much difference. I have also encapsulated most of he SAR (Search Analysis Result) operations in a single routine ("negamax") that handles updates to node count, PV, best score, and the current window.
Note that there is no move ordering at any level, so the overall performance is rather lacking in speed. Other than that, it appears to work as intended.
My idea here is to present the simplest possible mate-in-N search as a tutorial of sorts and then provide further versions with various optimizations.
Code: Select all
;;; SAR: Search Analysis Result structure
(defstruct
(sar
(:print-function
(lambda (my-sar my-stream my-level)
(declare (ignore my-level))
(encode-sar my-stream my-sar))))
(expect neginf-score)
(node-count 1)
(pv nil))
;;; Negamaxing
(defun negamax (my-move my-window my-sar my-d-sar)
"Perform negamax with the tried move, probe window, current SAR, and returned SAR."
(incf (sar-node-count my-sar) (sar-node-count my-d-sar))
(let ((upshift-expect (upshift-score (sar-expect my-d-sar))))
(when (> upshift-expect (sar-expect my-sar))
(setf (sar-expect my-sar) upshift-expect)
(setf (sar-pv my-sar) (cons my-move (sar-pv my-d-sar)))
(when (> (sar-expect my-sar) (window-alfa my-window))
(setf (window-alfa my-window) (sar-expect my-sar))))))
;;; Simple mate search (version 0): defender routine
(defun sms0-defend (my-window my-ply my-depth my-rcv 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-ply (1+ my-ply))
(new-depth (1- my-depth))
)
(dowhile (and (not (is-cutoff? my-window)) (negative? (sar-expect sar)) moves)
(let
(
(move (pop moves))
(saved-posenv (clone-posenv (pos-posenv my-pos)))
(d-sar nil)
)
(execute-move move my-pos)
(setf d-sar (sms0-attack (downshift-window my-window) new-ply new-depth (cons move my-rcv) my-pos))
(setf (pos-posenv my-pos) saved-posenv)
(retract-move move my-pos)
(negamax move my-window sar d-sar))))))
sar))
;;; Simple mate search (version 0): attacker routine
(defun sms0-attack (my-window my-ply my-depth my-rcv my-pos)
"Attack towards checkmate."
(let
(
(sar (make-sar))
(moves (generate my-pos))
(new-ply (1+ my-ply))
(new-depth (1- my-depth))
)
(dowhile (and (not (is-cutoff? my-window)) (not (is-mating-score? (sar-expect sar))) moves)
(let
(
(move (pop moves))
(saved-posenv (clone-posenv (pos-posenv my-pos)))
(d-sar nil)
)
(execute-move move my-pos)
(setf d-sar (sms0-defend (downshift-window my-window) new-ply new-depth (cons move my-rcv) my-pos))
(setf (pos-posenv my-pos) saved-posenv)
(retract-move 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 (make-widest-window))
)
(when (not pos)
(error "Broken position string, try again."))
(setf sar (sms0-attack window 0 (1- (2* my-fmvc)) nil 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)
(format t "~%"))
(progn
(setf (sar-pv sar) nil)
(format t "No mate located.~%")))
sar))
Samples:
Code: Select all
> (sms0-driver 2 "2r1nr1k/pp1q1p1p/3bpp2/5P2/1P1Q4/P3P3/1B3P1P/R3K1R1 w Q - 0 1")
Mate in two found: 1. Qxf6+ Ng7 2. Qxg7#
[EX:MateIn2 NC:103 PV:(Qxf6+ Ng7 Qxg7#)]
> (sms0-driver 2 "rnbqkbn1/ppppp3/7r/6pp/3P1p2/3BP1B1/PPP2PPP/RN1QK1NR w KQq - 0 1")
Mate in two found: 1. Qxh5+ Rg6 2. Qxg6#
[EX:MateIn2 NC:1144 PV:(Qxh5+ Rg6 Qxg6#)]
> (sms0-driver 2 "r1b1k2r/pp2bppp/8/3N2q1/2p5/8/PPP2PPP/R2QR1K1 w kq - 0 1")
No mate located.
[EX:Even NC:1665 PV:NIL]
> (sms0-driver 3 "r1b1k2r/pp2bppp/8/3N2q1/2p5/8/PPP2PPP/R2QR1K1 w kq - 0 1")
Mate in three found: 1. Nc7+ Kf8 2. Qd8+ Bxd8 3. Re8#
[EX:MateIn3 NC:2884 PV:(Nc7+ Kf8 Qd8+ Bxd8 Re8#)]
> (sms0-driver 4 "r1b2rk1/pp1p1pp1/1b1p2B1/n1qQ2p1/8/5N2/P3RPPP/4R1K1 w - - 0 1")
Mate in four found: 1. Qxf7+ Rxf7 2. Re8+ Rf8 3. Rxf8+ Kxf8 4. Re8#
[EX:MateIn4 NC:1027828 PV:(Qxf7+ Rxf7 Re8+ Rf8 Rxf8+ Kxf8 Re8#)]
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Tue Sep 02, 2008 2:44 pm
I've added a checking move generator to the new CIL Toolkit. Some of the pawn logic needs refinement for better efficiency, but this won't take too much and all of the other code is final. Millions and millions of random game positions say that the check generator is working okay. It's use at the last attacking ply (i.e.; depth = 1) in a mate search drastically speeds up things as would be expected.
Code: Select all
;;; Move generation: all legal checking moves when not in check
(defun generate-checks (my-pos)
"Return a list of all checking moves for the given position with the king not in check."
(let*
(
(result nil)
(act-color (pos-act-color my-pos))
(pas-color (pos-pas-color my-pos))
(act-king-sq (svref (pos-king-sq-vec my-pos) act-color))
(pas-king-sq (svref (pos-king-sq-vec my-pos) pas-color))
(act-loc-bb (svref (pos-loc-color-bb-vec my-pos) act-color))
(pas-loc-bb (svref (pos-loc-color-bb-vec my-pos) pas-color))
(loc-merge-bb (pos-loc-merge-bb my-pos))
(loc-sweep-bb (pos-loc-sweep-bb my-pos))
(target-bb (bb-not act-loc-bb))
(act-sweep-bb (bb-and2 act-loc-bb loc-sweep-bb))
(ep-sq (pos-ep-sq my-pos))
(adv-delta (svref pawn-advance-delta-vec act-color))
(pinned-bb (svref (pos-pinned-bb-vec my-pos) act-color))
(frozen-bb (svref (pos-frozen-bb-vec my-pos) act-color))
(rstrct-bb (bb-and2c2 pinned-bb frozen-bb))
(fr-bb (bb-and2c2 act-loc-bb frozen-bb))
(board-vec (pos-board-vec my-pos))
(inline-bb (mk-bb))
(nrw-bb (bb-and2c2 (svref crook-attack-bb-vec pas-king-sq) act-loc-bb))
(prw-bb (aref pawn-attack-bb-vec pas-color pas-king-sq))
(orw-bb (mk-bb))
(drw-bb (mk-bb))
(qrw-bb (mk-bb))
(atk-fr-sq-bb-vec (pos-atk-fr-sq-bb-vec my-pos))
(atk-to-sq-bb-vec (pos-atk-to-sq-bb-vec my-pos))
)
;;
;; Calculate runways: orthogonals
;;
(doorthodirs (dir)
(let ((scan-sqs (aref open-ray-sqs-vec pas-king-sq dir)))
(when scan-sqs
(do ((scan-sq (pop scan-sqs))) ((not scan-sq))
(if (sq-reset? loc-merge-bb scan-sq)
(progn
(set-sq orw-bb scan-sq)
(if scan-sqs
(setf scan-sq (pop scan-sqs))
(setf scan-sq nil)))
(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 qrw-bb orw-bb)
;;
;; Calculate runways: diagonals
;;
(dodiagodirs (dir)
(let ((scan-sqs (aref open-ray-sqs-vec pas-king-sq dir)))
(when scan-sqs
(do ((scan-sq (pop scan-sqs))) ((not scan-sq))
(if (sq-reset? loc-merge-bb scan-sq)
(progn
(set-sq drw-bb scan-sq)
(if scan-sqs
(setf scan-sq (pop scan-sqs))
(setf scan-sq nil)))
(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 qrw-bb drw-bb)
;;
;; Finalize discovery inline bitboard
;;
(let ((cand-bb (clone-bb inline-bb)))
(loop-bb (cand-bb cand-sq)
(when
(bb-empty?
(bb-and3
act-sweep-bb
(svref atk-to-sq-bb-vec cand-sq)
(fetch-beyond-bb pas-king-sq cand-sq)))
(reset-sq inline-bb cand-sq))))
;;
;; From man scan
;;
(loop-bb (fr-bb fr-sq)
(let*
(
(fr-man (get-man board-vec fr-sq))
(fr-piece (svref mc-man-to-piece-vec fr-man))
(to-bb (bb-and2 (svref atk-fr-sq-bb-vec fr-sq) target-bb))
)
(cond
;;
;; Pawn checks
;;
((= fr-piece piece-pawn)
(let*
(
(fr-file (map-sq-to-file fr-sq))
(fr-rank (map-sq-to-rank fr-sq))
(rstrct-flag (sq-set? rstrct-bb fr-sq))
(rstrct-dir (if rstrct-flag (fetch-dir act-king-sq fr-sq)))
(r2-flag (= fr-rank (svref second-rank-vec act-color)))
(r7-flag (= fr-rank (svref seventh-rank-vec act-color)))
(q-capt-sq nil)
(k-capt-sq nil)
)
(if (= act-color color-white)
(progn
(when (and (> fr-file file-a) (or (not rstrct-flag) (= rstrct-dir dir-nw)))
(setf q-capt-sq (+ fr-sq delta-nw))
(when (sq-reset? pas-loc-bb q-capt-sq)
(setf q-capt-sq nil)))
(when (and (< fr-file file-h) (or (not rstrct-flag) (= rstrct-dir dir-ne)))
(setf k-capt-sq (+ fr-sq delta-ne))
(when (sq-reset? pas-loc-bb k-capt-sq)
(setf k-capt-sq nil))))
(progn
(when (and (> fr-file file-a) (or (not rstrct-flag) (= rstrct-dir dir-sw)))
(setf q-capt-sq (+ fr-sq delta-sw))
(when (sq-reset? pas-loc-bb q-capt-sq)
(setf q-capt-sq nil)))
(when (and (< fr-file file-h) (or (not rstrct-flag) (= rstrct-dir dir-se)))
(setf k-capt-sq (+ fr-sq delta-se))
(when (sq-reset? pas-loc-bb k-capt-sq)
(setf k-capt-sq nil)))))
;;;;;;; Needs refinement: begin
(when
(or
(not rstrct-flag)
(= bidir-n (svref mc-sweep-dir-to-bidir-vec rstrct-dir)))
(let ((to-sq (+ fr-sq adv-delta)))
(when (sq-reset? loc-merge-bb to-sq)
(if r7-flag
(dolist (msc msc-gen-promotion-list)
(push (mm-prom fr-sq to-sq fr-man msc) result)
(unless (is-move-checking? (first result) my-pos)
(pop result)))
(progn
(push (mm-simp fr-sq to-sq fr-man) result)
(unless (is-move-checking? (first result) my-pos)
(pop result))
(when (and r2-flag (sq-reset? loc-merge-bb (+ to-sq adv-delta)))
(push (mm-simp fr-sq (+ to-sq adv-delta) fr-man) result)
(unless (is-move-checking? (first result) my-pos)
(pop result))))))))
(dolist (to-sq (list q-capt-sq k-capt-sq))
(when to-sq
(let ((to-man (get-man board-vec to-sq)))
(if r7-flag
(dolist (msc msc-gen-promotion-list)
(push (mm-prcp fr-sq to-sq fr-man to-man msc) result)
(unless (is-move-checking? (first result) my-pos)
(pop result)))
(progn
(push (mm-capt fr-sq to-sq fr-man to-man) result)
(unless (is-move-checking? (first result) my-pos)
(pop result)))))))
;;;;;;; Needs refinement: end
(when (and ep-sq (find ep-sq (aref pawn-sqs-vec act-color fr-sq)))
(let ((epcp-move (mm-epcp fr-man fr-sq ep-sq)))
(when (is-move-playable-and-checks? epcp-move my-pos)
(push epcp-move result))))))
;;
;; Knight checks
;;
((= fr-piece piece-knight)
(when (sq-reset? inline-bb fr-sq)
(bb-and2d to-bb nrw-bb))
(loop-bb (to-bb to-sq)
(push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
;;
;; Bishop checks
;;
((= fr-piece piece-bishop)
(when (sq-set? rstrct-bb fr-sq)
(bb-and2d to-bb (fetch-beamer-bb act-king-sq fr-sq)))
(when (sq-reset? inline-bb fr-sq)
(bb-and2d to-bb drw-bb))
(loop-bb (to-bb to-sq)
(push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
;;
;; Rook checks
;;
((= fr-piece piece-rook)
(when (sq-set? rstrct-bb fr-sq)
(bb-and2d to-bb (fetch-beamer-bb act-king-sq fr-sq)))
(when (sq-reset? inline-bb fr-sq)
(bb-and2d to-bb orw-bb))
(loop-bb (to-bb to-sq)
(push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
;;
;; Queen checks
;;
((= fr-piece piece-queen)
(when (sq-set? rstrct-bb fr-sq)
(bb-and2d to-bb (fetch-beamer-bb act-king-sq fr-sq)))
(bb-and2d to-bb qrw-bb)
(loop-bb (to-bb to-sq)
(push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
;;
;; King checks
;;
((= fr-piece piece-king)
(when (sq-set? inline-bb fr-sq)
(bb-and2c2d to-bb (fetch-beamer-bb pas-king-sq act-king-sq))
(bb-and2c2d to-bb (svref (pos-atk-by-color-bb-vec my-pos) pas-color))
(loop-bb (to-bb to-sq)
(push (mm-capt fr-sq to-sq fr-man (get-man board-vec to-sq)) result)))
(let ((castbits (pos-castbits my-pos)))
(when (nonzero? castbits)
(when (nonzero? (logand castbits (svref mc-color-to-castbits-vec act-color)))
(dolist (castling (svref mc-color-to-castling-list-vec act-color))
(when (can-castle-castling? castling my-pos)
(let ((rook-sq (svref castling-rook-cstl-sq-vec castling)))
(cond
((same-file? pas-king-sq rook-sq)
(when (clear-path? pas-king-sq rook-sq loc-merge-bb)
(push (clone-move (svref castling-move-vec castling)) result)))
((same-rank? pas-king-sq act-king-sq)
(when (clear-path? pas-king-sq act-king-sq loc-merge-bb)
(push (clone-move (svref castling-move-vec castling)) result)))
(t nil)))))))))
;;
(t (error "cond fault: generate-checks")))))
;;
;; Mark all moves as checks
;;
(dolist (move result)
(set-mf move mf-chck))
result))
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Tue Sep 02, 2008 7:15 pm
Here's a re-run of some quick mates using the new check generator; note the node count differences from prior postings:
Code: Select all
> (sms0-driver 2 "2r1nr1k/pp1q1p1p/3bpp2/5P2/1P1Q4/P3P3/1B3P1P/R3K1R1 w Q - 0 1")
Mate in two found: 1. Qxf6+ Ng7 2. Qxg7#
[EX:MateIn2 NC:14 PV:(Qxf6+ Ng7 Qxg7#)]
> (sms0-driver 2 "rnbqkbn1/ppppp3/7r/6pp/3P1p2/3BP1B1/PPP2PPP/RN1QK1NR w KQq - 0 1")
Mate in two found: 1. Qxh5+ Rg6 2. Qxg6#
[EX:MateIn2 NC:113 PV:(Qxh5+ Rg6 Qxg6#)]
> (sms0-driver 3 "r1b1k2r/pp2bppp/8/3N2q1/2p5/8/PPP2PPP/R2QR1K1 w kq - 0 1")
Mate in three found: 1. Nc7+ Kf8 2. Qd8+ Bxd8 3. Re8#
[EX:MateIn3 NC:470 PV:(Nc7+ Kf8 Qd8+ Bxd8 Re8#)]
> (sms0-driver 4 "r1b2rk1/pp1p1pp1/1b1p2B1/n1qQ2p1/8/5N2/P3RPPP/4R1K1 w - - 0 1")
Mate in four found: 1. Qxf7+ Rxf7 2. Re8+ Rf8 3. Rxf8+ Kxf8 4. Re8#
[EX:MateIn4 NC:87463 PV:(Qxf7+ Rxf7 Re8+ Rf8 Rxf8+ Kxf8 Re8#)]
sje
Posts: 4675Joined: Mon Mar 13, 2006 7:43 pm
Post by sje Wed Sep 03, 2008 11:59 am
The CIL Toolkit now knows about applying SI suffixes and can use this to help generate formatted timing statistics.
Code: Select all
;; SI suffixes
(defconstant si-limit 8)
(defconstant si-lower-vec (make-array si-limit :initial-contents "munpfazy"))
(defconstant si-upper-vec (make-array si-limit :initial-contents "KMGTPEZY"))
(defun calc-si-list (my-value)
"Return a list of a scaled value and the appropriate SI character suffix character."
(let ((scaled-value (abs my-value)) (suffix nil) (index 0))
(cond
((zero? scaled-value)
nil)
((>= scaled-value 1000)
(dowhile (and (>= scaled-value 1000) (< index si-limit))
(setf scaled-value (/ scaled-value 1000))
(incf index))
(setf suffix (svref si-upper-vec (1- index))))
((< scaled-value 1)
(dowhile (and (< scaled-value 1) (< index si-limit))
(setf scaled-value (* scaled-value 1000))
(incf index))
(setf suffix (svref si-lower-vec (1- index))))
(t nil))
(when (negative? my-value)
(setf scaled-value (- scaled-value)))
(list scaled-value suffix)))
;;; Timing
(defun calc-time-delta (my-tm0 my-tm1)
"Return the time difference in float seconds between the first and second time marks."
(float (/ (- my-tm1 my-tm0) internal-time-units-per-second)))
(defun calc-frequency (my-count my-seconds)
"Return a frequency."
(when (zero? my-seconds)
(error "calc-frequency: zero time"))
(/ my-count my-seconds))
(defun calc-period (my-count my-seconds)
"Return a period."
(when (zero? my-count)
(error "calc-period: zero count"))
(/ my-seconds my-count))
(defun encode-frequency (my-stream my-frequency)
"Encode a frequency."
(let* ((vs-pair (calc-si-list my-frequency)) (value (first vs-pair)) (suffix (second vs-pair)))
(when (and (rational? value) (not (integer? value)))
(setf value (float value)))
(format my-stream "~D " value)
(when suffix
(format my-stream "~C" suffix))
(format my-stream "Hz")))
(defun encode-period (my-stream my-period)
"Encode a period."
(let* ((vs-pair (calc-si-list my-period)) (value (first vs-pair)) (suffix (second vs-pair)))
(when (and (rational? value) (not (integer? value)))
(setf value (float value)))
(format my-stream "~D " value)
(when suffix
(format my-stream "~C" suffix))
(format my-stream "sec")))
(defun encode-fp (my-stream my-count my-seconds)
"Encode a frequnecy/period string on a stream."
(format my-stream "F/P: ")
(encode-frequency my-stream (calc-frequency my-count my-seconds))
(format my-stream " / ")
(encode-period my-stream (calc-period my-count my-seconds)))
Here's the current "visit all nodes" movepath enumerator that uses the SI formatter:
Code: Select all
;;; Visit and count all nodes (movepath enumeration)
(defun van-movepaths-aux (my-pos my-rcv my-ply my-depth)
"Return a count of distinct movepaths; apply diagnostics as needed."
(let ((result nil))
(cond
((zero? my-depth)
(setf result 1))
(t
(let ((moves (if (zero? my-ply) (generate-canon my-pos) (generate my-pos))))
(setf result 0)
(dolist (move moves)
(let ((saved-posenv (clone-posenv (pos-posenv my-pos))))
(execute-move move my-pos)
(incf result
(van-movepaths-aux my-pos (cons move my-rcv) (1+ my-ply) (1- my-depth)))
(setf (pos-posenv my-pos) saved-posenv)
(retract-move move my-pos))))))
(when (one? my-ply)
(format t "~A ~D~%" (first my-rcv) result))
result))
(defun van-movepaths (my-pos my-depth)
"Count the distinct movepaths from the given position to the given ply depth."
(let ((result (van-movepaths-aux my-pos nil 0 my-depth)))
(format t "Total path count for depth ~R: ~D~%" my-depth result)
result))
(defun time-van (my-pos my-depth)
"Time a visit-all-nodes movepath enumeration."
(let ((result nil) (tm0 nil) (tm1 nil) (seconds nil))
(setf tm0 (get-internal-run-time))
(setf result (van-movepaths my-pos my-depth))
(setf tm1 (get-internal-run-time))
(setf seconds (calc-time-delta tm0 tm1))
(encode-fp t result seconds)
(format t "~%")
result))
Sample output:
Code: Select all
> (time-van pos0 4)
Na3 8885
Nc3 9755
Nf3 9748
Nh3 8881
a3 8457
a4 9329
b3 9345
b4 9332
c3 9272
c4 9744
d3 11959
d4 12435
e3 13134
e4 13160
f3 8457
f4 8929
g3 9345
g4 9328
h3 8457
h4 9329
Total path count for depth four: 197281
F/P: 8.28693 KHz / 120.67195 usec
