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 --- plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas | 620 ----------------------- 1 file changed, 620 deletions(-) delete mode 100644 plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas (limited to 'plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas') diff --git a/plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas b/plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas deleted file mode 100644 index 535f181e9c..0000000000 --- a/plugins/Chess4Net/PosBaseChessBoardLayerUnit.pas +++ /dev/null @@ -1,620 +0,0 @@ -//////////////////////////////////////////////////////////////////////////////// -// 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