Code: Select all
;;;;; Symbolic: A cognitive chessplaying program by S. J. Edwards
;;
;; Copyright (C) 2007 by S. J. Edwards / All rights reserved.
;;
;; Distribution is prohibited except when explicitly permitted by the author.
;; There is no warranty, implied or otherwise. Use at your own risk.
;; The transposition data repository is a pair (one per color) of binary
;; trees with one position per transposition node. The anchors for the tree
;; pair are in the two element global vector TheSearchTransRootVec. Each
;; transposition node is an a-list and contains the position main hash, the
;; search tree node where the position first appeared, a list of all other
;; search tree nodes that have the same position, and links to the left and
;; right transposition subtrees.
;;
;; Each search tree node has a TransRec attribute that points into one of
;; two transposition record trees.
;; Factory
;;
(defun MakeTransRec (MyNode)
"Return a new transposition record for the given search node."
(let ((Result (MakeAL 'TransRec)))
(nassocq MainHash Result (PcMainHash (FetchPV MyNode)))
(nassocq Node Result MyNode)
(svn-assocq AltNodes Result)
(svn-assocq LinkLT Result)
(svn-assocq LinkGT Result)
Result))
;; Location (may or may not be present)
;;
(defun LocateTransRecAux (MyTransRec MyMainHash)
"Try to locate a transposition record; return nil if not found."
(let ((Result nil))
(when MyTransRec
(let ((TRMainHash (vassocq MainHash MyTransRec)))
(cond
((HashOpLT MyMainHash TRMainHash)
(setf Result
(LocateTransRecAux (vassocq LinkLT MyTransRec) MyMainHash)))
((HashOpGT MyMainHash TRMainHash)
(setf Result
(LocateTransRecAux (vassocq LinkGT MyTransRec) MyMainHash)))
((HashOpEQ MyMainHash TRMainHash)
(setf Result MyTransRec))
(t (error "LocateTransRecAux")))))
Result))
(defun LocateTransRecByNode (MyNode)
"Try to locate a transposition record by search node."
(let*
(
(Result nil)
(PV (FetchPV MyNode))
(RootTransRec (vref TheSearchTransRootVec (PcActColor PV)))
)
(when RootTransRec
(setf Result (LocateTransRecAux RootTransRec (PcMainHash PV))))
Result))
;; Insertion (only for non located nodes)
;;
(defun InsertTransRecAux (MyParentNode MyTransRec)
"Insert a new transposition record (only for non located node)."
(let
(
(PNMainHash (vassocq MainHash MyParentNode))
(TRMainHash (vassocq MainHash MyTransRec))
)
(assert (HashOpNE PNMainHash TRMainHash) "InsertTransRecAux")
(if (HashOpLT TRMainHash PNMainHash)
(let ((LinkLT (vassocq LinkLT MyParentNode)))
(if LinkLT
(InsertTransRecAux LinkLT MyTransRec)
(nassocq LinkLT MyParentNode MyTransRec)))
(let ((LinkGT (vassocq LinkGT MyParentNode)))
(if LinkGT
(InsertTransRecAux LinkGT MyTransRec)
(nassocq LinkGT MyParentNode MyTransRec))))))
(defun InsertTransRecByNode (MyNode)
"Make and insert a new transposition record (only for non located node)."
(let*
(
(Result (MakeTransRec MyNode))
(PV (FetchPV MyNode))
(ActColor (PcActColor PV))
(ParentTransRec (vref TheSearchTransRootVec ActColor))
)
(if ParentTransRec
(InsertTransRecAux ParentTransRec Result)
(setf (vref TheSearchTransRootVec ActColor) Result))
Result))
;; Application (called for each new search node)
;;
(defun ApplyTransByNode (MyNode)
"Return transposition record for a node with side effects."
(let ((Result (LocateTransRecByNode MyNode)))
(if (null? Result)
(setf Result (InsertTransRecByNode MyNode))
(when (neq? MyNode (vassocq Node Result))
(alv-pushq AltNodes Result MyNode)))
Result))
;; Counting utilities
;;
(defun CalcTransCountsByTransRec (MyTransRec)
"Return a list (unique alternate) of counts for a transposition record."
(let
(
(Result nil)
(UniqueCount 1)
(AlternateCount (length (vassocq AltNodes MyTransRec)))
(LinkLT (vassocq LinkLT MyTransRec))
(LinkGT (vassocq LinkGT MyTransRec))
)
(when LinkLT
(let ((ResultLT (CalcTransCountsByTransRec LinkLT)))
(incf UniqueCount (first ResultLT))
(incf AlternateCount (second ResultLT))))
(when LinkGT
(let ((ResultGT (CalcTransCountsByTransRec LinkGT)))
(incf UniqueCount (first ResultGT))
(incf AlternateCount (second ResultGT))))
(setf Result (list UniqueCount AlternateCount))
Result))
(defun CalcTransCountsByColor (MyColor)
"Return a list (unique alternate) of counts for a color."
(let ((Result nil) (RootTransRec (vref TheSearchTransRootVec MyColor)))
(if (null? RootTransRec)
(setf Result (list 0 0))
(setf Result (CalcTransCountsByTransRec RootTransRec)))
Result))
(defun CalcTransCounts ()
"Return a list (unique alternate) of counts."
(let ((Result nil) (UniqueCount 0) (AlternateCount 0))
(DoColors (ActColor)
(let ((ColorResult (CalcTransCountsByColor ActColor)))
(incf UniqueCount (first ColorResult))
(incf AlternateCount (second ColorResult))))
(setf Result (list UniqueCount AlternateCount))
Result))
;; Diagnostic reports
;;
(defun DumpTransDataByColor (MyStream MyColor)
"Dump transposition data by color to the given stream."
(let*
(
(Result (CalcTransCountsByColor MyColor))
(UniqueCount (first Result))
(AlternateCount (second Result))
(TotalCount (+ UniqueCount AlternateCount))
)
(format MyStream "Transpositions for %u: " MyColor)
(format MyStream " unique: %u" UniqueCount)
(format MyStream " alternate: %u" AlternateCount)
(format MyStream " total: %u" TotalCount)
(newline MyStream)
Result))
(defun DumpTransData (MyStream)
"Dump transposition data to the given stream."
(let ((ColorResult nil) (UniqueCount 0) (AlternateCount 0))
(DoColors (ActColor)
(setf ColorResult (DumpTransDataByColor MyStream ActColor))
(incf UniqueCount (first ColorResult))
(incf AlternateCount (second ColorResult)))
(format MyStream "Both colors: ")
(format MyStream " unique: %u" UniqueCount)
(format MyStream " alternate: %u" AlternateCount)
(format MyStream " total: %u" (+ UniqueCount AlternateCount))
(newline MyStream)
(list UniqueCount AlternateCount)))
