Курсовой проект групп 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.