Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/CONSULTP.ZIP/CONSULT.PAS

Pascal/Delphi Source File | 1988-06-24 | 22.8 KB | 863 lines

{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}

PROGRAM Consult(Input,Output,rules,dbase);


Uses
  Crt,
  Dos,
  Turbo3,Library;


CONST
   WORD_MAX=80;
   LINE_MAX=127;
   COLON=':';
   PERIOD='.';
   COMMA=',';
   SPACE=' ';
   EQUALS='=';
   DEFINITE=100;
TYPE
   word_string=string[Word_Max];
   line_string=string[Line_Max];
   infile_string=string[14];
   value_ptr=^value;
   legal_ptr=^legal_value;
   object_ptr=^object;

   value = RECORD
             name : word_string;
             cert : integer;
             setby : word_string;
             next : value_ptr
             END;

   legal_value = RECORD
             name : word_string;
             next : legal_ptr
             END;

   object = RECORD
             name : word_string;
             question : line_string;
             multivald : boolean;
             legal_list : legal_ptr;
             sought : boolean;
             value_list : value_ptr;
             next : object_ptr
             END;

   prem_ptr = ^prem;
   con_ptr = ^con;
   rule_ptr = ^rule;

   prem = RECORD
             object : word_string;
             value : word_string;
             next : prem_ptr
             END;

   con = RECORD
             object : word_string;
             value : word_string;
             cert : integer;
             next : con_ptr
             END;

   rule = RECORD
             name : word_string;
             prem : prem_ptr;
             con : con_ptr;
             next : rule_ptr
             END;
VAR
    choice, max_choice, choice_lim : integer;
    last_try,top_fact: object_ptr;
    s_word, s_object, s_value : word_string;
    s_line : line_string;
    datfile : infile_string;
    s_cf : integer;
    top_rule : rule_ptr;
    rules : Text;
    explain : boolean;
    another : boolean;
    ok : boolean;

Procedure Wait;

Var
   Ch : Char;

begin
     Off;
     write('Press any key to continue...');
     Read(kbd,ch);
     On;
end;

Function DressUp(f_object:word_string):word_string;
var
   Hit : Integer;
   Dressed : word_string;

begin
     For Hit := 1 to length(f_object) do
     if f_object[Hit] = #95 then f_object[Hit] := #32;
     DressUp :=f_object;

end;
PROCEDURE make_node(VAR curr_object: object_ptr);
    VAR
      head : object_ptr;
    BEGIN
      new(curr_object);
      head:=top_fact;
      top_fact:=curr_object;
      WITH curr_object^ DO
        Begin
          next:=head;
          value_list:=NIL;
          question:='';
          legal_list:=NIL;
          multivald:=FALSE;
          sought:=FALSE
        end
    END;


FUNCTION find_object(f_object: word_string):object_ptr;
  VAR
    curr_object:object_ptr;
  BEGIN
    IF (last_try<>NIL) AND (last_try^.name=f_object)
      THEN find_object:=last_try
    ELSE
      begin
        curr_object:=top_fact;
        last_try:=NIL;
        find_object:=NIL;
        WHILE ((curr_object<>NIL) AND (last_try=NIL)) DO
          begin
            IF (curr_object^.name=f_object) THEN
              begin
                find_object:=curr_object;
                last_try:=curr_object
              end;
            curr_object:=curr_object^.next
          end
      end
  END;

PROCEDURE split(f_line:line_string; VAR f_object,f_value:word_string);
  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_object:=f_line;
    IF (st_right=0) THEN st_right:=length(f_line)+1;
    IF (st_left>0) THEN
      Begin
        f_object:=copy(f_line,1,st_left-1);
        IF (pos(')',f_object)=0) THEN
          f_value:=copy(f_line,st_left+1,st_right-st_left-1)
      End;
    st_right:=pos(')',f_object);
    IF (st_right>0) THEN f_object:=copy(f_line,1,st_right-1)
  END;

FUNCTION test(f_object,f_value:word_string) :value_ptr;
    VAR
      curr_object : object_ptr;
      curr_value : value_ptr;
    BEGIN
      curr_object:=find_object(f_object);
      test:=NIL;
      IF (curr_object <> NIL) THEN
        begin
          curr_value := curr_object^.value_list;
          WHILE (curr_value<>NIL) DO
            begin
             IF (curr_value^.name=f_value) THEN test:=curr_value;
             curr_value:=curr_value^.next
            end
        end
    END;

PROCEDURE add_object(f_object,f_value:word_string);
    VAR
      curr_object : object_ptr;
      value_list, head : value_ptr;
    BEGIN
      curr_object:=find_object(f_object);
      IF (curr_object=NIL) THEN make_node(curr_object);
      curr_object^.name := f_object;
      curr_object^.sought:=TRUE;
      value_list:=test(f_object,f_value);
      IF (value_list = NIL) THEN
        begin
          head:=curr_object^.value_list;
          new(value_list);
          WITH value_list^ DO
             begin
               next:=head;
               cert:=0;
               setby:='';
               name:=f_value
             end;
          curr_object^.value_list:=value_list
        end
    END;

PROCEDURE see_vals(curr_object: object_ptr);
   VAR
     curr_value : value_ptr;
     cf: integer;
   BEGIN
     curr_value:=curr_object^.value_list;
     write('The answer to ',UpperCase(DressUp(curr_object^.name)),' is ');
     IF (curr_value=NIL) THEN write ('Undefined');
     WHILE (curr_value<>NIL) DO
       begin
         write(UpperCase(DressUp(curr_value^.name)),'. ');
         cf:=curr_value^.cert;
         write(' Degree of certainty is ',cf,'.');
         curr_value:=curr_value^.next;
         IF (curr_value<>NIL) THEN write(',')
       end;
     writeln
   END;

PROCEDURE see_objects;
   VAR
     curr_object : object_ptr;
   BEGIN
     writeln;
     writeln('KNOWLEDGE BASE FACTS:');
     writeln;
     curr_object:=top_fact;
     WHILE (curr_object<>NIL) DO
       begin
         see_vals(curr_object);
         curr_object:=curr_object^.next
       end;
     writeln;
     writeln('(END OF KNOWLEDGE BASE)')
   END;

PROCEDURE clean;
   VAR
     curr_object : object_ptr;
   BEGIN
     curr_object:=top_fact;
     WHILE (curr_object<>NIL) DO
       begin
         curr_object^.sought:=FALSE;
         curr_object^.value_list:=NIL;
         curr_object:=curr_object^.next
       end;
   END;



FUNCTION get_cf(f_line:line_string):integer;
  VAR
    result,st_right,cf : integer;
    trim : line_string;
  BEGIN
    cf:=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('cf',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,cf,result);
        IF (result>0)              THEN cf:=DEFINITE;
        IF pos('poor',trim)>0      THEN cf:= 25;
        IF pos('fair',trim)>0      THEN cf:= 50;
        IF pos('good',trim)>0      THEN cf:= 75;
        IF pos('excellent',trim)>0 THEN cf:= DEFINITE
      End;
    get_cf:=cf
  END;

FUNCTION blend(cf1,cf2:integer):integer;
  BEGIN
    blend:=(((100*cf1)+(100*cf2)-(cf1*cf2)) DIV 100)
  END;

PROCEDURE add_cf(f_object,f_value:word_string;cf2:integer);
  VAR
    cf1: integer;
    curr_value: value_ptr;
  BEGIN
    curr_value := test(f_object,f_value);
    cf1:=curr_value^.cert;
    curr_value^.cert :=blend(cf1,cf2)
  END;

FUNCTION ok_add(f_object: word_string; cf : integer):boolean;
  VAR
    curr_object:object_ptr;
    curr_value: value_ptr;
    is_100:boolean;
  BEGIN
    ok_add:=TRUE;
    is_100:=FALSE;
    curr_object:=find_object(f_object);
    IF (curr_object <> NIL) THEN
      begin
        curr_value:=curr_object^.value_list;
        WHILE (curr_value<>NIL) DO
          begin
            IF (curr_value^.cert=DEFINITE) THEN is_100:= TRUE;
            curr_value:=curr_value^.next
          end
      end;
    IF ((cf=DEFINITE) AND (is_100=TRUE) AND (curr_object^.multivald=FALSE))
      THEN ok_add:=FALSE
  END;

PROCEDURE make_multi(f_line:line_string);
  VAR
    curr_object:object_ptr;
    dummy, f_object: word_string;
  BEGIN
    split(f_line,f_object,dummy);
    curr_object:=find_object(f_object);
    IF (curr_object=NIL) THEN make_node(curr_object);
    curr_object^.name:=f_object;
    curr_object^.multivald:=TRUE
  END;

FUNCTION find_word(f_line:line_string;n:integer;VAR oneword:word_string):boolean;
  VAR
    x,com_place:integer;
  BEGIN
    find_word:=FALSE;
    oneword:='';
    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;
            find_word:=TRUE
          end;
        oneword:=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(f_object:word_string;curr_object:object_ptr);
  VAR
    curr_value, head: legal_ptr;
  BEGIN
    new(curr_value);
    curr_value^.next:=NIL;
    curr_value^.name:=f_object;
    head:=curr_object^.legal_list;
    IF (head<>NIL) THEN
      begin
        WHILE (head^.next<>NIL) DO
          head:=head^.next;
          Head^.next:=curr_value
      end
    ELSE curr_object^.legal_list:=curr_value
  END;

FUNCTION find_legal(f_object:word_string;n:integer;VAR oneword:word_string)
     :boolean;
  VAR
    curr_object:object_ptr;
    curr_value:legal_ptr;
    counter:integer;
  BEGIN
    curr_object:=find_object(f_object);
    find_legal:=TRUE;
    IF (curr_object<>NIL) THEN
      begin
        curr_value:=curr_object^.legal_list;
        oneword:=curr_value^.name;
        counter:=1;
        IF (curr_value=NIL) THEN find_legal :=FALSE;
        WHILE ((curr_value<>NIL) AND (counter<n)) DO
          begin
            curr_value:=curr_value^.next;
            IF (curr_value<>NIL) THEN
              begin
                oneword:=curr_value^.name;
                counter:=counter+1
              end
            ELSE find_legal:=FALSE;
          end
      end
    ELSE find_legal:=FALSE
  END;

PROCEDURE make_legals(f_line:line_string);
  VAR
    curr_object:object_ptr;
    counter, st_place :integer;
    new_line: line_string;
    f_object, dummy, oneword: word_string;
    done: boolean;
  BEGIN
    split(f_line,f_object,dummy);
    curr_object:=find_object(f_object);
    IF (curr_object=NIL) THEN make_node(curr_object);
    curr_object^.name:=f_object;
    st_place:=pos(EQUALS,f_line);
    new_line:=copy(f_line,st_place+1,length(f_line)-st_place);
    counter:=1;
    done:=FALSE;
    WHILE (done=FALSE) DO
      begin
        done:=find_word(new_line,counter,oneword);
        add_legal(oneword,curr_object);
        counter:=counter+1
      end
  END;

PROCEDURE add_question(f_line:line_string);
  VAR
    new_line:line_string;
    curr_object:object_ptr;
    f_object, dummy: word_string;
    st_place: integer;
  BEGIN
    split(f_line,f_object,dummy);
    curr_object:=find_object(f_object);
    IF (curr_object=NIL) THEN make_node(curr_object);
    curr_object^.name:=f_object;
    st_place:=pos(EQUALS,f_line);
    new_line:=copy(f_line,st_place+1,length(f_line)-st_place);
    curr_object^.question:=new_line
  END;




PROCEDURE p_question(f_object:word_string);
  VAR
    curr_object:object_ptr;
  BEGIN
    TextColor(LightGreen);
    curr_object:=find_object(f_object);
    IF (curr_object<>NIL) THEN
      begin
        IF (curr_object^.question<>'') THEN
          writeln(DressUp(curr_object^.question))
        ELSE
          writeln('What is the value of ',f_object,'?')
      end
    ELSE
      writeln('What is the value of ',f_object,'?')
  END;

PROCEDURE ask(f_object:word_string;VAR f_value:word_string);
  VAR
    pick, pick1, num_vals: integer;
    okay: boolean;
    oneword, select: word_string;
  BEGIN
    p_question(f_object);
    IF find_legal(f_object,1,oneword)=FALSE THEN
      readln(f_value)
    ELSE
      begin
        num_vals:=1;
        WHILE (find_legal(f_object,num_vals,oneword)<>FALSE) DO
          begin
            TextColor(LightBlue);
            writeln(num_vals,'. ',DressUp(oneword));
            num_vals:=num_vals+1
          end;
        pick:=0;
        WHILE ((pick<1) OR (pick>=num_vals)) DO
          begin
            writeln('Please enter a number from 1 to ',num_vals-1);
            readln(select);
            pick:=ord(select[1])-48;
            IF (length(select)>1) THEN
              begin
                pick1:=ord(select[2])-48;
                IF ((pick1>=0) AND (pick1<10)) THEN pick:=pick*10+pick1
              end
          end;
        okay:=find_legal(f_object,pick,oneword);
        f_value:=oneword
      end;
      writeln;
  END;

PROCEDURE p_read(VAR oline:line_string);
  VAR
    c:char;
    cs:string[1];
    len, counter,st_place: integer;
    supress: boolean;
    in_line: line_string;
  BEGIN
    readln(rules,in_line);
    oline:='';
    len:=length(in_line);
    st_place:=pos(' and',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('question',oline)>0)) THEN supress:=TRUE;
        IF (ord(c)=9) THEN c:=' ';
        IF ((c in ['A'..'Z']) AND (supress=FALSE)) THEN c:=chr(ord(c)+32);
        cs:=' ';
        cs[1]:=c;
        IF ((c<>' ') OR (supress=TRUE)) THEN oline:=concat(oline,cs)
      end
  END;

FUNCTION add_prem(curr_prem:prem_ptr;f_line:line_string):prem_ptr;
  VAR
    temp, new_prem: prem_ptr;
    f_object, f_value: word_string;
  BEGIN
    split(f_line,f_object,f_value);
    add_prem:=curr_prem;
    new(new_prem);
    WITH new_prem^ DO
      begin
        object:=f_object;
        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
    temp, new_con: con_ptr;
    f_object, f_value: word_string;
  BEGIN
    split(f_line,f_object,f_value);
    add_con:=curr_con;
    new(new_con);
    WITH new_con ^ DO
      begin
        object:=f_object;
        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:=curr_con^.next;
        curr_con^.next:=new_con
      end
  END;

PROCEDURE p_rule(curr_rule:rule_ptr);
  VAR
    curr_prem:prem_ptr;
    curr_con:con_ptr;
  BEGIN
    writeln(curr_rule^.name,': if');
    curr_prem:=curr_rule^.prem;
    WHILE (curr_prem<>NIL) DO
      begin
        write(curr_prem^.object,'=');
        write(curr_prem^.value);
        curr_prem:=curr_prem^.next;
        IF (curr_prem<>NIL) THEN writeln(' and') ELSE writeln
      end;
    writeln('then');
    curr_con:=curr_rule^.con;
    WHILE (curr_con<>NIL) DO
      begin
        write(curr_con^.object,'=');
        write(curr_con^.value,' cf',curr_con^.cert);
        curr_con:=curr_con^.next;
        IF curr_con<>NIL THEN writeln(' and')  ELSE writeln;
      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(rules))) DO
      begin
        new_rule^.prem:=add_prem(new_rule^.prem,line);
        p_read(line);
        IF pos('then',line)>0 THEN done:=TRUE
      end;
    p_read(line);
    done:=FALSE;
    REPEAT
      IF (Eof(rules)) THEN done:=TRUE;
      new_rule^.con:=add_con(new_rule^.con,line);
      IF line[length(line)]='.' THEN done:=TRUE ELSE p_read(line);
    UNTIL (done);
  END;

PROCEDURE read_file;
  VAR
    command: word_string;
    m_line, f_line: line_string;
    st_place: integer;
  BEGIN
    writeln(UpperCase(datfile),' Consultation.');writeln;
     writeln;
    TextColor(LightBlue);
    writeln('Loading ',UpperCase(datfile),' rulebase.');
    top_rule:=NIL;
    command:='';
    WHILE (NOT Eof(rules)) 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='objective') THEN
               s_object:=copy(m_line,1,length(m_line)-1);
            IF (command='multivalued') THEN make_multi(m_line);
            IF (command='question') THEN add_question(m_line);
            IF (command='legalvals') THEN make_legals(m_line);
            IF (pos('rule',command)>0) THEN enter_rule(m_line);
          end
      end;
      TextColor(red);
      write('Ready.');
      TextColor(LightBlue);
  END;

FUNCTION find_rule(obj:word_string;curr_rule:rule_ptr):rule_ptr;
  VAR
    found: boolean;
    curr_con: con_ptr;
  BEGIN
    found:=FALSE;
    find_rule:=NIL;
    WHILE ((curr_rule<>NIL) AND (found=FALSE)) DO
      begin
        curr_con:=curr_rule^.con;
        WHILE (curr_con<>NIL) DO
          begin
            IF (curr_con^.object=obj) THEN
              begin
                found:=TRUE;
                find_rule:=curr_rule
              end;
            curr_con:=curr_con^.next
          end;
        curr_rule:=curr_rule^.next
      end
  END;

PROCEDURE conclude(curr_rule:rule_ptr;prem_cert:integer);
  VAR
    curr_con: con_ptr;
    cert: integer;
  BEGIN
    curr_con:=curr_rule^.con;
    WHILE (curr_con<>NIL) DO
      begin
        add_object(curr_con^.object,curr_con^.value);
        cert:=(prem_cert*curr_con^.cert) DIV 100;
        add_cf(curr_con^.object,curr_con^.value,cert);
        curr_con:=curr_con^.next
      end
  END;

PROCEDURE explain_how(curr_rule:rule_ptr);
  VAR
    curr_prem: prem_ptr;
    curr_con: con_ptr;
  BEGIN
    writeln('Because:');
    curr_prem:=curr_rule^.prem;
    WHILE (curr_prem<>NIL) DO
      Begin
        write('The answer to ',UpperCase(DressUp(curr_prem^.object)),' was ');
        write(UpperCase(DressUp(curr_prem^.value)));
        curr_prem:=curr_prem^.next;
        If (curr_prem<> NIL) then writeln(' and ') ElSE writeln
      End;
    Writeln('We can conclude that');
    curr_con:=curr_rule^.con;
    WHILE (curr_con<>NIL) DO
      Begin
        write(' the answer to ',UpperCase(DressUp(curr_con^.object)),' is ');
        TextColor(White);
        writeln(UpperCase(DressUp(curr_con^.value)));
        TextColor(LightBlue);
        write(' and the degree of certainty is ',curr_con^.cert,'.');
        curr_con:=curr_con^.next;
        IF curr_con<>NIL THEN writeln(' and ') ELSE writeln
      End;
      Wait;
    writeln
    End;

PROCEDURE pursue(f_object:word_string);
  VAR
    f_value: word_string;
    curr_object: object_ptr;
    curr_value: value_ptr;
    curr_rule: rule_ptr;
    curr_prem: prem_ptr;
    bad, solved: boolean;
    lowest: integer;
  BEGIN
    curr_object:=find_object(f_object);
    IF curr_object=NIL THEN make_node(curr_object);
    curr_object^.name:= f_object;
    IF (curr_object^.sought<>TRUE) THEN
      begin
        solved:=FALSE;
        curr_object^.sought:=TRUE;
        curr_rule:=find_rule(f_object,top_rule);
        WHILE ((curr_rule<>NIL) AND (ok_add(f_object,DEFINITE)=TRUE)) DO
          begin
            curr_prem:=curr_rule^.prem;
            bad:=FALSE;
            lowest:=DEFINITE;
            WHILE ((curr_prem<>NIL) AND (bad=FALSE)) DO
              begin
                pursue(curr_prem^.object);
                curr_value:=test(curr_prem^.object,curr_prem^.value);
                IF curr_value=NIL THEN
                  bad:=TRUE
                ELSE IF curr_value^.cert<lowest THEN
                  lowest:=curr_value^.cert;
                curr_prem:=curr_prem^.next
              end;
            IF (bad=FALSE) THEN
              begin
                if (explain=TRUE) THEN explain_how(curr_rule);
                conclude(curr_rule,lowest);
                solved:=TRUE
              end;
            curr_rule:=find_rule(f_object,curr_rule^.next)
          end;
        IF (solved=FALSE) THEN
          begin
            ask(f_object,f_value);
            add_object(f_object,f_value);
            add_cf(f_object,f_value,DEFINITE)
          end
      end
  END;

PROCEDURE p_result(f_object:word_string);
  VAR
    curr_object:object_ptr;
  BEGIN
    TextColor(White);
    writeln;
    writeln('  RESULTS OF CONSULTATION');
    writeln;
    curr_object:=find_object(f_object);
    see_vals(curr_object);
    writeln;
    writeln('  END OF CONSULTATION')
  END;

BEGIN {MAIN PROGRAM}
  last_try:=NIL;
  top_fact:=NIL;
  choice:=0;
  ClrScr;

  If ParamCount=0 then
  repeat
    writeln('What is the name of the knowlege base data file?');
    readln(datfile);
    assign(rules,datfile);
    {$I-} reset(rules) {I+};
    ok:= (IOresult = 0);
    if not ok then writeln('Can''t find file ',datfile);
  until ok
  else
  begin
  datfile := ParamStr(1);
  repeat
  assign(rules,datfile);
    {$I-} reset(rules) {I+};
    ok:= (IOresult = 0);
    if not ok then writeln('Can''t find file ',datfile);
  until ok;
  end;
  read_file;
  Beep(800,50);Beep(900,50);Beep(1000,50);Beep(1100,50);Beep(1200,50);
  writeln;
  writeln;
  another:=TRUE;
  REPEAT
     repeat
       write('Do you want my reasoning explained');
       writeln(' during our consultation?');
       writeln('1-yes');
       writeln('2-no');
       readln(choice);
     until choice in [1..2];
     writeln;
     IF (choice = 1) THEN explain:=TRUE
         ELSE explain:=false;
     pursue(s_object);
     p_result(s_object);
     TextColor(LightBlue);
     repeat
       writeln('Do you want to have another consultation?');
       writeln('1-yes');
       writeln('2-no');
       readln(choice);
     until choice in [1..2];
     writeln;
     If (choice = 1) THEN
     begin
     clrscr;
     clean;
     end
      else another:=FALSE;
  Until another = FALSE
END.