{
По следам книги "Как построить свою экспертную систему". (c) К. Нейлор
Байесовская ЭС.
Embarcadero Delphi 10.2 Tokyo.
Delphi-компонент: TES_bayes.
Статус исходников компонента и иллюстрирующей программы: FreeWare (каждый использует для себя - как хочет).
Краткое описание см. в документе: ES_Bayes.pdf
===
(c) Сергей Попов, сентябрь-2023.
roamer55.ru
}
unit __es_bayes;
interface
uses
Classes,
Vcl.Grids,
Vcl.CheckLst, //Если такая возможность не нужна - закомментарить
//См., также, PropsValue_from_TCheckListBox(),
//Obj_Recognize(), PropsValue_from_TCheckListBox_to_TSTrings()
Forms,
SysUtils;
//-----------------
Type
//Режимы обучения ЭС
TTrainMode = (ES_tmAuto, ES_tmManual);
//Результат обучения ЭС
TTrainResult = (trNo, trYes);
//Результат распознавания объекта
TObjTrainResult = (otrNo, otrYes, otrConfused);
//Причина окончания/прерывания процесса обучения ЭС
TTrainProcessExit = (tpeNone, tpeNormal, tpeUserAbort, tpeExitForLimit);
//-----------------
//-----------------
//События
Type
//Перед стартом процесса АвтоОбучения ЭС и после останова/прерывания процесса АвтоОбучения ЭС
TES_Common_Event = procedure (Sender: TObject) of object;
//В начале очередного цикла (режим АвтоОбучения)
TES_Auto_Cycle_Before_Event = procedure (Sender: TObject; CycleNum:integer) of object;
//В конце очередного цикла (режим АвтоОбучения)
TES_Auto_Cycle_After_Event = procedure (Sender: TObject; CycleNum:integer; TR:TTrainResult; TPE:TTrainProcessExit) of object;
//В начале каждого шага (обучение ЭС для распознавания очередного объекта)
TES_Auto_Cycle_Step_Before_Event = procedure (Sender: TObject; CycleNum:integer; ObjTrainIndex:integer) of object;
//В конце каждого шага (обучение ЭС для распознавания очередного объекта)
TES_Auto_Cycle_Step_After_Event = procedure (Sender: TObject; CycleNum:integer; ObjTrainIndex:integer; TOR:TObjTrainResult) of object;
//-----------------
//-----------------
Type
//Рейтинг объекта
TObjRec = record
id:integer;
Rating:integer;
RatingNorm:integer;
RatingPercent:real;
YesTrain:boolean;
//RatingList:string; //потенциально это может представлять интерес
end;
//Признак (свойство)
TPropRec = record
id:integer;
Yes:boolean
end;
//Массив правил
TRules = array of array of integer;
//-----------------
type
//Компонент: Байесовская ЭС
TES_bayes = class(TComponent)
private
{ Private declarations }
//Версия компонента
fVersion : string;
//Флаг: Инициализация компонента (true - успешно)
fYesInit:boolean;
//**************************************************
//Обучение ЭС
//---------------------------------
//Состояние ЭС: в режиме обучения
fInTraining : boolean;
//Прервать процесс обучения (по требованию пользователя)
fTrainAbort : boolean;
//Режим обучения ЭС (авто или ручной)
fTrainMode : TTrainMode;
//Результат обучения ЭС
fTrainResult : TTrainResult;
//Результат распознавания объекта (на конкретном шаге)
fObjTrainResult : TObjTrainResult;
//Причина окончания/прерывания процесса обучения ЭС
fTrainProcessExit : TTrainProcessExit;
//максимальное кол-во циклов обучения
//в автоматическом режиме (защита от вечного цикла)
fTrainCycleMaxCount:integer;
//номер текущего цикла обучения
fTrainCycle:integer;
//номер текущего шага в текущем цикле обучения
fTrainStep:integer;
//Счетчик корректно распознанных объектов при обучении ЭС
fObjTrainCount:integer;
//---------------------------------
//Индекс объекта, используемого для обучения ЭС
//на очередном шаге очередного цикла
fObjTrain_J : integer;
//Рейтинг объекта с индексом fObjTrain_J
fObjTrain_Rating : integer;
//---------------------------------
//-----------------------------------
//События
//Перед стартом процесса АвтоОбучения ЭС
fBeforeTrain : TES_Common_Event;
//После останова/прерывания процесса АвтоОбучения ЭС
fAfterTrain : TES_Common_Event;
//В начале очередного цикла (режим АвтоОбучения)
fBeforeCycle : TES_Auto_Cycle_Before_Event;
//В конце очередного цикла (режим АвтоОбучения)
fAfterCycle : TES_Auto_Cycle_After_Event;
//В начале каждого шага (обучение ЭС для распознавания очередного объекта)
fBeforeStep : TES_Auto_Cycle_Step_Before_Event;
//В конце каждого шага (обучение ЭС для распознавания очередного объекта)
fAfterStep : TES_Auto_Cycle_Step_After_Event;
//-----------------------------------
//**************************************************
//**************************************************
//Исходные данные: Объекты и их признаки (свойства)
//---------------------------------
//Массив (список) распознаваемых объектов
fObjList : array of TObjRec;
//Кол-во распознаваемых объектов
fObjCount:integer;
//Кол-во цифр после запятой при округлении рейтингов объектов (%)
fRatingRoundTo : integer;
//---------------------------------
//---------------------------------
//Массив (список) признаков (свойств),
//используемых для распознавания
fPropList : array of TPropRec;
//Кол-во признаков (свойств), используемых для распознавания
fPropCount:integer;
//---------------------------------
//**************************************************
//**************************************************
//Обучение ЭС и распознавание объектов
//---------------------------------
//Массив (таблица) правил распознавания объектов
fRules : TRules;
//---------------------------------
//Индекс (номер) объекта с наилучшим рейтингом
fObjBest_J:integer;
//Значение рейтинга объекта с индексом fObjBest_J
fObjBest_Rating: integer;
//---------------------------------
//**************************************************
protected
{ Protected declarations }
//------------------------------------
//Методы, используемые (в том числе) при инициализации компонента
procedure Arrays_NIL;
function Arrays_Create:boolean;
function ObjList_Create:boolean;
function PropList_Create:boolean;
function Rules_Create:boolean;
procedure Arrays_Clear;
procedure ObjList_Clear;
procedure ObjList_Rating_Clear;
procedure ObjList_YesTrain_Clear;
procedure ObjList_TrainInfo_Clear;
procedure PropList_Clear;
procedure Rules_Clear;
//------------------------------------
//------------------------------------
//Полный цикл обучения ЭС в автоматическом режиме
function ES_Train_Auto(PropsListTrue_for_EachObj:TStrings):boolean;
//Обучение ЭС для очередного объекта (очередной шаг обучения)
//в автоматическом или ручном режиме
function Obj_Train_Auto(ListRat:TStrings):boolean;
//------------------------------------
//------------------------------------
//Старт обучения ЭС в ручном режиме
function ES_Train_Manual(PropsListTrue_for_EachObj:TStrings):boolean;
//см., также, ES_Train_Manual_Next()
//------------------------------------
//------------------------------------
//Нормальное завершение процесса обучения ЭС
function ES_Train_Exit_Normal:boolean;
//------------------------------------
//------------------------------------
//Прочитать значение ячейки из таблицы правил
function Rules_Cell_Get(I, J : integer):integer;
//Записать значение ячейки в таблицу правил
function Rules_Cell_Set(I, J, V : integer):boolean;
//------------------------------------
//Прочитать Id объекта по его индексу
function Obj_Id_Get(J:integer):integer;
//Записать Id объекта по его индексу
function Obj_Id_Set(J:integer; V:integer):boolean;
//------------------------------------
//------------------------------------
//Прочитать Рейтинг объекта по его индексу
function Obj_Rating_Get(J:integer):integer;
//Записать Рейтинг объекта по его индексу
function Obj_Rating_Set(J:integer; V:integer):boolean;
//Прочитать нормированный Рейтинг объекта по его индексу
function Obj_RatingNorm_Get(J:integer):integer;
//Записать нормированный Рейтинг объекта по его индексу
function Obj_RatingNorm_Set(J:integer; V:integer):boolean;
//Прочитать Рейтинг объекта (%) по его индексу
function Obj_RatingPercent_Get(J:integer):Real;
//Записать Рейтинг объекта (%) по его индексу
function Obj_RatingPercent_Set(J:integer; V:Real):boolean;
//------------------------------------
//------------------------------------
//Прочитать Флаг YesTrain объекта по его индексу
function Obj_YesTraing_Get(J:integer):boolean;
//Записать Флаг YesTrain объекта по его индексу
function Obj_YesTraing_Set(J:integer; V:boolean):boolean;
//------------------------------------
//------------------------------------
//Прочитать Id признака (свойства) по его индексу
function Prop_Id_Get(I:integer):integer;
//Записать Id признака (свойства) по его индексу
function Prop_Id_Set(I:integer; V:integer):boolean;
//------------------------------------
//------------------------------------
//Прочитать значение признака (свойства) по его индексу
function Prop_Yes_Get(I:integer):boolean;
//Зписать значение признака (свойства) по его индексу
function Prop_Yes_Set(I:integer; V:boolean):boolean;
//------------------------------------
//Расчет рейтингов объектов по правилам
function ObjList_Ratings_Calc:boolean;
//Поиск объекта с наилучшим рейтингом
function Obj_Rating_Best_Find:boolean;
//ЭС угадала?
function ES_right:boolean;
//Проверка: ЭС всче объекты угадала?
function ES_Recognized_All_Objects:boolean;
//Перерасчет правил для всех объектов (с рейтингом не хуже распознаваемого), кроме распознаваемого
function ObjList_Any_Rules_ReCalc:boolean;
//Перерасчет правил для распознавемого объекта
//function ObjTrain_Rating_ReCalc:boolean;
function ObjBest_Rules_ReCalc:boolean;
//Конвертация значений признаков (свойств) из TCheckListBox в TStrings
function PropsValue_from_TCheckListBox_to_TSTrings(ListFrom:TCheckListBox; ListTo:TStrings):boolean;
public
{ Public declarations }
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
//Версия компонента
property Version : string read fVersion;
//------------------------------------
//Флаг (признак): факт инициализации компонента
property ComponentInitOK : boolean read fYesInit;
//------------------------------------
//****************************************
//Свойства компонента (только чтение)
//--------------------------
//Режим обучения ЭС (авто или ручной)
property TrainMode : TTrainMode read fTrainMode;
//Состояние ЭС: в режиме обучения
property InTraining : boolean read fInTraining;
//номер текущего цикла обучения
property TrainCycle : integer read fTrainCycle;
//номер текущего шага в текущем цикле обучения
property TrainStep : integer read fTrainStep;
//Результат обучения ЭС
property TrainResult : TTrainResult read fTrainResult;
//Результат распознавания объекта (на конкретном шаге)
property ObjTrainResult : TObjTrainResult read fObjTrainResult;
//Причина окончания/прерывания процесса обучения ЭС
property TrainProcessExit : TTrainProcessExit read fTrainProcessExit;
//--------------------------
//--------------------------
//Кол-во распознаваемых объектов
property ObjCount : integer read fObjCount;
//Кол-во признаков (свойств), используемых для распознавания
property PropCount : integer read fPropCount;
//--------------------------
//--------------------------
//Индекс объекта, используемого для обучения ЭС
//на очередном шаге очередного цикла обучения
property ObjTrain_J : integer read fObjTrain_J;
//Рейтинг объекта с индексом fObjTrain_J
property ObjTrain_Rating : integer read fObjTrain_Rating;
//Счетчик корректно распознанных объектов при обучении ЭС
property ObjTrainCount : integer read fObjTrainCount;
//--------------------------
//--------------------------
//Индекс (номер) объекта с наилучшим рейтингом
property ObjBest_J : integer read fObjBest_J;
//Значение рейтинга объекта с индексом fObjBest_J
property ObjBest_Rating : integer read fObjBest_Rating;
//--------------------------
//****************************************
//------------------------------------
//Распознать объект (использование ЭС по назначению - для распознавания объектов)
function Obj_Recognize(ListProp:TStrings; ListFuzzi:TStrings=nil):integer; overload;
function Obj_Recognize(ListProp:TCheckListBox; ListFuzzi:TStrings=nil):integer; overload;
//------------------------------------
//--------------------------
//Иницализация компонента (обязательный шаг перед использованием компонента)
function Init(ObjCount:integer; PropCount:integer):boolean;
//Старт процесса обучения ЭС
function ES_Train_Start(ES_TrainMode:TTrainMode; PropsListTrue_for_EachObj:TStrings):boolean;
//Обучение ЭС для очередного объекта (очередной шаг на очередном цикле)) в ручном режиме
function ES_Train_Manual_Next(PropsListTrue_for_EachObj:TStrings):boolean;
//Досрочное завершение процесса обучения ЭС из-за превышения максимального кол-ва циклов обучения
procedure ES_Train_ExitForLimit;
//Досрочное завершение процесса обучения ЭС по требованию пользователя
procedure ES_Train_Exit_UserAbort;
//--------------------------
//--------------------------
//Добавить объект в перечень объектов
function Obj_Add(Id:integer):integer;
//Добавить признак (свойство) в перечень признаков (свойств)
function Prop_Add(Id:integer; Yes:boolean=false):integer;
//Загрузить список объектов из TStrings
function ObjList_LoadFromTStrings(List:TStrings):boolean;
//Загрузить список признаков (свойств) из TStrings
function PropList_LoadFromTStrings(List:TStrings):boolean;
//--------------------------
//-----------------------------------------------
//Создать пустую (из 2-х строк) таблицу Рейтингов
function Obj_Rating_TStringGrid_Clear(SG:TStringGrid) : boolean;
//Выгрузить рейтинги объектов в таблицу Рейтингов
function Obj_Rating_to_TStringGrid(SG:TStringGrid):boolean;
//Расчет нормированных значений рейтинга объектов и их же - в процентах
function Obj_Rating_Percent_Recalc:boolean;
//Создать пустую (из 2-х строк) таблицу правил в TStringGrid
function Rules_TStringGrid_Clear(SG:TStringGrid) : boolean;
//Экспорт таблицы правил в TStringGrid
function Rules_to_TStringGrid(SG:TStringGrid):boolean;
//Импорт таблицы правил из TStringGrid
function Rules_From_TStringGrid(SG:TStringGrid):boolean;
//-----------------------------------------------
//------------------------------------
//Установить значение свойства fObjTrain_J
function ObjTrain_Set(ObjTrainJ:integer):boolean;
//Импорт значений свойств из массива целых чисел (0-false, 1-true)
function PropsValue_from_IntArray(ArrayProp:array of integer; ArraySize:integer):boolean;
//Импорт значений свойств из TStrings ('0'-false, '1'-true)
function PropsValue_from_TStrings(ListProp:TStrings):boolean;
//Импорт значений свойств из TCheckListBox
//Если такая возможность не нужна - закомментарить (см., также, секцию Uses)
function PropsValue_from_TCheckListBox(ListProp:TCheckListBox):boolean;
//Получить значение признака, как целого числа
function PropValue_AsInteger(I:integer):integer;
//Контроль, что хотя бы один из признаков = TRUE
function PropsValue_Control:boolean;
//------------------------------------
//------------------------------------
//Конвертировать TTrainMode в String (используется в Log)
function TrainMode_to_Str(tm:TTrainMode; YesForUser:boolean=false):string;
//Конвертировать TTrainResult в String (используется в Log)
function TrainResult_to_Str(tr:TTrainResult; YesForUser:boolean=false):string;
//Конвертировать TObjTrainResult в String (используется в Log)
function ObjTrainResult_to_Str(tr:TObjTrainResult; YesForUser:boolean=false):string;
//Конвертировать TTrainProcessExit в String (используется в Log)
function TrainProcessExit_to_Str(tpe:TTrainProcessExit; YesForUser:boolean=false):string;
//------------------------------------
published
{ Published declarations }
//******************************************
//Свойства компонента (чтение/запись)
//------------------------------------
//максимальное кол-во циклов обучения
//в автоматическом режиме (защита от вечного цикла)
property TrainCycleMaxCount:integer read fTrainCycleMaxCount write fTrainCycleMaxCount;
//Кол-во цифр после запятой при округлении рейтингов объектов (%)
property RatingRoundTo:integer read fRatingRoundTo write fRatingRoundTo;
//------------------------------------
//******************************************
//******************************************
//События
//------------------------------------
//Перед стартом процесса АвтоОбучения ЭС
property BeforeTrain : TES_Common_Event read fBeforeTrain write fBeforeTrain;
//После останова/прерывания процесса АвтоОбучения ЭС
property AfterTrain : TES_Common_Event read fAfterTrain write fAfterTrain;
//В начале очередного цикла (режим АвтоОбучения)
property BeforeCycle : TES_Auto_Cycle_Before_Event read fBeforeCycle write fBeforeCycle;
//В конце очередного цикла (режим АвтоОбучения)
property AfterCycle : TES_Auto_Cycle_After_Event read fAfterCycle write fAfterCycle;
//В начале каждого шага (обучение ЭС для распознавания очередного объекта)
property BeforeStep : TES_Auto_Cycle_Step_Before_Event read fBeforeStep write fBeforeStep;
//В конце каждого шага (обучение ЭС для распознавания очередного объекта)
property AfterStep : TES_Auto_Cycle_Step_After_Event read fAfterStep write fAfterStep;
//------------------------------------
//******************************************
end;
procedure Register;
//Округление вещественного числа с заданной точностью
function RoundTo(V:extended;iRoundTo:integer=2):extended;
implementation
Const
//VersionX = '1.00 (12.09.2023)'; //Версия компонента
VersionX = '1.01 (20.09.2023)'; //Версия компонента
procedure Register;
begin
RegisterComponents('SP', [TES_bayes]);
end;
constructor TES_bayes.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
fVersion := VersionX;
//---------------------
fYesInit := false;
fRatingRoundTo := 3;
//---------------------
//---------------------
fTrainMode := ES_tmAuto;
fTrainResult := trNo;
fObjTrainResult := otrNo;
fTrainProcessExit := tpeNone;
fTrainAbort := false;
fInTraining := false;
fTrainCycleMaxCount := 100;
fTrainCycle := 0;
fTrainStep := 0;
//---------------------
//---------------------
fObjList := nil;
fObjCount := 0;
fPropList := nil;
fPropCount := 0;
fRules := nil;
//---------------------
end;
destructor TES_bayes.Destroy;
begin
Arrays_NIL;
inherited Destroy;
end;
procedure TES_bayes.Arrays_NIL;
begin
fObjList:=nil;
fObjCount := 0;
fPropList:=nil;
fPropCount := 0;
fRules:=nil;
end;
//***********************************
function TES_bayes.ObjList_Create:boolean;
begin
Result:=false;
fObjList:=nil;
if fObjCount>1 then begin
SetLength(fObjList,fObjCount);
ObjList_Clear;
Result:=true;
end;
end;
procedure TES_bayes.ObjList_Clear;
Var
J:integer;
begin
if fYesInit then begin
for J:=0 to (fObjCount-1) do
begin
fObjList[J].id:=0;
fObjList[J].Rating:=0;
fObjList[J].RatingNorm:=0;
fObjList[J].RatingPercent:=0.0;
fObjList[J].YesTrain:=false;
//fObjList[J].RatingList:='';
end;
end;
end;
procedure TES_bayes.ObjList_Rating_Clear;
//Очистить значение рейтинга у всех объктов
Var
J:integer;
begin
if fYesInit then begin
for J:=0 to (fObjCount-1) do
begin
fObjList[J].Rating:=0;
fObjList[J].RatingNorm:=0;
fObjList[J].RatingPercent:=0.0;
//fObjList[J].RatingList:='';
end;
end;
end;
procedure TES_bayes.ObjList_YesTrain_Clear;
//Сбросить флаг YesTrain у всех объктов
Var
J:integer;
begin
if fYesInit then begin
for J:=0 to (fObjCount-1) do
begin
fObjList[J].YesTrain:=false;
end;
end;
end;
procedure TES_bayes.ObjList_TrainInfo_Clear;
//Очистить значение рейтинга и сбросить флаг YesTrain
//у всех объктов
Var
J:integer;
begin
if fYesInit then begin
for J:=0 to (fObjCount-1) do
begin
fObjList[J].Rating:=0;
fObjList[J].RatingNorm:=0;
fObjList[J].RatingPercent:=0.0;
fObjList[J].YesTrain:=false;
//fObjList[J].RatingList:='';
end;
end;
end;
function TES_bayes.PropList_Create:boolean;
begin
Result:=false;
fPropList:=nil;
if fPropCount>1 then begin
SetLength(fPropList,fPropCount);
PropList_Clear;
Result:=true;
end;
end;
procedure TES_bayes.PropList_Clear;
Var
I:integer;
begin
if fPropList<>nil then begin
if Length(fPropList)=fPropCount then begin
for I:=0 to (fPropCount-1) do
begin
fPropList[I].id:=0;
fPropList[I].Yes:=false;
end;
end;
end;
end;
function TES_bayes.Rules_Create:boolean;
begin
Result:=false;
fRules:=nil;
if (fPropCount>1) and (fObjCount>1) then begin
SetLength(fRules,fPropCount, fObjCount);
Rules_Clear;
Result:=true;
end;
end;
procedure TES_bayes.Rules_Clear;
Var
I, J : integer;
begin
if fRules<>nil then begin
if (fPropCount>1) and (fObjCount>1) then begin
for I:=0 to (fPropCount-1) do
begin
for J:=0 to (fObjCount-1) do
begin
fRules[I,J]:=0;
end;
end;
end;
end;
end;
function TES_bayes.Arrays_Create:boolean;
begin
Result:=false;
if ObjList_Create then begin
if PropList_Create then begin
Result:=Rules_Create;
end;
end;
end;
procedure TES_bayes.Arrays_Clear;
begin
ObjList_Clear;
PropList_Clear;
Rules_Clear;
end;
//***********************************
function TES_bayes.Init(ObjCount:integer; PropCount:integer):boolean;
//Иницализация компонента (обязательный шаг перед использованием компонента)
begin
Result:=false;
fYesInit := false;
if not fInTraining then begin
Arrays_NIL;
if fTrainCycleMaxCount>=10 then begin
if (PropCount>1) and (ObjCount>1) then begin
//-------------------------
fTrainProcessExit := tpeNone;
fInTraining := false;
fTrainCycle := 0;
fTrainStep := 0;
fTrainAbort := false;
fTrainResult := trNo;
fObjTrainResult := otrNo;
//-------------------------
//-------------------------
fObjTrain_J := -1;
fObjTrain_Rating := 0;
//-------------------------
//-------------------------
fObjBest_J := -1;
fObjBest_Rating := 0;
//-------------------------
//-------------------------
fPropCount:=PropCount;
fObjCount:=ObjCount;
//-------------------------
//-------------------------
fYesInit:=Arrays_Create;
//-------------------------
Result:=fYesInit;
end;
end;
end;
end;
function TES_bayes.ES_Train_Start(ES_TrainMode:TTrainMode; PropsListTrue_for_EachObj:TStrings):boolean;
//Старт процесса обучения ЭС
Var
YesNext:boolean;
begin
Result:=false;
YesNext:=false;
if not fInTraining then begin
if fYesInit then begin
if Assigned(PropsListTrue_for_EachObj) then begin
if PropsListTrue_for_EachObj.Count>1 then begin
YesNext:=true;
end;
end;
end;
end;
if YesNext then begin
//-------------------------
fTrainMode := ES_TrainMode;
fTrainProcessExit := tpeNone;
fInTraining := true;
fTrainCycle := 1;
fTrainStep := 0;
fTrainAbort := false;
fTrainResult := trNo;
fObjTrainResult := otrNo;
//-------------------------
//-------------------------
fObjTrain_J := -1;
fObjTrain_Rating := 0;
//-------------------------
//-------------------------
fObjBest_J := -1;
fObjBest_Rating := 0;
//-------------------------
//-------------------------
//Очистить таблицу правил
Rules_Clear;
//-------------------------
//-------------------------
if fTrainMode=ES_tmAuto then begin
//Обучение ЭС в автоматическом режиме
Result:=ES_Train_Auto(PropsListTrue_for_EachObj);
fInTraining := false;
end
else begin
//Старт обучения ЭС в ручном режиме
Result:=ES_Train_Manual(PropsListTrue_for_EachObj);
end;
//-------------------------
end;
end;
function TES_bayes.ES_Train_Auto(PropsListTrue_for_EachObj:TStrings):boolean;
//Полный цикл обучения ЭС в автоматическом режиме
Var
J,I,v:integer;
sName,S:string;
YesExit:boolean;
ListRating:TStrings;
begin
Result:=false;
if fInTraining then begin
if Assigned(PropsListTrue_for_EachObj) then begin
if PropsListTrue_for_EachObj.Count>0 then begin
ListRating:=TStringList.Create;
TRY
fTrainCycle := 0;
fTrainStep := 0;
fObjTrainCount:= 0;
if Assigned(fBeforeTrain) then fBeforeTrain(Self);
YesExit:=false;
while not YesExit do
begin
fTrainCycle := fTrainCycle + 1;
fTrainStep := 0;
ListRating.Clear;
if Assigned(fBeforeCycle) then fBeforeCycle(Self, fTrainCycle);
J:=-1;
while J<(fObjCount-1) do
begin
J := J + 1;
fTrainStep := fTrainStep + 1;
//------------------------------------
fObjTrain_J := J;
fObjTrain_Rating := 0;
fObjBest_J := -1;
fObjBest_Rating := 0;
ListRating.Clear;
//------------------------------------
//------------------------------------
fObjList[fObjTrain_J].Rating:=0;
fObjList[fObjTrain_J].RatingNorm:=0;
fObjList[fObjTrain_J].RatingPercent:=0;
fObjList[fObjTrain_J].YesTrain:=false;
//fObjList[fObjTrain_J].RatingList:='';
//------------------------------------
if Assigned(fBeforeStep) then fBeforeStep(Self, fTrainCycle, fObjTrain_J);
//------------------------------------
//Установить в TRUE значение тех признаков, которые истинны для объекта fObjTrain_J
for I:=0 to (fPropCount-1) do
begin
fPropList[I].Yes:=false;
sName:=IntToStr(fObjTrain_J)+'_'+IntToStr(I);
S:=trim(PropsListTrue_for_EachObj.Values[sName]);
v:=StrToIntDef(S,0);
if v>0 then fPropList[I].Yes:=true;
end;
//------------------------------------
//------------------------------------
if Obj_Train_Auto(ListRating) then begin
fObjList[fObjTrain_J].YesTrain:=true;
fObjTrainCount := fObjTrainCount + 1;
if fObjTrainCount>=fObjCount then begin
//YesExit:=true;
fTrainResult := trYes; //ЭС Обучена
end;
end
else begin
fObjList[fObjTrain_J].YesTrain:=false;
fObjTrainCount := fObjTrainCount - 1;
fTrainResult := trNo; //???
end;
//------------------------------------
if Assigned(fAfterStep) then fAfterStep(Self, fTrainCycle, fObjTrain_J, fObjTrainResult);
Application.ProcessMessages;
end;
//-------------------
//fObjList[fObjTrain_J].RatingList:=ListRating.Text;
//-------------------
if fTrainAbort then begin
//Пользователь прервал обучение
fTrainProcessExit := tpeUserAbort;
fTrainResult := trNo;
YesExit := true;
end
else begin
if fTrainCycle>=fTrainCycleMaxCount then begin
//Лимит циклов на обучение превышен
fTrainProcessExit := tpeExitForLimit;
fTrainResult := trNo;
YesExit := true;
end
else begin
if fTrainResult = trYes then begin
Result:=true;
YesExit := true;
fTrainProcessExit := tpeNormal;
end;
end;
end;
if Assigned(fAfterCycle) then fAfterCycle(Self, fTrainCycle, fTrainResult, fTrainProcessExit);
Application.ProcessMessages;
end;
if Assigned(fAfterTrain) then fAfterTrain(Self);
FINALLY
FreeAndNil(ListRating);
END;
end;
end;
end;
end;
function TES_bayes.ES_Train_Manual(PropsListTrue_for_EachObj:TStrings):boolean;
//Старт обучения ЭС в ручном режиме
Var
J,I,v:integer;
sName,S:string;
begin
Result:=false;
if fInTraining then begin
if Assigned(PropsListTrue_for_EachObj) then begin
if PropsListTrue_for_EachObj.Count>0 then begin
Result:=true;
//------------------------------------
fTrainCycle := 1;
fTrainStep := 0;
fObjTrainCount:= 0;
//------------------------------------
//------------------------------------
fObjTrain_J := -1;
fObjTrain_Rating := 0;
fObjBest_J := -1;
fObjBest_Rating := 0;
//------------------------------------
end;
end;
end;
end;
function TES_bayes.ES_Train_Manual_Next(PropsListTrue_for_EachObj:TStrings):boolean;
//Обучение ЭС для очередного объекта (очередной шаг на очередном цикле)) в ручном режиме
Var
I,v:integer;
sName,S:string;
ListRat:TStrings;
begin
Result:=false;
if fInTraining then begin
if Assigned(PropsListTrue_for_EachObj) then begin
if PropsListTrue_for_EachObj.Count>0 then begin
Result:=true;
ListRat:=TStringList.Create;
TRY
//------------------------------------
fTrainStep := fTrainStep + 1;
fObjTrain_J := fObjTrain_J+1;
if fObjTrain_J>=fObjCount then begin
fTrainCycle := fTrainCycle+1;
fTrainStep := 1;
fObjTrain_J := 0;
end;
//------------------------------------
//------------------------------------
fObjTrain_Rating := 0;
fObjBest_J := -1;
fObjBest_Rating := 0;
ListRat.Clear;
//------------------------------------
//------------------------------------
fObjList[fObjTrain_J].Rating:=0;
fObjList[fObjTrain_J].RatingNorm:=0;
fObjList[fObjTrain_J].RatingPercent:=0;
fObjList[fObjTrain_J].YesTrain:=false;
//fObjList[fObjTrain_J].RatingList:='';
//------------------------------------
//------------------------------------
//Установить в TRUE значение тех признаков,
//которые истинны для объекта fObjTrain_J
for I:=0 to (fPropCount-1) do
begin
fPropList[I].Yes:=false;
sName:=IntToStr(fObjTrain_J)+'_'+IntToStr(I);
S:=trim(PropsListTrue_for_EachObj.Values[sName]);
v:=StrToIntDef(S,0);
if v>0 then fPropList[I].Yes:=true;
end;
//------------------------------------
//------------------------------------
if Obj_Train_Auto(ListRat) then begin
fObjList[fObjTrain_J].YesTrain:=true;
fObjTrainCount := fObjTrainCount + 1;
if fObjTrainCount>=fObjCount then begin
fTrainResult := trYes; //ЭС Обучена
end;
end
else begin
fObjList[fObjTrain_J].YesTrain:=false;
fObjTrainCount := fObjTrainCount - 1;
fTrainResult := trNo; //???
end;
//------------------------------------
FINALLY
FreeAndNil(ListRat);
END;
end;
end;
end;
end;
function TES_bayes.Obj_Train_Auto(ListRat:TStrings):boolean;
//Обучение ЭС для очередного объекта (очередной шаг обучения) в автоматическом или ручном режиме
Var
YesNext:boolean;
I,J,v,r,d:integer;
begin
Result:=false;
fObjTrainResult := otrNo;
YesNext:=false;
if Assigned(ListRat) then begin
ListRat.Clear;
if fInTraining then begin
if fObjTrain_J>=0 then begin
YesNext:=true;
end;
end;
end;
if YesNext then begin
//------------------------------------
//Очистить (обнулить) рейтинги объектов
ObjList_Rating_Clear;
//------------------------------------
//------------------------------------
//Вычислить рейтинги объектов
ObjList_Ratings_Calc;
//------------------------------------
//------------------------------------
//Найти объект с наилучшим рейтингом
Obj_Rating_Best_Find;
//------------------------------------
//------------------------------------
//Результат
if fObjBest_J <> fObjTrain_J then begin
//ЭС ошиблась
fObjTrainResult := otrNo;
fobjBest_J:=fObjTrain_J;
fObjBest_Rating:=fObjList[fobjBest_J].Rating;
end
else begin
if fObjBest_Rating>0 then begin
//ЭС угадала
Result:=true;
fObjTrainResult := otrYes;
end
else begin
//ЭС запуталась
fObjTrainResult := otrConfused;
fobjBest_J:=fObjTrain_J;
fObjBest_Rating:=fObjList[fobjBest_J].Rating;
end;
end;
//------------------------------------
//------------------------------------
//Перерасчет правил для всех объектов,
//кроме объекта с наилучшим рейтингом
ObjList_Any_Rules_ReCalc;
//------------------------------------
//------------------------------------
//Перерасчет правил для объекта с наилучшим рейтингом
ObjBest_Rules_ReCalc;
//------------------------------------
//------------------------------------
//Нормирование рейтингов объектов
Obj_Rating_Percent_Recalc;
//------------------------------------
end;
end;
function TES_bayes.Rules_Cell_Get(I, J : integer):integer;
//Прочитать значение ячейки из таблицы правил
begin
Result:=-999999999;
if fRules<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
if (I>=0) and (I<=(fPropCount-1)) then begin
Result:=fRules[I,J];
end;
end;
end;
end;
function TES_bayes.Rules_Cell_Set(I, J, V : integer):boolean;
//Записать значение ячейки в таблицу правил
begin
Result:=false;
if fRules<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
if (I>=0) and (I<=(fPropCount-1)) then begin
fRules[I,J]:=V;
Result:=true;
end;
end;
end;
end;
function TES_bayes.ES_Train_Exit_Normal:boolean;
//Нормальное завершение процесса обучения ЭС
//Т.е., ЭС обучена
begin
Result:=false;
if fInTraining then begin
//if fTrainResult = trYes then Result:=true;
Result := true;
fTrainResult := trYes;
fTrainProcessExit := tpeNormal;
fInTraining := false;
fTrainAbort := false;
end;
end;
procedure TES_bayes.ES_Train_Exit_UserAbort;
//Завершение (прерывание) процесса обучения ЭС по требованию пользователя
begin
if fInTraining then begin
fInTraining := false;
fTrainAbort := true;
if (fTrainMode = ES_tmAuto) then fTrainResult := trNo;
fTrainProcessExit := tpeUserAbort;
end;
end;
procedure TES_bayes.ES_Train_ExitForLimit;
//Завершение (прерывание) процесса обучения ЭС из-за превышения лимита циклов на обучение
begin
if fInTraining then begin
fInTraining := false;
fTrainAbort := false;
fTrainResult := trNo;
fTrainProcessExit := tpeExitForLimit;
end;
end;
function TES_bayes.Obj_Id_Get(J:integer):integer;
//Прочитать Id объекта по его индексу
begin
Result:=0;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
Result:=fObjList[J].Id;
end;
end;
end;
function TES_bayes.Obj_Id_Set(J:integer; V:integer):boolean;
//Записать Id объекта по его индексу
begin
Result:=false;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
if V>0 then begin
fObjList[J].Id:=V;
Result:=true;
end;
end;
end;
end;
function TES_bayes.Obj_Rating_Get(J:integer):integer;
//Прочитать Рейтинг объекта по его индексу
begin
Result:=0;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
Result:=fObjList[J].Rating;
end;
end;
end;
function TES_bayes.Obj_Rating_Set(J:integer; V:integer):boolean;
//Записать Рейтинг объекта по его индексу
begin
Result:=false;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
fObjList[J].Rating:=V;
Result:=true;
end;
end;
end;
function TES_bayes.Obj_RatingNorm_Get(J:integer):integer;
//Прочитать нормированный Рейтинг объекта по его индексу
begin
Result:=0;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
Result:=fObjList[J].RatingNorm;
end;
end;
end;
function TES_bayes.Obj_RatingNorm_Set(J:integer; V:integer):boolean;
//Записать нормированный Рейтинг объекта по его индексу
begin
Result:=false;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
fObjList[J].RatingNorm:=V;
Result:=true;
end;
end;
end;
function TES_bayes.Obj_RatingPercent_Get(J:integer):Real;
//Прочитать Рейтинг объекта (%) по его индексу
begin
Result:=0;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
Result:=fObjList[J].RatingPercent;
end;
end;
end;
function TES_bayes.Obj_RatingPercent_Set(J:integer; V:Real):boolean;
//Записать Рейтинг объекта (%) по его индексу
begin
Result:=false;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
fObjList[J].RatingPercent:=V;
Result:=true;
end;
end;
end;
function TES_bayes.Obj_YesTraing_Get(J:integer):boolean;
//Прочитать Флаг YesTrain объекта по его индексу
begin
Result:=false;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
Result:=fObjList[J].YesTrain;
end;
end;
end;
function TES_bayes.Obj_YesTraing_Set(J:integer; V:boolean):boolean;
//Записать Флаг YesTrain объекта по его индексу
begin
Result:=false;
if fObjList<>nil then begin
if (J>=0) and (J<=(fObjCount-1)) then begin
fObjList[J].YesTrain:=V;
Result:=true;
end;
end;
end;
function TES_bayes.Prop_Yes_Get(I:integer):boolean;
//Прочитать значение признака (свойства) по его индексу
begin
Result:=false;
if fPropList<>nil then begin
if (I>=0) and (I<=(fPropCount-1)) then begin
Result:=fPropList[I].Yes;
end;
end;
end;
function TES_bayes.Prop_Yes_Set(I:integer; V:boolean):boolean;
//Зписать значение признака (свойства) по его индексу
begin
Result:=false;
if fPropList<>nil then begin
if (I>=0) and (I<=(fPropCount-1)) then begin
fPropList[I].Yes:=V;
Result:=true;
end;
end;
end;
function TES_bayes.Prop_Id_Get(I:integer):integer;
//Прочитать Id признака (свойства) по его индексу
begin
Result:=0;
if fPropList<>nil then begin
if (I>=0) and (I<=(fPropCount-1)) then begin
Result:=fPropList[I].Id;
end;
end;
end;
function TES_bayes.Prop_Id_Set(I:integer; V:integer):boolean;
//Записать Id признака (свойства) по его индексу
begin
Result:=false;
if fPropList<>nil then begin
if (I>=0) and (I<=(fPropCount-1)) then begin
if V>0 then begin
fPropList[I].Id:=V;
Result:=true;
end;
end;
end;
end;
function TES_bayes.Obj_Add(Id:integer):integer;
//Добавить объект. Возвращаемое значение: значение J объекта (начиная с нуля)
Var
J:integer;
begin
Result:=-1;
if fObjList<>nil then begin
if Id>0 then begin
J:=-1;
while J<(fObjCount-1) do
begin
J:=J+1;
if fObjList[J].id<=0 then begin
Result:=J;
fObjList[J].id:=Id;
fObjList[J].Rating:=0;
fObjList[J].RatingNorm:=0;
fObjList[J].RatingPercent:=0;
fObjList[J].YesTrain:=false;
//fObjList[J].RatingList:='';
J:=(fObjCount+1);
end;
end;
end;
end;
end;
function TES_bayes.Prop_Add(Id:integer; Yes:boolean=false):integer;
//Добавить признак. Возвращаемое значение: значение I признака (начиная с нуля)
Var
I:integer;
begin
Result:=-1;
if fPropList<>nil then begin
if Id>0 then begin
I:=-1;
while I<(fPropCount-1) do
begin
I:=I+1;
if fPropList[I].id<=0 then begin
Result:=I;
fPropList[I].id:=Id;
fPropList[I].Yes:=Yes;
I:=(fPropCount+1);
end;
end;
end;
end;
end;
function TES_bayes.ObjList_LoadFromTStrings(List:TStrings):boolean;
//Импорт объектов из TStrings
//Формат List:
// id=ЛюбоеЗначение;
Var
J:integer;
Id:integer;
begin
Result:=false;
if fObjList<>nil then begin
if Assigned(List) then begin
if List.Count=fObjCount then begin
Result:=true;
J:=-1;
while J<(List.Count-1) do
begin
J:=J+1;
Id:=StrToIntDef(trim(List.Names[J]),0);
if Id>0 then begin
if Obj_Add(Id)<0 then begin
Result:=false;
J:=(List.Count+1);
end;
end
else begin
Result:=false;
J:=(List.Count+1);
end;
end;
end;
end;
end;
end;
function TES_bayes.PropList_LoadFromTStrings(List:TStrings):boolean;
//Импорт признаков из TStrings
//Формат List:
// id=0или1;
Var
I:integer;
Id:integer;
N:integer;
Yes:boolean;
begin
Result:=false;
if fPropList<>nil then begin
if Assigned(List) then begin
if List.Count=fPropCount then begin
Result:=true;
I:=-1;
while I<(List.Count-1) do
begin
I:=I+1;
Id:=StrToIntDef(trim(List.Names[I]),0);
if Id>0 then begin
N:=StrToIntDef(trim(List.Values[trim(List.Names[I])]),0);
Yes:=false;
if N>0 then Yes:=true;
if Prop_Add(Id, Yes)<0 then begin
Result:=false;
I:=(List.Count+1);
end;
end
else begin
Result:=false;
I:=(List.Count+1);
end;
end;
end;
end;
end;
end;
//**************************************
function TES_bayes.TrainMode_to_Str(tm:TTrainMode; YesForUser:boolean=false):string;
//Конвертировать TTrainMode в String (используется в Log)
begin
Result:='???';
if not YesForUser then begin
if tm=ES_tmAuto then Result:='ES_tmAuto';
if tm=ES_tmManual then Result:='ES_tmManual';
end
else begin
if tm=ES_tmAuto then Result:='Автоматический';
if tm=ES_tmManual then Result:='Ручной';
end;
end;
function TES_bayes.TrainResult_to_Str(tr:TTrainResult; YesForUser:boolean=false):string;
//Конвертировать TTrainResult в String (используется в Log)
begin
Result:='???';
if not YesForUser then begin
if tr=trNo then Result:='trNo';
if tr=trYes then Result:='trYes';
end
else begin
if tr=trNo then Result:='ЭС не обучена';
if tr=trYes then Result:='ЭС обучена';
end;
end;
function TES_bayes.ObjTrainResult_to_Str(tr:TObjTrainResult; YesForUser:boolean=false):string;
//Конвертировать TObjTrainResult в String (используется в Log)
begin
Result:='???';
if not YesForUser then begin
if tr=otrNo then Result:='otrNo';
if tr=otrYes then Result:='otrYes';
if tr=otrConfused then Result:='otrConfused';
end
else begin
if tr=otrNo then Result:='Нет';
if tr=otrYes then Result:='Да';
if tr=otrConfused then Result:='ЭС запуталась';
end;
end;
function TES_bayes.TrainProcessExit_to_Str(tpe:TTrainProcessExit; YesForUser:boolean=false):string;
//Конвертировать TTrainProcessExit в String (используется в Log)
begin
Result:='???';
if not YesForUser then begin
if tpe=tpeNone then Result:='tpeNone';
if tpe=tpeNormal then Result:='tpeNormal';
if tpe=tpeUserAbort then Result:='tpeUserAbort';
if tpe=tpeExitForLimit then Result:='tpeExitForLimit';
end
else begin
if tpe=tpeNone then Result:='Обучение незавершено';
if tpe=tpeNormal then Result:='Нормальное завершение';
if tpe=tpeUserAbort then Result:='По требованию пользователя';
if tpe=tpeExitForLimit then Result:='Превышен лимит обучения';
end;
end;
//**************************************
function TES_bayes.Obj_Rating_TStringGrid_Clear(SG:TStringGrid) : boolean;
//Создать пустую (из 2-х строк) таблицу Рейтингов
begin
Result:=false;
if Assigned(SG) then begin
//SG.ColCount:=7;
SG.ColCount:=6;
SG.RowCount:=2;
SG.Rows[0].Clear;
SG.Rows[1].Clear;
SG.Cells[0,0]:='J';
SG.Cells[1,0]:='Объект';
SG.Cells[2,0]:='Рейтинг';
SG.Cells[3,0]:='Рейтинг(норм)';
SG.Cells[4,0]:='Рейтинг,%';
SG.Cells[5,0]:='id';
Result:=true;
end;
end;
function TES_bayes.Obj_Rating_to_TStringGrid(SG:TStringGrid):boolean;
//Экспорт рейтинга объектов в TStringGrid
Var
J:integer;
begin
Result:=false;
if Assigned(SG) then begin
Obj_Rating_TStringGrid_Clear(SG);
if fObjList<>nil then begin
if fObjCount>1 then begin
Result:=true;
Obj_Rating_Percent_Recalc;
J:=-1;
while J<(fObjCount-1) do
begin
J:=J+1;
if J>0 then begin
SG.RowCount:=SG.RowCount+1;
end;
SG.Cells[0,SG.RowCount-1]:=IntToStr(J+1);
//SG.Cells[1,SG.RowCount-1]:=''; //сомнительно...
SG.Cells[2,SG.RowCount-1]:=IntToStr(fObjList[J].Rating);
SG.Cells[3,SG.RowCount-1]:=IntToStr(fObjList[J].RatingNorm);
SG.Cells[4,SG.RowCount-1]:=FloatToStr(fObjList[J].RatingPercent);
SG.Cells[5,SG.RowCount-1]:=IntToStr(fObjList[J].id);
end;
end;
end;
end;
end;
function TES_bayes.Obj_Rating_Percent_Recalc:boolean;
//Расчет нормированнных значений рейтинга объектов и их же - в процентах
Var
J:integer;
vMin, vNorm, vSum, v : integer;
Rat,vW:real;
begin
Result:=false;
if fYesInit then begin
Result:=true;
if fRatingRoundTo<0 then fRatingRoundTo:=0;
if fRatingRoundTo>5 then fRatingRoundTo:=5;
vMin:=999999999;
vSum:=0;
for J:=0 to (fObjCount-1) do
begin
v:=fObjList[J].Rating;
if vMin>v then vMin:=v;
end;
for J:=0 to (fObjCount-1) do
begin
v:=fObjList[J].Rating;
vNorm:=v-vMin;
vSum:=vSum+vNorm;
fObjList[J].RatingNorm:=vNorm;
end;
for J:=0 to (fObjCount-1) do
begin
v:=fObjList[J].RatingNorm;
vW:=v;
if vSum<>0 then vW:=(v/vSum)*100;
Rat:=RoundTo(vW,fRatingRoundTo);
fObjList[J].RatingPercent:=Rat;
end;
end;
end;
function TES_bayes.Rules_TStringGrid_Clear(SG:TStringGrid) : boolean;
//Создать пустую (из 2-х строк) таблицу правил в TStringGrid
begin
Result:=false;
if Assigned(SG) then begin
SG.ColCount:=2;
SG.RowCount:=2;
SG.Rows[0].Clear;
SG.Rows[1].Clear;
SG.Cells[1,1]:='0';
SG.Cells[0,0]:=' i \ j ';
Result:=true;
end;
end;
function TES_bayes.Rules_From_TStringGrid(SG:TStringGrid):boolean;
//Импорт таблицы правил из TStringGrid
Var
I,J, v:integer;
S:string;
begin
Result:=false;
if fYesInit then begin
if Assigned(SG) then begin
for I:=1 to (SG.RowCount-1) do
begin
for J:=1 to (SG.ColCount-1) do
begin
v:=StrToIntDef(SG.Cells[J,I],0);
fRules[I-1,J-1]:=v;
end;
end;
end;
end;
end;
function TES_bayes.Rules_to_TStringGrid(SG:TStringGrid):boolean;
//Экспорт таблицы правил в TStringGrid
Var
I, J, Row, Col : integer;
begin
Result:=false;
if Assigned(SG) then begin
Rules_TStringGrid_Clear(SG);
if fRules<>nil then begin
if (fPropCount>1) and (fObjCount>1) then begin
Result:=false;
SG.ColCount:=fObjCount+1;
SG.RowCount:=fPropCount+1;
for Row:=1 to (SG.RowCount-1) do
begin
SG.Rows[Row].Clear;
SG.Cells[0, Row]:=IntToStr(Row);
end;
for Col:=1 to (SG.ColCount-1) do
begin
SG.Cells[Col, 0]:=IntToStr(Col);
end;
Row:=0;
for I:=0 to (fPropCount-1) do
begin
Row:=Row+1;
//SG.Rows[Row].Clear;
Col:=0;
for J:=0 to (fObjCount-1) do
begin
Col:=Col+1;
SG.Cells[Col, Row]:=IntToStr(fRules[I,J]);
end;
end;
end;
end;
end;
end;
function TES_bayes.PropsValue_from_TCheckListBox_to_TSTrings(ListFrom:TCheckListBox; ListTo:TStrings):boolean;
//Конвертация значений признаков (свойств) из TCheckListBox в TStrings
Var
I,v:integer;
begin
Result:=false;
if Assigned(ListTo) then begin
ListTo.Clear;
for I:=0 to (ListFrom.Items.Count-1) do
begin
v:=0;
if ListFrom.Checked[I] then v:=1;
ListTo.Add(IntToStr(v));
end;
if ListTo.Count>1 then Result:=true;
end;
end;
function TES_bayes.PropsValue_from_IntArray(ArrayProp:array of integer; ArraySize:integer):boolean;
//Импорт значений свойств из массива целых чисел (0-false, 1-true)
Var
I:integer;
begin
Result:=false;
if fYesInit then begin
if ArraySize=fPropCount then begin
Result:=true;
for I:=0 to (fPropCount-1) do
begin
if ArrayProp[I]<=0 then begin
fPropList[I].Yes:=false;
end
else begin
fPropList[I].Yes:=true;
end;
end;
end;
end;
end;
function TES_bayes.PropsValue_from_TStrings(ListProp:TStrings):boolean;
//Импорт значений свойств из TStrings ('0'-false, '1'-true)
Var
I,v:integer;
begin
Result:=false;
if fYesInit then begin
if Assigned(ListProp) then begin
if ListProp.Count=fPropCount then begin
Result:=true;
for I:=0 to (fPropCount-1) do
begin
v:=StrToIntDef(trim(ListProp[I]),0);
if v<=0 then begin
fPropList[I].Yes:=false;
end
else begin
fPropList[I].Yes:=true;
end;
end;
end;
end;
end;
end;
function TES_bayes.PropsValue_from_TCheckListBox(ListProp:TCheckListBox):boolean;
//Импорт значений признаколв из TCheckListBox
//Если такая возможность не нужна - закомментарить (см., также, секцию Uses)
Var
I:integer;
begin
Result:=false;
if fYesInit then begin
if Assigned(ListProp) then begin
if ListProp.Items.Count=fPropCount then begin
Result:=true;
for I:=0 to (fPropCount-1) do
begin
fPropList[I].Yes:=ListProp.Checked[I];
end;
end;
end;
end;
end;
function TES_bayes.PropsValue_Control:boolean;
//Контроль, что хотя бы один из признаков = TRUE
Var
I:integer;
begin
Result:=false;
if fYesInit then begin
I:=-1;
while I<(fPropCount-1) do
begin
I:=I+1;
if fPropList[I].Yes then begin
Result:=true;
I:=(fPropCount+1);
end;
end;
end;
end;
function TES_bayes.PropValue_AsInteger(I:integer):integer;
//Получить значение признака, как целого числа
begin
//Result:=-1;
Result:=0;
if fYesInit then begin
if (I>=0) and (I
Result:=1;
end
else begin
Result:=0;
end;
end;
end;
end;
function TES_bayes.ObjTrain_Set(ObjTrainJ:integer):boolean;
//Установить значение свойства fObjTrain_J
begin
Result:=false;
fObjTrain_J:=-1;
fObjTrain_Rating:=0;
if fYesInit then begin
if fInTraining then begin
if (ObjTrainJ>=0) and (ObjTrainJ
fObjTrain_J:=ObjTrainJ;
end;
end;
end;
end;
function TES_bayes.ObjList_Ratings_Calc:boolean;
//Расчет рейтингов объектов по текущим правилам
Var
I,J:integer;
v,d,r:integer;
begin
Result:=false;
if fYesInit then begin
Result:=true;
for I:=0 to (fPropCount-1) do
begin
v:=PropValue_AsInteger(I);
for J:=0 to (fObjCount-1) do
begin
d := fObjList[J].Rating;
r := fRules[I,J];
d := d + v*r;
fObjList[J].Rating := d;
end;
end;
end;
end;
function TES_bayes.Obj_Rating_Best_Find:boolean;
//Поиск объекта с наилучшим рейтингом
Var
J:integer;
begin
Result:=false;
fObjBest_J := -999999999;
fObjBest_Rating := -999999999;
if fYesInit then begin
for J:=0 to (fObjCount-1) do
begin
if fObjList[J].Rating>fObjBest_Rating then begin
fObjBest_Rating:=fObjList[J].Rating;
fObjBest_J:=J;
end;
end;
if fObjBest_J>=0 then begin
Result:=true;
end;
end;
end;
function TES_bayes.ES_right:boolean;
//ЭС распознала объект?
begin
Result:=false;
if fInTraining then begin
if fObjTrain_J>=0 then begin
if fObjBest_J = fObjTrain_J then begin
if fObjBest_Rating>0 then begin
Result:=true;
end;
end;
fObjList[fObjTrain_J].YesTrain:=Result;
end;
end;
end;
function TES_bayes.ES_Recognized_All_Objects:boolean;
//Проверка: ЭС все объекты распознала?
Var
J:integer;
begin
Result:=false;
if fInTraining then begin
Result:=true;
J:=-1;
while J<(fObjCount-1) do
begin
J:=J+1;
if not fObjList[J].YesTrain then begin
Result:=false;
J:=(fObjCount+1);
end;
end;
end;
end;
function TES_bayes.ObjList_Any_Rules_ReCalc:boolean;
//Перерасчет правил для всех объектов (с рейтингом не хуже распознаваемого), кроме распознаваемого
Var
I,J:integer;
v,d,r:integer;
begin
Result:=false;
if fInTraining then begin
if fObjTrain_J>=0 then begin
Result:=true;
for J:=0 to (fObjCount-1) do
begin
d := fObjList[J].Rating;
if (d>=fObjBest_Rating) and (J<>fObjBest_J) then begin
for I:=0 to (fPropCount-1) do
begin
v:=PropValue_AsInteger(I);
r := fRules[I,J];
r := r - v;
fRules[I,J]:=r;
end;
end;
end;
end;
end;
end;
function TES_bayes.ObjBest_Rules_ReCalc:boolean;
//Перерасчет правил для заданного объекта fObjBest_J
//(в текущей версии - это fObjTrain_J)
Var
I,J:integer;
v,d,r:integer;
begin
Result:=false;
if fInTraining then begin
if fObjBest_J>=0 then begin
Result:=true;
for I:=0 to (fPropCount-1) do
begin
v:=PropValue_AsInteger(I);
r := fRules[I,fObjBest_J];
r := r + v;
fRules[I,fObjBest_J]:=r;
end;
end;
end;
end;
//****************************
//****************************
//****************************
function TES_bayes.Obj_Recognize(ListProp:TCheckListBox; ListFuzzi:TStrings=nil):integer;
//Распознать объект (использование ЭС по назначению - для распознавания объектов)
Var
J :integer;
YesNext:boolean;
ListPropBuf:TStrings;
begin
Result:=-1;
if Assigned(ListFuzzi) then ListFuzzi.Clear;
YesNext:=false;
if fRules<>nil then begin
if fObjList<>nil then begin
if fPropList<>nil then begin
if (fPropCount>1) and (fObjCount>1) then begin
if Assigned(ListProp) then begin
if ListProp.Items.Count=fPropCount then begin
YesNext:=true;
end;
end;
end;
end;
end;
end;
if YesNext then begin
ListPropBuf:=TStringList.Create;
TRY
//-------------------
//Конвертация значений признаков (свойств) из TCheckListBox в TStrings
PropsValue_from_TCheckListBox_to_TSTrings(ListProp, ListPropBuf);
//-------------------
//-------------------
//Распознавание объекта по признакам
Result:=Obj_Recognize(ListPropBuf, ListFuzzi);
//-------------------
FINALLY
FreeAndNil(ListPropBuf);
END;
end;
end;
function TES_bayes.Obj_Recognize(ListProp:TStrings; ListFuzzi:TStrings=nil):integer;
//Распознать объект (использование ЭС по назначению - для распознавания объектов)
Var
J :integer;
YesNext:boolean;
begin
Result:=-1;
if Assigned(ListFuzzi) then ListFuzzi.Clear;
YesNext:=false;
if fRules<>nil then begin
if fObjList<>nil then begin
if fPropList<>nil then begin
if (fPropCount>1) and (fObjCount>1) then begin
if Assigned(ListProp) then begin
if ListProp.Count=fPropCount then begin
YesNext:=true;
end;
end;
end;
end;
end;
end;
if YesNext then begin
//-------------------
//"Обнуление" объектов
ObjList_TrainInfo_Clear;
//-------------------
//-------------------
//Конвертация значений признаков,
//переданных в параметре ListProp,
//в их внутренне представление
PropsValue_from_TStrings(ListProp);
//-------------------
//-------------------
//Расчет рейтингов объектов по текущим правилам
ObjList_Ratings_Calc;
//-------------------
//-------------------
//Поиск объекта с наилучшим рейтингом
//(в общем случае их может быть и несколько)
Obj_Rating_Best_Find;
Result:=fObjBest_J;
//-------------------
//-------------------
//Получение списка объектов с наивысшим рейтингом
//(в общем случае их может быть и несколько)
for J:=0 to (fObjCount-1) do
begin
if fObjList[J].Rating>=fObjBest_Rating then begin
if Assigned(ListFuzzi) then ListFuzzi.Add(IntToStr(J));
end;
end;
//-------------------
//-------------------
//Нормирование рейтингов объектов
Obj_Rating_Percent_Recalc;
//-------------------
end;
end;
//****************************
//****************************
//****************************
//****************************
//****************************
function iPower_10(N:integer):int64;
//вычисление 10 в степени N (без проверок на переполнение)
Var
i:integer;
begin
Result:=0;
if n>0 then begin
Result:=1;
for i:=1 to N do
begin
Result:=Result*10;
end;
end;
end;
function RoundTo(V:extended;iRoundTo:integer=2):extended;
//Округление вещественного числа с заданной точностью
Var
Sx:string;
N,iRes : int64;
begin
Result:=V;
if iRoundTo>0 then begin
N:=iPower_10(iRoundTo);
if N>0 then begin
iRes:=round(Result*N);
Result:=iRes/N;
end;
end
else begin
Result:=round(V);
end;
end;
//****************************
//****************************
end.