Разработка алгоритмического и программного обеспечения ситуационного управления безопасностью магистральных газопроводов (стр. 10 из 11)

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);


ДОБАВИТЬ КОММЕНТАРИЙ  [можно без регистрации]
перед публикацией все комментарии рассматриваются модератором сайта - спам опубликован не будет

Ваше имя:

Комментарий

Хотите опубликовать свою статью или создать цикл из статей и лекций?
Это очень просто – нужна только регистрация на сайте.

Copyright © MirZnanii.com 2015-2018. All rigths reserved.