6








                                                                             
                                 PROGRAMAS DE MUESTRA

          _________________________________________________________________


          Esta secci¢n describe  los programas de  muestra incluidos  en el
          diskete SAMPLES (muestras).  Se recomienda ejecutar los programas
          (usando la opci¢n A del men£ principal)  conforme se estudian los
          listados.

          A. Programa KEYB [1]

          Este programa (batch)  dibuja en la pantalla el  teclado numrico
          de la  IBM PC/XT,  e ilustra la aplicaci¢n de  los procedimientos
          BOX y CLEARBOX.

          Para simplificar el algor¡tmo,  el programa supone  la existencia
          de 20 teclas numeradas del modo siguiente:

             1 2 3 4
             5 6 7 8
             9 10 11 12
             13 14 15 16
             17 18 19 20

          Sin embargo,  como las teclas 16 y 17 son m s grandes, se manejan
          de manera especial.

          Los arreglos l y c comienzan en la posici¢n (l¡nea/columna) de la
          esquina  superior  izquierda de  cada  tecla.  Estos  valores son
          inicializados en base a los valores de L1  y C1 que determinan la
          posici¢n del dibujo  en  la  pantalla.  Las  variables  de cadena
          (string)  arriba y abajo  contienen  las  etiquetas  de  la parte
          central e inferior de   cada tecla.  Debido a que CDS/ISIS Pascal
          no soporta  arreglos de cadenas,  se simulan en este  caso cuando
          solo  una variable de  cadena,  la  cual  contiene  subcadenas de
          longitud fija:  arriba contiene  20  cadenas de  4  caracteres, y
          abajo contiene 20 cadenas de 1 caracter.

          El teclado se dibuja dos veces, tecla por tecla, usando el proce-
          dimiento DRAWKEY:  la primera vez con el atributo 0  y la segunda
          con el  atributo  1.  El efecto visual logrado es que  despus de
          dibujadas, las teclas cambian de color.

          N¢tese que el procedimiento DRAWKEY duplica la altura de la tecla
          16, y el ancho de la tecla 17, y no dibuja las teclas 18 y 20, ya
          que estas corresponden a la  segunda mitad de  las teclas grandes
          16 y 17.



                                         41








          N¢tese como las etiquetas correctas de  las etiquetas  se extraen
          de arriba y de abajo usando la funci¢n SUBSTR.

          B. Programa DISPL

          Este programa ilustra el uso de procedimientos de  formateo. Des-
          pliega secuencialmente los registros de la base de datos de mues-
          tra CDS. Se despliegan cuatro campos de cada registro: el MFN, el
          t¡tulo (campo 24),  los autores (campo 70),  y las palabras clave
          (campo 69).  Cada campo se enmarca en  un  rect ngulo. Despus de
          desplegar  cada  registro,   el  programa  presenta  el  mensaje:
          "n[sigte reg]  q[salir]", y termina cuando la respuesta del usua-
          rio es Q, o se alcanza el fin del archivo maestro (rc<0).

          El procedimiento DISPLAY borra todos los marcos,  define  el for-
          mato para cada campo,  y despus lo despliega  usando el procedi-
          miento WRT.

          C. Programa TEXT

          Este programa realiza una b£squeda de texto libre sencilla en una
          base  de  datos.  Primero pide la etiqueta del  campo a utilizar,
          despus la cadena de caracteres a buscar.  La b£squeda  es reali-
          zada usando la  funci¢n Position.  Como tanto el  contenido de la
          cadena  a   ser  localizada,   y  el  contenido   del  campo  son
          transformados a may£sculas antes de la comparaci¢n de caracteres,
          la b£squeda es  insensible  al hecho  de que las  letras estn en
          may£sculas o min£sculas.  Conforme  un  registro  cuenta  con una
          correspondencia con la cadena buscada, es desplegado y el usuario
          puede continuar la b£squeda o  salir.  El programa hace una pausa
          cada 100  registros consecutivos que no satisfagan el criterio de
          b£squeda.

          D. Programa THES

          Este programa aporta las funciones completas  para la administra-
          ci¢n de un  tesaurus (monolinge).  Se dise¤¢ como una llamada de
          men£ (pero puede tambin operar en forma aut¢noma). Presupone que
          existe una base de datos del tesaurus llamada THES.

          Se utilizan las siguientes variables globales:

           maxt n£mero m ximo de relaciones definidas

           rel cadena que contiene el nombre (3 caracteres) de las relacio-
          nes

           invrel cadena que contiene el nombre (3 caracteres) de las rela-
          ciones inversas

           etq arreglo que contiene las etiquetas de cada relaci¢n

           term trmino del tesaurus que se est  procesando

           q mantiene los trminos de b£squeda seleccionados a travs de la
          opci¢n Q (ver m s adelante)


                                         42









          Los sub-men£s y los mensajes de  solicitud de  datos se presentan
          en el   rea de mensajes.  Las opciones primarias del  programa se
          describen a continuaci¢n:

            T permite seleccionar un trmino: un recuadro vac¡o se presenta
          en la parte superior de la pantalla, donde debe teclearse el tr-
          mino; si este existe, es desplegado, en caso contrario, se selec-
          ciona autom ticamente la opci¢n L;  el programa termina si  no se
          teclea un trmino;

            L despliega la lista de trminos del  tesaurus en orden alfab-
          tico,  iniciando  desde el  trmino actual;  se puede avanzar una
          p gina oprimiendo P,  pasar de un trmino al siguiente  con Enter
          (hacia adelante),  o B (hacia atr s),  o seleccionar las opciones
          S, C, T, o X;

            S selecciona un trmino dado y despliega el registro correspon-
          diente (ver la descripci¢n del procedimiento FINDTERM);

           A agrega una relaci¢n (ver ADDREL);

           C crea un nuevo trmino en el tesaurus (ver CREATERM);

           D dependiendo de  la  posici¢n del cursor, borra un trmino (ver
          DELTRM) o una relaci¢n (vr DELREL);

           Q selecciona un trmino para usarlo en una b£squeda; si ya hab¡a
          trminos  seleccionados previamente,  se  inserta entre  ellos un
          operador '+' (o l¢gico, conocido tambin como OR);

            ?  Despliega el conjunto actual de  trminos seleccionados para
          b£squeda con la opci¢n Q,  si los hay; estos trminos aparecen en
          una ventana que se abre para ello;

            X salir;  si hubo trminos de b£squeda seleccionados, la expre-
          si¢n se despliega en modo de edici¢n y despus se ejecuta la b£s-
          queda,  siempre y cuando haya habido una base de  datos seleccio-
          nada cuando se activ¢ el programa THES.

          El programa utiliza  cierto n£mero de  procedimientos y funciones
          internas:

           FUC: convierte una cadena a may£sculas;

            ERRMSG:  suena la alarma y despliega un mensaje de  error en el
           rea de mensajes, despus espera a que se oprima una tecla;

           DISPLT: borra el  rea de datos y despliega el recuadro de trmi-
          nos;  si se llama desde la opci¢n S tambin despliega  el MFN del
          trmino; la pantalla se guarda en el buffer 1;







                                         43








            DISPLAY:  despliega hasta maxl  relaciones  de un trmino, ini-
          ciando desde una etiqueta y ocurrencia  dadas;  el ¡ndice de eti-
          quetas y la ocurrencia de cada relaci¢n se despliegan tal como se
          registran en los arreglos dt y doc respectivamente,  y  nl recibe
          el valor del n£mero de relaciones desplegadas;

            DECIDE:  permite ver las relaciones de un trmino y seleccionar
          una de las opciones del programa descritas m s arriba;  si la op-
          ci¢n seleccionada es S,  el trmino seleccionado es almacenado en
          term;

           FINDTERM: busca un trmino y lo despliega en caso de que exista;
          asigna  a mfn el  valor del MFN del  registro  correspondiente, y
          establece accion como la opci¢n seleccionada a travs de DECIDE;

             FLDUC:   regresa  un  campo  dado  del  registro  convertido a
          may£sculas;

           CHKREL: verifica si ya existe una relaci¢n;

           UPDINVF: actualiza el archivo invertido;

           CREATERM: crea un nuevo termino en el tesaurus (siempre y cuando
          no exista previamente);  el nuevo registro es creado y el archivo
          invertido es actualizado de inmediato;

            ADDREL:  agrega una relaci¢n a un trmino; verifica que el tr-
          mino relacionado ya haya sido definido  en el tesaurus,  y que no
          exista previamente una relaci¢n  con ese mismo trmino;  la rela-
          ci¢n inversa,  en caso necesario,  tambin se  agrega al registro
          correspondiente al trmino relacionado;

            DELREL: borra una relaci¢n, y si es necesario, la relaci¢n  in-
          versa correspondiente;

            DELTRM: borra un trmino, siempre y cuando no tenga relaciones;
          el archivo invertido tambin es actualizado;

           SHOWDICT: despliega la lista alfabtica de trminos del tesaurus
          y permite seleccionar una de las opciones C,  S,  T o X; se puede
          avanzar por p ginas hacia adelante  oprimiendo  P,  o pasar de un
          trmino a otro con Enter (hacia adelante), o B (hacia atr s).

          Program SKEYB;

          { Dibuja el teclado numrico de la IBM PC}

          var l: array[1..20] of real;
              c: array[1..20] of real;
              l1,c1,i,j: real; 
              arriba,abajo: string;

          Procedure DRAWKEY(i,a: real);

          { Dibuja una tecla con i=numero de tecla, a=atributo }



                                         44








          Var h,w: real;

          Begin
            if (i<>18) and (i<>20) then
              begin
               if i=16
                  then begin h:=6; w:=6; end
                  else if i=17
                          then begin h:=3; w:=12; end
                          else begin h:=3; w:=6; end;
               if a<>0 then clearbox(l[i],c[i],h,w,a);
               box(l[i],c[i],h,w,1);
               cursor(l[i]+1,c[i]+1);write(substr(arriba,(i-1)*4+1,4));
               if substr(abajo,i,1)<>' ' then
                      begin cursor(l[i]+2,c[i]+1);write(substr(abajo,i,1));
          end;
            end;
          end;

          Begin
          arriba:='Esc Num ScrLSysRHome ^   PgUpPrtS <-       ->     End  v
          PgDn    Ins     Del     ';
          abajo:='    789*456-123+0 . ';
          l1:=3; c1:=30;
          clear;
          for i:=1 to 5 do for j:=1 to 4 do l[(i-1)*4+j]:=l1+(i-1)*3;
          for i:=1 to 5 do for j:=1 to 4 do c[(i-1)*4+j]:=c1+(j-1)*6;

          for i:=1 to 20 do drawkey(i,0);

          for i:=1 to 20 do
          begin
            drawkey(i,1);
            for j:=1 to 200 do; { loop de espera }
          end;

          cursor(22,1);
          end.
          Program SDISPL;
          var i,j,k,n,rc,l: real;
              f,lin: string;

          Procedure WRT(i,nl,lw: real);
          var l,ll,rc: real;
          begin
          rc:=format(lw);
          rc:=nxtline(lin); l:=i;
          ll:=l+nl-1;
          while rc=0 do
           begin
           cursor(l,2);
           if l>ll then rc:=1
                   else begin writeln(lin); rc:=nxtline(lin); end;
           l:=l+1;
           end;
          end;


                                         45









          Procedure DISPLAY;
          begin
          cursor(2,74); write(i:4);

          clearbox(2,2,1,28,2);
          getfmt('mdl,(v70/)');
          wrt(2,1,28);

          clearbox(5,2,4,78,1);
          getfmt('mdl,v24/');
          wrt(5,4,78);

          clearbox(11,2,2,78,1);
          getfmt('mdl,v70+|; |/');
          wrt(11,2,78);

          clearbox(15,2,6,78,1);
          getfmt('mdl,v69/');
          wrt(15,6,78);

          end;


          begin
          open('cds');
          i:=0;
          clear;
          box(1,1,3,30,2); box(1,71,3,10,1);
          box(4,1,6,80,1);
          cursor(4,1);writeln('Titulo: ');
          box(10,1,4,80,1);
          cursor(10,1);writeln('Autores: ');
          box(14,1,8,80,2);
          cursor(14,1);writeln('Palabras clave: ');

          repeat
          i:=i+1;
          rc:=record(i);
          if rc=0 then   { el registro existe }
             begin
             DISPLAY;
             cursor(23,1); write('n[sigte reg]  q[salir]');
             f:=inkey; uc(f);
             end;

          until (f='Q') or (rc<0);
          end.
          Program STEXT;

          { Realiza una busqueda de texto simple }

          var tc,etq,rc,n,i,o,j,k,tot,nr,y: real;
              nombrebd,campo,s,r: string;

          Begin


                                         46








          clear;
          nombrebd:=dbn;
          if nombrebd='' then
             begin
             msg(1); readln(nombrebd);
             open(nombrebd);
             end;
          write('Nombre de la base de datos: ',nombrebd);
          cursor(2,1); write('Etiqueta para busqueda ?    ');
          cursor(3,1); write('Cadena a buscar? ');

          repeat
          box(5,2,16,78,2);
          r:='';
          attr(' ',1,2,24,5);
          readln(s);
          if s<>'' then
             begin
             etq:=val(s);
             attr(' ',1,3,24,50); readln(s);
             uc(s);
             i:=0; y:=0; nr:=0; tot:=0; tc:=0;
             cursor(22,1); writeln('Registros recuperados:  ');
             repeat
             i:=i+1;   rc:=record(i);
             tc:=tc+1;
             cursor(5,5); writeln(i:1);
             if rc=0 then
                begin
                nr:=nr+1; n:=nocc(etq); o:=0;
                while o<n do
                begin
                o:=o+1;
                       j:=fieldn(etq,o);        campo:=field(j); uc(campo);
          k:=position(campo,s,1);
                if k<>0 then
                   begin
                   Y:=Y+1;
                   k:=format(70); o:=6;
                   clearbox(6,3,14,76,1);
                   while (nxtline(campo)=0) and (o<19) do
                     begin cursor(o,5); writeln(campo); o:=o+1; end;
                   cursor(22,30); write(y:1,'  '); r:=inkey; uc(r);
                   clearbox(6,3,14,76,0);
                   tc:=0;
                   end;
                end;
                end;
             if tc=100 then
                begin
                cursor(23,1);
                 write('<CR>  -  continuar otros 100  registros   X - Salir
          -->');
                r:=inkey; uc(r);
                tc:=0;
                end;


                                         47








             until (rc<0) or (r='X');
             end;
          until (s='') or (r='X');
          end.
          Program STHES(option: string) [menu];

          var dt: array[1..15] of real;
              doc: array[1..15] of real;
              etq: array[1..10] of real;{ etq de relacion }
              maxt: real;               { num max etq (limite sup etq) }
              maxl: real;               { num max lineas (lim sup dt.doc)}
              rel,invrel: string;       { indicadores de relacion }
              it,io: real;              { etq/occ actual}
              nl: real;                 { lineas en esta pagina }
              cl: real;                 { linea actual }
              term: string;             { termino actual }
              q: string;                { busqueda }
              nombrebd: string;         { base de datos actual }
               mfn:  real;                 { mfn actual  (en  base de datos
          THES)}
              s,accion,ft: string;
              i,k,kl,lq,rc: real;

          Function FUC(s: string): string;

          {----------------------------------------------------------}
          { Convierte cadena s a may£sculas                          }
          {----------------------------------------------------------}

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


          Procedure ERRMSG(t: string);

          {----------------------------------------------------------}
          { Despliega mensaje de error t y pausa                     }
          {----------------------------------------------------------}

          var s: string;
          begin
          clearmsg; writeln(chr(7),t);
          write('Oprima ENTER para seguir'); s:=inkey;
          end;

          Procedure DISPLT;

          {----------------------------------------------------------}
          { Despliega recuadro de trmino en parte superior          }
          {----------------------------------------------------------}

          begin
          cleardata;


                                         48








          box(1,1,3,32,2); clearbox(2,2,1,30,2);
          cursor(2,2); write(fuc(term));
          if accion='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);

          {----------------------------------------------------------}
          { Despliega relac. de trminos desde etq[t], occurrencia 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(etq[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;

          {----------------------------------------------------------}
          { Lee c¢digo de acci¢n (<CR>, B, F y P se manejan aqu¡; los}
          {     dem s c¢digos se regresan                            }
          {----------------------------------------------------------}

          var s: string;
              sc: real;
          begin
          cl:=l;


                                         49








          if nl>0 then
            begin
            clearmsg;
             writeln('<CR>[sigte] B[atras] F[prim]  P[agina] S[elecc] T[sel
          term]  Q[busq]');
              write    ('?[despl  busq]   A[gr  rel]   D[canc]  C[rea term]
          X[salir]');
            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(etq[dt[cl]],doc[cl]));
          end;

          Function FINDTERM(term: string): real;

          {----------------------------------------------------------}
          { Busca y despliega termino seleccionado                   }
          {   Regresa 0 si termino existe (accion tiene cod valido)  }
          {           1 si termino no existe (accion no se define)   }
          {----------------------------------------------------------}

          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);
                        accion:=decide(0);
                        end;
                     end;
          end;


                                         50









          Function FLDUC(k: real): string;

          {----------------------------------------------------------}
          { regresa campo k-esimo de registro, convertido a may£scula}
          {----------------------------------------------------------}

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

          Function CHKREL(t: string): real;

          {----------------------------------------------------------}
          { Checa si ya existe una relaci¢n                          }
          {----------------------------------------------------------}

          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;

          {----------------------------------------------------------}
          { actualiza archivo invertido (se borra pantalla ya que se }
          {    despliega FST)                                        }
          {----------------------------------------------------------}

          begin
          cleardata;
          updif;
          end;

          Procedure CREATERM;

          {----------------------------------------------------------}
          { Crea nuevo trmino en tesaurus                           }
          {----------------------------------------------------------}

          var tuc: string;
              rc,np: real;
          begin
          term:=''; clearmsg;
          displt;
          clearmsg; write('Escriba nuevo termino');
          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;


                                         51








             if (rc=0) and (np>0)
                then errmsg('Termino ya existe')
                else begin
                     mfn:=newrec;
                     rc:=fldadd(etq[1],1,term);
                     update; updinvf;
                     accion:='S';
                     end;
             end
             else accion:='T';
          end;

          Procedure ADDREL;

          {----------------------------------------------------------}
          { Agrega nueva relaci¢n a trmino                          }
          {----------------------------------------------------------}

          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('Termino relacionado no existe');
                  end
             else
          if (chkrel(rtu)<>0) and (substr(r,1,2)<>'SN')
             then begin
                  addit:=1;
                  errmsg('Relacion ya existe');
                  end
             else
          begin
          rtag:=etq[(rtag-1)/3+1];
          reladd;
          ir:=substr(invrel,(rtag-1)*3+1,3);
          if ir<>'   ' then
             begin
             k:=nxtpost; relmfn:=posting('MFN');
             rtag:=etq[(position(rel,ir,1)-1)/3+1];
             rt:=field(fieldn(etq[1],1)); rtu:=rt; uc(rtu);


                                         52








             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('Relacion');
          r:=''; rt:='';
          repeat
          clearbox(19,15,1,50,1);
          clearmsg; write('Escriba codigo fr relacion: ');
          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;
          accion:='S';
          end;


          Procedure DELREL;

          {----------------------------------------------------------}
          { cancela relaci¢n                                         }
          {----------------------------------------------------------}

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


                                         53








                   rtag:=etq[(position(rel,ir,1)-1)/3+1];
                   rt:=field(fieldn(etq[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);
          accion:='S';
          end;


          Procedure DELTRM;

          {----------------------------------------------------------}
          { cancela trmino del tesaurus                             }
          {----------------------------------------------------------}

          begin
          if nfields>1
             then begin
                   errmsg('No puede cancelarse termino con relaciones. Pri-
          mero cancele todas las relaciones');
                  accion:='S';
                  end
             else begin
                  rc:=flddel(1);
                  update; updinvf;
                  accion:='T';
                  end;
          end;

          Procedure SHOWDICT;

          {----------------------------------------------------------}
          { Lista diccionario                                        }
          {----------------------------------------------------------}

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


                                         54








          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(accion); uc(accion);
          if accion=chr(13) then k:=k+1 else
          if accion='B' then if k>1 then k:=k-1;
          chattr(0,ii+4,5,30);
          until (position('CPSTX', accion,1)>0) or (k>i);
          page(1);
          until (position('CSTX',accion,1)>0) or (term='');
          end;


          {----------------- Cuerpo del programa THES ----------------}

          begin

          maxt:=7;                          { Num relaciones definidas }
          rel:=   '   SN USEUF BT NT RT ';  { Nombre de relaciones }
          invrel:='      UF USENT BT RT ';  { Nombre relaciones inversas }
          for i:=1 to maxt do etq[i]:=i;    { etq de relacion }

          maxl:=15; q:='';
          nombrebd:=dbn; { guarda nombre base datos actual }
          if nombrebd<>'THES' then open('THES');
          clear;
          if maxmfn=1 then accion:='C' else accion:='T';

          repeat

          case accion of

          'T': { selecci¢n de trminos }

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

          'L': { Lista de terminos del tesaurus }



                                         55








               begin
               uc(term);
               rc:=find(term);
               page(1);
               clearmsg;
               writeln('<CR>[sgte]  B[previo]      P[ag]     S[elec]');
               write  ('C[rea term] T[selec term]  X[salir]');
               savescr(1);
               showdict;
               if term='' then accion:='L';
               end;

          'S': { Despliega relaciones entre terminos }

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

          'A': { Agrega una relacion }

               addrel;

          'C': { Crea nuevo termino }

               createrm;

          'D': { cancela termino o relacion }

               if cl=1 then deltrm else delrel;

          'Q': { Selecciona termino para busqueda }

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

          '?': { Despliega busqueda actual }

               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 se han seleccionado trminos') else
                  begin
                  k:=1; kl:=17;


                                         56








                  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('Oprima cualquier tecla para seguir');
               s:=inkey;
               page(2);
               accion:=decide(cl+1);
               end;

          end;
          until accion='X';

          option:=' ';
          if nombrebd<>'THES' then
             begin
             open(nombrebd);
             if size(q)>0 then
                begin
                clear;
                clearmsg; write('Edite expresion u oprima ENTER');
                rc:=edit(q,254,2,1,254,0,' ');
                if size(q)>0 then
                   begin
                   rc:=search(q);
                   option:=inkey;
                   end;
                end;
             end;
          end.

          (1)La versi¢n en  espa¤ol de  estos programas se  denomina con el
          nombre  indicado,  precedido de la  letra S (c¢digo de  idioma de
          CDS/ISIS para el espa¤ol). Estas versiones en espa¤ol son idnti-
          cas a las originales en ingls  salvo que se  han traducido todos
          los comentarios,  todos los letreros, y los nombres de algunas de
          las variables (aquellas que ten¡an  un  nombre reconocible clara-
          mente).  N¢tese que los comandos,  los nombres de las funciones y
          de los procedimientos no deben ni  pueden ser  traducidos, ya que
          esto impedir¡a la compilaci¢n  correcta de los programas  (N. del
          T.).














                                         57




:
