1 files changed, 603 insertions, 0 deletions
diff --git a/plugins/!NotAdopted/Chess4Net/PosBaseUnit.pas b/plugins/!NotAdopted/Chess4Net/PosBaseUnit.pas
new file mode 100644
index 0000000000..60f6cba6c4
--- /dev/null
+++ b/plugins/!NotAdopted/Chess4Net/PosBaseUnit.pas
@@ -0,0 +1,603 @@
+////////////////////////////////////////////////////////////////////////////////
+// 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 PosBaseUnit;
+
+interface
+
+uses
+  Classes,
+  //
+  ChessRulesEngine;
+
+type
+  PMoveEst = ^TMoveEst;
+  TMoveEst = record
+    move: TMoveAbs;
+    estimate: LongWord;
+  end;
+
+  TReestimate = procedure(moveEsts: TList; nRec: integer);
+
+  TPosBaseStream = class
+  private
+    m_iRecordSize: integer;
+    m_iHeaderSize: integer;
+    m_InnerStream: TStream;
+    constructor Create(const strFileName: string; RecordSize: integer);
+    function FGetSize: integer;
+  public
+    destructor Destroy; override;
+    procedure SeekHeader;
+    procedure SeekRec(lwRecordNumber: LongWord);
+    procedure SeekEnd;
+    procedure Write(const Buffer); overload;
+    procedure Write(const Buffer; Count: integer); overload;
+    procedure Read(var Buffer); overload;
+    procedure Read(var Buffer; Count: integer); overload;
+    property Size: integer read FGetSize;
+    property HeaderSize: integer read m_iHeaderSize write m_iHeaderSize;
+  end;
+
+  TPosBase = class
+  private
+    m_iDBVersion: Integer;
+    fPos: TPosBaseStream;
+    fMov: TPosBaseStream;
+    FReestimate: TReestimate;
+    procedure FCreateStreams(const strPosFileName, strMovFileName: string);
+    procedure FDestroyStreams;
+    procedure FSetDBVersion;
+    function FCheckDBVersion: Boolean;
+  public
+    procedure Add(const posMove: TPosMove); // добавление позиции и хода в базу
+    function Find(const pos: TChessPosition): boolean; overload;
+    function Find(const pos: TChessPosition; var moveEsts: TList): boolean; overload;
+    constructor Create(fileNameNoExt: string; Reestimate: TReestimate = nil);
+    destructor Destroy; override;
+  end;
+
+implementation
+
+uses
+  SysUtils;
+
+type
+  TFieldNode = packed object
+  public
+    btField: byte;
+  private
+    m_btNextNode: byte; // сл. узел
+    m_wNextNode: word;
+    m_btNextValue: byte; // сл. значение данных
+    m_wNextValue: word;
+    function FGetNextNode: LongWord;
+    procedure FSetNextNode(lwValue: LongWord);
+    function FGetNextValue: LongWord;
+    procedure FSetNextValue(lwValue: LongWord);
+  public
+    property NextNode: LongWord read FGetNextNode write FSetNextNode;
+    property NextValue: LongWord read FGetNextValue write FSetNextValue;
+  end;
+
+  TMoveNode = packed object
+  public
+    wMove: word;
+    estimate: LongWord;
+  private
+    m_btNextValue: byte; // сл. значение данных
+    m_wNextValue: word;
+    function FGetNextValuePos: LongWord;
+    procedure FSetNextValuePos(lwValue: LongWord);
+  public
+    procedure EmptyNode;
+    property NextValue: LongWord read FGetNextValuePos write FSetNextValuePos;
+  end;
+
+  TCoord = record
+    i, j: integer;
+  end;
+
+const
+  POS_FILE_EXT = 'pos';
+  MOV_FILE_EXT = 'mov';
+
+  DB_VERSION = 1;
+
+  FIELD_SEQ: array[1..64] of TCoord = // 13617 kb
+    ((i: 1; j: 1), (i: 1; j: 2), (i: 1; j: 3), (i: 1; j: 4),
+     (i: 1; j: 5), (i: 1; j: 6), (i: 1; j: 7), (i: 1; j: 8),
+     (i: 8; j: 8), (i: 8; j: 7), (i: 8; j: 6), (i: 8; j: 5),
+     (i: 8; j: 4), (i: 8; j: 3), (i: 8; j: 2), (i: 8; j: 1),
+     (i: 2; j: 1), (i: 2; j: 2), (i: 2; j: 3), (i: 2; j: 4),
+     (i: 2; j: 5), (i: 2; j: 6), (i: 2; j: 7), (i: 2; j: 8),
+     (i: 7; j: 8), (i: 7; j: 7), (i: 7; j: 6), (i: 7; j: 5),
+     (i: 7; j: 4), (i: 7; j: 3), (i: 7; j: 2), (i: 7; j: 1),
+     (i: 3; j: 1), (i: 3; j: 2), (i: 3; j: 3), (i: 3; j: 4),
+     (i: 3; j: 5), (i: 3; j: 6), (i: 3; j: 7), (i: 3; j: 8),
+     (i: 6; j: 8), (i: 6; j: 7), (i: 6; j: 6), (i: 6; j: 5),
+     (i: 6; j: 4), (i: 6; j: 3), (i: 6; j: 2), (i: 6; j: 1),
+     (i: 4; j: 1), (i: 4; j: 2), (i: 4; j: 3), (i: 4; j: 4),
+     (i: 4; j: 5), (i: 4; j: 6), (i: 4; j: 7), (i: 4; j: 8),
+     (i: 5; j: 1), (i: 5; j: 2), (i: 5; j: 3), (i: 5; j: 4),
+     (i: 5; j: 5), (i: 5; j: 6), (i: 5; j: 7), (i: 5; j: 8));
+
+////////////////////////////////////////////////////////////////////////////////
+// TPosBase
+
+constructor TPosBase.Create(fileNameNoExt: string; Reestimate: TReestimate = nil);
+begin
+  inherited Create;
+
+  self.FReestimate := Reestimate;
+
+  FCreateStreams(fileNameNoExt + '.' + POS_FILE_EXT,
+    fileNameNoExt + '.' + MOV_FILE_EXT);
+  FSetDBVersion;
+end;
+
+
+destructor TPosBase.Destroy;
+begin
+  FDestroyStreams;
+  inherited;
+end;
+
+
+procedure TPosBase.FSetDBVersion;
+var
+  btData: byte;
+  wVersion: word;
+begin
+  m_iDBVersion := DB_VERSION; // default version
+
+  if (fPos.Size > 0) then
+  begin
+    fPos.SeekHeader;
+    fPos.Read(btData, SizeOf(btData));
+    if (btData <> $FF) then
+    begin
+      m_iDBVersion := 0;
+      fPos.HeaderSize := 0;
+      exit;
+    end;
+    fPos.Read(wVersion, SizeOf(wVersion));
+    m_iDBVersion := wVersion;
+  end
+  else
+  begin
+    btData := $FF;
+    wVersion := m_iDBVersion;
+    fPos.Write(btData, SizeOf(btData));
+    fPos.Write(wVersion, SizeOf(wVersion));
+  end;
+
+  fPos.HeaderSize := SizeOf(byte) + SizeOf(word);
+end;
+
+
+function TPosBase.FCheckDBVersion: Boolean;
+begin
+  Result := (m_iDBVersion <= DB_VERSION);
+end;
+
+
+procedure TPosBase.FCreateStreams(const strPosFileName, strMovFileName: string);
+begin
+  fPos := TPosBaseStream.Create(strPosFileName, SizeOf(TFieldNode));
+  fMov := TPosBaseStream.Create(strMovFileName, SizeOf(TMoveNode));
+end;
+
+
+procedure TPosBase.FDestroyStreams;
+begin
+  fMov.Free;
+  fPos.Free;
+end;
+
+
+function EncodeAddInf(const pos: TChessPosition): byte;
+begin
+  Result := pos.en_passant;
+  if WhiteKingSide in pos.castling then
+    Result := Result or $80;
+  if WhiteQueenSide in pos.castling then
+    Result := Result or $40;
+  if BlackKingSide in pos.castling then
+    Result := Result or $20;
+  if BlackQueenSide in pos.castling then
+    Result := Result or $10;
+end;
+
+
+function EncodeMove(const move: TMoveAbs): word;
+begin
+  with move do
+    Result := ((((((((i0-1) shl 3) or (j0-1)) shl 3) or (i-1)) shl 3) or (j-1)) shl 3) or Ord(prom_fig);
+end;
+
+
+procedure TPosBase.Add(const posMove: TPosMove);
+var
+  addInf: byte;
+  fn: TFieldNode;
+
+  procedure AddPosNodes(k: integer; r: integer = -1);
+  var
+    l, nr: integer;
+    mn: TMoveNode;
+    estList: TList;
+  begin
+    // Добавление узлов позиции
+    if r >= 0 then
+    begin
+      nr := fPos.Size;
+      fn.NextValue := nr;
+      fPos.SeekRec(r);
+      fPos.Write(fn);
+      fPos.SeekRec(nr);
+    end
+    else
+      nr := 0;
+    for l := k to 66 do // 65 - доп. инф, 66 - цвет.
+    begin
+      if l = 66 then
+      begin
+        fn.btField := ord(posMove.pos.color);
+        nr := fMov.Size;
+      end
+      else
+      begin
+        if l <= 64 then
+          fn.btField := ord(posMove.pos.board[FIELD_SEQ[l].i, FIELD_SEQ[l].j])
+        else // l = 65
+          fn.btField := addInf;
+        inc(nr);
+      end;
+      fn.NextNode := nr;
+      fn.NextValue := 0;
+      fPos.Write(fn);
+    end;
+    // формирование записи хода
+    mn.EmptyNode;
+    mn.wMove := EncodeMove(posMove.move);
+
+    if Assigned(FReestimate) then
+    begin
+      estList := TList.Create;
+      try
+        estList.Add(Pointer(mn.estimate));
+        FReestimate(estList, 0);
+        mn.estimate := LongWord(estList[0]);
+      finally
+        estList.Free;
+      end;
+
+    end;
+    fMov.SeekEnd;
+    fMov.Write(mn);
+  end;
+
+var
+  k, r, pr, rm, moveSet, moveCount: integer;
+  mv: word;
+  mn: TMoveNode;
+  enc_mv: word;
+  estList: TList;
+begin
+  if (not FCheckDBVersion) then
+    exit;
+
+  addInf := EncodeAddInf(posMove.pos);
+  if (fPos.Size = 0) then
+  begin
+    AddPosNodes(1);
+    exit;
+  end;
+  r := 0;
+  for k := 1 to 66 do // 65 - доп. инф, 66 - цвет.
+  begin
+    fPos.SeekRec(r);
+    fPos.Read(fn);
+
+    while ((k <= 64) and (fn.btField <> ord(posMove.pos.board[FIELD_SEQ[k].i, FIELD_SEQ[k].j]))) or
+          ((k = 65) and (fn.btField <> addInf)) or
+          ((k = 66) and (fn.btField <> ord(posMove.pos.color))) do
+    begin
+      pr := r;
+      r := fn.NextValue;
+      if (r = 0) then
+      begin
+        AddPosNodes(k, pr);
+        exit;
+      end;
+      fPos.SeekRec(r);
+      fPos.Read(fn);
+    end; { while }
+    // значение в цепочке найдено
+    r := fn.NextNode;
+  end;
+
+  moveCount := 0;
+  moveSet := -1;
+  estList := TList.Create;
+  try
+    rm := r;
+    enc_mv := EncodeMove(posMove.move);
+    repeat
+      pr := r;
+      fMov.SeekRec(r);
+      fMov.Read(mn);
+
+      mv := mn.wMove;
+      if mv = enc_mv then
+        moveSet := moveCount;
+
+      if Assigned(FReestimate) then
+        estList.Add(Pointer(mn.estimate));
+
+      inc(moveCount);
+      r := mn.NextValue;
+    until r = 0;
+
+    if moveSet < 0 then // хода нет в списке, добавляем
+      begin
+        // связывание нового узла с текущим узлом
+        r := fMov.Size;
+        mn.NextValue := r;
+        fMov.SeekRec(pr);
+        fMov.Write(mn);
+
+        // Добавление нового узла ходов
+        mn.EmptyNode;
+        mn.wMove := enc_mv;
+        fMov.SeekRec(r);
+        fMov.Write(mn);
+
+        if Assigned(FReestimate) then
+          estList.Add(Pointer(mn.estimate));
+        moveSet := moveCount;
+      end;
+
+      if Assigned(FReestimate) then
+      begin
+        FReestimate(estList, moveSet);
+        for k := 0 to estList.Count - 1 do
+        begin
+          fMov.SeekRec(rm);
+          fMov.Read(mn);
+          if (mn.estimate <> LongWord(estList[k])) then
+          begin
+            mn.estimate := LongWord(estList[k]);
+            fMov.SeekRec(rm);
+            fMov.Write(mn);
+          end;
+          rm := mn.NextValue;
+        end;
+      end;
+      
+  finally
+    estList.Free;
+  end;  
+end;
+
+
+function TPosBase.Find(const pos: TChessPosition): boolean;
+var
+  lstDummy: TList;
+begin
+  lstDummy := nil;
+  Result := Find(pos, lstDummy);
+end;
+
+
+function TPosBase.Find(const pos: TChessPosition; var moveEsts: TList): boolean;
+
+  function DecodeMove(enc_move: word): TMoveAbs;
+  begin
+   with Result do
+     begin
+       prom_fig := TFigureName(enc_move and $07);
+       enc_move := enc_move shr 3;
+       j := (enc_move and $07) + 1;
+       enc_move := enc_move shr 3;
+       i := (enc_move and $07) + 1;
+       enc_move := enc_move shr 3;
+       j0 := (enc_move and $07) + 1;
+       enc_move := enc_move shr 3;
+       i0 := (enc_move and $07) + 1;
+     end;
+  end;
+
+var
+  k, r: integer;
+  fn: TFieldNode;
+  mn: TMoveNode;
+  pme: PMoveEst;
+label
+  here;
+begin // TPosBase.Find
+  Result := FALSE;
+
+  if (not FCheckDBVersion) then
+    exit;
+
+  if (Assigned(moveEsts)) then
+  begin
+    for k := 0 to moveEsts.Count - 1 do
+      Dispose(moveEsts[k]);
+    moveEsts.Clear;
+  end;
+
+  if (fPos.Size = 0) then
+    exit;
+
+  r := 0;
+  for k := 1 to 66 do // 65 - доп. инф, 66 - цвет.
+  begin
+here:
+    fPos.SeekRec(r);
+    fPos.Read(fn);
+
+    r := fn.NextNode;
+    while ((k <= 64) and (fn.btField <> ord(pos.board[FIELD_SEQ[k].i, FIELD_SEQ[k].j]))) or
+          ((k = 65) and (fn.btField <> EncodeAddInf(pos))) or
+          ((k = 66) and (fn.btField <> ord(pos.color))) do
+    begin
+      r := fn.NextValue;
+      if r = 0 then
+        exit
+      else
+        goto here;
+    end; { while }
+  end; { for }
+
+  Result := TRUE;
+  if (not Assigned(moveEsts)) then
+    exit;
+
+  // Filling the moves list
+  repeat
+    fMov.SeekRec(r);
+    fMov.Read(mn);
+
+    new(pme);
+    pme^.move := DecodeMove(mn.wMove);
+    pme^.estimate := mn.estimate;
+    moveEsts.Add(pme);
+
+    r := mn.NextValue;
+  until (r = 0);
+  
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TFieldNode
+
+function TFieldNode.FGetNextNode: LongWord;
+begin
+  Result := (m_wNextNode shl 8) or m_btNextNode;
+end;
+
+
+procedure TFieldNode.FSetNextNode(lwValue: LongWord);
+begin
+  m_btNextNode := lwValue and $FF;
+  m_wNextNode := lwValue shr 8;
+end;
+
+
+function TFieldNode.FGetNextValue: LongWord;
+begin
+  Result := (m_wNextValue shl 8) or m_btNextValue;
+end;
+
+
+procedure TFieldNode.FSetNextValue(lwValue: LongWord);
+begin
+  m_btNextValue := lwValue and $FF;
+  m_wNextValue := lwValue shr 8;
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TMoveNode
+
+
+function TMoveNode.FGetNextValuePos: LongWord;
+begin
+  Result := (m_wNextValue shl 8) or m_btNextValue;
+end;
+
+
+procedure TMoveNode.FSetNextValuePos(lwValue: LongWord);
+begin
+  m_btNextValue := lwValue and $FF;
+  m_wNextValue := lwValue shr 8;
+end;
+
+
+procedure TMoveNode.EmptyNode;
+begin
+  FillChar(self, SizeOf(self), 0);
+end;
+
+////////////////////////////////////////////////////////////////////////////////
+// TPosBaseStream
+
+constructor TPosBaseStream.Create(const strFileName: string; RecordSize: integer);
+var
+  FileHandle: Integer;
+begin
+  inherited Create;
+
+  m_iRecordSize := RecordSize;
+
+  if (not FileExists(strFileName)) then
+  begin
+    FileHandle := FileCreate(strFileName);
+    FileClose(FileHandle);
+  end;
+
+  m_InnerStream := TFileStream.Create(strFileName, fmOpenReadWrite,
+    fmShareDenyWrite);
+end;
+
+
+destructor TPosBaseStream.Destroy;
+begin
+  m_InnerStream.Free;
+  inherited;
+end;
+
+
+function TPosBaseStream.FGetSize: integer;
+begin
+  Result := (m_InnerStream.Size - m_iHeaderSize) div m_iRecordSize;
+end;
+
+
+procedure TPosBaseStream.SeekHeader;
+begin
+  m_InnerStream.Seek(0, soFromBeginning);
+end;
+
+
+procedure TPosBaseStream.SeekRec(lwRecordNumber: LongWord);
+begin
+  m_InnerStream.Seek(m_iHeaderSize + lwRecordNumber * m_iRecordSize, soFromBeginning);
+end;
+
+
+procedure TPosBaseStream.SeekEnd;
+begin
+  m_InnerStream.Seek(0, soFromEnd);
+end;
+
+
+procedure TPosBaseStream.Write(const Buffer);
+begin
+  m_InnerStream.WriteBuffer(Buffer, m_iRecordSize);
+end;
+
+
+procedure TPosBaseStream.Write(const Buffer; Count: integer);
+begin
+  m_InnerStream.WriteBuffer(Buffer, Count);
+end;
+
+
+procedure TPosBaseStream.Read(var Buffer);
+begin
+  m_InnerStream.ReadBuffer(Buffer, m_iRecordSize);
+end;
+
+
+procedure TPosBaseStream.Read(var Buffer; Count: integer);
+begin
+  m_InnerStream.ReadBuffer(Buffer, Count);
+end;
+
+end.