Курсовой проект групп 3341 и 3382 / DMCore / Utils

unit Utils;

interface

  uses
    Math,
    DmmConstants,
    DmmTypes,
    SysUtils,
    Dialogs,
    Exceptions;

    //возвращает коэффициент корреляции двух векторов типа double
    //параметр y1 вектор типа double
    //параметр y2 вектор типа double
    //параметр n длина двух векторов типа double
    //функция возвращает коэффициент корреляции
    function correlation (y1 :DArray; y2: DArray;
                          n: integer) : double;

    // проверка эквивалентности a и b.
    // параметр a типа double
    // параметр b типа double
    function eq (a : double; b : double) : boolean;

    //возвращает c*log2(c) для заданного c типа integer
    //параметр c типа integer
    //возвращает c*log2(c) (возвращает 0 если c 0)
    function xlogx (c : integer) : double;

    //вычисление энтропии элементов массива типа integer
    //параметр counts массив
    //возвращает - a log2 a - b log2 b - c log2 c + (a+b+c) log2 (a+b+c)
    //для массива [a b c]
    function info(counts : IArray) : double;

    //проверка если a меньше или равно b.
    //параметр a типа double
    //параметр b типа double
    function smOrEq(a : double; b: double) : boolean;

    //проверка если a больше или равно b
    //параметр a типа double
    //параметр b типа double
    function  grOrEq(a : double; b : double) : boolean;

    //проверка если a меньше b
    //параметр a типа double
    //параметр b типа double
    function sm(a : double; b : double): boolean;

    //проверка если a меньше b
    //параметр a типа double
    //параметр b типа double
    function gr(a : double; b : double) : boolean;

    // возврвщает индекс максимального элемента массива
    // типа doubles; возвращает индекс первого максимального элемента
    // параметр doubles массив типа doubles
    // возвращает индекс максимального элемента
    function maxIndex(doubles : DArray) : integer; overload;


    //возвращает индекс максимального элемента в
    //массиве типа integer; возвращается индекс первого
    //максимального элемента
    //параметр ints массив типа integer
    //возвращает индекс максимального элемента
    function maxIndex(ints : IArray) : integer; overload;

    //вычисляет среднее для массива типа double
    //параметр vector масив
    //возвращает среднее
    function mean(vector : DArray) : double;

    //сумма элементов массива
    function summ(vector : DArray) : double;

    //возвращает индекс минимального элемента в
    //массиве типа integer; возвращается индекс первого
    //минимального элемента
    //параметр ints массив типа integer
    //возвращает индекс минимального элемента
    function minIndex(ints : IArray) : integer; overload;

    //возвращает индекс минимального элемента в
    //массиве типа double; возвращается индекс первого
    //минимального элемента
    //параметр ints массив типа integer
    //возвращает индекс минимального элемента
    function minIndex(doubles : DArray) : integer; overload;

    //нормализация массива типа double по сумме
    //параметр doubles массив типа double
    //исключение IllegalArgumentException если сумма
    //равна нулю или NaN
    procedure normalize(var doubles : DArray); overload;

    //нормализация массива типа double по заданному значению
    //параметр doubles массив типа double
    //параметр sum значение по которому проводится нормализация
    //исключение IllegalArgumentException сли сумма
    //равна нулю или NaN
    procedure normalize(var doubles : DArray; sum : double); overload;

    //выполняет быструю сортировку для массива
    //параметр double массив типа doublе, в котором хранится результат
    //параметр index индекс элемента в отсортированном массиве
    //параметр lo0 индекс, с которого начинать сортировку
    //параметр hi0 индекс, на котором завершить сортировку
    procedure quickSort(doubles : DArray; var index : IArray; lo0 : integer;
                        hi0 : integer) ; overload;

    //сортирует массив типа double в порядке возрастания и возвращает
    //массив типа integer с позициями элементов исходного массива в
    //в отсортированном массиве; значение NaN рассматривается как MAX_VALUE
    //параметр array исходный массив; в процедуре не изменяется
    //возвращает массив типа integer с сортированными интексами
    function sort(doubles : DArray) : IArray; overload

    //выполняет быструю сортировку для массива
    //параметр integers массив типа integer, в котором хранится результат
    //параметр index индекс элемента в отсортированном массиве
    //параметр lo0 индекс, с которого начинать сортировку
    //параметр hi0 индекс, на котором завершить сортировку
    //требования
    //0 <= lo0 & lo0 <= hi0 & hi0 < length(index);
    //(forall i; 0 <= i & i < length(index);
    //           0 <= index[i] & index[i] < length(array));
    //array != index;
    procedure quickSort(integers : IArray; var index : IArray;
                        lo0 : integer; hi0 : integer); overload;

    //сортирует массив типа integer в порядке возрастания и возвращает
    //массив типа integer с позициями элементов исходного массива в
    //в отсортированном массиве; значение NaN рассматривается как MAX_VALUE
    //параметр array исходный массив; одинаковые элементы остаются в
    //исходном порядке
    function sort(integers : IArray) : IArray; overload;

    //сортирует массив типа double в порядке возрастания и возвращает
    //массив типа integer с позициями элементов исходного массива в
    //в отсортированном массиве; значение NaN рассматривается как MAX_VALUE
    //параметр array исходный массив; при сортировке одинаковые элементы
    //остаются в исходном порядке
    function stableSort(doubles : DArray) : IArray;

    //вычисление разброса значений ветора типа doubles
    //параметр vector массив
    //возвращает значение разброса
    function variance(vector : DArray) : double;

    //округляет double до заданного числа знаков после запятой
    //параметр value the double value
    //параметр afterDecimalPoint - число цифр послезапятой
    //возвращает double округленный до заданной точности
    function roundDouble(value : double; afterDecimalPoint : integer) : double ;

    function simpleQuote( str : AnsiString ) : AnsiString;

    function BoolToInt(bool : boolean) : integer;
    function IntToBool(int : integer) : boolean;

    //преобразовывает массив, содержащий натуральные логарифмы вероятностей,
    //сохраненые в векторе вероятностей
    //вероятности приводятся, чтобы суммировать к одной
    //параметр a - массив, содержащий натуральные логарифмы вероятностей
    //возвращает преобразованный массив
    function logs2probs(a:DArray):DArray;

    //сравнение строк без учета регистра
    function equalsIgnorCase (str :AnsiString; strToCompare: AnsiString) : boolean;
    function uSort(doubles : DArray) : IArray;
    procedure uQuickSort(doubleArr :DArray; var index :IArray;
                         left : integer; right : integer);
    function partition(doubleArr :DArray; var index : IArray; l : integer; r : integer) : integer;
    function numOfValuesInInterval(arr :TDMInstanceValues; step : double; intNumber : integer) : integer;

implementation

  function correlation(y1 : DArray; y2: DArray;
                       n: integer) : double;
  var
    av1, av2, y11, y22, y12, c : double;
    i : integer;
  begin
    av1 := 0.0;
    av2 := 0.0;
    y11 := 0.0;
    y22 := 0.0;
    y12 := 0.0;

    if (n <= 1) then
    begin
      Result := 1.0;
      Exit;
    end;

    i := 0;
    while (i < n) do
    begin
      if ( IsNaN(y1[i]) or IsNaN(y2[i])) then
      begin
        Result := MISSING_VALUE;
        exit;
      end;
      av1 := av1 + y1[i];
      av2 := av2 + y2[i];
      inc(i);
    end;

    av1 := av1 / n;
    av2 := av2 / n;

    i := 0;
    while ( i < n) do
    begin
      y11 := y11 + (y1[i] - av1) * (y1[i] - av1);
      y22 := y22 + (y2[i] - av2) * (y2[i] - av2);
      y12 := y12 + (y1[i] - av1) * (y2[i] - av2);
      inc(i);
    end;

    if (y11 * y22 = 0.0) then c := 1.0
    else c := y12 / sqrt(abs(y11 * y22));

    Result := c;
  end;

  function eq (a : double;  b : double) : boolean;
  begin
    Result := ((a - b < SMALL) and (b - a < SMALL));
  end;

  function xlogx(c : integer) : double;
  begin
    if (c = 0) then
    begin
      Result := 0.0;
      Exit;
    end;

    Result := c * log2(c);
  end;

  function info(counts : IArray) : double;
  var
    total, j : integer;
    x : double;

  begin
    total := 0;
    x := 0;
    j := 0;

    while (j < length(counts)) do
    begin
      x := x - xlogx(counts[j]);
      total := total + counts[j];
      inc(j);
    end;

    Result := x + xlogx(total);
  end;

  function smOrEq(a : double; b : double) : boolean;
  begin
    Result := (a-b < SMALL);
  end;

  function grOrEq(a : double; b : double) : boolean;
  begin
    Result := (b-a < SMALL);
  end;

  function sm(a : double; b : double) : boolean;
  begin
    Result := (b-a > SMALL);
  end;

  function gr(a : double; b : double) : boolean;
  begin
    Result := (a-b > SMALL);
  end; 

  function maxIndex(doubles : DArray) : integer;
  var
    maximum : double;
    maxIndex : integer;
    i : integer;
  begin
    maximum := 0;
    maxIndex := 0;

    i := 0;
    while (i < length(doubles)) do
    begin
      if ( IsNaN(doubles[i])) then
      begin
        inc(i);
        continue;
      end;
      if ((i = 0) or (doubles[i] > maximum)) then
      begin
	      maxIndex := i;
	      maximum := doubles[i];
      end;
      inc(i);
    end;

    Result := maxIndex;
  end;


  function maxIndex(ints : IArray) : integer;
  var
    maximum : double;
    maxIndex : integer;
    i : integer;
  begin
    maximum := 0;
    maxIndex := 0;

    i := 0;
    while (i < length(ints)) do
    begin
      if ((i = 0) or (ints[i] > maximum)) then
      begin
	      maxIndex := i;
	      maximum := ints[i];
      end;
      inc(i);
    end;

    Result := maxIndex;
  end;

  function mean(vector : DArray) : double;
  var
    sum : double;
    i : integer;
  begin
    sum := 0;

    if (length(vector)= 0) then
    begin
      Result := 0;
      exit;
    end;

    i := 0;
    while (i < length(vector)) do
    begin
      if ( IsNaN(vector[i])) then
      begin
        Result := MISSING_VALUE;
        exit;
      end;
        sum := sum + vector[i];
        inc(i);
    end;

    Result := sum / length(vector);
  end; {mean}

  function summ(vector : DArray) : double;
  var
    summa : double;
    i : integer;
  begin
    summa := 0;

    if (length(vector)= 0) then
    begin
      Result := 0;
      exit;
    end;

    i := 0;
    while (i < length(vector)) do
    begin
      if ( IsNaN(vector[i])) then
      begin
        Result := MISSING_VALUE;
        exit;
      end;
      summa := summa + vector[i];
      inc(i);
    end;

    Result := summa ;
  end; 

  function minIndex(ints : IArray) : integer;
  var
    minimum : integer;
    minIndex : integer;
    i : integer;
  begin
    minimum := 0;
    minIndex := 0;

    i := 0;
    while (i < length(ints)) do
    begin
      if ((i = 0) or (ints[i] < minimum)) then
      begin
	      minIndex := i;
	      minimum := ints[i];
      end;
      inc(i);
    end;

    Result := minIndex;
  end;

  function minIndex(doubles : DArray) : integer;
  var
    minimum : double;
    minIndex: integer;
    i: integer;
  begin
    minimum := 0;
    minIndex := 0;

    i := 0;
    while (i < length(doubles)) do
    begin
      if ( IsNaN(doubles[i])) then
      begin
        inc(i);
        continue;
      end;

      if ((i = 0) or (doubles[i] < minimum)) then
      begin
        minIndex := i;
	      minimum := doubles[i];
      end;

      inc(i);
    end;

    Result := minIndex;
  end;

  procedure normalize(var doubles : DArray);
  var
    sum : double;
    i : integer;
  begin
    sum := 0;
    i := 0;

    try
      while (i < length(doubles)) do
      begin
        if ( IsNaN(doubles[i])) then
          raise EIllegalArgumentException.Create
            ('Невозможно вычислить сумму элементов массива. Один из элементов массива не определен.');

        sum := sum + doubles[i];
        inc(i);
      end;

      normalize(doubles, sum);

      except
        on E: EIllegalArgumentException do ShowMessage(E.Message);
    end;
  end;

  procedure normalize(var doubles : DArray; sum : double);
  var
    i : integer;
  begin
    try
      if isNaN(sum) then
        raise EIllegalArgumentException.Create
          ('Невозможно нормализовать массив. Сумма равна не определена.');

      if (sum = 0) then
        raise EIllegalArgumentException.Create
          ('Невозможно нормализовать массив. Сумма равна нулю.');

      i := 0;
      while (i < length(doubles) ) do
      begin
        if ( IsNaN(doubles[i])) then
        begin
          inc(i);
          continue;
        end;
        doubles[i] := doubles[i] / sum;
        inc(i);
      end;

      except
        on E: EIllegalArgumentException do ShowMessage(E.Message);
    end;
  end;

  procedure quickSort(doubles : DArray; var index : IArray; lo0 : integer;
                      hi0 : integer) ;
  var
    lo : integer;
    hi : integer;
    mid : double;
    help : integer;
  begin
    lo := lo0;
    hi := hi0;

    if (hi0 > lo0) then
    begin
      //в качестве граничного элемента рассматривается середина масива
      mid := doubles[index[(lo0 + hi0) div 2]];

      //перебор элементов массива
      while (lo <= hi) do
      begin
	      //поиск первого элемента, который больше или равен
	      //граничному элементу, поиск начинается с нижней границы массива
	      while ((doubles[index[lo]] < mid) and (lo < hi0)) do inc(lo);

        //поиск первого элемента, который меньше или равен
	      //граничному элементу, поиск начинается с верхней границы массива
	    	while ((doubles[index[hi]] > mid) and (hi > lo0)) do dec(hi);

	      //если индексы не пересеклись, поменять местами
	      if (lo <= hi) then
        begin
	        help := index[lo];
	        index[lo] := index[hi];
	        index[hi] := help;
	        inc(lo);
	        dec(hi);
	      end;
      end;

      //если правый индекс не достиг левого края массива
      // сортируется левая часть
      if (lo0 < hi) then	quickSort(doubles, index, lo0, hi);

      //если левый индекс не достиг правого края массива
      // сортируется правая часть
      if (lo < hi0) then	quickSort(doubles, index, lo, hi0);
    end;
  end;

  function sort(doubles : DArray) : IArray;
  var
    index : IArray;
    newDoubles : DArray;
    i : integer;

  begin
    SetLength(index, length(doubles));
    newDoubles := copy(doubles, 0, length(doubles));

    i := 0;
    while (i < length(index)) do
    begin
      index[i] := i;
      if (isNaN(newDoubles[i])) then newDoubles[i] := MAX_VALUE;
      inc(i);
    end;

    quickSort(newDoubles, index, 0, length(newDoubles) - 1);
    Result := index;
  end;

  procedure quickSort(integers : IArray; var index : IArray;
                      lo0 : integer; hi0 : integer);
  var
    lo : integer;
    hi : integer;
    mid : integer;
    help : integer;
  begin
    lo := lo0;
    hi := hi0;

    if (hi0 > lo0) then
    begin
      //в качестве граничного элемента рассматривается середина масива
      mid := integers[index[(lo0 + hi0) div 2]];

      //перебор элементов массива
      while (lo <= hi) do
      begin
	      //поиск первого элемента, который больше или равен
	      //граничному элементу, поиск начинается с нижней границы массива
        while ((integers[index[lo]] < mid) and (lo < hi0)) do  inc(lo);

        //поиск первого элемента, который меньше или равен
	      //граничному элементу, поиск начинается с верхней границы массива
	    	while ((integers[index[hi]] > mid) and (hi > lo0)) do dec(hi);

	      //если индексы не пересеклись, поменять местами
	      if (lo <= hi) then
        begin
	        help := index[lo];
	        index[lo] := index[hi];
          index[hi] := help;
	        inc(lo);
	        dec(hi);
        end;
      end;

      //если правый индекс не достиг левого края массива
      // сортируется левая часть
      if (lo0 < hi) then	quickSort(integers, index, lo0, hi);
      //если левый индекс не достиг правого края массива
      // сортируется правая часть
      if (lo < hi0) then	quickSort(integers, index, lo, hi0);
    end;
  end;

  function sort(integers : IArray) : IArray;
  var
    index : IArray;
    newIndex : IArray;
    helpIndex : IArray;
    numEqual : integer;
    i : integer;
    j : integer;
  begin
    SetLength(index, length(integers));
    SetLength(newIndex, length(integers));

    i := 0;
    while(i < length(index)) do
    begin
      index[i] := i;
      inc(i);
    end;

    quickSort(integers, index, 0, length(integers) - 1);

    //одинаковые элементы остаются в исходном порядке
    i := 0;
    while (i < length(index)) do
    begin
      numEqual := 1;

      j := i + 1;
      while ((j < length(index)) and
             (integers[index[i]] = integers[index[j]])) do
	    begin
	      inc(numEqual);
        inc(j);
      end;

      if (numEqual > 1) then
      begin
	      SetLength(helpIndex, numEqual);

        j := 0;
	      while (j < numEqual ) do
        begin
	        helpIndex[j] := i + j;
          inc(j);
        end;

	      quickSort(index, helpIndex, 0, numEqual - 1);

        j := 0;
        while (j < numEqual) do
        begin
          newIndex[i + j] := index[helpIndex[j]];
          inc(j);
        end;

	      i := i + numEqual;
      end
      else
      begin
	      newIndex[i] := index[i];
	      inc(i);
      end;
    end;

    Result :=  newIndex;
  end;

  function partition(doubleArr :DArray; var index : IArray; l : integer; r : integer) : integer;
  var
    pivot : double;
    help : integer;
  begin
    pivot := doubleArr[index[(l + r) div 2]];

    while (l < r) do
    begin
      while ((doubleArr[index[l]] < pivot) and (l < r)) do inc(l);
      while ((doubleArr[index[r]] > pivot) and (l < r)) do dec(r);
        if (l < r) then
        begin
          help := index[l];
          index[l] := index[r];
          index[r] := help;
          inc(l);
          dec(r);
        end;
    end;
    if ((l = r) and (doubleArr[index[r]] > pivot)) then dec(r);
      result := r;
  end;

  procedure uQuickSort(doubleArr :DArray; var index :IArray;
                                left : integer; right : integer);
  var
    middle : integer;
  begin
    if (left < right) then
    begin
      middle := partition(doubleArr, index, left, right);
      quickSort(doubleArr, index, left, middle);
      quickSort(doubleArr, index, middle + 1, right);
    end;
  end;

  function uSort(doubles : DArray) : IArray;
  var
    index : IArray;
    newDoubles : DArray;
    i : integer;
  begin
    SetLength(index, length(doubles));
    newDoubles := copy(doubles, 0, length(doubles));

    i := 0;
    while (i < length(index)) do
    begin
      index[i] := i;
      if (isNaN(newDoubles[i])) then newDoubles[i] := MAX_VALUE;
      inc(i);
    end;

    uQuickSort(newDoubles, index, 0, length(newDoubles) - 1);
    Result := index;
  end;

  function stableSort(doubles : DArray) : IArray;
  var
    index : IArray;
    newIndex : IArray;
    helpIndex : IArray;
    numEqual : integer;
    newDoubles : DArray;
    i : integer;
    j : integer;
  begin
    SetLength(index,length(doubles));
    SetLength(newIndex,length(doubles));

    newDoubles := copy(doubles, 0, length(doubles));

    i := 0;
    while (i < length(index) ) do
    begin
      index[i] := i;
      if (isNaN(doubles[i])) then doubles[i] := MAX_VALUE;
      inc(i);
    end;

    quickSort(doubles,index,0,length(doubles)-1);

    //одинаковые элементы остаются в исходном порядке
    i := 0;

    while (i < length(index)) do
    begin
      numEqual := 1;

      j := i+1;
      while ( (j < length(index)) and eq(doubles[index[i]],
							doubles[index[j]])) do
      begin
	      inc(numEqual);
        inc(j);
      end;

      if (numEqual > 1) then
      begin
	      SetLength(helpIndex, numEqual);

        j := 0;
	      while ( j < numEqual ) do
        begin
	        helpIndex[j] := i+j;
          inc(j);
        end;

	      quickSort(index, helpIndex, 0, numEqual-1);

        j := 0;
	      while (j < numEqual ) do
        begin
	        newIndex[i+j] := index[helpIndex[j]];
          inc(j);
        end;

	      i := i + numEqual;
      end
      else
      begin
        newIndex[i] := index[i];
	      inc(i);
      end;
    end;
    SetLength(index,0);
    SetLength(newDoubles,0);
    SetLength(helpIndex,0);
    Result := newIndex;
  end;

  function variance(vector : DArray) : double;
  var
    sum : double;
    sumSquared : double;
    i : integer;
  begin
    sum := 0;
    sumSquared := 0;
    if (length(vector)<= 1) then
    begin
      Result := 0;
      exit;
    end;

    i := 0;
    while (i < length(vector) ) do
    begin
      sum := sum + vector[i];
      sumSquared := sumSquared + (vector[i] * vector[i]);
      inc(i);
    end;
    Result := (sumSquared - (sum * sum / length(vector))) / (length(vector) - 1);

    // We don't like negative variance
    if (result < 0) then Result :=0;
  end;

  function roundDouble(value : double; afterDecimalPoint : integer) : double ;
  var
    mask : double;
  begin
    mask := power(10.0, afterDecimalPoint);
    Result := (round(value * mask)) / mask;
  end;

  function simpleQuote( str : AnsiString ) : AnsiString;
  begin
    if ( Pos( ' ', str ) <> 0 ) then Result := QuotedStr( str )
    else Result := str;
  end;

  function BoolToInt(bool : boolean) : integer;
  begin
    if (bool = true) then Result := 1 else Result := 0;
  end;

  function IntToBool(int : integer) : boolean;
  begin
    if (int = 0) then Result := false else
    if (int = 1) then Result := true else
      raise EIllegalTypeConvertion.Create('Преобразование целого типа к булевскому типу невозможно');
  end;

  function logs2probs(a:DArray):DArray;
  var
    max,sum:double;
    res:DArray;
    i:integer;
  begin
    max := a[maxIndex(a)];
    sum := 0.0;
    SetLength(res,length(a));
    for i := 0 to length(a)-1 do
    begin
      res[i] := exp(a[i] - max);
      sum := sum + res[i];
    end;
    normalize(res, sum);
    Result:= res;
  end;

  function equalsIgnorCase (str :AnsiString; strToCompare: AnsiString) : boolean;
  begin
    result := false;
    if (str = strToCompare) or (str = AnsiLowerCase(strToCompare)) then
      result:=true;
  end;

  function numOfValuesInInterval(arr :TDMInstanceValues; step : double; intNumber : integer) : integer;
  var
    curLow : double;
    curHi : double;
    i : integer;
    s : integer;
    doubleArr : DArray;
  begin
    doubleArr := DArray(arr);
    result := 0;
    curLow := doubleArr[minIndex(doubleArr)];
    curHi := curLow + step; 
    for s := 1 to intNumber do
    begin
      curLow := curHi;
      curHi := curHi + step;
    end;
    for i := 0 to length(doubleArr)-1 do
      if (doubleArr[i] >= curLow) and (doubleArr[i] < curHi) then
        inc(result);
   end;

end.