From 194923c172167eb3fc33807ec8009b255f86337e Mon Sep 17 00:00:00 2001 From: Vadim Dashevskiy Date: Mon, 8 Oct 2012 09:10:06 +0000 Subject: Plugin is not adapted until someone can compile it and tell others how to do the same git-svn-id: http://svn.miranda-ng.org/main/trunk@1809 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c --- .../Chess4Net/PosBaseChessBoardLayerUnit.pas | 620 +++++++++++++++++++++ 1 file changed, 620 insertions(+) create mode 100644 plugins/!NotAdopted/Chess4Net/PosBaseChessBoardLayerUnit.pas (limited to 'plugins/!NotAdopted/Chess4Net/PosBaseChessBoardLayerUnit.pas') diff --git a/plugins/!NotAdopted/Chess4Net/PosBaseChessBoardLayerUnit.pas b/plugins/!NotAdopted/Chess4Net/PosBaseChessBoardLayerUnit.pas new file mode 100644 index 0000000000..535f181e9c --- /dev/null +++ b/plugins/!NotAdopted/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. -- cgit v1.2.3