Core/DBDUtils.pas - master - YakuninAV/Convertors

Core/DBDUtils.pas
1 081 строка35 KB
YakuninAV
begin with gitflick
31 июл 2026, 15:21
31 июл 2026, 15:211dc0fc6
{*******************************************************}
{                                                       }
{       DBD Core library                                }
{                                                       }
{       Copyright (C) 2020 DataBasis Development        }
{                                                       }
{*******************************************************}
/// утилиты для работы с числами
unit DBDUtils;

{$IFDEF FPC}
{$mode DELPHI} {$H+} {$codepage UTF8}
{$ENDIF}

{$I mormot.defines.inc}

interface

uses
{$IFDEF ISDELPHIXE2}
   System.SysUtils, System.Classes, System.Variants, System.Math, System.IOUtils, System.Masks, System.TypInfo,
{$ELSE}
   SysUtils, Classes, Variants, Math, TypInfo,
{$ENDIF}
  mormot.core.base, mormot.core.buffers, mormot.core.os, mormot.core.data, mormot.core.json, mormot.core.variants,
  mormot.core.text, mormot.core.unicode, mormot.core.zip, mormot.core.os.security,
  mormot.crypt.core, mormot.crypt.secure
 ;


const
  Digits = ['0'..'9'];
  RusABC = ['А'..'Я'];
  RusStrABC = ['а'..'я'];
  LatABC = ['A'..'Z'];
  LatStrABC = ['a'..'z'];

const
  ///
  ZeroBoundDbl = 0.0000001;
  ZeroBoundExt = 0.0000000001;
  /// Название узла JSON-документа, содержащего тип документа
  JDocNodeName_DocType   = 'doc';
  /// Название узла JSON-документа, содержащего версию документа
  JDocNodeName_Version   = 'ver';
  /// Название узла JSON-документа, содержащего наименование файла из которого получен документ
  JDocNodeName_FileName  = 'file';    //Файл

var
  RoundToDigs: integer = 2;

type

  TExtendedDynArray = array of Extended;

  TRoundedElem = packed record
  private
    FValue: Extended;
    FError: Extended;
    FIndex: Integer;
    FFlag: Boolean;
    procedure SetValue(const NewValue: Extended);
    procedure SetError(const NewValue: Extended);
    procedure SetFlag(const NewValue: Boolean);
    procedure SetIndex(const NewValue: Integer);
  public
    class var ZeroBounds: Extended;
    class var RoundingDigs: Integer;
    class var MinDelta: Extended;
    property Error: Extended read FError write SetError;
    property Value: Extended read FValue write SetValue;
    property Flag: Boolean read FFlag write SetFlag;
    property Index: Integer read FIndex write SetIndex;
    constructor Create(const aValue: Extended; const aIndex: Integer=-1); overload;
    constructor Create(const aValue, aError: Extended; const aFlag: Boolean; const aIndex: Integer=-1); overload;
    class function CompareErrors(const Elem1, Elem2; const Accuracy: Boolean=False): Integer; static;
    class function CompareValues(const Elem1, Elem2; const Accuracy: Boolean=False): Integer; static;
    class function GetMinDelta(const Digs: integer): Extended; static;
    /// Функция возвращает true, если Value попадает в область нуля ограниченную BoundOfZero
    class function IsAboutZero(const Value: Extended; const BoundOfZero: Extended=ZeroBoundExt): Boolean; static;
    /// Функция возвращает true, если заданное значение приблизительно равно минимальному значению погрешности
    // или меньше него без учёта знака
    class function IsMinDelta(const aValue: Extended): Boolean; static;
    /// функция модифициует значения в массиве с тем, тобы сумма значений приблизительно совпадала со значением в записи
    function RoundToArray(Values: TExtendedDynArray): Extended;
  end;
  TRoundedElems = array of TRoundedElem;

  /// Запись для представления даты объявления цены имеет вид MM/YY[YY]
  TDBDPriceDate = record
  private
    FPriceDate: Integer;
    function GetPriceDate: Integer;
    function GetMonth: Word;
    function GetQuarter: Word;
    function GetYear: Word;
    procedure SetPriceDate(const Value: Integer);
    procedure SetMonth(const Value: Word);
    procedure SetQuarter(const Value: Word);
    procedure SetYear(const Value: Word);
    function GetDate: TDateTime;
    procedure SetDate(const Value: TDateTime);
  public
    /// Ценовая дата
    property PriceDate: Integer read GetPriceDate write SetPriceDate;
    /// Дата
    property Date: TDateTime read GetDate write SetDate;
    /// Год, к которому относится ценовая дата
    property Year: Word read GetYear write SetYear;
    /// Месяц, к которому относится ценовая дата
    property Month: Word read GetMonth write SetMonth;
    /// Квартал, к которому относится ценовая дата
    property Quarter: Word read GetQuarter write SetQuarter;
    /// Конструктор создаёт ценовую дату из календарной
    constructor Create(const aDate: TDateTime);
    /// Конструктор создаёт ценовую дату из года и месяца
    constructor CreateMonth(const aYear, aMonth: Word);
    /// Конструктор создаёт ценовую дату из года и номера квартала
    constructor CreateQuarter(const aYear, aQuorter: Word);
    /// Функция преобразует календарную дату в ценовую
    class function PriceDateFromDateTime(const dt: TDateTime): Integer; static;
    /// Функция преобразует сроку вида MM/YY[YY] в число
    class function PriceDateFromStr(const dt: string): Integer; static;
    /// Функция преобразует число в сроку вида MM/YY[YY]
    class function PriceDateToStr(const dt: Integer; const TwoDigsYear: Boolean=True): string; static;
    /// Функция выделяет из чила номер месяца
    class function MonthFromPriceDate(const dt: Integer): Integer; static; inline;
    /// Функция выделяет из чила год
    class function YearFromPriceDate(const dt: Integer): Integer; static; inline;
  end;

/// Функция подчситывает количество количество элементов в наборе aSet
function ElementCount(const aSet; aTypeInfo : PTypeInfo) : Integer;

function IsAboutZeroDbl(const Value: Double; const BoundOfZero: Double = ZeroBoundDbl): Boolean;
function IsAboutZeroExt(const Value: Extended; const BoundOfZero: Extended = ZeroBoundExt): Boolean;
function IsSameDbl(const Val1,Val2: Double; const BoundOfZero: Double = ZeroBoundDbl): Boolean; inline;
/// Функция возвращает стандартный JSON-документ (без данных)
// Стандартный JSON-документ содержит следующие объекты:
// docType - тип документа
// docVer - версия документа
// docFile - имя файла из которого получен документ (необязательный элемент)
function InitDocumentObject(const docType, docVer: RawUtf8; const docFile: RawUtf8='';
                            const jOpt: TDocVariantOptions=JSON_FAST_FLOAT): Variant;

/// Функция конвертирует число в двухсимвольный код. Предполагается что число меньше 64^2=4096
// В качестве символов кода используются ansichar с "!" по "'"
function TinyIntToSortID2(const Num: Integer): RawUTF8;

function CheckINN(const iInn: Integer; out sINN: string): Boolean; overload;
function CheckINN(const aInn: RawUtf8; out oInn: RawUtf8): Boolean; overload;


/// функция возвращает версию длл из которой она вызвана
function GetDllVersion: RawUtf8;

function DBDReadNumber(const aStr: string; var vPos: Integer; out oNum: Cardinal): Boolean;
function DBDReadDigit(const aStr: string; var vPos: Integer; out oNum: Byte): Boolean;
function DBDFloatToString(const F: Double; const MinDecimals: integer=2): string;

/// Функция разбивает многочен на части и возвращает массив членов
function DBDSplitPolynomial(const Poly: RawUtf8): TRawUtf8DynArray;
///
function IsBalanceBrackets(const R: RawUtf8; const Br: RawUtf8='()'): Boolean;

function DBDCheckFilenameTypeS(const S: String): Boolean;
function DBDCheckFilenameTypeU(const R: RawUtf8): Boolean;

function DBDCheckUriStrictTypeS(const S: String): Boolean;
function DBDCheckUriStrictTypeU(const R: RawUtf8): Boolean;

/// Функция определяет  идентификатор региона по его наименованию, используя список регионов РФ,
// хранящийся в ресурсах программы или в файле
function RegionNameByCode(const RName: string; const RCode: Integer; const FromResource: Boolean=True): RawUtf8;

function DBDTruncString(const S: string): string;

/// функция от Кирилла
procedure SetPrecision(var E: extended; P : integer);
function pMultChar(count:integer; value:AnsiChar):AnsiString;
function AddZeros(const S: AnsiString; P: integer): AnsiString;
function FloatToStrEx(F: Extended; P: Integer; ThousandSep: Boolean = False; Fixed: Boolean = True): String;
function FloatToStringR(E: extended; P: integer): String;
function SetFracZeros(const Value: String; FixMin: Integer = 0): String;
function FloatToStringP(E: extended; P: integer): string;
function IsNumeric(const S: String): Boolean;
function Cut(var S: String; Index, Count: Integer): String;
procedure DeleteSpaces(var S: string);
function AnsiStrLen(const Str: PAnsiChar): Integer; register; inline;
procedure FilterChar(AStr: PAnsiChar; OldCh,NewCh: AnsiChar);
procedure Replace(const Repstr: String; var S: String; Index, Count: Integer);
function ReplaceEx(const Substr, Repstr: String; var S: String; CaseSens: Boolean = True): Boolean;
procedure ReplaceRec(const Substr, Repstr: String; var S: String; CaseSens: Boolean = True); //заменяет, образовавшиеся вхождения после первого прохода, пока их не останется
function ReplaceText(const S: String; SrcText, DstText: array of String): String;
function PosFunction(const F: String; const FS: array of String; var Fi: Integer): Integer;
function CorrFloatTrunc(R: extended): int64;

/// Вычисляет CRC32 для строки
procedure DBDCrc32(Buf: RawByteString; out Crc: RawUtf8);
procedure DBDCrc128(Buf: RawByteString; out Crc: RawUtf8);
procedure DBDCrc128File(const FN: TFileName; out Crc: RawUtf8);
/// Вычисляет MD5 для строки. Обёртка над функцией MD5 из юнита mormot.crypt.core
procedure DBDMD5(Buf: RawByteString; out Crc: RawUtf8); inline;
/// Вычисляет MD5 для файла. Обёртка над функцией MD5 из юнита mormot.crypt.secure
procedure DBDMD5File(const FN: TFileName; out Crc: RawUtf8); inline;

implementation

uses dbdutf8utils;

procedure DBDCrc32(Buf: RawByteString; out Crc: RawUtf8);
var t: THash128; c: Cardinal;
begin
  if Buf<>'' then begin
    c:=crc32cHash(Buf);
    Crc:=BinToHex(@c,SizeOf(c))
  end else Crc:='';
end;
procedure DBDCrc128(Buf: RawByteString; out Crc: RawUtf8);
var t: THash128;
begin
  if Buf<>'' then begin
    crc128c(@Buf[1], Length(Buf), t);
    Crc:=BinToHex(@t,SizeOf(t))
  end else Crc:='';
end;
procedure DBDCrc128File(const FN: TFileName; out Crc: RawUtf8);
var r: RawByteString;
begin
   if FileExists(FN) then begin
     r:=StringFromFile(FN);
     DBDCrc128(r, Crc);
   end else Crc:='';
end;
procedure DBDMD5(Buf: RawByteString; out Crc: RawUtf8);
begin
  Crc:=Md5(Buf);
end;
procedure DBDMD5File(const FN: TFileName; out Crc: RawUtf8);
begin
  crc:=HashFileMd5(FN);
end;

function DBDTruncString(const S: string): string;
var l: Integer;
begin
  Result:=S; if Result='' then Exit;
  SetLength(Result, Length(S));
  l:=1;
  while Ord(Result[l])<>0 do Inc(l);
  SetLength(Result,l-1);
end;

function DBDCheckFilenameTypeS(const S: String): Boolean;
{$IFNDEF ISDELPHIXE2} var c: Char; {$ENDIF}
begin
{$IFNDEF ISDELPHIXE2}
  Result:=(Length(S)>0) and (Length(S)<256) and
          (S[1]<>' ') and (S[Length(S)]<>' ') and
          (S[Length(S)]<>'.');
  if not Result then Exit;
  // базовый паттерн: \/:*?"<>|\p{C}]+
  for c in S do begin
    Result:= Ord(c)>31; if not Result then Exit;
    Result:= not (c in ['\','/',':','*','?','"','<','>']); if not Result then Exit;
  end;
{$ELSE}
  Result:=DBDCheckFilenameTypeU(StringToUtf8(S));
{$ENDIF}
end;

function DBDCheckFilenameTypeU(const R: RawUtf8): Boolean;
var i,l:Integer; p,t: PUtf8Char;
begin
  Result:=Length(R)>0; if not Result then  Exit;
  p:=@R[1];
  l:=DBDCharCount(p);
  Result:= l<256; if not Result then Exit;
  Result:=(R[1]<>' '); if not Result then Exit;
  t:=DBDLastChar(p);
  Result:=(t^<>' ') and (t^<>'.'); if not Result then Exit;
  Result:=DBDFindStopChar(p,'\/:*?"<>|')=nil;
  //проверить категорию символов
  p:=DBDFindCharCategory(@R[1], dbdClassUnicodeCategoryC);
  Result:=(p=nil) or (p=#0);
//  p:=@R[1];
//  while (p<>nil) or (p^<>#0) do
//    if DBDGetCategory(p) in dbdClassCategoryC then begin
//      Result:=False; Break;
//    end;
end;

function DBDCheckUriStrictTypeS(const S: String): Boolean;
{$IFNDEF ISDELPHIXE2} var c: Char; {$ENDIF}
begin
{$IFNDEF ISDELPHIXE2}
  Result:=(Length(S)>0) and (Length(S)<256) and
          (S[1]<>' ') and (S[Length(S)]<>' ') and
          (S[Length(S)]<>'.');
  if not Result then Exit;
  for c in S do begin
    Result:= Ord(c)>32; if not Result then Exit;
  end;
{$ELSE}
  Result:=DBDCheckUriStrictTypeU(StringToUtf8(S));
{$ENDIF}
end;

function DBDCheckUriStrictTypeU(const R: RawUtf8): Boolean;
var i,l:Integer; p,t: PUtf8Char;
begin
  Result:=Length(R)>0; if not Result then  Exit;
  p:=@R[1];
  l:=DBDCharCount(p);
                             Result:=(l<=2048);           if not Result then Exit;
                             Result:=(R[1]<>' ');         if not Result then Exit;
  t:=DBDLastChar(p);         Result:=(t^<>' ');           if not Result then Exit;
  t:=DBDFindStopChar(p,' '); Result:=(t=nil) or (t^=#0);  if not Result then Exit;
  if DBDStartWithUCase(R,'HTTP') then begin

  end;
  //проверить категорию символов
  p:=DBDFindCharCategory(@R[1], dbdClassUnicodeCategoryC);
  Result:=(p=nil) or (p=#0);
//  p:=@R[1];
//  while (p<>nil) or (p^<>#0) do
//    if DBDGetCategory(p) in dbdClassCategoryC then begin
//      Result:=False; Break;
//    end;
end;

function RegionNameByCode(const RName: string; const RCode: Integer; const FromResource: Boolean): RawUtf8;
var r: RawUtf8; rr: RawByteString; ra: TRawUtf8List; ar: TRawUtf8DynArray; i: Integer; s: string; sa: TStringDynArray;
begin
  Result:='';
  if RCode<1 then Result:=''
  else if FromResource then begin
    ResourceToRawByteString(RName, PChar(10), rr);
    r:=rr;
  end else begin
    if FileExists(RName) then r:=StringFromFile(RName)
                         else Result:='';
  end;
  if r<>'' then begin
    ra:=TRawUtf8List.Create;
    try
      ra.Text:=r;
      for i:=0 to ra.Count-1 do begin
        ar:=CsvToRawUtf8DynArray(ra[i], '#');
        if (Length(ar)>1) and (Utf8ToInteger(ar[1], 0,99,-1)=RCode) then begin
          Result:=ar[0]; Exit;
        end;
        SetLength(ar,0);
      end;
    finally
      ra.Free;
    end;
  end;
end;


function IsBalanceBrackets(const R: RawUtf8; const Br: RawUtf8='()'): Boolean;
begin
  Result:= (R<>'') and (Br<>''); if not Result then Exit;

end;

function DBDReadDigit(const aStr: string; var vPos: Integer; out oNum: Byte): Boolean;
var c: Char; i: Integer;
begin
  oNum:=0; Result :=((aStr<>'') and (vPos>0) and (vPos<=Length(aStr))); if not Result then Exit;
  c := aStr[vPos];
{$ifdef ISDELPHIXE2}
  i := System.Pos(c,'0123456789')-1;
  Result := i>=0;
{$else}
  {$ifdef FPC_OR_UNICODE}
  i := System.Pos(c,'0123456789')-1;
  Result := i>=0;
  {$else}
  i := Ord(c)-$30;
  Result := (i>=0) and (i<=9);
  {$endif FPC_OR_UNICODE}
{$endif ISDELPHIXE2}
  if Result then begin oNum:=i; Inc(vPos); end;
end;

function DBDReadNumber(const aStr: string; var vPos: Integer; out oNum: Cardinal): Boolean;
var f: Boolean; b: Byte;
const maxCardinal = 429496729; // ~ (4294967295 div 10);
begin
{$IFDEF DEBUG}
  Assert((aStr<>'') and (vPos>0) and (vPos<=Length(aStr)),'Неверная передача параметров: DBDReadNumber');
{$ENDIF}
  Result:=(aStr<>'') and (vPos>0) and (vPos<=Length(aStr));
  if not Result then begin
    oNum:=0;
    Exit;
  end;
  Result := DBDReadDigit(aStr,vPos, b); oNum:=0; if not Result then Exit;
  f := True;
  try
    while f do begin
      oNum := oNum*10+b;
      f := (vPos<=Length(aStr)) and DBDReadDigit(aStr,vPos, b);
    end;
  except
    Result := false; // слишком много цифр подряд
  end;
end;

function DBDFloatToString(const F: Double; const MinDecimals: integer=2): string;
var i,dotPos : Integer;
begin
  // 1. Округляем до 7 знаков после точки
  Result := Format('%.7f', [F]);
  Result:=Utf8ToString(DBDReplaceTextAll(StringToUtf8(Result),',','.'));
//  Result:=DBDDoubleToText(F,7);
  // 2. Убираем лишние нули с конца, но сохраняем не менее MinDecimals знаков
  i := Length(Result);
  while (i > 1) and (Result[i] = '0') do begin
    // Проверяем, где находится точка, чтобы не удалить нули до точки или не сделать знаков меньше MinDecimals
    dotPos := PosEx('.', Result);
    if (dotPos > 0) and ((i - dotPos) > MinDecimals) then Dec(i)
                                                     else Break;
  end;
  SetLength(Result, i);
end;

function DBDSplitPolynomial(const Poly: RawUtf8): TRawUtf8DynArray;
var i: Integer; r: RawUtf8;
begin
  SetLength(Result,0);
  if Poly='' then Exit;
  Result:=CsvToRawUtf8DynArray(Poly,'*');
  for i:=0 to High(Result) do begin
    r:=Result[i];
    if r='' then Continue;

  end;

end;

function CheckINN(const aInn: RawUtf8; out oInn: RawUtf8): Boolean; overload;
var i: Integer; c: AnsiChar;
begin
  Result:= (Length(aInn)>=7) or (Length(aINN)<=12); if not Result then Exit;
  for i := 1 to Length(aInn) do begin
     c:=aINN[i];
     if (ord(c)<Ord('0')) or (ord(aINN[i])>Ord('9')) then begin
       Result:=False; Exit;
     end;
  end;
  oInn:=aInn;
  if Length(aInn)<=10 then for i:=Length(aInn) to 9  do oInn:='0'+oInn
                      else for i:=Length(aInn) to 11 do oInn:='0'+oInn;
  Result:=True;
end;

function CheckINN(const iInn: Integer; out sINN: string): Boolean;
begin
  Result:=False;
  if (iInn<999999) or (iInn>999999999999) then Exit;
  Result:=True;
  if iInn<9999999999 then sINN:=Format('%d10',[iInn])
                     else sINN:=Format('%d10',[iInn]);
end;

function GetDllVersion: RawUtf8;
var fv: TFileVersion; fn: TFileName;
begin
  Result:='';
  fn:=Executable.InstanceFileName;
  if FileExists(fn) then begin
    fv:=TFileVersion.Create(fn);
    try
      if fv.RetrieveInformationFromFileName then Result:= fv.FileVersion;
    finally
      FreeAndNil(fv);
    end;
  end;
end;

function InitDocumentObject(const docType, docVer: RawUtf8; const docFile: RawUtf8='';
                            const jOpt: TDocVariantOptions=JSON_FAST_FLOAT): Variant;
begin
  Result:=_Obj([JDocNodeName_DocType, docType,
                JDocNodeName_Version, docVer], jOpt);
  if docFile<>'' then TDocVariantData(Result).AddValue(JDocNodeName_FileName, docFile);
end;

function TinyIntToSortID2(const Num: Integer): RawUTF8;
var i,j: Integer;
begin
  i:=(Num div 64)+33; j:=(Num mod 64)+33;
  Result:=AnsiChar(i)+AnsiChar(j);
end;

function CompareErrorsOfRoundedElems(const A,B): integer;
begin
  Result:=TRoundedElem.CompareErrors(a,b,true);
end;

function CompareValuesOfRoundedElems(const A,B): integer;
begin
  Result:=TRoundedElem.CompareValues(a,b,true);
end;

function ElementCount(const aSet; aTypeInfo : PTypeInfo) : Integer;
var
  aTypeData : PTypeData;
  aCompTypeData : PTypeData;
  K: Integer;
  aDataByte : PByte;
  aBitByte  : Byte;
  aCurIndex : Integer;
begin
  Assert (aTypeInfo <> nil, 'aTypeInfo is required parameter in ElementCount');
  Assert (aTypeInfo.Kind = tkSet, 'aTypeInfo is not Set Type');

  Result := 0;

  aTypeData := GetTypeData (aTypeInfo);

  if aTypeData.CompType = nil then
  begin
    aDataByte := @aSet;
    for K := 0 to aTypeData.MaxLength - 1 do begin
      aBitByte := aDataByte^;

      while aBitByte <> 0 do begin
        if aBitByte and 1 <> 0 then
          Inc (Result);
        aBitByte := aBitByte shr 1;
      end;

      Inc (aDataByte);
    end;
  end else begin
    {$IFDEF FPC}
      aCompTypeData := GetTypeData(aTypeData.CompType);
    {$ELSE}
      aCompTypeData := GetTypeData(aTypeData.CompType^);
    {$ENDIF}
    aDataByte := @aSet;
    for K := aCompTypeData.MinValue shr 3 to aCompTypeData.MaxValue shr 3 do begin
      aBitByte := aDataByte^;
      aCurIndex := K shl 3;

      while aBitByte <> 0 do begin
        if (aBitByte and 1 <> 0) and (aCurIndex >= aCompTypeData.MinValue) then
          Inc (Result);

        Inc (aCurIndex);
        if aCurIndex > aCompTypeData.MaxValue then
          Break;

        aBitByte := aBitByte shr 1;
      end;

      Inc (aDataByte);
    end;
  end;

end;

function IsAboutZeroDbl(const Value: Double; const BoundOfZero: Double): Boolean;
begin
  if      Value=0 then Result := True
  else if Value>0 then Result := Value<BoundOfZero
                  else Result := Value>(-BoundOfZero);
end;

function IsAboutZeroExt(const Value: Extended; const BoundOfZero: Extended): Boolean;
begin
  if      Value=0 then Result := True
  else if Value>0 then Result := Value<BoundOfZero
                  else Result := Value>(-BoundOfZero);
end;

function IsSameDbl(const Val1,Val2: Double; const BoundOfZero: Double): Boolean;
begin
  Result:=IsAboutZeroDbl(Val1-Val2, BoundOfZero);
end;

function SumRoundedElems(arr: TRoundedElems): TRoundedElem;
var i: Integer;
begin
  Result.Value:=0; Result.Error:=0; Result.Flag:=False; Result.Index:=-1;
  for i := Low(arr) to High(arr) do begin
    Result.Value := Result.Value + arr[i].Value;
    Result.Error := Result.Error + arr[i].Error;
  end;
end;

function Proximity(sum: TRoundedElem; arr: TRoundedElems; var delta: Extended): Boolean;
var step: Extended; i: Integer;
begin
  delta:=sum.Value-SumRoundedElems(arr).Value;
  // если delta меньше 0, то нужно уменьшить числа в массиве - уменьшить положительные error, увеличть отрицательные
  if TRoundedElem.IsAboutZero(delta) then Result:=True
  else begin
    Result:=False;
    step:=TRoundedElem.MinDelta;
    if delta<0 then step:=-step;
    for i := 0 to High(arr) do begin
      if arr[i].Flag then begin
        if arr[i].Error>0 then begin
          arr[i]:= TRoundedElem.Create(arr[i].Value - step, arr[i].Index);
        end else begin
          arr[i]:= TRoundedElem.Create(arr[i].Value + step, arr[i].Index);
        end;
        delta:=sum.Value-SumRoundedElems(arr).Value;
        if TRoundedElem.IsAboutZero(delta) then begin Result:=True; Break; end;
      end;
    end;
  end;
end;

////////////////////////// ComUtils
procedure SetPrecision(var E: extended; P : integer);
var A: extended;
begin
  if P>=0 then begin
//      E:=Round(E*IntPower(10,P))*IntPower(10,-P);
//      if E<0 then A:=-0.500000000001 else A:=0.500000000001;
    if E<0 then A:=-0.5-IntPower(10,-(12-p+Ord(p=12)))
           else A:= 0.5+IntPower(10,-(12-p+Ord(p=12)));
    E:=Int(E*IntPower(10,P)+A)*IntPower(10,-P);
  end;
end;

function pMultChar(count: integer; value:AnsiChar):AnsiString;
begin
  if Count>0 then begin
    SetLength(Result,Count);
    FillChar(PANSIChar(Result)^,Count,ord(Value));
  end else Result:='';
end;

function AddZeros(const S: AnsiString; P: integer): AnsiString;
var X,L,D,PP: integer;
begin
  Result:=S; if P<=0 then Exit;
  if P>2 then PP:=2 else PP:=P;
  L:=Length(Result);
  X:=Pos('.',Result);
  if X=0 then begin
    Result:=Result+'.';
    inc(L);
    X:=L;
  end;
  D:=PP-(L-X);
  if (D>0) then Result:=Result+pMultChar(D,'0');
end;

//////////////////////////
function FloatToStrEx(F: Extended; P: Integer; ThousandSep: Boolean = False; Fixed: Boolean = True): String;
const
  DigFmt: array[Boolean] of Char = ('#', '0');
var
  FS: String;
  i: Integer;
begin
  FS := '0.';
  if ThousandSep then FS := ',' + FS;
  if (P < 0) or (P > 12) then P := 12;
  for i := 0 to P-1 do FS := FS + DigFmt[Fixed];
  Result := FormatFloat(FS, F);
end;
function FloatToStringR(E: extended; P: integer): String;
begin
  SetPrecision(E, P);
  Result := FloatToStringP(E, P);
end;
function SetFracZeros(const Value: String; FixMin: Integer = 0): String;
var
  i, p, L: Integer;
begin
  Result := Value;
  L := Length(Value);
  p := Pos('.', Value);
  if p = 0 then begin
    if FixMin < 1 then Exit;
    Result := Result + '.';
    Inc(L);
    p := L;
  end;
  i := L;
  while (i > p + FixMin) and (Result[i] = '0') do Dec(i);
  if i < L then begin
    Delete(Result, i+1, L-i);
    if Result[i] = '.' then Delete(Result, i, 1);
  end else begin
    i := FixMin - (L - p);
    if i > 0 then Result := Result + pMultChar(i, '0');
  end;
end;
function FloatToStringP(E: extended; P: integer): string;
var
  R: TFloatRec;
  PP,Exp: integer;
  M: extended;
  Err: boolean;
  a: AnsiString; pa: PAnsiChar;
  rr: RawByteString;
begin
  Frexp(E,M,Exp);
  FillChar(R,SizeOf(R),0);
  FloatToDecimal(R,E,fvExtended,18,18);
  Exp:=R.Exponent;
  //if P<0 then PP:=18 else PP:=P;
  if P<0 then PP:=12 else PP:=P;
  if Exp>=0 then PP:=PP+Exp;
  FloatToDecimal(R,E,fvExtended,PP,18);
  //ShowMessage(IntToStr(Round(Exp/LogN(2,10)))+'  '+IntToStr(R.Exponent));
//  SetLength(a, Length(R.Digits)+1); pa:= PAnsiChar(a[1]);
//  Result:=AnsiString(R.Digits);
//  SetAnsiString(pa, PAnsiChar(R.Digits));
//  BytesToRawByteString(TBytes(R.Digits),rr);
    SetLength(a, Length(R.Digits));
  Move(R.Digits[0], a[1], Length(R.Digits) * SizeOf(AnsiChar));
  Result:=a;
  Result:=DBDTruncString(Result);
  if R.Exponent<0 then
    begin
      Result:='0.'+pMultChar(-R.Exponent,'0')+Result;
    end
      else if R.Exponent<Length(Result) then
    begin
      insert('.',Result,R.Exponent+1);
    end
      else
    if R.Exponent>Length(Result) then
      begin
        if R.Exponent>20 then
          begin
            Result:='#REF';
            Exit;
          end;
        Result:=Result+pMultChar(R.Exponent-Length(Result),'0');
      end;
  if Result='' then Result:='0' else
  if Result[1]='.' then Result:='0'+Result;
  if R.Negative then Result:='-'+Result;
  Result:=AddZeros(Result,P);
end;
function IsNumeric(const S: String): Boolean;
var
  TS: String;
  V: Extended;
  C: Integer;
begin
  Result := False;
  if S = '' then Exit;
  TS := S;
  FilterChar(@TS[1], ',', '.');
  V := 0;
  Val(TS, V, C);
  Result := C = 0;
end;
procedure FilterChar(AStr: PAnsiChar; OldCh,NewCh: AnsiChar);
var L,i: integer;
begin
  L:=AnsiStrLen(AStr);
  if L>0 then
    for i:=0 to L-1 do
//        if (AStr+i)^=OldCh then (AStr+i)^:=NewCh;
      if AStr[i]=OldCh then AStr[i]:=NewCh;

end;
function AnsiStrLen(const Str: PAnsiChar): Integer; register; inline;
begin
//  Result := PAnsichar(Str)^ + 1; // Добавляем 1, так как первый символ - это сам указатель (PChar)
  Result := PInteger(Str - SizeOf(Integer))^;
end;
procedure DeleteSpaces(var S: string);
var
  N: integer;
begin
  N:=Pos(' ',S);
  while N>0 do
    begin
      Delete(S,N,1);
      N:=Pos(' ',S);
    end;
end;
function Cut(var S: String; Index, Count: Integer): String;
begin
  Result := Copy(S, Index, Count);
  Delete(S, Index, Count);
end;
procedure Replace(const Repstr: String; var S: String; Index, Count: Integer);
begin
  Delete(S, Index, Count);
  if Repstr > '' then Insert(Repstr, S, Index);
end;
function ReplaceEx(const Substr, Repstr: String; var S: String; CaseSens: Boolean = True): Boolean;
var
  P, PP: Integer;
  SS, RS: String;
begin
  Result := False;
  if CaseSens then begin
    SS := Substr;
    RS := S;
  end else begin
    SS := AnsiUpperCase(Substr);
    RS := AnsiUpperCase(S);
  end;
  PP := 0;
  P := Pos(SS, RS);
  while P > 0 do begin
    Replace(Repstr, S, P+PP, Length(Substr));
    Inc(PP, P+Length(Repstr)-1);
    Delete(RS, 1, P+Length(Substr)-1);
    P := Pos(SS, RS);
    Result := True;
  end;
end;
procedure ReplaceRec(const Substr, Repstr: String; var S: String; CaseSens: Boolean = True); //заменяет, образовавшиеся вхождения после первого прохода, пока их не останется
var
  EntriesWere: Boolean;
begin
  EntriesWere := ReplaceEx(Substr, Repstr, S, CaseSens);
  while EntriesWere do EntriesWere := ReplaceEx(Substr, Repstr, S, CaseSens);
end;
function ReplaceText(const S: String; SrcText, DstText: array of String): String;
var
  F: String;
  i, p: Integer;
begin
  Result := S;
  if Length(DstText) = 1 then
    for i := 0 to Length(SrcText)-1 do
      ReplaceEx(SrcText[i], DstText[0], Result, True)
  else
    for i := 0 to Length(SrcText)-1 do
      ReplaceEx(SrcText[i], DstText[i], Result, True);
end;
function PosFunction(const F: String; const FS: array of String; var Fi: Integer): Integer;
begin
  Fi := 0;
  while Fi < Length(FS) do begin
    Result := Pos(FS[Fi], F);
    if Result > 0 then Exit;
    Inc(Fi);
  end;
  Result := 0;
end;
function CorrFloatTrunc(R: extended): int64;
begin
  if R<0 then Result:=trunc(R-0.000000000001) else
  if R>0 then Result:=trunc(R+0.000000000001) else
  Result:=0;
end;


{ TRoundedElem }

class function TRoundedElem.CompareErrors(const Elem1, Elem2; const Accuracy: Boolean): Integer;
var e,d: Extended;
begin
  if TRoundedElem(Elem1).Error>=0 then e := TRoundedElem(Elem1).Error else e := -TRoundedElem(Elem1).Error;
  if TRoundedElem(Elem2).Error>=0 then d := TRoundedElem(Elem2).Error else d := -TRoundedElem(Elem2).Error;
  e:=e-d;
  if Accuracy and (e=0) then Result:=0
  else if IsAboutZero(e) then Result:=0
// обратный порядок
  else if e<0 then Result:=1
  else Result:=-1;
end;

class function TRoundedElem.CompareValues(const Elem1, Elem2; const Accuracy: Boolean): Integer;
var e: Extended;
begin
  e:=TRoundedElem(Elem1).Value-TRoundedElem(Elem2).Value;
  if Accuracy and (e=0) then Result:=0
  else if IsAboutZero(e) then Result:=0
  else if e<0 then Result:=-1
  else Result:=1;
end;

constructor TRoundedElem.Create(const aValue: Extended; const aIndex: Integer);
var e: Extended; f: Boolean;
begin
  e:=RoundTo(aValue, -RoundingDigs); SetValue(e);
  e:= aValue-e; SetError(e);
  f := (not IsAboutZero(e)) and (aValue>MinDelta); SetFlag(f);
  SetIndex(aIndex);
end;

constructor TRoundedElem.Create(const aValue, aError: Extended; const aFlag: Boolean; const aIndex: Integer);
begin
  SetValue(aValue); SetError(aError);
end;

class function TRoundedElem.GetMinDelta(const Digs: integer): Extended;
var e: Extended;
begin
  e:= IntPower(10., TRoundedElem.RoundingDigs);
//  Result := RoundTo(0.5/e, -TRoundedElem.RoundingDigs);  //??????
  Result:=0.5/e;
end;

class function TRoundedElem.IsAboutZero(const Value, BoundOfZero: Extended): Boolean;
begin
  if      Value=0 then Result := True
  else if Value>0 then Result := Value<ZeroBounds
                  else Result := Value>(-ZeroBounds);
end;

class function TRoundedElem.IsMinDelta(const aValue: Extended): Boolean;
begin
  if aValue>0 then Result := IsAboutZero(aValue-MinDelta)
              else Result := IsAboutZero(aValue+MinDelta);
end;

function TRoundedElem.RoundToArray(Values: TExtendedDynArray): Extended;
var i: Integer; dlt: Extended;
    r: TRoundedElem; ra: TRoundedElems; ar: TDynArray;
begin
  ar.Init(TypeInfo(TRoundedElems), ra);
  for i := Low(Values) to High(Values) do begin
    r:= TRoundedElem.Create(Values[i],i);
    ar.Add(r);
  end;
  dlt := SumRoundedElems(ra).Value;
  Result:=FValue-dlt;
  if IsAboutZero(Result) then for i := Low(ra) to High(ra) do Values[i]:=ra[i].Value
  else begin
    ar.Sort(@CompareErrorsOfRoundedElems);
    i:=0;
    while (not IsAboutZero(Result)) and (i<10) do begin
      Inc(i);
      Proximity(Self, ra, Result);
    end;
  end;
  for i := 0 to Length(Values)-1 do begin
    Values[ra[i].Index]:=ra[i].Value;
  end;
end;

procedure TRoundedElem.SetError(const NewValue: Extended);
begin
  FError := NewValue;
end;

procedure TRoundedElem.SetFlag(const NewValue: Boolean);
begin
  FFlag := NewValue;
end;

procedure TRoundedElem.SetIndex(const NewValue: Integer);
begin
  FIndex := NewValue;
end;

procedure TRoundedElem.SetValue(const NewValue: Extended);
begin
  if isAboutZero(NewValue) then FValue:=0
                        else FValue := NewValue;
end;

{ TDBDPriceDate }

constructor TDBDPriceDate.Create(const aDate: TDateTime);
begin
  SetDate(aDate);
end;

constructor TDBDPriceDate.CreateMonth(const aYear, aMonth: Word);
begin
  FPriceDate:=aYear*100+aMonth;
end;

constructor TDBDPriceDate.CreateQuarter(const aYear, aQuorter: Word);
begin
  FPriceDate:=aYear*100+(aQuorter*3-2);
end;

function TDBDPriceDate.GetPriceDate: Integer;
begin
  Result:=FPriceDate;
end;

function TDBDPriceDate.GetDate: TDateTime;
begin
  Result:=EncodeDate(GetYear,GetMonth,1);
end;

function TDBDPriceDate.GetMonth: Word;
begin
  Result:=(FPriceDate mod 100);
end;

function TDBDPriceDate.GetQuarter: Word;
begin
  Result:=((GetMonth - 1) div 3) + 1;
end;

function TDBDPriceDate.GetYear: Word;
begin
  Result:=(FPriceDate div 100);
end;

class function TDBDPriceDate.MonthFromPriceDate(const dt: Integer): Integer;
begin
  Result:=(dt mod 100);
end;

class function TDBDPriceDate.PriceDateFromDateTime(const dt: TDateTime): Integer;
var Y,M,D: Word;
begin
  DecodeDate(dt,Y,M,D);
  Result:=Y*100+M;
end;

class function TDBDPriceDate.PriceDateFromStr(const dt: string): Integer;
var i: Integer; m,y: Cardinal;
begin
  if dt='' then Result:=0
  else begin
    i:=1;
    if DBDReadNumber(dt,i,m) and (dt[i]='/') and (m>0) and (m<13) then begin
      Inc(i);
      if DBDReadNumber(dt,i,y) then begin
        if y<50 then y:=y+2000
        else if y<100 then y:=y+1900;
        Result:=y*100+m;
      end;
    end;
  end;
end;

class function TDBDPriceDate.PriceDateToStr(const dt: Integer; const TwoDigsYear: Boolean): string;
var w: Word;
begin
  if TwoDigsYear then begin
    w:= YearFromPriceDate(dt);
    if w>2000 then w:=w-2000
    else if w>1900 then w:=w-1900;
    Result:=Format('%2.2d/%2.2d', [MonthFromPriceDate(dt), w])
  end else Result:=Format('%2.2d/%d', [MonthFromPriceDate(dt), YearFromPriceDate(dt)])
end;

procedure TDBDPriceDate.SetPriceDate(const Value: Integer);
begin
  FPriceDate:=Value;
end;

procedure TDBDPriceDate.SetDate(const Value: TDateTime);
begin
  FPriceDate:=PriceDateFromDateTime(Value);
end;

procedure TDBDPriceDate.SetMonth(const Value: Word);
begin
  FPriceDate:=GetYear*100+Value;
end;

procedure TDBDPriceDate.SetQuarter(const Value: Word);
begin
  FPriceDate:=GetYear*100+((Value div 3)+1);
end;

procedure TDBDPriceDate.SetYear(const Value: Word);
begin
  FPriceDate:=Value*100+GetMonth;
end;

class function TDBDPriceDate.YearFromPriceDate(const dt: Integer): Integer;
begin
  Result:=(dt div 100);
end;

initialization
  TRoundedElem.ZeroBounds:=0.0001;
  TRoundedElem.RoundingDigs:=2;
  TRoundedElem.MinDelta := TRoundedElem.GetMinDelta(TRoundedElem.RoundingDigs);
end.