Добавил:
Studfiles2
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз:
Предмет:
Файл:Курсовой проект групп 3341 и 3382 / ExpertModule / logic_str
.pasunit logic_str;
interface
uses Attribute,Instances,RuleItem,Modul,Classes,DmmConstants;
{Процедура логического вывода}
procedure Execute(rule1:TList;inst1:TDMInstances);
{Процедура ответа на вопрос при первичном вводе значений атрибутов}
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 nom:integer;active_rules:array of boolean):boolean; {поиск правила}
function znachen_pravila(rule:TList;nom:integer;inst_size:integer; steck:Tlist):integer; {значение правила}
procedure rule_true(rule:TList;var steck_f:TList;var steck_f_all:TList;var list_rez:TList;nom:integer;inst_size:integer;var active_rules:array of boolean);
procedure print_rez(rez_list:Tlist;inst:TDMInstances);
procedure Otv_Kak(ind:integer;list_true_rul:TList;list_rules:TList;inst:TDMInstances);
procedure Otv_Poch;
procedure del_elofsteck(var steck : TList;index1:integer);
implementation
uses SysUtils;
{закпись в сtек}
procedure in_steck(var steck : TList; atrindex : integer;atrval:double);
var atr1,atr2:^TElemSteck;
atr:TElemSteck;
i,cnt:integer;
begin
{тело процедуры}
{Запись в стек на место следующее за последним элементом}
new(atr1);
new(atr2);
atr:=TElemSteck.Create(atrindex,atrval);
atr1^:=atr;
cnt:=0;
for i:=0 to steck.Count-1 do begin
atr2:=steck.Items[i];
if atr2.index=atrindex then cnt:=cnt+1;
end;
if cnt=0 then steck.Insert(steck.Count,atr1);
end;
{выталкивание из стека}
procedure out_steck(var steck : TList);
begin
{тело процедуры}
{удаляем из конца списка}
steck.Delete(steck.Count-1);
end;
{Удаление конкр записи}
procedure del_elofsteck(var steck : TList;index1:integer);
var i:integer;
atr:^TElemSteck;
begin
for i:=0 to steck.Count-1 do begin
atr:=steck.Items[i];
if atr.index=index1 then begin steck.Delete(i);exit end;
end;
end;
{поиск правила}
function poisk_pravila(rule: TList; AtrInd:integer;var nom:integer;active_rules:array of boolean):boolean; {поиск правила}
var rul:TDMRuleItem;
i:integer;
begin
//new(rul);
nom:=0;
for i:=0 to rule.Count-1 do begin
rul:=rule.Items[i];
if (rul.m_premise.m_condidtions[AtrInd]>IMIN_VALUE)and (active_rules[i]=true) then
begin
nom:=i;
poisk_pravila:=true;
exit;
end
end;
poisk_pravila:=false;
end;
{значение правила}
function znachen_pravila(rule:TList;nom:integer;inst_size:integer; steck:Tlist):integer;
var rul:TDMRuleItem;
fakt:^TElemSteck;
i,j,cnt:integer;
res:integer;
begin
//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:=1;exit; end;
end;
result:=res;
end;
{правило истинно}
procedure rule_true(rule:TList;var steck_f:TList;var steck_f_all:TList;var list_rez:TList;nom:integer;inst_size:integer;var active_rules:array of boolean);
var rul:TDMRuleItem;
i:integer;
begin
//new(rul);
rul:=rule.Items[nom];
for i:=0 to inst_size-1 do
if rul.m_consequence.m_condidtions[i]>IMIN_VALUE then
begin
in_steck(steck_f,i,rul.m_consequence.m_items[i]);
in_steck(list_rez,i,rul.m_consequence.m_items[i]);
in_steck(steck_f_all,i,rul.m_consequence.m_items[i]);
active_rules[nom]:=false; //доказано
end;
end;
{Печать результата}
procedure print_rez(rez_list:Tlist;inst:TDMInstances);
var fakt:^TElemSteck;
i:integer;
s:string;
begin
new(fakt);
ExpertMod.Memo1.Clear;
if rez_list.Count=0 then begin
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.TakeSys(3);
for i:=0 to rez_list.Count-1 do
begin
fakt:=rez_list.Items[i];
if inst.attribute(fakt.index).attributeType=1 then s:=inst.attribute(fakt.index).name+' равно '+FloatToStr(fakt.val);
if inst.attribute(fakt.index).attributeType=2 then s:=inst.attribute(fakt.index).name+' равно '+inst.attribute(fakt.index).value(round(fakt.val));
ExpertMod.Memo1.Lines.Add(s);
end;
end;
end;
{Роцедура прямого вывода}
procedure Execute(rule1:TList;inst1:TDMInstances);
type active= array of boolean;
var
active_rules: active; {доказано ли правило}
steck_f,steck_f_all,rez_list,list_true_rul:TList;
flag: boolean; {Флаг готовности}
i,nom,index,nom_pred:integer;
fakt:^TElemSteck;
BEGIN
{Инициализация всех списков}
steck_f:=TList.Create;
steck_f.Clear;
rez_list:=TList.Create;
rez_list.Clear;
list_true_rul:=TList.Create;
list_true_rul.Clear;
steck_f_all:=TList.Create;
steck_f_all.Clear;
new(fakt);
{Помечаем все правила как недоказанные}
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));
for i:=0 to inst1.instance(i).numAttributes-1 do
if inst1.instance(i).value(2)=1 then in_steck(steck_f_all,i,inst1.instance(i).value(1));
flag:=true;
nom_pred:=0;
while flag do
if steck_f.Count>0 then begin
fakt:=steck_f.Items[steck_f.Count-1];
if poisk_pravila(rule1,fakt.index,nom,active_rules) then
if znachen_pravila(rule1,nom,inst1.numAttributes,steck_f_all)=0 then
begin
rule_true(rule1,steck_f,steck_f_all,rez_list,nom,inst1.numAttributes,active_rules);
in_steck(list_true_rul,nom,0);
nom_pred:=nom;
end;
del_elofsteck(steck_f,fakt.index); //Удаляем текущий элемент из стека фактов
if steck_f.Count=0 then flag:=false;
end
else
if steck_f.Count=0 then flag:=false;
ExpertMod.TakeVal(0,list_true_rul);
print_rez(rez_list,inst1);
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 Otv_Poch;
begin
ExpertMod.Memo1.Lines.Add('');
ExpertMod.Memo1.Lines.Add('*****************************************');
ExpertMod.Memo1.Lines.Add('В данном режиме ответ на этот вопрос не потдерживается');
ExpertMod.Memo1.Lines.Add('*****************************************');
end;
{Отвечает на вопрос "КАК" по результатам вывода}
procedure Otv_Kak(ind:integer;list_true_rul:TList;list_rules: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 list_true_rul.Count>0 then begin
if ind<list_true_rul.count then begin
if ind=0 then ExpertMod.Memo1.Lines.Add('В начале было доказано правило: ')
else ExpertMod.Memo1.Lines.Add('Затем было доказано: ');
ExpertMod.Memo1.Lines.Add('');
//ind - какой раз смотрим
elem:=list_true_rul.Items[ind];
rul:=list_rules.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(rul.m_consequence.m_items[i]);
ExpertMod.Memo1.Lines.Add(inst.attribute(i).name+' равно '+s);
end;
end;
end;
end
else {Если ist_true_rul.Count=0}
begin
ExpertMod.Memo1.Lines.Add('На основе введенных значений не удалось доказать ни');
ExpertMod.Memo1.Lines.Add('одного правила');
end;
end;
end.