Program THES(option: string) [menu];

var dt: array[1..15] of real;
    doc: array[1..15] of real;
    tag: array[1..10] of real;   { tag of relation }
    maxt: real;                  { max no. of tags (upper bound of tag) }
    maxl: real;                  { max no. of lines (upper bound of dt,doc) }
    rel,invrel: string;          { Relation indicators }
    it,io: real;                 { current tag/occ }
    nl: real;                    { lines on this page }
    cl: real;                    { current line }
    term: string;                { current term }
    q: string;                   { query }
    dbname: string;              { current data base }
    mfn: real;                   { current mfn (in THES data base) }
    s,action,ft: string;
    i,k,kl,lq,rc: real;


Function FUC(s: string): string;

{----------------------------------------------------------------------------}
{ Converts string s to upper case }
{----------------------------------------------------------------------------}

var us: string;
begin
us:=s; uc(us);
fuc:=us;
end;


Procedure ERRMSG(t: string);

{----------------------------------------------------------------------------}
{ Display error message t and pause                                          }
{----------------------------------------------------------------------------}

var s: string;
begin
clearmsg; writeln(chr(7),t);
write('Press ENTER to continue'); s:=inkey;
end;

Procedure DISPLT;

{----------------------------------------------------------------------------}
{ Display top term box }
{----------------------------------------------------------------------------}

begin
cleardata;
box(1,1,3,32,2); clearbox(2,2,1,30,2);
cursor(2,2); write(fuc(term));
if action='S' then
   begin
   box(1,74,3,7,1);
   cursor(1,76); write('MFN'); cursor(2,75); write(mfn:5);
   end;
savescr(1);
end;


Procedure DISPLAY(t,o: real);

{----------------------------------------------------------------------------}
{ Display term relations starting from tag[t], occurrence o }
{----------------------------------------------------------------------------}

var rc,fn: real;

begin
nl:=0;
if t=1
   then begin
        displt;
        it:=1; io:=1;
        end
   else begin
        clearbox(5,1,15,80,0);
        it:=t; io:=o;
        end;
while (it<=maxt) and (nl<=maxl) do
  begin
  repeat
    fn:=fieldn(tag[it],io);
    if fn=0 then begin it:=it+1; io:=1; end;
  until (fn>0) or (it>maxt);
  if fn>0 then
     begin
     nl:=nl+1; dt[nl]:=it; doc[nl]:=io; io:=io+1;
     cursor(nl+4,1);
     write('_ ',substr(rel,(it-1)*3+1,3),' ',field(fn));
     end;
  end;
end;


Function DECIDE(l: real): string;

{----------------------------------------------------------------------------}
{ Read action code (<CR>,B,F and P are handled here; othere codes returned   }
{----------------------------------------------------------------------------}

var s: string;
    sc: real;
begin
cl:=l;
if nl>0 then
  begin
  clearmsg;
  writeln('Ù Next  B[ack]   F[irst]   P[age]   S[elect]  T[erm select]  Q[uery]');
  write  ('?[display query]  A[dd relation]     D[elete]  C[reate term]  X[exit]');
  repeat
  if cl<1 then cl:=1;
  if cl>nl then cl:=nl;
  cursor(cl+4,1);
  sc:=kbdkey(s); uc(s);
  if s=chr(13) then s:=' ';
  case s of
  ' ': if cl>=nl then cl:=1 else cl:=cl+1;
  'B': cl:=cl-1;
  'F': begin display(1,1); cl:=1; end;
  'P': begin
       display(dt[nl],doc[nl]);
       cl:=1;
       end;
  end;
  until position('?ACDLMQSTX',s,1)>0;
  end;
decide:=s;
if s='S' then term:=field(fieldn(tag[dt[cl]],doc[cl]));
end;


Function FINDTERM(term: string): real;

{----------------------------------------------------------------------------}
{ Search and display selected term                                           }
{      Return 0 if term exists (action contains a valid action code)         }
{             1 if term does not exist (action is not set)                   }
{----------------------------------------------------------------------------}

var rc: real;
    t: string;
begin
t:=fuc(term);
rc:=find(t);
findterm:=rc;
if rc=0 then
   if nxtpost<0
      then findterm:=1
      else begin
           mfn:=posting('MFN');
           rc:=record(mfn);
           findterm:=rc;
           if rc=0 then
              begin
              display(1,1);
              action:=decide(0);
              end;
           end;
end;


Function FLDUC(k: real): string;

{----------------------------------------------------------------------------}
{ Returns k-th field of record converted to upper case                       }
{----------------------------------------------------------------------------}

var f: string;
begin
f:=field(k); uc(f);
flduc:=f;
end;


Function CHKREL(t: string): real;

{----------------------------------------------------------------------------}
{ Check if a relation already exists                                         }
{----------------------------------------------------------------------------}

var i,n: real;
begin
n:=nfields; i:=1;
while (i<=n) and (flduc(i)<>t) do i:=i+1;
if i>n then chkrel:=0
       else chkrel:=i;
end;


Procedure UPDINVF;

{----------------------------------------------------------------------------}
{ Update inverted file (screen is clear because FST is displayed)            }
{----------------------------------------------------------------------------}

begin
cleardata;
updif;
end;


Procedure CREATERM;

{----------------------------------------------------------------------------}
{ Create new thesaurus term                                                  }
{----------------------------------------------------------------------------}

var tuc: string;
    rc,np: real;
begin
term:=''; clearmsg;
displt;
clearmsg; write('Enter new term');
rc:=edit(term,30,2,2,30,1,' ');
if term<>'' then
   begin
   tuc:=term; uc(tuc); rc:=find(tuc); np:=-1;
   if rc=0 then np:=nxtpost;
   if (rc=0) and (np>0)
      then errmsg('Term already exists')
      else begin
           mfn:=newrec;
           rc:=fldadd(tag[1],1,term);
           update; updinvf;
           action:='S';
           end;
   end
   else action:='T';
end;


Procedure ADDREL;

{----------------------------------------------------------------------------}
{ Add new relation to a term                                                 }
{----------------------------------------------------------------------------}

var r,rt,rtu: string;
    rc,i,rtag: real;

Function ADDIT: real;
var tt,ir: string;
    n,k: real;
    relmfn: real;

Procedure RELADD;
var rc: real;
begin
n:=nocc(rtag); k:=1;
while (k<=n) and (flduc(fieldn(rtag,k))<rtu) do k:=k+1;
rc:=fldadd(rtag,k+1,rt); update;
end;

begin
if (find(rtu)<>0) and (substr(r,1,2)<>'SN')
   then begin
        addit:=1;
        errmsg('Related term does not exist');
        end
   else
if (chkrel(rtu)<>0) and (substr(r,1,2)<>'SN')
   then begin
        addit:=1;
        errmsg('Relation already exists');
        end
   else
begin
rtag:=tag[(rtag-1)/3+1];
reladd;
ir:=substr(invrel,(rtag-1)*3+1,3);
if ir<>'   ' then
   begin
   k:=nxtpost; relmfn:=posting('MFN');
   rtag:=tag[(position(rel,ir,1)-1)/3+1];
   rt:=field(fieldn(tag[1],1)); rtu:=rt; uc(rtu);
   k:=record(relmfn);
   reladd;
   end;
k:=record(mfn);
addit:=0;
end;
end;

begin
box(18,10,3,5,1); box(18,14,3,52,1);
cursor(19,1); write('Relation');
r:=''; rt:='';
repeat
clearbox(19,15,1,50,1);
clearmsg; write('Enter relation code: ');
for i:=2 to maxt do write(substr(rel,(i-1)*3+1,3),' ');
clearbox(19,11,1,3,1); rc:=edit(r,3,19,11,3,1,' '); uc(r);
rtag:=position(rel,r,1);
if rtag=0 then write(chr(7));
until (r='') or (rtag>0);
repeat
i:=0;
if rtag>0 then
   begin
   clearmsg;
   rc:=edit(rt,30,19,16,30,1,' '); rtu:=rt; uc(rtu);
   if rtu<>'' then i:=addit;
   end;
until i=0;
action:='S';
end;


Procedure DELREL;

{----------------------------------------------------------------------------}
{ Delete a relation                                                          }
{----------------------------------------------------------------------------}

var rtag,rc,k,relmfn: real;
    rt,rtu,ir: string;
begin
rtag:=fieldn(dt[cl],doc[cl]);
rt:=field(rtag); rtu:=rt; uc(rtu);
rc:=flddel(rtag);
update;
ir:=substr(invrel,(dt[cl]-1)*3+1,3);
if ir<>'   ' then
   begin
   rc:=find(rtu);
   if rc=0 then
      begin
      k:=nxtpost;
      if k>=0 then
         begin
         relmfn:=posting('MFN');
         rtag:=tag[(position(rel,ir,1)-1)/3+1];
         rt:=field(fieldn(tag[1],1));
         rtu:=rt; uc(rtu);
         rc:=record(relmfn);
         if rc=0 then
            begin
            k:=chkrel(rtu);
            if k>0 then
               begin
               rc:=flddel(k);
               update;
               end;
            end;
         end;
      end;
   end;
k:=record(mfn);
action:='S';
end;


Procedure DELTRM;

{----------------------------------------------------------------------------}
{ Delete a thesaurus term                                                    }
{----------------------------------------------------------------------------}

begin
if nfields>1
   then begin
        errmsg('Cannot delete term with relations. Delete all relations first.');
        action:='S';
        end
   else begin
        rc:=flddel(1);
        update; updinvf;
        action:='T';
        end;
end;


Procedure SHOWDICT;

{----------------------------------------------------------------------------}
{ List dictionary                                                            }
{----------------------------------------------------------------------------}

var i,ii,k,sc: real;
    tp: array[1..16] of real;
    ts: array[1..16] of real;
    pg,ft: string;

begin
ft:=term;
repeat
pg:=''; i:=1; sc:=find(ft);
repeat
tp[i]:=size(pg)+1; ts[i]:=size(ft);
pg:=pg|ft;
ft:=nxtterm; i:=i+1;
until (i=17) or (ft='');
i:=i-1;
for k:=1 to i do
    begin cursor(k+4,5); writeln('_ ',substr(pg,tp[k],ts[k])); end;
k:=1;
repeat
ii:=k;
chattr(1,k+4,5,30); term:=substr(pg,tp[k],ts[k]);
sc:=kbdkey(action); uc(action);
if action=chr(13) then k:=k+1 else
if action='B' then if k>1 then k:=k-1;
chattr(0,ii+4,5,30);
until (position('CPSTX', action,1)>0) or (k>i);
page(1);
until (position('CSTX',action,1)>0) or (term='');
end;



{------------------------- Body of program THES -----------------------------}

begin

maxt:=7;                                   { Number of defined relations }
rel:=   '   SN USEUF BT NT RT ';           { Name of relations }
invrel:='      UF USENT BT RT ';           { Name of inverse relation }
for i:=1 to maxt do tag[i]:=i;             { Tag of relation }

maxl:=15; q:='';
dbname:=dbn; { save currently selected data base }
if dbname<>'THES' then open('THES');
clear;
if maxmfn=1 then action:='C' else action:='T';

repeat

case action of

'T': { Term selection }

     begin
     clearmsg;
     write('Select term');
     term:=''; displt;
     cursor(2,2); readln(term);
     if term='' then action:='X' else
     if (substr(term,size(term),1)='$') or (findterm(term)<>0)
        then action:='L';
     end;

'L': { List of thesaurus terms }

     begin
     uc(term);
     rc:=find(term);
     page(1);
     clearmsg;
     writeln('Ù [Next]        B[previous]       P[age]        S[elect]');
     write  ('C[reate term]    T[erm select]     X[exit]');
     savescr(1);
     showdict;
     if term='' then action:='L';
     end;

'S': { Display term relations }

     begin
     rc:=findterm(term);
     if rc<>0 then action:='L';
     end;

'A': { Add a relation }

     addrel;

'C': { Create a new term }

     createrm;

'D': { Delete a term or a relation }

     if cl=1 then deltrm else delrel;

'Q': { Select term for searching }

     begin
     s:=field(fieldn(tag[dt[cl]],doc[cl]));
     if size(s)+size(q)+3>255
        then begin
             write('');
             action:='?';
             end
        else begin
             if q<>'' then q:=q|' + ';
             q:=q|s;
             action:=decide(cl+1);
             end;
     end;

'?': { Display current query }

     begin
     savescr(2);
     box(16,8,6,66,2); clearbox(17,9,4,64,1);
     cursor(17,9); lq:=size(q);
     if lq=0 then write('No search terms currently selected') else
        begin
        k:=1; kl:=17;
        repeat
        if lq>64 then i:=64 else i:=lq;
        writeln(substr(q,k,i));
        k:=k+i; lq:=lq-i;
        kl:=kl+1; cursor(kl,9);
        until lq=0;
        end;
     clearmsg; write('Press any key to continue');
     s:=inkey;
     page(2);
     action:=decide(cl+1);
     end;

end;
until action='X';

option:=' ';
if (dbname<>'THES') and (dbname<>'') then
   begin
   open(dbname);
   if size(q)>0 then
      begin
      clear;
      clearmsg; write('Edit search expresssion or press Enter');
      rc:=edit(q,254,2,1,254,0,' ');
      if size(q)>0 then
         begin
         rc:=search(q);
         option:=inkey;
         end;
      end;
   end;
end.