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

unit logic;

interface
uses Attribute,Instances,RuleItem,Modul,Classes,DmmConstants,Forms;

{Процедура обратного вывода}
procedure Execute(rule1:TList;inst1:TDMInstances;OC:integer);
{Процедура ответа на вопрос при первичном вводе значений атрибутов}
procedure OtvetPoch_1v(i: integer);

{Процедуры из обратного вывода}
procedure in_steck(var steck : TList; atrindex : integer;atrval:double); {закпись в стек}
procedure out_steck(var steck : TList); {выталкивание из стека}
function poisk_pravila(rule: TList; AtrInd:integer;var active_rule: array of boolean;var nom:integer):boolean; {поиск правила}
function znachen_pravila(rule:TList;nom:integer;inst_size:integer; steck:Tlist;var index:integer):integer; {значение правила}
procedure rule_true(var steck_f,steck_c:TList;nom:integer;Rule:TList;var flag:boolean); {правило истинно}
procedure zapomn_cel(var steck : TList;index:integer); {запомнить цель}
procedure print_cel(steck_f:TList;inst:TDMInstances); {печать значения цели}
procedure Icannot;
procedure TakeVal(index:integer;val:double{;var steck_f:TList}); {Взять значение}
procedure Otv_Poch(nom:integer;rule:TList;inst:TDMInstances;sys:integer); {Ответить ПОЧЕМУ}
procedure Otv_Kak(ind:integer;list_rules:TList;rule:TList;inst:TDMInstances); {Ответить КАК}
procedure initlogic(rule1:TList;inst1:TDMInstances;OC : integer);
procedure Execute_all(rule1:TList;inst1:TDMInstances;OC : integer);
procedure Free();
implementation

uses SysUtils,ItemSet;
var g_ind:integer; {Значения запрошенного атрибута}
g_value:double;
active_rules: array of boolean; {Массив активных правил}
steck_f,steck_c,list_rules:TList;

{закпись в сtек}
procedure in_steck(var steck : TList; atrindex : integer;atrval:double);
var atr1:^TElemSteck;
atr:TElemSteck;
begin
{тело процедуры}
{Запись в стек на место следующее за последним элементом}
new(atr1);
atr:=TElemSteck.Create(atrindex,atrval);

atr1^:=atr;

steck.Insert(steck.Count,atr1);

end;

{выталкивание из стека}
procedure out_steck(var steck : TList);
begin
{тело процедуры}

{удаляем из конца списка}
steck.Delete(steck.Count-1);
end;

{поиск правила} {наличие соотв индекса в правилах и не закрытого}
function poisk_pravila(rule: TList; AtrInd:integer;var active_rule: array of boolean;var nom:integer):boolean;
var
i:integer;
rul:TDMRuleItem; {!!!!!!!!!!!!!!}
begin
{тело процедуры}
{Проверяем, содержит ли правая часть данный набор}
{Поиск сводится к поиску индекса соотв атрибута среди ItemSetов}
//new(rul);

for i:=0 to rule.Count-1 do
begin
rul:=rule.Items[i];

if (rul.m_premise.m_condidtions[AtrInd]>IMIN_VALUE) then {active_rule[i]:=false}
else
if (rul.m_consequence.m_condidtions[AtrInd]>IMIN_VALUE) and (active_rule[i]=true) then
begin poisk_pravila:=true; nom:=i; exit; end;

end;
poisk_pravila:=false;
end;

{значение правила}
function znachen_pravila(rule:TList;nom:integer;inst_size:integer; steck:Tlist;var index:integer):integer;
var i,j,cnt:integer;
res:integer;
rul:TDMRuleItem;
fakt:^TElemSteck;
s:string;
begin
{тело процедуры}
index:=-1;
//new(rul);
new(fakt);
{Если все значения из правой части правила содержаться в стеке фактов,то
правило истинно}
rul:= rule.Items[nom];

for i:=0 to inst_size-1 do
if (rul.m_premise.m_condidtions[i]>IMIN_VALUE) then begin
cnt:=0;
for j:=0 to steck.Count-1 do begin
fakt:= steck.Items[j];
if (i=fakt.index) then
begin
cnt:=1;
if ((rul.m_premise.m_items[i]=fakt.val)and(rul.m_premise.m_condidtions[i]=0))or
((rul.m_premise.m_items[i]<=fakt.val)and(rul.m_premise.m_condidtions[i]=1))or
((rul.m_premise.m_items[i]>=fakt.val)and(rul.m_premise.m_condidtions[i]=-1))
then res:=0
else begin result:=1; exit; end;
end;

end;
if cnt=0 then begin result:=2;index:=i;exit; end;
end;
result:=res;
end;

{правило истинно}
procedure rule_true(var steck_f,steck_c:TList;nom:integer;Rule:TList;var flag:boolean);
var fakt:^TElemSteck;
rul:TDMRuleItem;
begin
new(fakt);
//new(rul);
{тело процедуры}
rul:=Rule.Items[nom];

fakt:= steck_c.Items[steck_c.Count-1];

in_steck(steck_f,fakt.index,rul.m_consequence.m_items[fakt.index]); {запись в стек фактов}
out_steck(steck_c);

if steck_c.Count=0 then flag:=false else flag:=true;

end;

{запомнить цель}
procedure zapomn_cel(var steck : TList;index:integer);

begin
{тело процедуры}

in_steck(steck, index,0)

end;

{печать значения цели}
procedure print_cel(steck_f:TList;inst:TDMInstances);
var fakt:^TElemSteck;
i:integer;
begin
{тело процедуры}
new(fakt);
ExpertMod.Memo1.Clear;
ExpertMod.Memo1.Lines.Add('*****************************************');
ExpertMod.Memo1.Lines.Add('Значение основной выведено успешно.');
ExpertMod.Memo1.Lines.Add('*****************************************');
ExpertMod.TakeSys(3);
fakt:= steck_f.Items[steck_f.Count-1];
ExpertMod.Memo1.Lines.Add(inst.attribute(fakt.index).name);

if inst.attribute(fakt.index).attributeType=1 then ExpertMod.Memo1.Lines.Add('равно '+FloatToStr(fakt.val));
if inst.attribute(fakt.index).attributeType=2 then ExpertMod.Memo1.Lines.Add('равно '+inst.attribute(fakt.index).value(round(fakt.val)));
end;

{Процедура начальной инициализации}
procedure initlogic(rule1:TList;inst1:TDMInstances;OC : integer);
var i:integer;
begin
{Инициализация всех списков}
steck_f:=TList.Create;
steck_f.Clear;
steck_c:=TList.Create;
steck_c.Clear;
list_rules:=TList.Create;
list_rules.Clear;

{делаем все правила активными}
SetLength(active_rules, rule1.Count);
for i:=0 to rule1.Count-1 do
active_rules[i]:=true;

{Заполнение стека фактов данными из первичного ввода}

for i:=0 to inst1.instance(i).numAttributes-1 do
if inst1.instance(i).value(2)=1 then in_steck(steck_f,i,inst1.instance(i).value(1));

{Занесение основной цели в стек целей}
in_steck(steck_c,OC,0);

end;

{Процедура обратного вывода}
procedure Execute(rule1:TList;inst1:TDMInstances;OC : integer);
var
flag,flag1: boolean; {Флаг готовности}
i,nom,index:integer;
val:double;
fakt:^TElemSteck;

begin
if (g_ind<>-1) and (g_value<>-1) then
begin in_steck(steck_f,g_ind,g_value);
g_ind:=-1;
g_value:=-1;
out_steck(steck_c);
end;

new(fakt);
{Готовность = false}
flag:=true;

{Пока не будет установлен флаг готовности}
while flag do
begin
flag1:=true;
fakt:= steck_c.Items[steck_c.Count-1];// as TElemSteck;

if poisk_pravila(rule1,fakt.index, active_rules,nom) then
begin
case znachen_pravila(rule1,nom,inst1.numAttributes,steck_f,index) of
0:{истина} begin rule_true(steck_f,steck_c,nom,rule1,flag1); flag:=flag1; in_steck(list_rules,nom,0); end;
1:{ложь} active_rules[nom]:=false;
2:{не определено} zapomn_cel(steck_c,index);
end;
end
else {нет правил}
if fakt.index=OC then {Была основная цель}
begin
Icannot; {Не можем вывести}
flag:=false;
end
else
begin
ExpertMod.TakeVal(nom,list_rules); {пересылка значений в modul}
ExpertMod.otvet(index); {Запросит значение}
break;
end;

end;
ExpertMod.TakeVal(nom,list_rules); {пересылка значений в modul}
if steck_c.Count=0 then print_cel(steck_f,inst1);
end;

procedure Execute_all(rule1:TList;inst1:TDMInstances;OC : integer);
begin
TakeVal(-1,-1);
logic.initlogic(rule1,inst1,OC);
logic.Execute(rule1,inst1,OC);
end;

{Выводит ответ на вопрос "Почему?" при первом вводе}
procedure OtvetPoch_1v(i: integer);
begin
if i=2 then begin
ExpertMod.Memo1.Lines.Add('*****************************************');
ExpertMod.Memo1.Lines.Add('Данный атрибут запрашивается, чтобы узнать состояние исследуемой');
ExpertMod.Memo1.Lines.Add('предметной области в данный момент времени.');
ExpertMod.Memo1.Lines.Add('');
ExpertMod.Memo1.Lines.Add('Введение всех атрибутов поможет системе быстрее получить результат.');
ExpertMod.Memo1.Lines.Add('');
ExpertMod.Memo1.Lines.Add('Вы можете не вводить это значение, тогда оно будет запрошено во время');
ExpertMod.Memo1.Lines.Add('выполнения логического вывода, и у Вас будет возможность узнать более полную информацию об атрибуте.');
ExpertMod.Memo1.Lines.Add('*****************************************');
end
else begin
ExpertMod.Memo1.Lines.Add('*****************************************');
ExpertMod.Memo1.Lines.Add('Значение атрибута вводится во второе поле,');
ExpertMod.Memo1.Lines.Add('расположенное под полем названия атрибута.');
ExpertMod.Memo1.Lines.Add('');
ExpertMod.Memo1.Lines.Add('Если атрибут числовой, то значение должно быть вещественным числом.');
ExpertMod.Memo1.Lines.Add('');
ExpertMod.Memo1.Lines.Add('Если атрибут номинальный, достаточно ввести либо номер атрибута из приведенного списка,');
ExpertMod.Memo1.Lines.Add('либо значение целым словом, либо первой буквой значения.');
ExpertMod.Memo1.Lines.Add('*****************************************');
end;
end;

{Сообщает, что основная цель недосижима}
procedure Icannot;
begin
ExpertMod.Memo1.Clear;
ExpertMod.Memo1.Lines.Add('*****************************************');
ExpertMod.Memo1.Lines.Add('Значение заданной Вами основной цели не может быть ');
ExpertMod.Memo1.Lines.Add('получено из-за недостаточности информации');
ExpertMod.Memo1.Lines.Add('в распоряжении системы.');
ExpertMod.Memo1.Lines.Add('*****************************************');
end;

{Вызывается из modul заносит полученные значения в стек фактов}
procedure TakeVal(index:integer;val:double);
begin
g_ind:= index;
g_value:=val;
end;

{отвечает на вопрос "Почему"}
procedure Otv_Poch(nom:integer;rule:TList;inst:TDMInstances;sys:integer);
var rul:TDMRuleItem;
i:integer;
s:String;
begin
//new(rul);
ExpertMod.Memo1.Lines.Add('');
if sys = 3 then begin
ExpertMod.Memo1.Lines.Add('*****************************************');
ExpertMod.Memo1.Lines.Add('Чтобы проследить ход рассуждений системы');
ExpertMod.Memo1.Lines.Add('введите вопрос "КАК?".');
ExpertMod.Memo1.Lines.Add('Ответ на вопрос "Почему?" после получения результата');
ExpertMod.Memo1.Lines.Add('система не потдерживает.');
ExpertMod.Memo1.Lines.Add('*****************************************');
end
else begin
ExpertMod.Memo1.Lines.Add('*****************************************');
ExpertMod.Memo1.Lines.Add('Значение нужно, чтобы доказать правило: ');
ExpertMod.Memo1.Lines.Add('');
rul:=rule.Items[nom];

ExpertMod.Memo1.Lines.Add('ЕСЛИ');

for i:=0 to inst.numAttributes-1 do begin
if (rul.m_premise.m_condidtions[i]>IMIN_VALUE) then
begin

if inst.attribute(i).attributeType=1 then s:=FloatToStr(rul.m_premise.m_items[i]);
if inst.attribute(i).attributeType=2 then s:=inst.attribute(i).value(round(rul.m_premise.m_items[i]));

if rul.m_premise.m_condidtions[i]=0 then ExpertMod.Memo1.Lines.Add(inst.attribute(i).name+' равно '+s);
if rul.m_premise.m_condidtions[i]=1 then ExpertMod.Memo1.Lines.Add(inst.attribute(i).name+' больше '+s);
if rul.m_premise.m_condidtions[i]=-1 then ExpertMod.Memo1.Lines.Add(inst.attribute(i).name+' меньше '+s);

end;
end;

ExpertMod.Memo1.Lines.Add('ТО');
for i:=0 to inst.numAttributes-1 do begin
if (rul.m_consequence.m_items[i]>IMIN_VALUE) then
begin

if inst.attribute(i).attributeType=1 then s:=FloatToStr(rul.m_consequence.m_items[i]);
if inst.attribute(i).attributeType=2 then s:=inst.attribute(i).value(round(rul.m_consequence.m_items[i]));

ExpertMod.Memo1.Lines.Add(inst.attribute(i).name+' равно '+s);

end;
end;
end;
end;

{Отвечает на вопрос "Как"}
procedure Otv_Kak(ind:integer;list_rules:TList;rule:TList;inst:TDMInstances);
var rul:TDMRuleItem;
elem:^TElemSteck;
i:integer;
s:String;
begin
//new(rul);
new(elem);
ExpertMod.Memo1.Lines.Add('');
ExpertMod.Memo1.Lines.Add('*****************************************');
if ind = list_rules.Count then ExpertMod.Memo1.Lines.Add('На этом все. ')
else begin
ExpertMod.Memo1.Lines.Add('Последнее доказанное правило: ');
ExpertMod.Memo1.Lines.Add('');
//ind - какой раз смотрим
elem:=list_rules.Items[list_rules.Count-ind-1];

rul:=rule.Items[elem.index];

ExpertMod.Memo1.Lines.Add('ЕСЛИ');
for i:=0 to inst.numAttributes-1 do begin
if (rul.m_premise.m_condidtions[i]>IMIN_VALUE) then
begin

if inst.attribute(i).attributeType=1 then s:=FloatToStr(rul.m_premise.m_items[i]);
if inst.attribute(i).attributeType=2 then s:=inst.attribute(i).value(round(rul.m_premise.m_items[i]));

if rul.m_premise.m_condidtions[i]=0 then ExpertMod.Memo1.Lines.Add(inst.attribute(i).name+' равно '+s);
if rul.m_premise.m_condidtions[i]=-1 then ExpertMod.Memo1.Lines.Add(inst.attribute(i).name+' меньше '+s);
if rul.m_premise.m_condidtions[i]=1 then ExpertMod.Memo1.Lines.Add(inst.attribute(i).name+' больше '+s);

end;
end;

ExpertMod.Memo1.Lines.Add('ТО');
for i:=0 to inst.numAttributes-1 do begin
if (rul.m_consequence.m_condidtions[i]>IMIN_VALUE) then
begin

if inst.attribute(i).attributeType=1 then s:=FloatToStr(rul.m_consequence.m_items[i]);
if inst.attribute(i).attributeType=2 then s:=inst.attribute(i).value(round(rul.m_consequence.m_items[i]));

ExpertMod.Memo1.Lines.Add(inst.attribute(i).name+' равно '+s);

end;
end;
end;
end;

procedure Free();
begin
g_ind:=-1;
g_value:=-1;
steck_f.Free;
steck_c.Free;
list_rules.Free;
end;

end.