procedure ask (f_frime: word_string; var f_value: word_string);
procedure p_read (var oline: line_string);
function add_prem (curr_prem: prem_ptr; f_line: line_string): prem_ptr;
function add_con (curr_con: con_ptr; f_line: line_string): con_ptr;
procedure p_rule (curr_rule: rule_ptr);
procedure enter_rule (rule_name: word_string);
procedure LoadFormFile;
procedure SaveToFile;
function find_rule (fri: word_string; curr_rule: rule_ptr): rule_ptr;
procedure pursue (f_frime: word_string);
procedure q_result (f_frime: word_string);
procedure explain_how (curr_rule: rule_ptr);
procedure explain_why (f_frime: word_string);
implementation
{$R *. dfm}
procedure make_node;
var
head: frime_ptr;
begin
new (curr_frime);
head: =top_fact;
top_fact: =curr_frime;
with curr_frime^ do begin
next: =head;
value_list: =nil;
question: ='';
legal_list: =nil;
multivald: =false;
sought: =false;
end;
end;
function find_frime;
var
curr_frime: frime_ptr;
begin
if (last_try<>nil) and (last_try^. name=f_frime)
then begin
Result: =last_try;
exit;
end
else begin
curr_frime: =top_fact;
last_try: =nil;
Result: =nil;
while (curr_frime<>nil) and (Result=nil) do begin
if (curr_frime^. name=f_frime)
then begin
Result: =curr_frime;
Last_try: =curr_frime;
exit;
end;
curr_frime: =curr_frime^. next;
end;
end;
end;
procedure split;
var
st_left,
st_right: integer;
begin
st_right: =pos (period,f_line);
if st_right=length (f_line) then f_line: =copy (f_line,1,st_right-1);
st_left: =pos (equals,f_line);
st_right: =pos (comma,f_line);
if ( (st_left=0) and (st_right=0)) then f_frime: =f_line;
if (st_right=0) then st_right: =length (f_line) +1;
if st_left>0
then begin
f_frime: =copy (f_line,1,st_left-1);
if pos (') ',f_frime) =0
then f_value: =copy (f_line,st_left+1,st_right-st_left-1);
end;
st_right: =pos (') ',f_frime);
Приложение А (продолжение)
if st_right>0 then f_frime: =copy (f_line,1,st_right-1);
end;
function test (f_frime,f_value: word_string): value_ptr;
var
curr_frime: frime_ptr;
curr_value: value_ptr;
begin
curr_frime: =find_frime (f_frime);
Result: =nil;
if curr_frime<>nil
then begin
curr_value: =curr_frime^. value_list;
while (curr_value<>nil) do begin
if curr_value^. name= f_value
then Result: =curr_value;
curr_value: =curr_value^. next;
end;
end;
end;
procedure add_frime (f_frime,f_value: word_string);
var
curr_frime: frime_ptr;
value_list,head: value_ptr;
begin
curr_frime: =find_frime (f_frime);
if curr_frime=nil
then begin
make_node (curr_frime);
curr_frime^. name: =f_frime;
end;
curr_frime^. sought: = true;
value_list: =test (f_frime, f_value);
if value_list=nil
then begin
head: =curr_frime^. value_list;
new (value_list);
with value_list^ do begin
next: =head;
cert: =0;
name: =f_value;
end;
curr_frime^. value_list: =value_list;
end;
end;
procedure see_vals;
var
curr_value: value_ptr;
cf: integer;
bufStr: string;
begin
curr_value: =curr_frime^. value_list;
bufStr: =curr_frime^. name+equals;
if curr_value=nil
then bufStr: =bufStr+' He определено';
while (curr_value<>nil) do begin
bufStr: =bufStr+curr_value^. name;
if (cf_on=true)
then begin
cf: =curr_value^. cert;
bufStr: =BufStr+' (Кд='+IntToStr (cf) +') ';
end;
curr_value: =curr_value^. next;
if curr_value<>nil then bufStr: =BufStr+','+NextRow;
end;
MainForm. Memo_Report. Lines. Add (BufStr);
end;
procedure see_frimes (cf_on: boolean);
var
curr_frime: frime_ptr;
begin
MainForm. Memo_Report. Lines. Add ('');
MainForm. Memo_Report. Lines. Add ('Просмотр фактов базы знаний: ');
curr_frime: =top_fact;
while (curr_frime<>nil) do begin
see_vals (curr_frime,cf_on);
curr_frime: =curr_frime^. next;
MainForm. Memo_Report. Lines. Add ('');
end;
end;
function get_cf;
var
resultat,
st_right: integer;
trim: line_string;
begin
Result: =definite;
st_right: =pos (period,f_line);
if st_right=length (f_line)
then f_line: =copy (f_line, 1,st_right-1);
st_right: =pos ('Кд',f_line);
if (st_right>0) and (st_right+3<line_max)
then begin
trim: =copy (f_line,st_right+3,length (f_line) - st_right-2);
val (trim,Result,resultat);
if result>0 then Result: =definite;
if pos ('Плохой',trim) >0
then Result: =25;
if pos ('Средний',trim) >0
then Result: =50;
if pos ('Хороший',trim) >0
then Result: =75;
if pos ('Абсолютный',trim) >0
then Result: =definite;
end;
end;
function blend;
begin
blend: = (100* (cf1+cf2) - (cf1*cf2)) div 100;
end;
procedure add_cf (f_frime,f_value: word_string; cf2: integer);
var
cf1: integer;
curr_value: value_ptr;
begin
curr_value: =test (f_frime,f_value);
cf1: =curr_value^. cert;
curr_value^. cert: =blend (cf1,cf2);
end;
function ok_add;
var
curr_frime: frime_ptr;
curr_value: value_ptr;
is_100: boolean;
begin
is_100: =false;
curr_frime: =find_frime (f_frime);
if curr_frime<>nil
then begin
curr_value: =curr_frime^. value_list;
while (curr_value<>nil) do begin
if curr_value^. cert=definite
then begin
is_100: =true;
break;
end;
curr_value: =curr_value^. next;
end;
end;
Result: =not ( (cf=definite) and (is_100) and (not (curr_frime^. multivald)));
end;
procedure make_multi;
var
curr_frime: frime_ptr;
begin
curr_frime: =find_frime (f_frime);
if curr_frime=nil
then begin
make_node (curr_frime);
curr_frime^. name: =f_frime;
end;
curr_frime^. multivald: =true;
end;
function find_word;
var
x, com_place: integer;
begin
Result: =false;
_word: ='';
for x: =1 to n do begin
com_place: =pos (comma,f_line);
if com_place=0
then begin
com_place: =length (f_line) +1;
Result: =true;
end;
_word: =copy (f_line,1,com_place-1);
f_line: =copy (f_line,com_place+1,length (f_line) - com_place);
end;
end;
procedure add_legal;
var curr_legal,head: legal_ptr;
begin
new (curr_legal);
curr_legal^. next: =nil;
curr_legal^. name: =f_legal;
head: =curr_frime^. legal_list;
if head<>nil
then begin
while (head^. next<>nil) do
head^. next: =curr_legal;
end
else
curr_frime^. legal_list: =curr_legal;
end;
function find_legal;
var
curr_frime: frime_ptr;
curr_legal: legal_ptr;
counter: integer;
begin
curr_frime: =find_frime (f_frime);
Result: =true;
if curr_frime<>nil
then begin
curr_legal: =curr_frime^. legal_list;
_word: =curr_legal^. name;
counter: =1;
if curr_legal=nil
then Result: =false;
while (curr_legal<>nil) and (counter<n) do begin
curr_legal: =curr_legal^. next;
if curr_legal<>nil
then begin
_word: =curr_legal^. name;
inc (counter);
end
else
Result: =False;
end;
end
else
Result: =False;
end;
procedure make_legals;
var
curr_frime: frime_ptr;
counter,
st_place: integer;
new_line: line_string;
_word,
f_frime,
dummy: word_string;
done: boolean;
begin
split (m_line,f_frime,dummy);
curr_frime: =find_frime (f_frime);
if curr_frime=nil
then begin
make_node (curr_frime);
curr_frime^. name: =f_frime;
end;
st_place: =pos (equals,f_frime);
new_line: =copy (f_frime,st_place+1,length (f_frime) - st_place);
counter: =1;
done: =false;
while not done do begin
done: =find_word (new_line,counter,_word);
add_legal (_word,curr_frime);
counter: =counter+1;
end;
end;
procedure make_legals_from_form;
var
curr_frime: frime_ptr;
i: integer;
begin
curr_frime: =find_frime (f_frime);
if curr_frime=nil
then begin
make_node (curr_frime);
curr_frime^. name: =f_frime;
end;
with MainForm. M_MakeLegal_Value do
If Lines. Count>0 then
for i: =0 to Lines. Count-1 do
add_legal (Lines [i],curr_frime);
end;
procedure add_question;
var
curr_frime: frime_ptr;
begin
curr_frime: =find_frime (f_frime);
if curr_frime=nil
then begin
make_node (curr_frime);
curr_frime^. name: =f_frime;
end;
curr_frime^. question: =s_value;
end;
function p_question;
var
curr_frime: frime_ptr;
begin
curr_frime: =find_frime (f_frime);
if curr_frime<>nil
then begin
if curr_frime^. question<>''
then
Result: =curr_frime^. question
else
Result: ='Вопрос объекта пуст';
еnd
else
Result: ='Объект в базе не найден';
end;
procedure ask;
var
pick,
num_vals: integer;
_word: word_string;
begin
if not find_legal (f_frime,1,_word)
then begin
MainForm. Memo_Report. Lines. Add ('Введите значение и нажмите кнопку "Выбрать"');
MainForm. B_Answer_GetNumVals. Enabled: =True;
while MainForm. B_Answer_GetNumVals. Tag=0 do
Application. ProcessMessages;
MainForm. B_Answer_GetNumVals. Tag: =0;
f_value: =MainForm. LE_Answer_Value. Text; // readln (f_value)
end
else begin
num_vals: =1;
with MainForm. Memo_Report. Lines do begin
Add ('Допустимые значения объекта "'+f_frime+'": ');
while find_legal (f_frime,num_vals,_word) do begin
Add (IntToStr (num_vals) +'. '+_word);
inc (num_vals);
end;
end;
MainForm. SE_Answer. MaxValue: =num_vals-1;
MainForm. Memo_Report. Lines. Add ('Выберите номер ответа и нажмите кнопку "Выбрать"');
MainForm. B_Answer_GetNumVals. Enabled: =True;
while MainForm. B_Answer_GetNumVals. Tag=0 do
Application. ProcessMessages;
pick: =MainForm. SE_Answer. Value; // ord (select [1]) - 48;
MainForm. B_Answer_GetNumVals. Tag: =0;
find_legal (f_frime,pick,_word);
f_value: =_word;
end;
end;
procedure p_read;
var
c: char;
len,
counter,
st_place: integer;
supress: boolean;
in_line: line_string;
begin
readln (RulesFile, in_line);
in_line: =AnsiLowerCase (in_line);
oline: ='';
len: =length (in_line);
st_place: =pos (' (', in_line);
if st_place>0
then len: =st_place;
supress: =false;
for counter: =1 to len do begin
c: =in_line [counter] ;
if (c=equals) and (pos ('вопрос',oline) >0)
then supress: =true;
if ord (c) =9
then c: =' ';
if (c<>'') or (supress=true)
then oline: =concat (oline,c);
end;
end;
function add_prem;
var
new_prem: prem_ptr;
f_frime,f_value: word_string;
begin
split (f_line,f_frime,f_value);
add_prem: =curr_prem;
new (new_prem);
with new_prem^ do begin
frime: =f_frime;
value: =f_value;
next: =nil;
end;
if curr_prem=nil
then
add_prem: =new_prem
else begin
while (curr_prem^. next<>nil) do
curr_prem: =curr_prem^. next;
curr_prem^. next: =new_prem;
end;
end;
function add_con (curr_con: con_ptr; f_line: line_string): con_ptr;
var
new_con: con_ptr;
f_frime,
f_value: word_string;
begin
split (f_line,f_frime,f_value);
add_con: =curr_con;
new (new_con);
with new_con^ do begin
frime: =f_frime;
value: =f_value;
cert: =get_cf (f_line);
next: =nil;
end;
if curr_con=nil
then
add_con: =new_con
else begin
while (curr_con^. next<>nil) do
curr_con^. next: =new_con;
end;
end;
procedure p_rule (curr_rule: rule_ptr);
var
curr_prem: prem_ptr;
curr_con: con_ptr;
bufStr: string;
begin
bufStr: =curr_rule^. name+' ';
curr_prem: =curr_rule^. prem;
while (curr_prem<>nil) do begin
bufStr: =bufStr+curr_prem^. frime+'=';
bufStr: =bufStr+curr_prem^. value;
curr_prem: =curr_prem^. next;
if curr_prem<>nil
then
bufStr: =bufStr+' '
else
MainForm. Memo_Report. Lines. Add (BufStr);
end;
curr_con: =curr_rule^. con;
while curr_con<>nil do begin
bufStr: =curr_con^. frime+'=';
bufStr: =bufStr+curr_con^. value+', Кд='+IntToStr (curr_con. cert);
curr_con: =curr_con^. next; if curr_con<>nil
then
bufStr: =bufStr+' '
else
MainForm. Memo_Report. Lines. Add (BufStr);
end;
end;
procedure enter_rule (rule_name: word_string);
var
new_rule,
curr_rule: rule_ptr;
line: line_string;
done: boolean;
begin
new (new_rule);
if top_rule<>nil
then begin
curr_rule: =top_rule;
while curr_rule^. next<>nil do
curr_rule: =curr_rule^. next;
curr_rule^. next: =new_rule;
end
else
top_rule: =new_rule;
with new_rule^ do begin
name: =rule_name;
next: =nil;
prem: =nil;
con: =nil;
end;
p_read (line);
done: =false;
while ( (not done) and (not Eof (RulesFile))) do begin
new_rule^. prem: =add_prem (new_rule^. prem,line);
p_read (line);
done: = (pos ('ВВ',line) >0) and (length (line) =2);
end;
p_read (line);
repeat
done: =Eof (RulesFile);
new_rule^. con: =add_con (new_rule^. con,line);
done: =done or (line [length (line)] ='. ');
if not done then p_read (line);
until done;
p_rule (new_rule);
end;
procedure LoadFormFile;
var
command: word_string;
m_line,f_line: line_string;
st_place: integer;
s_frime,s_value: word_string;
begin
MainForm. Memo_Report. Lines. Add ('Чтение файла, содержащего правила');
assign (RulesFile,'rules. txt');
reset (RulesFile);
top_rule: =nil;
command: ='';
while not Eof (RulesFile) do begin
p_read (f_line);
st_place: =pos (' (',f_line);
if st_place=0
then
st_place: =pos (colon,f_line);
if st_place>1
then begin
command: =copy (f_line,1,st_place-1);
m_line: =copy (f_line,st_place+1,length (f_line) - st_place);
if command='многозначный'
then begin
split (m_line,s_frime,s_value);
make_multi (s_frime);
add_frime (s_frime,s_value);
add_cf (s_frime,s_value,get_cf (m_line));
end else
if command='вопрос'
then begin
split (m_line,s_frime,s_value);
add_question (s_frime,s_value);
end else
if command='разрешён'
then begin
make_legals (m_line);
end else
if command='правило'
then begin
split (m_line,s_frime,s_value);
enter_rule (s_frime);
end;
end;
end;
end;
procedure SaveToFile;
var
a_frime: frime_ptr;
a_legal: legal_ptr;
a_value: value_ptr;
a_rule: rule_ptr;
a_con: con_ptr;
a_prem: prem_ptr;
f: TextFile;
begin
AssignFile (f,'rules. txt');
Rewrite (f);
a_frime: =top_fact;
while a_frime<>nil do begin
a_value: =a_frime^. value_list;
while a_value<>nil do begin
writeln (f,'многозначный'+colon+a_frime^. name+equals+a_value^. name+comma+'Кд=',a_value^. cert);