diff options
Diffstat (limited to 'plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas')
| -rw-r--r-- | plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas | 620 |
1 files changed, 620 insertions, 0 deletions
diff --git a/plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas b/plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas new file mode 100644 index 0000000000..535f181e9c --- /dev/null +++ b/plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas @@ -0,0 +1,620 @@ +////////////////////////////////////////////////////////////////////////////////
+// All code below is exclusively owned by author of Chess4Net - Pavel Perminov
+// (packpaul@mail.ru, packpaul1@gmail.com).
+// Any changes, modifications, borrowing and adaptation are a subject for
+// explicit permition from the owner.
+
+unit PosBaseChessBoardLayerUnit;
+
+interface
+
+uses
+ Classes,
+ //
+ ChessBoardUnit, PosBaseUnit;
+
+
+type
+ TGameResult = (grWin, grWinTime, grDraw, grLost, grLostTime);
+
+ // Layer extended with Position DB
+ TPosBaseChessBoardLayer = class(TChessBoardLayerBase)
+ private
+ m_bTrainingMode: boolean;
+ m_lstMovePrior: TList;
+ m_bUseUserBase: boolean;
+ m_PosBase, m_ExtPosBase: TPosBase;
+ m_strPosBaseName, m_strExtPosBaseName: string;
+
+ procedure FSetTrainingMode(bValue: boolean);
+ procedure FSetUseUserBase(bValue: boolean);
+
+ procedure FClearMovePriorList;
+ procedure FReadFromBase;
+ procedure FWriteGameToBase;
+ protected
+ procedure RDraw; override;
+ procedure ROnAfterMoveDone; override;
+ procedure ROnAfterSetPosition; override;
+ procedure ROnAfterModeSet(const OldValue, NewValue: TMode); override;
+ procedure ROnResetMoveList; override;
+ public
+ constructor Create(const strPosBaseName: string = '');
+ destructor Destroy; override;
+ procedure SetExternalBase(const strExtPosBaseName: string);
+ procedure WriteGameToBase(AGameResult: TGameResult);
+ procedure UnsetExternalBase;
+ property TrainingMode: boolean read m_bTrainingMode write FSetTrainingMode;
+ property UseUserBase: boolean read m_bUseUserBase write FSetUseUserBase;
+ end;
+
+implementation
+
+uses
+ Graphics, SysUtils,
+ //
+ ChessRulesEngine, ChessBoardHeaderUnit;
+
+type
+ TPrior = (mpNo, mpHigh, mpMid, mpLow);
+
+ PMovePrior = ^TMovePrior;
+ TMovePrior = record
+ move: TMoveAbs;
+ prior: TPrior;
+ end;
+
+ TPosBaseOperator = class(TThread)
+ private
+ m_Operation: (opRead, opWrite);
+ m_Layer: TPosBaseChessBoardLayer;
+ constructor FCreateRead(ALayer: TPosBaseChessBoardLayer;
+ vbFreeOnTerminate: boolean = TRUE);
+ constructor FCreateWrite(ALayer: TPosBaseChessBoardLayer);
+ protected
+ procedure Execute; override;
+ public
+ class function CreateRead(ALayer: TPosBaseChessBoardLayer;
+ vbFreeOnTerminate: boolean = TRUE): TPosBaseOperator;
+ class function CreateWrite(ALayer: TPosBaseChessBoardLayer): TPosBaseOperator;
+ procedure WaitFor;
+ end;
+
+var
+ gameResult: TGameResult; // Not threadsafe
+ gameID: word; // It's used for writing unique positions (not threadsafe)
+
+const
+ NUM_PRIORITIES = 3; // Maximal number of priorities
+{$IFDEF RESTRICT_TRAINING_DB}
+ MAX_PLY_TO_BASE = 60;
+{$ELSE}
+ MAX_PLY_TO_BASE = -1; // The whole game is saved to the DB
+{$ENDIF}
+
+////////////////////////////////////////////////////////////////////////////////
+// TPosBaseChessBoardLayer
+
+constructor TPosBaseChessBoardLayer.Create(const strPosBaseName: string = '');
+begin
+ inherited Create;
+
+ m_bUseUserBase := TRUE;
+ m_strPosBaseName := strPosBaseName;
+
+ m_lstMovePrior := TList.Create;
+end;
+
+
+destructor TPosBaseChessBoardLayer.Destroy;
+begin
+ FClearMovePriorList;
+ m_lstMovePrior.Free;
+
+ TrainingMode := FALSE;
+
+ inherited;
+end;
+
+
+procedure TPosBaseChessBoardLayer.RDraw;
+const
+ ARROW_END_LENGTH = 10; // в пикселях
+ ARROW_END_ANGLE = 15 * (Pi / 180); // угол концов стрелки
+ ARROW_INDENT = 7;
+
+ HIGH_ARROW_COLOR = clRed;
+ HIGH_ARROW_WIDTH = 2;
+ MID_ARROW_COLOR = clTeal;
+ MID_ARROW_WIDTH = 2;
+ LOW_ARROW_COLOR = clSkyBlue;
+ LOW_ARROW_WIDTH = 1;
+
+var
+ i, x0, y0, x, y: integer;
+ xa, ya, ca, sa: double;
+ move: TMoveAbs;
+begin
+ if (not (Assigned(ChessBoard) and Assigned(Canvas))) then
+ exit;
+
+ if (not (m_bTrainingMode and (ChessBoard.Mode in [mGame, mAnalyse]) and
+ (ChessBoard.PlayerColor = ChessBoard.PositionColor))) then
+ exit;
+
+ Canvas.Pen.Style := psSolid;
+
+ for i := 0 to m_lstMovePrior.Count - 1 do
+ begin
+ case PMovePrior(m_lstMovePrior[i]).prior of
+ mpNo: continue;
+ mpHigh:
+ begin
+ Canvas.Pen.Color := HIGH_ARROW_COLOR;
+ Canvas.Pen.Width := HIGH_ARROW_WIDTH;
+ end;
+ mpMid:
+ begin
+ Canvas.Pen.Color := MID_ARROW_COLOR;
+ Canvas.Pen.Width := MID_ARROW_WIDTH;
+ end;
+ mpLow:
+ begin
+ Canvas.Pen.Color := LOW_ARROW_COLOR;
+ Canvas.Pen.Width := LOW_ARROW_WIDTH;
+ end;
+ end;
+
+ move := PMovePrior(m_lstMovePrior[i]).move;
+
+ if (not ChessBoard.Flipped) then
+ begin
+ x0 := CHB_X + SquareSize * (move.i0 - 1) + (SquareSize div 2);
+ y0 := CHB_Y + SquareSize * (8 - move.j0) + (SquareSize div 2);
+ x := CHB_X + SquareSize * (move.i - 1) + (SquareSize div 2);
+ y := CHB_Y + SquareSize * (8 - move.j) + (SquareSize div 2);
+ end
+ else
+ begin
+ x0 := CHB_X + SquareSize * (8 - move.i0) + (SquareSize div 2);
+ y0 := CHB_Y + SquareSize * (move.j0 - 1) + (SquareSize div 2);
+ x := CHB_X + SquareSize * (8 - move.i) + (SquareSize div 2);
+ y := CHB_Y + SquareSize * (move.j - 1) + (SquareSize div 2);
+ end;
+
+ // Draw an arrow
+ ca := (x - x0) / sqrt(sqr(x - x0) + sqr(y - y0));
+ sa := (y - y0) / sqrt(sqr(x - x0) + sqr(y - y0));
+ x0 := x0 + Round(ARROW_INDENT * ca);
+ y0 := y0 + Round(ARROW_INDENT * sa);
+ x := x - Round(ARROW_INDENT * ca);
+ y := y - Round(ARROW_INDENT * sa);
+
+ Canvas.MoveTo(x0, y0);
+ Canvas.LineTo(x, y);
+
+ xa := x + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * ca -
+ (ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * sa;
+ ya := y + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * sa +
+ (ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * ca;
+
+ Canvas.LineTo(Round(xa), Round(ya));
+
+ xa := x + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * ca -
+ (-ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * sa;
+ ya := y + (-ARROW_END_LENGTH * cos(ARROW_END_ANGLE)) * sa +
+ (-ARROW_END_LENGTH * sin(ARROW_END_ANGLE)) * ca;
+
+ Canvas.MoveTo(x, y);
+ Canvas.LineTo(Round(xa), Round(ya));
+ end;
+
+end;
+
+
+procedure Reestimate(lstMoveEsts: TList; viRec: integer);
+var
+ est: SmallInt;
+ id: word;
+begin
+ id := LongWord(lstMoveEsts[viRec]) shr 16;
+ if id = gameID then
+ exit; // позиция дублируется в рамках одной партии
+
+ est := SmallInt(lstMoveEsts[viRec]);
+ case gameResult of
+ grWin: inc(est, 2);
+ grWinTime: inc(est);
+ grDraw: ;
+ grLost: dec(est, 2);
+ grLostTime: dec(est);
+ end;
+ lstMoveEsts[viRec] := Pointer((gameID shl 16) or Word(est));
+end;
+
+
+procedure TPosBaseChessBoardLayer.FSetTrainingMode(bValue: boolean);
+begin
+ if (m_bTrainingMode = bValue) then
+ exit;
+
+ m_bTrainingMode := bValue;
+
+ try
+ if (m_bTrainingMode) then
+ begin
+ if (m_strPosBaseName <> '') then
+ m_PosBase := TPosBase.Create(m_strPosBaseName, Reestimate);
+ if (m_strExtPosBaseName <> '') then
+ m_ExtPosBase := TPosBase.Create(m_strExtPosBaseName);
+ with TPosBaseOperator.CreateRead(self, FALSE) do
+ try
+ WaitFor;
+ finally
+ Free;
+ end;
+ end
+ else
+ begin
+ FreeAndNil(m_PosBase);
+ FreeAndNil(m_ExtPosBase);
+ end;
+
+ RDoUpdate;
+
+ except
+ on Exception do
+ begin
+ FreeAndNil(m_PosBase);
+ FreeAndNil(m_ExtPosBase);
+ m_bTrainingMode := FALSE;
+ end;
+ end;
+
+end;
+
+
+procedure TPosBaseChessBoardLayer.FSetUseUserBase(bValue: boolean);
+begin
+ if (m_bUseUserBase = bValue) then
+ exit;
+ m_bUseUserBase := bValue;
+ TPosBaseOperator.CreateRead(self, FALSE);
+end;
+
+
+procedure TPosBaseChessBoardLayer.ROnAfterMoveDone;
+begin
+ if (m_bTrainingMode) then
+ begin
+ if (Assigned(ChessBoard) and
+ (ChessBoard.PlayerColor = ChessBoard.PositionColor)) then
+ TPosBaseOperator.CreateRead(self) // Read from PosBase and update
+ end;
+end;
+
+
+procedure TPosBaseChessBoardLayer.ROnAfterSetPosition;
+begin
+ if (m_bTrainingMode) then
+ begin
+ with TPosBaseOperator.CreateRead(self, FALSE) do // Read from DB and update
+ try
+ WaitFor;
+ finally
+ Free;
+ end;
+ end;
+end;
+
+
+procedure TPosBaseChessBoardLayer.SetExternalBase(const strExtPosBaseName: string);
+begin
+ if (m_bTrainingMode) then
+ begin
+ if (m_strExtPosBaseName = strExtPosBaseName) then
+ exit;
+ FreeAndNil(m_ExtPosBase);
+ m_ExtPosBase := TPosBase.Create(strExtPosBaseName);
+ TPosBaseOperator.CreateRead(self, FALSE);
+ end;
+
+ m_strExtPosBaseName := strExtPosBaseName;
+end;
+
+
+procedure TPosBaseChessBoardLayer.WriteGameToBase(AGameResult: TGameResult);
+begin
+ if (m_bTrainingMode) then
+ begin
+ gameResult := AGameResult;
+ TPosBaseOperator.CreateWrite(self);
+ end;
+end;
+
+
+procedure TPosBaseChessBoardLayer.UnsetExternalBase;
+begin
+ FreeAndNil(m_ExtPosBase);
+end;
+
+
+procedure TPosBaseChessBoardLayer.ROnAfterModeSet(const OldValue, NewValue: TMode);
+begin
+ if (OldValue = mEdit) then
+ ROnAfterSetPosition; // Read from PosBase
+end;
+
+
+procedure TPosBaseChessBoardLayer.ROnResetMoveList;
+begin
+ if (ChessBoard.Mode = mEdit) then
+ FClearMovePriorList;
+end;
+
+
+procedure TPosBaseChessBoardLayer.FClearMovePriorList;
+var
+ i: integer;
+begin
+ for i := 0 to m_lstMovePrior.Count - 1 do
+ Dispose(m_lstMovePrior[i]);
+ m_lstMovePrior.Clear;
+end;
+
+
+function EstComape(item1, item2: pointer): integer;
+begin
+ Result := SmallInt(PMoveEst(item2).estimate and $FFFF) - SmallInt(PMoveEst(item1).estimate and $FFFF);
+end;
+
+
+procedure TPosBaseChessBoardLayer.FReadFromBase;
+
+ procedure ClasterMoves(var rlstMove: TList);
+ var
+ i, j, num_clast, i_min, j_min, curr_assoc: integer;
+ modus_min: double;
+ clastWeights: array of record
+ grav: double;
+ assoc: integer;
+ end;
+ mp: PMovePrior;
+ p: TPrior;
+ begin
+ if rlstMove.Count = 0 then
+ exit;
+
+ rlstMove.Sort(EstComape);
+ SetLength(clastWeights, rlstMove.Count);
+
+ num_clast := rlstMove.Count;
+ for i := 0 to num_clast - 1 do
+ begin
+ clastWeights[i].assoc := i + 1;
+ clastWeights[i].grav := SmallInt(PMoveEst(rlstMove[i]).estimate and $FFFF);
+ end;
+
+ repeat
+ i_min := 0;
+ j_min := 0;
+ modus_min := $7FFF; // $7FFF - макс. значение для оценки
+ curr_assoc := 0; // текущий просматриваемый кластер
+
+ for i := 0 to length(clastWeights) - 2 do
+ begin
+ if curr_assoc = clastWeights[i].assoc then
+ continue;
+ curr_assoc := clastWeights[i].assoc;
+ for j := i + 1 to length(clastWeights) - 1 do
+ if (clastWeights[j].assoc <> clastWeights[j-1].assoc) and
+ (curr_assoc <> clastWeights[j].assoc) and
+ (abs(clastWeights[i].grav - clastWeights[j].grav) <= modus_min) then
+ begin
+ i_min := i;
+ j_min := j;
+ modus_min := abs(clastWeights[i].grav - clastWeights[j].grav);
+ end;
+ end;
+
+ if (num_clast > Ord(High(TPrior))) or (modus_min = 0.0) then
+ begin
+ for i := High(clastWeights) downto j_min do
+ if clastWeights[i].assoc = clastWeights[j_min].assoc then
+ clastWeights[i].assoc := clastWeights[i_min].assoc;
+ clastWeights[i_min].grav := (clastWeights[i_min].grav + clastWeights[j_min].grav) / 2;
+ end;
+
+ dec(num_clast);
+ until (num_clast <= Ord(High(TPrior))) and ((modus_min <> 0.0) or (num_clast < 1));
+
+ p := mpHigh;
+ for i := 0 to rlstMove.Count - 1 do
+ begin
+ new(mp);
+ if (i > 0) and (clastWeights[i].assoc > clastWeights[i-1].assoc) then
+ p := Succ(p);
+ mp.move := PMoveEst(rlstMove[i]).move;
+ mp.prior := p;
+ Dispose(rlstMove[i]);
+ rlstMove[i] := mp;
+ end;
+
+ SetLength(clastWeights, 0);
+ end;
+
+var
+ lstUsrMove, lstExtMove: TList;
+
+ procedure MergeMoves;
+ function NEqualMoves(i,j: integer): boolean;
+ begin
+ with PMovePrior(lstExtMove[i])^, PMovePrior(m_lstMovePrior[j]).move do
+ Result := (i0 = move.i0) and (j0 = move.j0) and (j = move.j) and (i = move.i) and
+ (prom_fig = move.prom_fig);
+ end;
+
+ var
+ i, j, n: integer;
+ const
+ PRIOR_CALC: array[TPrior, TPrior] of TPrior =
+ ((mpNo, mpNo, mpNo, mpNo), // UsrPrior = mpNo - ?, т.к. ещё нигде не исп.
+ (mpHigh, mpHigh, mpHigh, mpMid), // UsrPrior = mpHigh
+ (mpMid, mpMid, mpMid, mpMid), // UsrPrior = mpMid
+ (mpLow, mpMid, mpLow, mpLow)); // UsrPrior = mpLow
+ begin
+ for i := 0 to lstUsrMove.Count - 1 do
+ m_lstMovePrior.Add(lstUsrMove[i]);
+
+ // Merging of lists
+ n := m_lstMovePrior.Count;
+
+ for i := 0 to lstExtMove.Count - 1 do
+ begin
+ j := n - 1;
+ while (j >= 0) do
+ begin
+ if NEqualMoves(i,j) then
+ begin
+ PMovePrior(m_lstMovePrior[j]).prior :=
+ PRIOR_CALC[PMovePrior(m_lstMovePrior[j]).prior,
+ PMovePrior(lstExtMove[j]).prior];
+ Dispose(lstExtMove[i]);
+ break;
+ end;
+ dec(j);
+ end;
+ if (j < 0) then
+ m_lstMovePrior.Add(lstExtMove[i]);
+ end; // for
+ end;
+
+begin // .FReadFromBase
+ FClearMovePriorList;
+
+ if (not Assigned(Position)) then
+ exit;
+
+ lstExtMove := nil;
+ lstUsrMove := TList.Create;
+ try
+ lstExtMove := TList.Create;
+
+ if (m_bUseUserBase or (not Assigned(m_ExtPosBase))) then
+ begin
+ if (Assigned(m_PosBase)) then
+ m_PosBase.Find(Position^, lstUsrMove);
+ end;
+ if (Assigned(m_ExtPosBase)) then
+ m_ExtPosBase.Find(Position^, lstExtMove);
+
+ // TODO: Handle wrong DB
+
+ ClasterMoves(lstUsrMove);
+ ClasterMoves(lstExtMove);
+
+ MergeMoves;
+
+ finally
+ lstExtMove.Free;
+ lstUsrMove.Free;
+ end;
+
+end;
+
+
+procedure TPosBaseChessBoardLayer.FWriteGameToBase;
+var
+ ply: integer;
+begin
+ if (not (Assigned(m_PosBase) and Assigned(PositionsList))) then
+ exit;
+
+ gameID := Random($FFFF) + 1;
+
+ if (ChessBoard.PlayerColor = RGetColorStarts) then
+ ply := 0
+ else
+ ply := 1;
+
+ while ((ply < PositionsList.Count) and ((MAX_PLY_TO_BASE < 0) or (ply <= MAX_PLY_TO_BASE))) do
+ begin
+ m_PosBase.Add(PPosMove(PositionsList[ply])^);
+ inc(ply, 2);
+ end;
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TPosBaseOperator
+
+constructor TPosBaseOperator.FCreateRead(ALayer: TPosBaseChessBoardLayer;
+ vbFreeOnTerminate: boolean = TRUE);
+begin
+ m_Operation := opRead;
+ m_Layer := ALayer;
+
+ inherited Create(TRUE);
+ Priority := tpNormal;
+ FreeOnTerminate := vbFreeOnTerminate;
+ Resume;
+end;
+
+
+constructor TPosBaseOperator.FCreateWrite(ALayer: TPosBaseChessBoardLayer);
+begin
+ m_Layer := ALayer;
+ m_Operation := opWrite;
+
+ inherited Create(TRUE);
+
+ Priority := tpNormal;
+ FreeOnTerminate := TRUE;
+
+ Resume;
+end;
+
+
+class function TPosBaseOperator.CreateRead(ALayer: TPosBaseChessBoardLayer;
+ vbFreeOnTerminate: boolean = TRUE): TPosBaseOperator;
+begin
+ Result := nil;
+
+ if (Assigned(ALayer.ChessBoard) and (ALayer.ChessBoard.Mode <> mEdit)) then
+ Result := TPosBaseOperator.FCreateRead(ALayer, vbFreeOnTerminate);
+end;
+
+
+class function TPosBaseOperator.CreateWrite(ALayer: TPosBaseChessBoardLayer): TPosBaseOperator;
+begin
+ Result := nil;
+
+ if (Assigned(ALayer.ChessBoard) and (ALayer.ChessBoard.Mode <> mEdit)) then
+ Result := TPosBaseOperator.FCreateWrite(ALayer);
+end;
+
+
+procedure TPosBaseOperator.Execute;
+begin
+ case m_Operation of
+ opRead:
+ begin
+ m_Layer.FReadFromBase;
+ Synchronize(m_Layer.RDoUpdate);
+ end;
+ opWrite:
+ m_Layer.FWriteGameToBase;
+ end;
+end;
+
+
+procedure TPosBaseOperator.WaitFor;
+begin
+ if (not Assigned(self)) then
+ exit;
+ inherited WaitFor;
+end;
+
+initialization
+ Randomize;
+
+end.
|