program La_Flipe; (* Asignatura: Ficheros y Base de Datos Curso: 2005-06 1er cuatrimetre Práctica 1 - Ficheros Alumnos: {100033768} {Grupo 5 } {M} {Vega Caridad}, {Richard} {100033426} {Grupo 5 } {M} {Cristina Fernandez}, {Roberto} {100029067} {Grupo 5 } {M} {Ruiz Mulas}, {Daniel} *) {$APPTYPE CONSOLE} uses SysUtils, Ficheros; TYPE tDireccion = RECORD Tipo:string; {incluye tipo de via} Nombre:string; Portal:string; CP:string; Localidad:string; end; tPublicacion = RECORD Nombre:string; Numero:string; Fecha:string; end; tArt = RECORD Titulo:string; Palabras:string; DatosPublicacion:tPublicacion; end; tArticulo = array [1..21] of tArt; tCorreo = RECORD Nickname:string; Dominio:string; End; tRegistro = RECORD Nombre:string; Apellido1:string; Apellido2:string; DNI:string; Sexo:string; Correo:tCorreo; Telefono1:string; Telefono2:string; URL:string; Direccion:tDireccion; Articulo:tArticulo; end; VAR c1024:integer; {contador del bloque lectura} c1024_E: integer; {contador del bloque escritura} registroLogico:tRegistro ; bloque,bloque_E: TBloque ; fichero,fichero_E: TFicheroSerial; ficheroTitulo, ficheroApellido: TFicheroDireccionado; control:boolean; totalCaracteres :integer ; enumerado:array[0..20000] of string; {Contiene los apellido y los nombres} colisiones:array[0..499] of integer; ficheroD:TFicheroDireccionado; desbordados: integer; (* Este fichero fuente es un esqueleto para la práctica, y podrá ser modificado libremente por los alumnos. Se suministran dos funciones de prueba: - Test_FicheroDireccionado - Test_FicheroSerial El programa principal simplemente llama a estas funciones, englobéndolas en un tratamiento de excepciones, y espera a que pulsemos la tecla ENTER. *) {procedure Test_FicheroDireccionado ( nombreFichero : String ); var fichero : TFicheroDireccionado; var bloque : TBloque; begin fichero.Abrir(nombreFichero); bloque.RellenarCero(); fichero.EscribirBloque(0,bloque); fichero.EscribirBloque(3,bloque); // no devuelve error bloque.RellenarRandom(); fichero.LeerBloque(1,bloque); bloque.Mostrar(); // Descomentar estas líneas para obtener error // bloque.RellenarRandom(); // fichero.LeerBloque(5,bloque); // sí devuelve error // bloque.Mostrar(); fichero.MostrarEstadisticas(); fichero.Cerrar(); end; procedure Test_FicheroSerial ( nombreFichero : String ); var fichero : TFicheroSerial; var bloque : TBloque; begin fichero.Abrir(nombreFichero); bloque.RellenarCero(); fichero.EscribirBloque(bloque); fichero.IrAPosicionInicial(); bloque.RellenarRandom(); fichero.LeerBloque(bloque); fichero.MostrarEstadisticas(); fichero.Cerrar(); end;} FUNCTION leerCaracterD:char; BEGIN IF c1024_E>=1024 THEN BEGIN c1024_E:=0; fichero.leerbloque(bloque_E); End; leerCaracterD:=chr(bloque_E.data[c1024_E]); inc(c1024_E); End; Procedure leerCaracterI(fich: TFicheroDireccionado; var devol : char; var ent: integer ); BEGIN IF c1024_E>=1023 THEN BEGIN c1024_E:=2; inc (ent); fich.leerbloque(ent ,bloque_E); End; devol :=chr(bloque_E.data[c1024_E]); inc(c1024_E); End; FUNCTION leerCaracter:char; BEGIN IF c1024>=1024 THEN BEGIN c1024:=0; fichero.leerbloque(bloque); End; leerCaracter:=chr(bloque.data[c1024]); inc(c1024); End; PROCEDURE escribirCaracter ( ch : char ); BEGIN IF c1024_E >= 1024 THEN BEGIN c1024_E:=0; fichero_E.escribirbloque(bloque_E); End; bloque_E.data[c1024_E] := ord(ch); inc(c1024_E); End; PROCEDURE escribirTamanyo(entrada:string); BEGIN bloque_E.data[0]:=ord(entrada[1]); bloque_E.data[1]:=ord(entrada[2]); End; PROCEDURE escribirDesbordado(entrada:string); BEGIN bloque_E.data[2]:=ord(entrada[1]); End; PROCEDURE QuitarEspacios(entrada:string; VAR salida:string); VAR indice,x,y:integer; BEGIN salida:=''; x:=1; WHILE (entrada[x]=' ') AND (x<=length(entrada)) DO inc(x); IF x>length(entrada) THEN salida:='' else BEGIN y:=length(entrada); WHILE entrada[y]=' ' DO dec(y); FOR indice:=x to y DO salida:=salida+entrada[indice]; End; End; PROCEDURE limpiarRegLogico; VAR x:byte; BEGIN registroLogico.Nombre:=''; registroLogico.Apellido1:=''; registroLogico.Apellido2:=''; registroLogico.DNI:=''; registroLogico.Sexo:=''; registroLogico.Correo.Nickname:=''; registroLogico.Correo.Dominio:=''; registroLogico.Telefono1:=''; registroLogico.Telefono2:=''; registroLogico.URL:=''; registroLogico.Direccion.Tipo := ''; registroLogico.Direccion.Nombre :=''; registroLogico.Direccion.Portal := ''; registroLogico.Direccion.CP:=''; registroLogico.Direccion.Localidad:=''; FOR x:=1 to 20 DO BEGIN registroLogico.Articulo[x].Titulo:=''; registroLogico.Articulo[x].Palabras:=''; registroLogico.Articulo[x].datosPublicacion.Nombre:=''; registroLogico.Articulo[x].datosPublicacion.Numero:=''; registroLogico.Articulo[x].datosPublicacion.Fecha:=''; End; {FOR} control := true; End; {limpiarRegLogico} FUNCTION potencia(base:longint; exp:integer):longint; BEGIN IF exp=0 THEN potencia:=1 else potencia:=base*potencia(base,exp-1); End; PROCEDURE descodificarNumero(entrada:string; VAR salida:longint); VAR num,exp,i:integer; sumando,pot:longint; BEGIN salida:=0; pot:=0; exp:=0; FOR i:=1 to length(entrada) DO BEGIN num:=ord(entrada[i]); sumando:=num*potencia(256,exp); pot:=pot+sumando; inc(exp); End; salida:=pot; End; FUNCTION descodificarLetra(entrada:longint):char; VAR modulo:integer; aux:char; BEGIN modulo:=entrada mod 23; CASE modulo OF 0:aux:='T'; 1:aux:='R'; 2:aux:='W'; 3:aux:='A'; 4:aux:='G'; 5:aux:='M'; 6:aux:='Y'; 7:aux:='F'; 8:aux:='P'; 9:aux:='D'; 10:aux:='X'; 11:aux:='B'; 12:aux:='N'; 13:aux:='J'; 14:aux:='Z'; 15:aux:='S'; 16:aux:='Q'; 17:aux:='V'; 18:aux:='H'; 19:aux:='L'; 20:aux:='C'; 21:aux:='K'; else aux:='E'; End; descodificarLetra:=aux; End; PROCEDURE descodificarDNI(entrada:string; VAR salida:string); VAR DNI:string; letra:char; aux:longint; BEGIN descodificarNumero(entrada,aux); letra:=descodificarLetra(aux); str(aux,DNI); salida:=DNI+letra; End; PROCEDURE descodificarPortal(entrada:string; VAR salida:string); VAR aux:longint; BEGIN descodificarNumero(entrada,aux); str(aux,salida); End; PROCEDURE descodificarApellidos(entrada:string; VAR salida:string); VAR aux:longint; // indice,error:integer; BEGIN descodificarNumero(entrada,aux); //val(aux,indice,error); salida:=enumerado[aux]; End; PROCEDURE descodificarNombre(entrada:string; VAR salida:string); VAR aux:longint; BEGIN descodificarNumero(entrada,aux); salida:=enumerado[aux]; End; PROCEDURE descodificarCP(entrada:string; VAR salida:string); VAR aux:longint; BEGIN descodificarNumero(entrada,aux); str(aux,salida); End; PROCEDURE descodificarTelefono(entrada:string; VAR salida:string); VAR aux:longint; BEGIN descodificarNumero(entrada,aux); str(aux,salida); End; PROCEDURE descodificarPalabras(entrada:string; VAR salida:string); VAR aux:longint; BEGIN descodificarNumero(entrada,aux); str(aux,salida); End; PROCEDURE descodificarNumPubli(entrada:string; VAR salida:string); VAR aux:longint; BEGIN descodificarNumero(entrada,aux); str(aux,salida); End; PROCEDURE codificarNumero(longitud:integer; entrada:string; VAR aux:string); VAR error,x,auxi:integer; salida:longint; resto:byte; caracter:char; BEGIN val(entrada,salida,error); resto:=0; IF error=0 THEN BEGIN aux:=''; WHILE salida>=256 DO BEGIN resto:=salida mod 256; caracter:=chr(resto); aux:=aux+caracter; salida:=salida div 256; End;{Fin WHILE} IF salida<256 THEN resto:=salida mod 256; caracter:=chr(resto); aux:=aux+caracter; x:=longitud-length(aux); FOR auxi:=1 to x DO aux:=aux+#0; End;{Fin IF} End; PROCEDURE escribirCaracter2 ( ch : char; fich : TFicheroDireccionado; var estamos:integer ); Var aux:string; BEGIN IF c1024_E = 1023 THEN BEGIN str(c1024_E, aux); codificarNumero(2,aux,aux); escribirTamanyo(aux); fich.escribirbloque(estamos,bloque_E); inc(estamos); bloque_E.RellenarCero; c1024_E:=2; End; bloque_E.data[c1024_E] := ord(ch); inc(c1024_E); End; PROCEDURE codificarDNI(entrada:string; VAR salida:string); VAR aux:string; x:byte; BEGIN aux:=''; salida:=''; FOR x:=1 to length(entrada) DO BEGIN IF (entrada[x]>='0') AND (entrada[x]<='9') THEN aux:=aux+entrada[x]; End; codificarNumero(4,aux,salida); End; PROCEDURE codificarCP(entrada:String; VAR salida:string); BEGIN salida:=''; codificarNumero(3,entrada,salida); End; PROCEDURE codificarTelefono(entrada:String; VAR salida:string); BEGIN salida:=''; codificarNumero(4,entrada,salida); End; PROCEDURE codificarPalabras(entrada:String; VAR salida:string); BEGIN salida:=''; codificarNumero(3,entrada,salida); End; PROCEDURE codificarNumPubli(entrada:String; VAR salida:string); BEGIN salida:=''; codificarNumero(2,entrada,salida); End; PROCEDURE codificarPortal(entrada:String; VAR salida:string); BEGIN salida:=''; codificarNumero(2,entrada,salida); End; FUNCTION codificarSexo(cadena1:string):char; BEGIN IF cadena1='mujer' THEN codificarSexo:='M' else codificarSexo:='H'; End; PROCEDURE descodificarSexo(sexo:char; VAR cadena1:string); BEGIN IF sexo='M' THEN cadena1:='mujer' else cadena1:='varón'; End; PROCEDURE codificarDia(entrada:string; VAR salida:string); BEGIN IF entrada=' ' THEN salida:=#0 else BEGIN salida:=''; quitarEspacios(entrada,entrada); codificarNumero(1,entrada,salida); End; End; PROCEDURE codificarMes (entrada : string ; VAR salida : String); Var noMes: boolean; begin noMes := FALSE; quitarEspacios(entrada,entrada); If entrada = 'Enero' then salida := '1' else If entrada = 'Febrero' then salida := '2' else If entrada = 'Marzo' then salida := '3' else If entrada = 'Abril' then salida := '4' else If entrada = 'Mayo' then salida := '5' else If entrada = 'Junio' then salida := '6' else If entrada = 'Julio' then salida := '7' else If entrada = 'Agosto' then salida := '8' else If entrada = 'Septiembre' then salida := '9' else If entrada = 'Octubre' then salida := 'A' else If entrada = 'Noviembre' then salida := 'B' else If entrada = 'Diciembre' then salida := 'C' else noMes:=TRUE; If noMes then salida := '0'; end; PROCEDURE codificarAnyo(entrada:string; VAR salida:string); BEGIN salida:=''; codificarNumero(2,entrada,salida); End; PROCEDURE codificarFecha(entrada:string; VAR sal1,sal2,sal3:string); VAR dia,mes,anyo:string; i:integer; BEGIN dia:=''; mes:=''; anyo:=''; sal1:=''; sal2:=''; sal3:=''; FOR i:=1 to 2 DO dia:=dia+entrada[i]; codificarDia(dia,sal1); FOR i:=4 to 13 DO mes:=mes+entrada[i]; codificarMes(mes,sal2); FOR i:=15 to 18 DO anyo:=anyo+entrada[i]; codificarAnyo(anyo,sal3); End; PROCEDURE descodificarDia(entrada:string; VAR salida:string); VAR aux:longint; BEGIN IF entrada=#0 THEN salida:='' else BEGIN descodificarNumero(entrada,aux); str(aux,salida); End; End; PROCEDURE descodificarMes (entrada:string; VAR salida:string); BEGIN If entrada = '1' then salida := 'Enero' else If entrada = '2' then salida := 'Febrero' else If entrada = '3' then salida := 'Marzo' else If entrada = '4' then salida := 'Abril' else If entrada = '5' then salida := 'Mayo' else If entrada = '6' then salida := 'Junio' else If entrada = '7' then salida := 'Julio' else If entrada = '8' then salida := 'Agosto' else If entrada = '9' then salida := 'Septiembre' else If entrada = 'A' then salida := 'Octubre' else If entrada = 'B' then salida := 'Noviembre' else If entrada = 'C' then salida := 'Diciembre' else salida:=''; End; PROCEDURE descodificarAnyo(entrada:string; VAR salida:string); VAR aux:longint; BEGIN descodificarNumero(entrada,aux); str(aux,salida); End; PROCEDURE descodificarFecha(entrada:string; VAR salida:string); VAR dia,diaD,mes,mesD,anyoD,anyo:string; BEGIN salida:=''; dia:=entrada[1]; mes:=entrada[2]; anyo:=entrada[3]+entrada[4]; descodificarDia(dia,diaD); descodificarMes(mes,mesD); descodificarAnyo(anyo,anyoD); IF diaD<>'' THEN salida:=salida+diaD+'-'; IF mesD<>'' THEN salida:=salida+mesD+'-'; salida:=salida+anyoD; End; PROCEDURE cambiarGitano ( entrada : integer ; VAR salida : String); Begin salida := ''; if entrada < 10 THEN Begin str(entrada, salida); end; if entrada = 10 Then begin salida := 'A'; end; If entrada = 11 Then begin salida := 'B'; end; If entrada = 12 Then begin salida := 'C'; end; If entrada = 13 Then begin salida := 'D'; end; If entrada = 14 Then begin salida := 'E'; end; If entrada = 15 Then begin salida := 'F'; end; If entrada = 16 Then begin salida := 'G'; end; If entrada = 17 Then begin salida := 'H'; end; If entrada = 18 Then begin salida := 'I'; end; If entrada = 19 Then begin salida := 'J'; end; If entrada = 20 Then begin salida := 'K'; end; End; PROCEDURE desCambiarGitano ( entrada : string ; VAR salida : integer ); Var retocado : boolean ; u : integer; Begin retocado := False ; if entrada = 'A' Then begin salida := 10; retocado := true ; end; If entrada = 'B' Then begin salida := 11; retocado := true ; end; If entrada = 'C' Then begin salida := 12; retocado := true ; end; If entrada = 'D' Then begin salida := 13; retocado := true ; end; If entrada = 'E' Then begin salida := 14; retocado := true ; end; If entrada = 'F' Then begin salida := 15 ; retocado := true ; end; If entrada = 'G' THEn begin salida := 16 ; retocado := true ; end; If entrada = 'H' Then begin salida := 17; retocado := true ; end; If entrada = 'I' Then begin salida := 18; retocado := true ; end; If entrada = 'J' Then begin salida := 19; retocado := true ; end; If entrada = 'K' Then begin salida := 20; retocado := true ; end; If not retocado then Begin val(entrada, salida , u); End ; End; PROCEDURE marcaFinFichero ; BEGIN escribirCaracter('#'); escribirCaracter('#'); escribirCaracter('#'); escribirCaracter('#'); fichero_E.escribirbloque(bloque_E); writeln('Fichero importado.'); End; PROCEDURE escribirCampo( aux:string ); VAR indice:integer; BEGIN FOR indice:=1 to length(aux) DO BEGIN escribirCaracter(aux[indice]); End; End; Procedure escribirCampo2(aux:string; fich : TFicheroDireccionado; var estamos: integer); VAR indice:integer; BEGIN FOR indice:=1 to length(aux) DO BEGIN escribirCaracter2(aux[indice],fich, estamos ); End; End; PROCEDURE leerCampoC(VAR cadena1:string); VAR caracter:char; BEGIN caracter:=leerCaracter; IF caracter='#' THEN BEGIN cadena1:=cadena1+caracter; caracter:=leerCaracter; IF caracter='#' THEN BEGIN cadena1:=cadena1+caracter; caracter:=leerCaracter; IF caracter='#' THEN BEGIN cadena1:=cadena1+caracter; caracter:=leerCaracter; IF caracter='#' THEN cadena1:=cadena1+caracter; End; End; End else while(caracter <> '$') DO BEGIN cadena1:=cadena1+caracter; caracter:=leerCaracter; End; {Fin del WHILE del else} End; PROCEDURE leerCampo(n:integer; VAR aux:string); VAR indice:integer; auxCar:char; BEGIN aux:=''; FOR indice:=1 to n DO BEGIN auxCar:=leerCaracter; aux:=aux+auxCar; End; End; PROCEDURE leerCampoDN(n:integer; VAR aux:string); VAR indice:integer; auxCar:char; BEGIN aux:=''; FOR indice:=1 to n DO BEGIN auxCar:=leerCaracterD; aux:=aux+auxCar; End; End; PROCEDURE leerCampoIN(n:integer; fich: TFicheroDireccionado ; VAR aux:string ; var ent : integer ); VAR indice:integer; auxCar:char; BEGIN aux:=''; FOR indice:=1 to n DO BEGIN leerCaracterI(fich, auxCar, ent); aux:=aux+auxCar; End; End; procedure leerDesbordado(Var aux:string); begin aux:=''; aux := chr(bloque_E.data[2]); end; PROCEDURE leerCampoLong( VAR aux:string); BEGIN aux:=''; aux:= chr(bloque_E.data[0])+ chr(bloque_E.data[1]); { while(auxCar <> '$') DO BEGIN aux := aux + chr(bloque_E.data[p]); inc(p); auxCar:=chr(bloque_E.data[p]) ; End;} End; PROCEDURE leerCampoD( VAR aux:string); VAR auxCar:char; BEGIN aux:=''; auxCar := leerCaracterD ; while(auxCar <> '$') DO BEGIN aux := aux + auxCar; auxCar:=leerCaracterD; End; End; PROCEDURE leerCampoI( fich: TFicheroDireccionado ;VAR aux:string ; var ent : integer ); VAR auxCar:char; BEGIN aux:=''; auxCar := leerCaracterD ; while(auxCar <> '$') DO BEGIN aux := aux + auxCar; leerCaracterI(fich,auxCar, ent ); End; End; Procedure descodificarTituloPublicacion(entrada : string ; Var salida : string); Begin IF entrada='0' THEN BEGIN salida:='World News'; End else IF entrada='1' THEN BEGIN salida:='Watchung'; End else IF entrada='2' THEN BEGIN salida:='Treinta Días'; End else IF entrada='3' THEN BEGIN salida:='The High Noon Chronicles'; End else IF entrada='4' THEN BEGIN salida:='The Everywhere-News'; End else IF entrada='5' THEN BEGIN salida:='The Daily Bugle'; End else IF entrada='6' THEN BEGIN salida:='Sprites'; End else IF entrada='7' THEN BEGIN salida:='Semanario del Mes'; End else IF entrada='8' THEN BEGIN salida:='Resolutions'; End else IF entrada='9' THEN BEGIN salida:='Radio Patio Press'; End else IF entrada='A' THEN BEGIN salida:='Páginas con Tinta'; End else IF entrada='B' THEN BEGIN salida:='Nitroglicerinico'; End else IF entrada='C' THEN BEGIN salida:='New Realms'; End else IF entrada='D' THEN BEGIN salida:='New News'; End else IF entrada='E' THEN BEGIN salida:='Nebuchadnezzar'; End else IF entrada='F' THEN BEGIN salida:='Milenio3'; End else IF entrada='G' THEN BEGIN salida:='Mesenario'; End else IF entrada='H' THEN BEGIN salida:='Manamaná'; End else IF entrada='I' THEN BEGIN salida:='Letrenario'; End else IF entrada='J' THEN BEGIN salida:='Le Chauvin'; End else IF entrada='K' THEN BEGIN salida:='Las Noticias'; End else IF entrada='L' THEN BEGIN salida:='Lapso'; End else IF entrada='M' THEN BEGIN salida:='La Última Frontera'; End else IF entrada='N' THEN BEGIN salida:='Gimme Five'; End else IF entrada='O' THEN BEGIN salida:='Extra Time'; End else IF entrada='P' THEN BEGIN salida:='El puntazo'; End else IF entrada='Q' THEN BEGIN salida:='El Pisto'; End else IF entrada='R' THEN BEGIN salida:='El Pasquín'; End else IF entrada='S' THEN BEGIN salida:='El Panfleto'; End else IF entrada='T' THEN BEGIN salida:='El Heraldo Cultural'; End else IF entrada='U' THEN BEGIN salida:='El Espejo de la Verdad'; End else IF entrada='V' THEN BEGIN salida:='El Diario de Aquí'; End else IF entrada='W' THEN BEGIN salida:='El Cardinal'; End else IF entrada='X' THEN BEGIN salida:='El Boletín del Mediodia'; End else IF entrada='Y' THEN BEGIN salida:='El Australopitecus'; End else IF entrada='Z' THEN BEGIN salida:='Daily Notes on News'; End else IF entrada='a' THEN BEGIN salida:='Cantos con Bits'; End else IF entrada='b' THEN BEGIN salida:='Buena Prensa'; End else IF entrada='c' THEN BEGIN salida:='Aqua'; End else IF entrada='d' THEN BEGIN salida:='Ankí Akonkagua'; End else leerCampoD(salida); End; {Codificar titulo de publicaciones} Procedure comparar(nom:string;ap1:string;ap2:string;var iguales:boolean); begin if(nom=registroLogico.nombre) and (ap1=registroLogico.apellido1) and (ap2=registroLogico.apellido2) then begin iguales := true; end else begin iguales := false; end; end; Procedure compararNombre(nom:string;var iguales:boolean); begin if(nom=registroLogico.nombre)then begin iguales := true; end else begin iguales := false; end; end; Procedure compararApellido(nom:string;var iguales:boolean); begin if(nom=registroLogico.apellido1)then begin iguales := true; end else begin iguales := false; end; end; Procedure compararApellido2(nom:string; nom2 : string ;var iguales:boolean); begin if(nom=nom2)then begin iguales := true; end else begin iguales := false; end; end; Procedure compararDNI(nom:string;var iguales:boolean); begin if(nom=registroLogico.DNI)then begin iguales := true; end else begin iguales := false; end; end; Procedure compararTitulo(nom:string;var iguales:boolean); Var indiceArticulo : integer; begin iguales := false; FOR indiceArticulo:=1 to 20 DO BEGIN if(nom=registroLogico.Articulo[indiceArticulo].Titulo)then begin iguales := true; end; end; end; PROCEDURE desCodificarTipoDireccion(entrada:string; Var salida : string); Begin If entrada[1] = '1' then Begin salida := 'Calle' End else If entrada[1] = '2' then Begin salida := 'Plaza' End else If entrada[1] = '3' then Begin salida := 'Avenida' End else If entrada[1] = '4' then Begin salida := 'Paseo' End else If entrada[1] = '5' then Begin salida := 'Travesía' End else If entrada[1] = '6' then Begin leerCampoD(salida); //HACER salida := entrada[2]....entrada[length] End End; PROCEDURE descodificarCorreo(entrada:string; Var salida : string); Begin IF entrada[1]='0' THEN BEGIN salida:='socios.paparazzi.org' End else IF entrada[1]='1' THEN BEGIN salida:='users.reportajes.com' End else IF entrada[1]='2' THEN BEGIN salida:='prensa.es' End else IF entrada[1]='3' THEN BEGIN salida:='mimail.es' End else IF entrada[1]='4' THEN BEGIN salida:='mimail.com' End else IF entrada[1]='5' THEN BEGIN salida:='usuarios.arena.es' End else IF entrada[1]='6' THEN BEGIN salida:='usuarios.arena.net' End else IF entrada[1]='7' THEN BEGIN salida:='reports.docuteca.es' End else IF entrada[1]='8' THEN BEGIN salida:='usuarios.portalprensa.org' End else IF entrada[1]='9' THEN BEGIN salida:='authors.fededitores.com' End else IF entrada[1]='A' THEN BEGIN salida:='authors.fededitores.org' End else IF entrada[1]='B' THEN BEGIN salida:='autores.fededitores.org' End else If entrada[1] = 'C' then Begin leerCampoD(salida) End; End; {Procedimiento descodificar Direccion} PROCEDURE descodificarURL1(entrada:char; VAR salida:string); VAR noEntra:boolean; BEGIN noEntra:=TRUE; IF entrada='0' THEN BEGIN salida:='webpages.4free.com'; noEntra:=FALSE; End else IF entrada='1' THEN BEGIN salida:='web.freemegabytes.com'; noEntra:=FALSE End else IF entrada='2' THEN BEGIN salida:='www.webspace.com'; noEntra:=FALSE; End else IF entrada='3' THEN BEGIN salida:='www.prensa.es'; noEntra:=FALSE; End else IF entrada='4' THEN BEGIN salida:='www.mimail.es'; noEntra:=FALSE; End else IF entrada='5' THEN BEGIN salida:='wwww.usuarios.arena.es'; noEntra:=FALSE; End else IF entrada='6' THEN BEGIN salida:='www.portalprensa.org'; noEntra:=FALSE; End else IF entrada='7' THEN BEGIN salida:='paginas.reportajes.com'; noEntra:=FALSE; End else IF entrada='8' THEN BEGIN salida:='www.fededitores.com'; noEntra:=FALSE; End else IF entrada='9' THEN BEGIN salida:='www.arena.com'; noEntra:=FALSE; End else IF entrada='A' THEN BEGIN salida:='www.docuteca.es'; noEntra:=FALSE; End; If noEntra then Begin leerCampoD(salida) End; End; {Fin descodificar URL1} PROCEDURE descodificarURL2 (entrada:char; VAR salida:string); BEGIN IF entrada='1' THEN salida:=registroLogico.Correo.Nickname else BEGIN leerCampoD(salida); End; End; {Fin descodificar URL2} PROCEDURE descodificarURL3 (entrada:string; VAR salida:string); BEGIN leerCampoD(salida) End; {PROCEDURE codificarFecha(entrada:string; VAR salida:string); VAR dia,mes,anyo:string; BEGIN dia:=''; mes:=''; anyo:=''; IF entrada[1]=' ' THEN IF entrada[2]=' ' THEN dia:='0' else BEGIN dia:=dia+entrada[1]+entrada[2]; codificarDia(dia); End; IF entrada[4]=' ' THEN mes:='0' else BEGIN WHILE x codificarMes(mes); codificarAnyo(anyo); End; } //Function codificarFechaRob(f:string):string; //Var // i:byte; {variable para recorrer f } // separador:byte; {variable que separa el dia, el mes y el anyo} // k:integer; {variable util para la funcion val } // enterodia:integer; {recoge el entero de ese dato } // enteroanyo:integer; {recoge el entero de ese dato } // dia,mes,anyo:string; // dosdigitos:string; // recogefecha:string; //BEGIN // dia:=''; // mes:=''; // anyo:=''; // separador := 0; // recogefecha:=''; // for i:=1 to length(f) do // begin {cogemos todos los caracteres de fecha } // if f[i]= '-' then // inc(separador) {si hay -, no queremos guardarlo, y sirve} // else {para saber si vamos por dia, mes o anyo } // begin // if separador=0 then {si separador es 0, entonces} // dia:=dia+f[i] {guardamos en dia } // else // begin // if separador=1 then {si separador es 2, entonces} // mes:=mes+f[i] {guardamos en mes } // else {si no es ninguno, entonces } // anyo:=anyo+f[i] {es que vamos por anyo } // end; // end; // end; // val(dia,enterodia,k); {pasamos de char a entero el dia} // recogefecha:=recogefecha+chr(100+enterodia); {y guardamos el caracter} {Ahora tratamos los meses} // if mes[1]='E' then {Enero} // recogefecha:=recogefecha+'E' // else // if mes[1]='F' then {febrero} // recogefecha:=recogefecha+'F' // else // if mes[1]='M' then // begin // if mes[4]='Z' then {marzo} // recogefecha:=recogefecha+'M' // else {mayo} // recogefecha:=recogefecha+'Y' // end // else // if mes[1]='A' then // begin // if mes[2]='B' then {abril} // recogefecha:=recogefecha+'A' // else {agosto} // recogefecha:=recogefecha+'G' // end // else // if mes[1]='J' then // begin // if mes[3]='N' then {junio} // recogefecha:=recogefecha+'J' // else {julio} // recogefecha:=recogefecha+'L' // end // else // if mes[1]='S' then {septiembre} // recogefecha:=recogefecha+'S' // else // if mes[1]='O' then {Octubre} // recogefecha:=recogefecha+'O' // else // if mes[1]='N' then {noviembre} // recogefecha:=recogefecha+'N' // else // if mes[1]='D' then {Diciembre} // recogefecha:=recogefecha+'D'; {Una vez codificamos el mes, solo queda codificar el anyo} // dosdigitos:=anyo[1]+anyo[2]; {cogemos los dos primeros digitos} // val(dosdigitos,enteroanyo,k); {y los pasamos a entero} // recogefecha:=recogefecha+chr(100+enteroanyo); {los guardamos como char} // dosdigitos:=anyo[3]+anyo[4]; {repetimos la operacion} // val(dosdigitos,enteroanyo,k); {con los ultimos char } // recogefecha:=recogefecha+chr(100+enteroanyo); // codificarFecha:=recogefecha; //end; Procedure codificarTituloPublicacion(entrada : string ; Var salida : string); Var noEntra:boolean; Begin salida := ''; NoEntra:=TRUE; IF entrada='World News' THEN BEGIN salida:=salida+'0'; noEntra:=FALSE; End else IF entrada='Watchung' THEN BEGIN salida:=salida+'1'; noEntra:=FALSE End else IF entrada='Treinta Días' THEN BEGIN salida:=salida+'2'; noEntra:=FALSE; End else IF entrada='The High Noon Chronicles' THEN BEGIN salida:=salida+'3'; noEntra:=FALSE; End else IF entrada='The Everywhere-News' THEN BEGIN salida:=salida+'4'; noEntra:=FALSE; End else IF entrada='The Daily Bugle' THEN BEGIN salida:=salida+'5'; noEntra:=FALSE; End else IF entrada='Sprites' THEN BEGIN salida:=salida+'6'; noEntra:=FALSE; End else IF entrada='Semanario del Mes' THEN BEGIN salida:=salida+'7'; noEntra:=FALSE; End else IF entrada='Resolutions' THEN BEGIN salida:=salida+'8'; noEntra:=FALSE; End else IF entrada='Radio Patio Press' THEN BEGIN salida:=salida+'9'; noEntra:=FALSE; End else IF entrada='Páginas con Tinta' THEN BEGIN salida:='A'; noEntra:=FALSE; End else IF entrada='Nitroglicerinico' THEN BEGIN salida:=salida+'B'; noEntra:=FALSE; End else IF entrada='New Realms' THEN BEGIN salida:=salida+'C'; noEntra:=FALSE End else IF entrada='New News' THEN BEGIN salida:=salida+'D'; noEntra:=FALSE; End else IF entrada='Nebuchadnezzar' THEN BEGIN salida:=salida+'E'; noEntra:=FALSE; End else IF entrada='Milenio3' THEN BEGIN salida:=salida+'F'; noEntra:=FALSE; End else IF entrada='Mesenario' THEN BEGIN salida:=salida+'G'; noEntra:=FALSE; End else IF entrada='Manamaná' THEN BEGIN salida:=salida+'H'; noEntra:=FALSE; End else IF entrada='Letrenario' THEN BEGIN salida:=salida+'I'; noEntra:=FALSE; End else IF entrada='Le Chauvin' THEN BEGIN salida:=salida+'J'; noEntra:=FALSE; End else IF entrada='Las Noticias' THEN BEGIN salida:=salida+'K'; noEntra:=FALSE; End else IF entrada='Lapso' THEN BEGIN salida:='L'; noEntra:=FALSE; End else IF entrada='La Última Frontera' THEN BEGIN salida:=salida+'M'; noEntra:=FALSE; End else IF entrada='Gimme Five' THEN BEGIN salida:=salida+'N'; noEntra:=FALSE; End else IF entrada='Extra Time' THEN BEGIN salida:=salida+'O'; noEntra:=FALSE; End else IF entrada='El puntazo' THEN BEGIN salida:=salida+'P'; noEntra:=FALSE; End else IF entrada='El Pisto' THEN BEGIN salida:=salida+'Q'; noEntra:=FALSE; End else IF entrada='El Pasquín' THEN BEGIN salida:=salida+'R'; noEntra:=FALSE; End else IF entrada='El Panfleto' THEN BEGIN salida:='S'; noEntra:=FALSE; End else IF entrada='El Heraldo Cultural' THEN BEGIN salida:=salida+'T'; noEntra:=FALSE; End else IF entrada='El Espejo de la Verdad' THEN BEGIN salida:=salida+'U'; noEntra:=FALSE End else IF entrada='El Diario de Aquí' THEN BEGIN salida:=salida+'V'; noEntra:=FALSE; End else IF entrada='El Cardinal' THEN BEGIN salida:=salida+'W'; noEntra:=FALSE; End else IF entrada='El Boletín del Mediodia' THEN BEGIN salida:=salida+'X'; noEntra:=FALSE; End else IF entrada='El Australopitecus' THEN BEGIN salida:=salida+'Y'; noEntra:=FALSE; End else IF entrada='Daily Notes on News' THEN BEGIN salida:=salida+'Z'; noEntra:=FALSE; End else IF entrada='Cantos con Bits' THEN BEGIN salida:=salida+'a'; noEntra:=FALSE; End else IF entrada='Buena Prensa' THEN BEGIN salida:=salida+'b'; noEntra:=FALSE; End else IF entrada='Aqua' THEN BEGIN salida:=salida+'c'; noEntra:=FALSE; End else IF entrada='Ankí Akonkagua' THEN BEGIN salida:='d'; noEntra:=FALSE; End; If noEntra then Begin salida:=salida + 'e'+ entrada + '$'; End; End; {Codificar titulo de publicaciones} Procedure codificarURL(entrada : string ; Var salida : string); Var aux:string; i,j,y : integer; barra,noEntra:boolean; Begin salida := ''; aux:=''; barra:=FALSE; {Quita http://} //for i := 8 to length(entrada) do // Begin // salida := salida + entrada[i]; // end; {Acaba aqui} IF entrada='' THEN salida:='0' else {existe URL} BEGIN salida:='1'; // FOR i:= 1 to 7 DO // aux:=aux+entrada[i]; // entrada1:=aux; // aux:=''; i:=8; WHILE entrada[i]<>'/' do BEGIN aux:=aux+entrada[i]; inc(i); End; noEntra:=TRUE; IF aux='webpages.4free.com' THEN BEGIN salida:=salida+'0'; noEntra:=FALSE; End else IF aux='web.freemegabytes.com' THEN BEGIN salida:=salida+'1'; noEntra:=FALSE End else IF aux='www.webspace.com' THEN BEGIN salida:=salida+'2'; noEntra:=FALSE; End else IF aux='www.prensa.es' THEN BEGIN salida:=salida+'3'; noEntra:=FALSE; End else IF aux='www.mimail.es' THEN BEGIN salida:=salida+'4'; noEntra:=FALSE; End else IF aux='wwww.usuarios.arena.es' THEN BEGIN salida:=salida+'5'; noEntra:=FALSE; End else IF aux='www.portalprensa.org' THEN BEGIN salida:=salida+'6'; noEntra:=FALSE; End else IF aux='paginas.reportajes.com' THEN BEGIN salida:=salida+'7'; noEntra:=FALSE; End else IF aux='www.fededitores.com' THEN BEGIN salida:=salida+'8'; noEntra:=FALSE; End else IF aux='www.arena.com' THEN BEGIN salida:=salida+'9'; noEntra:=FALSE; End else IF aux='www.docuteca.es' THEN BEGIN salida:=salida+'A'; noEntra:=FALSE; End; If noEntra then Begin salida:=salida + 'B'+ aux + '$'; End; {Rutina para obtener la segunda parte del URL} aux:=''; {Localizamos la ultima /} j:=length(entrada); WHILE entrada[j]<>'/' DO dec(j); //y:=j-1; inc(i); WHILE i<>j DO BEGIN aux:=aux+entrada[i]; IF entrada[i]='/' THEN barra:=TRUE; inc(i); End; //WHILE entrada[i]<>'/' do // BEGIN // aux:=aux+entrada[i]; // inc(i); // End; IF registroLogico.Correo.Nickname=aux THEN salida:=salida+'1' else salida:=salida +'0'+aux; IF barra THEN salida:=salida+'$'; inc(i); {Rutina para obtener la ultima parte de la URL} aux:=''; FOR y:=i to length(entrada) DO BEGIN aux:=aux+entrada[y]; End; salida:=salida+aux; End; {Fin del IF si existe la URL} End; {Rutina para sacar enumerados} // h:=1; //pp:=0 // WHILE h<1000 DO // BEGIN // IF enumerado[h]<>aux THEN // BEGIN //writeln(enumerado[h],aux,h); // IF enumerado[h]='' THEN // BEGIN // enumerado[h]:=aux; // h:=1000; // end; // inc(h); // End // else h:=1000; // End; // readln; PROCEDURE CodificarTipoDireccion( entrada:string; Var salida : string); Var noEntra : boolean; Begin noEntra := true; If entrada = 'Calle' then Begin salida := '1'; noEntra := false ; End; If entrada = 'Plaza' then Begin salida := '2'; noEntra := false ; End; If entrada = 'Avenida' then Begin salida := '3'; noEntra := false ; End; If entrada = 'Paseo' then Begin salida := '4'; noEntra := false ; End; If entrada = 'Travesía' then Begin noEntra := false ; salida := '5'; End; If noEntra then Begin salida:='6'+ entrada + '$'; End; End; PROCEDURE codificarApellido(entrada:String; VAR salida:string); BEGIN salida:=''; codificarNumero(2,entrada,salida); End; PROCEDURE codificarApellidos(apellidos1,apellido2:string; VAR sal1,sal2:string); VAR i:integer; aux:string; existe:boolean; BEGIN {calcular enumerado} existe:=FALSE; FOR i:=1 to 20000 DO BEGIN IF enumerado[i]=registroLogico.Apellido1 THEN BEGIN existe:=TRUE; str(i,aux); codificarApellido(aux,sal1) End; IF (enumerado[i]='') AND (existe=FALSE) THEN BEGIN enumerado[i]:=registroLogico.Apellido1; existe:=TRUE; str(i,aux); codificarApellido(aux,sal1); End; End; existe:=FALSE; FOR i:=1 to 20000 DO BEGIN IF enumerado[i]=registroLogico.Apellido2 THEN BEGIN existe:=TRUE; str(i,aux); codificarApellido(aux,sal2); End;{IF} IF (enumerado[i]='') AND (existe=FALSE) THEN BEGIN enumerado[i]:=registroLogico.Apellido2; existe:=TRUE; str(i,aux); codificarApellido(aux,sal2); End;{IF} End;{FOR} End; PROCEDURE codificarNombre(entrada:string; VAR salida:string); VAR existe:boolean; i:integer; aux:string; BEGIN existe:=FALSE; FOR i:=1 to 20000 DO BEGIN IF enumerado[i]=registroLogico.Nombre THEN BEGIN existe:=TRUE; str(i,aux); salida:=''; codificarNumero(4,aux,salida); End; IF (enumerado[i]='') AND (existe=FALSE) THEN BEGIN enumerado[i]:=registroLogico.Nombre; existe:=TRUE; str(i,aux); salida:=''; codificarNumero(4,aux,salida); End; End; End; PROCEDURE codificarCorreo (entrada:string); VAR dominio,nickname:string; x,y:byte; BEGIN nickname:=''; x:=1; WHILE entrada[x]<>'@' DO BEGIN nickname:=nickname+entrada[x]; inc(x); End; registroLogico.Correo.Nickname:=nickname; y:=x+1; dominio:=''; FOR x:=y to length(entrada) DO BEGIN dominio:=dominio+entrada[x]; End; registroLogico.Correo.Dominio:=dominio; End; PROCEDURE codificarTipoCorreo (entrada:string; VAR salida:string); VAR noEntra:boolean; aux:string; BEGIN noEntra:=TRUE; aux:=''; IF entrada='socios.paparazzi.org' THEN BEGIN salida:='0'; noEntra:=FALSE; End else IF entrada='users.reportajes.com' THEN BEGIN salida:='1'; noEntra:=FALSE End else IF entrada='prensa.es' THEN BEGIN salida:='2'; noEntra:=FALSE; End else IF entrada='mimail.es' THEN BEGIN salida:='3'; noEntra:=FALSE; End else IF entrada='mimail.com' THEN BEGIN salida:='4'; noEntra:=FALSE; End else IF entrada='usuarios.arena.es' THEN BEGIN salida:='5'; noEntra:=FALSE; End else IF entrada='usuarios.arena.net' THEN BEGIN salida:='6'; noEntra:=FALSE; End else IF entrada='reports.docuteca.es' THEN BEGIN salida:='7'; noEntra:=FALSE; End else IF entrada='usuarios.portalprensa.org' THEN BEGIN salida:='8'; noEntra:=FALSE; End else IF entrada='authors.fededitores.com' THEN BEGIN salida:='9'; noEntra:=FALSE; End else IF entrada='authors.fededitores.org' THEN BEGIN salida:='A'; noEntra:=FALSE; End else IF entrada='autores.fededitores.org' THEN BEGIN salida:='B'; noEntra:=FALSE; End; If noEntra then Begin salida:='C'+ entrada + '$'; End; End; PROCEDURE codificarDireccion(entrada:string); VAR y:byte; x:integer ; tipoCalle,calle,portalCalle:string; BEGIN {Hasta primer espacio enumerado tipo de via} {Hasta la coma nombre de la calle} {El final el portal} x:=1;{contador} tipoCalle:=''; WHILE entrada[x] <> ' ' DO {localizamos el tipo de via} BEGIN tipoCalle:=tipoCalle+entrada[x]; inc(x); End; {codificamos el tipo de via} registroLogico.Direccion.Tipo := tipoCalle; inc(x); WHILE entrada[x]<>',' DO {localizamos el nombre de la calle} BEGIN calle:=calle+entrada[x]; inc(x); End; QuitarEspacios(calle,calle); // y:=1; // WHILE calle[y]<>',' DO // BEGIN // aux:=aux+calle[y]; // inc(y); // End; registroLogico.Direccion.Nombre:=calle; {Guardamos el nombre de la calle} WHILE entrada[x]<>'N' DO {localizamos el numero} BEGIN inc(x); End; FOR y:=x+1 to length(entrada) DO BEGIN portalCalle:=portalCalle+entrada[y]; End; quitarEspacios(portalCalle,portalCalle); // while length(portalCalle) < 3 do // begin // portalCalle := ' ' + portalCalle; // end ; registroLogico.Direccion.Portal := portalCalle; End; {codificarDireccion} PROCEDURE leerRegCod; Var aux,tipoVia,DNI,dominio,URL1,URL2,URL3,Portal,Telefono1,Telefono2: string; CP,Palabras,Numpubli,fecha:string; auxi,sexo,URL : char; numero, indiceArticulo: integer; Begin numero := 0; leerCampoD(registroLogico.Nombre); IF (registroLogico.Nombre[1] = '#') and (registroLogico.Nombre[4] = '#') and (registroLogico.Nombre[2] = '#') and (registroLogico.Nombre[3] = '#') Then Begin control:=FALSE; End; IF control THEN Begin leerCampoD(registroLogico.Apellido1); leerCampoD(registroLogico.Apellido2); leerCampoDN(4,DNI); descodificarDNI(DNI,registroLogico.DNI); //leerCampo(9, registroLogico.DNI); sexo := leerCaracterD; descodificarSexo(sexo, registroLogico.Sexo); leerCampoD(registroLogico.Correo.Nickname); leerCampoDN(1,dominio); descodificarCorreo(dominio,registroLogico.Correo.Dominio); //leerCampoC(registroLogico.Correo); leerCampoDN(1,aux); IF aux = '2' THEN Begin leerCampoDN(4,Telefono1); descodificarTelefono(Telefono1,registroLogico.Telefono1); leerCampoDN(4,Telefono2); descodificarTelefono(Telefono2,registroLogico.Telefono2); End; IF aux = '1' THEN begin leerCampoDN(4,Telefono1); descodificarTelefono(Telefono1,registroLogico.Telefono1); end; URL:=leerCaracterD; IF URL='1' THEN BEGIN URL:=leerCaracterD; descodificarURL1(URL,URL1); auxi:=leerCaracterD; descodificarURL2(auxi,URL2); leerCampoD(URL3); registroLogico.URL:='http://'+URL1+'/'+URL2+'/'+URL3; End else registroLogico.URL:=''; //leerCampoC(registroLogico.URL); //if(registroLogico.URL <> '') then //begin // registroLogico.URL := 'http://' + registroLogico.URL; //end; leerCampoDN(1,TipoVia); desCodificarTipoDireccion(TipoVia,registroLogico.Direccion.Tipo); leerCampoD(registroLogico.Direccion.Nombre); leerCampoDN(2,Portal); descodificarPortal(Portal,registroLogico.Direccion.Portal); leerCampoDN(3,CP); descodificarCP(CP,registroLogico.Direccion.CP); leerCampoD(registroLogico.Direccion.Localidad); //Leemos campo repeticion Articulos leerCampoDN(1,aux); desCambiarGitano(aux,numero); FOR indiceArticulo:=1 to numero DO BEGIN leerCampoD(registroLogico.Articulo[indiceArticulo].Titulo); leerCampoDN(3,Palabras); descodificarPalabras(Palabras,registroLogico.Articulo[indiceArticulo].Palabras); leerCampoDN(1,aux); descodificarTituloPublicacion(aux,RegistroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); //leerCampoC(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); leerCampoDN(2,NumPubli); descodificarNumPubli(NumPubli,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Numero); leerCampoDN(4,fecha); descodificarFecha(fecha,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Fecha); End; {FOR articulo} End;{If control} End; {Metodo leerRegCod} PROCEDURE leerRegIni; VAR indiceArticulo: integer; cadena:string; //fecha:string; BEGIN leerCampo(35,registroLogico.Nombre); quitarEspacios(registroLogico.Nombre,registroLogico.Nombre); IF registroLogico.Nombre[1] = '#' THEN Begin IF (registroLogico.Nombre[4] = '#') and (registroLogico.Nombre[2] = '#') and (registroLogico.Nombre[3] = '#') Then control:=FALSE; End; IF control THEN BEGIN leerCampo(15,registroLogico.Apellido1); quitarEspacios(registroLogico.Apellido1,registroLogico.Apellido1); leerCampo(15,registroLogico.Apellido2); quitarEspacios(registroLogico.Apellido2,registroLogico.Apellido2); leerCampo(9,registroLogico.DNI); // IF registroLogico.DNI='81451600K' THEN // writeln; leerCampo(5,registroLogico.Sexo); leerCampo(50,cadena); quitarEspacios(cadena,cadena); codificarCorreo(cadena); leerCampo(9,registroLogico.Telefono1); leerCampo(9,registroLogico.Telefono2); leerCampo(70,registroLogico.URL); leerCampo(40,cadena); quitarEspacios(cadena,cadena); codificarDireccion(cadena); leerCampo(5,registroLogico.Direccion.CP); quitarEspacios(registroLogico.Direccion.CP,registroLogico.Direccion.CP); leerCampo(35,registroLogico.Direccion.Localidad); quitarEspacios(registroLogico.Direccion.Localidad,registroLogico.Direccion.Localidad); FOR indiceArticulo:=1 to 20 DO BEGIN leerCampo(50,registroLogico.Articulo[indiceArticulo].Titulo); quitarEspacios(registroLogico.Articulo[indiceArticulo].Titulo,registroLogico.Articulo[indiceArticulo].Titulo); leerCampo(5,registroLogico.Articulo[indiceArticulo].Palabras); leerCampo(30,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); leerCampo(3,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Numero); leerCampo(18,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Fecha); //fecha:=registroLogico.Articulo[indiceArticulo].DatosPublicacion.Fecha; //codificarFecha(fecha); End; {FOR articulo} End; {IF control} End; {leerRegIni} PROCEDURE inicializarFichero; VAR x:integer; empieza: string; BEGIN codificarNumero(2,'0003',empieza); escribirCampo(empieza); codificarNumero(2,'0',empieza); escribirCampo(empieza); //escribirCampo('0$'); FOR x:=0 to 500 DO BEGIN ficheroD.EscribirBloque(x,Bloque_E); End; End; PROCEDURE ConseguirClave(entrada1,entrada2,entrada3:string; VAR salida:integer); var i,aux :integer; cad: string; begin cad:=entrada1+entrada2+entrada3; aux:=0; i:=1; IF length(cad)<3 THEN cad:=cad+' '; while i<=LENGTH(CAD)-2 do begin aux:= aux+ ((ORD(CAD[I]) - ORD(CAD[I+1])) * ORD(CAD[I+2])); i:=i+3; end; if (aux >=0) and (aux <=499) then salida:=AUX ELSE BEGIN AUX:= ABS(AUX); salida := aux MOD 499; END; end; PROCEDURE ConseguirClave2(entrada1,entrada2,entrada3:string; VAR salida:integer); VAR aux1,aux, i :integer; cad:string; primos:array[1..96] of integer; encontrado:boolean; BEGIN encontrado:=FALSE; {Colocamos en un array los numeros primos entre el 1 y el 499} primos[1]:=499; primos[2]:=491;primos[3]:=487;primos[4]:=479; primos[5]:=467;primos[6]:=463;primos[7]:=461;primos[8]:=457; primos[9]:=449;primos[10]:=443;primos[11]:=439;primos[12]:=433; primos[13]:=431;primos[14]:=421;primos[15]:=419;primos[16]:=409; primos[17]:=401;primos[18]:=397;primos[19]:=389;primos[20]:=383; primos[21]:=379;primos[22]:=373;primos[23]:=367;primos[24]:=359; primos[25]:=353;primos[26]:=349;primos[27]:=347;primos[28]:=337; primos[29]:=331;primos[30]:=317;primos[31]:=313;primos[32]:=311; primos[33]:=307;primos[34]:=293;primos[35]:=283;primos[36]:=281; primos[37]:=277;primos[38]:=271;primos[39]:=269;primos[40]:=263; primos[41]:=257;primos[42]:=251;primos[43]:=241;primos[44]:=239; primos[45]:=233;primos[46]:=229;primos[47]:=227;primos[48]:=223; primos[49]:=211;primos[50]:=199;primos[51]:=197;primos[52]:=193; primos[53]:=191;primos[54]:=181;primos[55]:=179;primos[56]:=173; primos[57]:=167;primos[58]:=163;primos[59]:=157;primos[60]:=151; primos[61]:=149;primos[62]:=139;primos[63]:=137;primos[64]:=131; primos[65]:=127;primos[66]:=113;primos[67]:=109;primos[68]:=107; primos[69]:=103;primos[70]:=101;primos[71]:=97;primos[72]:=89; primos[73]:=83;primos[74]:=79;primos[75]:=73;primos[76]:=71; primos[77]:=67;primos[78]:=61;primos[79]:=59;primos[80]:=53; primos[81]:=47;primos[82]:=43;primos[83]:=41;primos[84]:=37; primos[85]:=31;primos[86]:=29;primos[87]:=23;primos[88]:=19; primos[89]:=17;primos[90]:=13;primos[91]:=11;primos[92]:=7; primos[93]:=5;primos[94]:=3;primos[95]:=2;primos[96]:=1; cad:=entrada1+entrada2+entrada3; aux:=ord(cad[1]); for i:= 2 to length(cad) do begin aux:=aux+ord(cad[i]); end; {Algortimo de dispersion doble} salida:= aux mod 500; aux1:=colisiones[salida]+totalcaracteres; if aux1 <=1020 then begin colisiones[salida]:= aux1; encontrado:=TRUE ; end else begin i:=1; {Indice del array primos} WHILE (i<=96) AND (not encontrado) DO BEGIN salida:=primos[i]-(aux mod(primos[i]))-1; aux1:=colisiones[salida]+totalcaracteres; inc(i); IF aux1<=1020 THEN BEGIN colisiones[salida]:=aux1; encontrado:=TRUE End; {Fin IF} End; {Fin WHILE} End; {Fin else} //Si no cabe, lo introducimos en desbordados. if not encontrado then begin salida := 499 + desbordados; inc(desbordados) end; end; PROCEDURE DesConseguirClave(entrada1,entrada2,entrada3:string; VAR existe : boolean); VAR aux,i,num,bloqueAcaba:integer; cad,aux4:string; salida : integer; primos:array[1..96] of integer; encontrado, regristoIgual, iguales :boolean; BEGIN existe := false; regristoIgual:= false; {Colocamos en un array los numeros primos entre el 1 y el 499} primos[1]:=499; primos[2]:=491;primos[3]:=487;primos[4]:=479; primos[5]:=467;primos[6]:=463;primos[7]:=461;primos[8]:=457; primos[9]:=449;primos[10]:=443;primos[11]:=439;primos[12]:=433; primos[13]:=431;primos[14]:=421;primos[15]:=419;primos[16]:=409; primos[17]:=401;primos[18]:=397;primos[19]:=389;primos[20]:=383; primos[21]:=379;primos[22]:=373;primos[23]:=367;primos[24]:=359; primos[25]:=353;primos[26]:=349;primos[27]:=347;primos[28]:=337; primos[29]:=331;primos[30]:=317;primos[31]:=313;primos[32]:=311; primos[33]:=307;primos[34]:=293;primos[35]:=283;primos[36]:=281; primos[37]:=277;primos[38]:=271;primos[39]:=269;primos[40]:=263; primos[41]:=257;primos[42]:=251;primos[43]:=241;primos[44]:=239; primos[45]:=233;primos[46]:=229;primos[47]:=227;primos[48]:=223; primos[49]:=211;primos[50]:=199;primos[51]:=197;primos[52]:=193; primos[53]:=191;primos[54]:=181;primos[55]:=179;primos[56]:=173; primos[57]:=167;primos[58]:=163;primos[59]:=157;primos[60]:=151; primos[61]:=149;primos[62]:=139;primos[63]:=137;primos[64]:=131; primos[65]:=127;primos[66]:=113;primos[67]:=109;primos[68]:=107; primos[69]:=103;primos[70]:=101;primos[71]:=97;primos[72]:=89; primos[73]:=83;primos[74]:=79;primos[75]:=73;primos[76]:=71; primos[77]:=67;primos[78]:=61;primos[79]:=59;primos[80]:=53; primos[81]:=47;primos[82]:=43;primos[83]:=41;primos[84]:=37; primos[85]:=31;primos[86]:=29;primos[87]:=23;primos[88]:=19; primos[89]:=17;primos[90]:=13;primos[91]:=11;primos[92]:=7; primos[93]:=5;primos[94]:=3;primos[95]:=2;primos[96]:=1; cad:=entrada1+entrada2+entrada3; aux:=ord(cad[1]); for i:= 2 to length(cad) do begin aux:=aux+ord(cad[i]); end; {Algortimo de dispersion doble} salida:= aux mod 500; ficheroD.LeerBloque(salida, bloque_E); leerCampoLong(aux4); descodificarNumero(aux4,num); bloqueAcaba := num; if (num = 2 ) then begin //No existe en direccionado, tenemos q mirar en desbordamiento end else begin c1024_E:=2; while (c1024_E < bloqueAcaba) and not (regristoIgual) do begin limpiarRegLogico; leerRegCod; comparar(entrada1,entrada2,entrada3,iguales); if iguales then begin regristoIgual := true; existe := true; end; end; {while} end;{else} if regristoIgual = false then begin i:=1; {Indice del array primos} encontrado:=FALSE; WHILE (i<=96) AND (not encontrado) AND (NOT regristoIgual) DO BEGIN salida:=primos[i]-(aux mod(primos[i]))-1; inc(i); ficheroD.LeerBloque(salida, bloque_E); leerCampoLong(aux4); descodificarNumero(aux4,num); bloqueAcaba := num; if (num = 2 ) then begin writeln('Regristo no existente.'); end else begin c1024_E:=2; while (c1024_E < bloqueAcaba) and not (regristoIgual) do begin limpiarRegLogico; leerRegCod; comparar(entrada1,entrada2,entrada3,iguales); if iguales then regristoIgual := true; existe := true; end; {while} end;{else} End; {Fin WHILE} //Leer de desbordamiento //Regristo no existente. if (not regristoIgual) then begin writeln; writeln('Registro no existente.'); existe := false; end; End; end; PROCEDURE saberNumeroReg; Var indiceArticulo,vacio,num_tlf :integer; numArticulos,aux,DNI,TipoVia,Portal,dominio,telefono1,telefono2:string; CP,Palabras,NumPubli,dia,mes,anyo,prueba:string; BEGIN totalCaracteres := 0; num_tlf:=0; totalCaracteres := totalCaracteres + length(registroLogico.Nombre); totalCaracteres := totalCaracteres + 1; quitarEspacios(registroLogico.Apellido1,registroLogico.Apellido1); totalCaracteres := totalCaracteres + length(registroLogico.Apellido1); totalCaracteres := totalCaracteres + 1; quitarEspacios(registroLogico.Apellido2,registroLogico.Apellido2); totalCaracteres := totalCaracteres + length(registroLogico.Apellido2); totalCaracteres := totalCaracteres + 1; codificarDNI(registroLogico.DNI,DNI); totalCaracteres := totalCaracteres + length(DNI); totalCaracteres := totalCaracteres + 1; totalCaracteres := totalCaracteres + length(registroLogico.Correo.Nickname); totalCaracteres := totalCaracteres + 1; codificarTipoCorreo(registroLogico.Correo.Dominio,dominio); totalCaracteres := totalCaracteres + length(dominio); quitarEspacios(registroLogico.Telefono1,registroLogico.Telefono1); if registroLogico.Telefono1 <> '' then Begin inc(num_tlf); end; quitarEspacios(registroLogico.Telefono2,registroLogico.Telefono2); if registroLogico.Telefono2 <> '' then Begin inc(num_tlf); end; str(num_tlf, aux); totalCaracteres := totalCaracteres + 1; IF registroLogico.Telefono1 <> '' THEN BEGIN codificarTelefono(registroLogico.Telefono1,Telefono1); totalCaracteres := totalCaracteres + length(Telefono1); End; IF registroLogico.Telefono2 <> '' THEN BEGIN codificarTelefono(registroLogico.Telefono2,Telefono2); totalCaracteres := totalCaracteres + length(Telefono2); end; quitarEspacios(registroLogico.URL,registroLogico.URL); if(registroLogico.URL <> '') then begin codificarURL(registroLogico.URL,prueba); totalCaracteres := totalCaracteres + length(prueba); totalCaracteres := totalCaracteres + 1; end else begin totalCaracteres := totalCaracteres + 1; end; CodificarTipoDireccion(registroLogico.Direccion.Tipo, TipoVia); totalCaracteres := totalCaracteres + length(TipoVia); quitarEspacios(registroLogico.Direccion.Nombre,registroLogico.Direccion.Nombre); totalCaracteres := totalCaracteres + length(registroLogico.Direccion.Nombre); totalCaracteres := totalCaracteres + 1; codificarPortal(registroLogico.Direccion.Portal,Portal); totalCaracteres := totalCaracteres + length(Portal); quitarEspacios(registroLogico.Direccion.CP,registroLogico.Direccion.CP); codificarCP(registroLogico.Direccion.CP,CP); totalCaracteres := totalCaracteres + length(CP); quitarEspacios(registroLogico.Direccion.Localidad,registroLogico.Direccion.Localidad); totalCaracteres := totalCaracteres + length(registroLogico.Direccion.Localidad); totalCaracteres := totalCaracteres + 1; indiceArticulo := 1; vacio:=0; WHILE registroLogico.Articulo[indiceArticulo].Titulo<>'' DO BEGIN inc(indiceArticulo); inc(vacio); End; cambiarGitano(vacio, numArticulos); totalCaracteres := totalCaracteres + 1; FOR indiceArticulo:=1 to vacio DO BEGIN quitarEspacios(registroLogico.Articulo[indiceArticulo].Titulo,registroLogico.Articulo[indiceArticulo].Titulo); totalCaracteres := totalCaracteres + length(registroLogico.Articulo[indiceArticulo].Titulo); totalCaracteres := totalCaracteres + 1; quitarEspacios(registroLogico.Articulo[indiceArticulo].Palabras,registroLogico.Articulo[indiceArticulo].Palabras); codificarPalabras(registroLogico.Articulo[indiceArticulo].Palabras,Palabras); totalCaracteres := totalCaracteres + length(Palabras); quitarEspacios(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); codificarTituloPublicacion(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); totalCaracteres := totalCaracteres + length(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); quitarEspacios(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Numero,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Numero); codificarNumPubli(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Numero,NumPubli); totalCaracteres := totalCaracteres + length(NumPubli); codificarFecha(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Fecha,dia,mes,anyo); totalCaracteres := totalCaracteres + length(dia) + length(mes)+ length(anyo); End; {FOR articulo} End; {Metodo importarReg} PROCEDURE importarReg; Var indiceArticulo,vacio,num_tlf :integer; numArticulos,aux,DNI,TipoVia,Portal,dominio,telefono1,telefono2:string; CP,Palabras,NumPubli,dia,mes,anyo:string; BEGIN num_tlf:=0; escribirCampo(registroLogico.Nombre); escribirCampo('$'); quitarEspacios(registroLogico.Apellido1,registroLogico.Apellido1); escribirCampo(registroLogico.Apellido1); escribirCampo('$'); quitarEspacios(registroLogico.Apellido2,registroLogico.Apellido2); escribirCampo(registroLogico.Apellido2); escribirCampo('$'); codificarDNI(registroLogico.DNI,DNI); escribirCampo(DNI); escribirCampo(codificarSexo(registroLogico.Sexo)); escribirCampo(registroLogico.Correo.Nickname); escribirCampo('$'); codificarTipoCorreo(registroLogico.Correo.Dominio,dominio); escribirCampo(dominio); quitarEspacios(registroLogico.Telefono1,registroLogico.Telefono1); if registroLogico.Telefono1 <> '' then Begin inc(num_tlf); end; //quitarEspacios(registroLogico.Telefono2,registroLogico.Telefono2); if registroLogico.Telefono2 <> '' then Begin inc(num_tlf); end; str(num_tlf, aux); escribirCampo(aux); IF registroLogico.Telefono1 <> '' THEN BEGIN codificarTelefono(registroLogico.Telefono1,Telefono1); escribirCampo(Telefono1); End; IF registroLogico.Telefono2 <> '' THEN BEGIN codificarTelefono(registroLogico.Telefono2,Telefono2); escribirCampo(Telefono2); end; //quitarEspacios(registroLogico.URL,registroLogico.URL); if(registroLogico.URL <> '') then begin codificarURL(registroLogico.URL,registroLogico.URL); escribirCampo(registroLogico.URL); escribirCampo('$'); end else begin escribirCampo('0'); end; CodificarTipoDireccion(registroLogico.Direccion.Tipo, TipoVia); escribirCampo(TipoVia); quitarEspacios(registroLogico.Direccion.Nombre,registroLogico.Direccion.Nombre); escribirCampo(registroLogico.Direccion.Nombre); escribirCampo('$'); codificarPortal(registroLogico.Direccion.Portal,Portal); escribirCampo(Portal); quitarEspacios(registroLogico.Direccion.CP,registroLogico.Direccion.CP); codificarCP(registroLogico.Direccion.CP,CP); escribirCampo(CP); quitarEspacios(registroLogico.Direccion.Localidad,registroLogico.Direccion.Localidad); escribirCampo(registroLogico.Direccion.Localidad); escribirCampo('$'); indiceArticulo := 1; vacio:=0; WHILE registroLogico.Articulo[indiceArticulo].Titulo<>'' DO BEGIN inc(indiceArticulo); inc(vacio); End; cambiarGitano(vacio, numArticulos); escribirCampo(numArticulos); FOR indiceArticulo:=1 to vacio DO BEGIN quitarEspacios(registroLogico.Articulo[indiceArticulo].Titulo,registroLogico.Articulo[indiceArticulo].Titulo); escribirCampo(registroLogico.Articulo[indiceArticulo].Titulo); escribirCampo('$'); quitarEspacios(registroLogico.Articulo[indiceArticulo].Palabras,registroLogico.Articulo[indiceArticulo].Palabras); codificarPalabras(registroLogico.Articulo[indiceArticulo].Palabras,Palabras); escribirCampo(Palabras); quitarEspacios(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); // codificarTituloPublicacion(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); escribirCampo(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); quitarEspacios(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Numero,registroLogico.Articulo[indiceArticulo].DatosPublicacion.Numero); codificarNumPubli(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Numero,NumPubli); escribirCampo(NumPubli); codificarFecha(registroLogico.Articulo[indiceArticulo].DatosPublicacion.Fecha,dia,mes,anyo); escribirCampo(dia); escribirCampo(mes); escribirCampo(anyo); End; {FOR articulo} End; {Metodo importarReg} PROCEDURE mostrarRegPantalla(x:integer); Var indiceArticulo:integer; BEGIN {clrscr;} writeln; writeln('Registro numero: ',x); writeln('Nombre: ',registroLogico.nombre); writeln('Primer apellido: ',registroLogico.Apellido1); writeln('Segundo apellido: ',registroLogico.Apellido2); writeln('DNI: ',registroLogico.DNI); writeln('Sexo: ',registroLogico.sexo); writeln('Correo: ',registroLogico.correo.nickname,'@',registroLogico.correo.Dominio); writeln('Telefono 1: ',registroLogico.telefono1); writeln('Telefono 2: ',registroLogico.telefono2); writeln('URL: ',registroLogico.URL); WITH registroLogico.Direccion DO BEGIN writeln('Direccion: ', Tipo , ' ' , Nombre , ', N ',Portal); writeln('Codigo Postal: ',CP); writeln('Localidad: ',Localidad); End; {WITH direccion} FOR indiceArticulo:=1 to 20 DO BEGIN IF (registroLogico.Articulo[indiceArticulo].Titulo<>' ' ) and (registroLogico.Articulo[indiceArticulo].Titulo <> '' )THEN BEGIN writeln; writeln('Articulo numero: ',indiceArticulo); writeln('Titulo del Articulo: ',registroLogico.Articulo[indiceArticulo].Titulo); writeln('Numero de palabras: ',registroLogico.Articulo[indiceArticulo].Palabras); writeln('Titulo de la Publicacion: ',registroLogico.Articulo[indiceArticulo].DatosPublicacion.Nombre); writeln('Numero: ',registroLogico.Articulo[indiceArticulo].DatosPublicacion.Numero); writeln('Fecha: ',registroLogico.Articulo[indiceArticulo].DatosPublicacion.Fecha) End; {IF} End {FOR articulo} End {Mostrar x pantalla}; Procedure ficheroTituloImportacion(clave:integer; lugar: integer; var estamos2 : integer); var aux, entrada: String; i : integer; hayTitulo : boolean; begin hayTitulo := true; ficheroTitulo.LeerBloque(estamos2,bloque_E); leerCampoLong(aux); descodificarNumero(aux,c1024_E); i := 1; if( c1024_E = 0 ) then c1024_E := 2; while hayTitulo do begin if registroLogico.Articulo[i].Titulo <> '' then begin escribirCampo2(registroLogico.Articulo[i].Titulo,ficheroTitulo, estamos2); inc(i); escribirCampo2('$', ficheroTitulo, estamos2); str(clave, entrada); codificarNumero(2,entrada ,entrada ); escribirCampo2(entrada,ficheroTitulo, estamos2); str(lugar,entrada) ; codificarNumero(2,entrada ,entrada ); escribirCampo2(entrada,ficheroTitulo, estamos2); str(c1024_E, entrada) ; codificarNumero(2,entrada,entrada); escribirTamanyo(entrada); end else begin hayTitulo:= false; end; end; ficheroTitulo.EscribirBloque(estamos2,bloque_E); end; Procedure ficheroApellidoImportacion(clave:integer ; lugar : integer; Var estamos: integer); var aux, entrada: String; begin ficheroApellido.LeerBloque(estamos, bloque_E); leerCampoLong(aux); descodificarNumero(aux,c1024_E); if( c1024_E = 0 ) then c1024_E := 2; escribirCampo2(registroLogico.Apellido1,ficheroApellido, estamos); escribirCampo2('$', ficheroApellido, estamos); str(clave, entrada); codificarNumero(2,entrada ,entrada ); escribirCampo2(entrada,ficheroApellido, estamos); str(lugar,entrada) ; codificarNumero(2,entrada ,entrada ); escribirCampo2(entrada,ficheroApellido, estamos); str(c1024_E, entrada) ; codificarNumero(2,entrada,entrada); escribirTamanyo(entrada); ficheroApellido.EscribirBloque(estamos,bloque_E); end; Procedure direccionar; Var aux,cadenaNumero, aux4,desbordado, cadena: string; estamos2, estamos, auxliar , clave, contadorDesbordamientos, contadorBloquesVacios,x, num2, num3 : integer; desbordamiento, num:longint; Begin try fichero.abrir('C:\Temp\original\antiguo.txt'); except WriteLn('Se ha producido un error'); ExitCode:=1; end; estamos := 0; estamos2 := 0; desbordamiento := 1; fichero.leerbloque(bloque); bloque_E.RellenarCero; ficheroApellido.EscribirBloque(0,bloque_E); ficheroTitulo.EscribirBloque(0,bloque_E); inicializarFichero; leerRegIni; contadorDesbordamientos:=0; WHILE control DO BEGIN saberNumeroReg; conseguirClave(registroLogico.nombre,registroLogico.apellido1,registroLogico.apellido2,clave ); bloque_E.RellenarCero; ficheroD.LeerBloque(clave, bloque_E); leerCampoLong(aux); descodificarNumero(aux,num); num:=num+totalCaracteres; if( num > 1020 )then begin inc(contadorDesbordamientos); leerDesbordado(desbordado); descodificarNumero(desbordado,num3); if (num3 = 0) then begin str( desbordamiento , cadena); codificarNumero(1,cadena,cadena); escribirDesbordado(cadena); ficheroD.EscribirBloque(clave, bloque_E); clave := 499+ desbordamiento; ficheroD.LeerBloque(clave,bloque_E); ficheroD.EscribirBloque(clave+1,bloque_E); c1024_E:= 0; codificarNumero(2,'0003',cadena); escribirCampo(cadena); codificarNumero(2,'0',cadena); escribirCampo(cadena); num := 3; num:=num+totalCaracteres; inc(desbordamiento); end else begin while (num3 <> 0 ) AND (num > 1020) do begin clave:= 499 + num3; bloque_E.RellenarCero; ficheroD.LeerBloque(clave, bloque_E); leerCampoLong(aux); descodificarNumero(aux,num); num:=num+totalCaracteres; leerDesbordado(desbordado); descodificarNumero(desbordado,num3); if (num3 = 0) and (num > 1020 ) then begin str( desbordamiento , cadena); codificarNumero(1,cadena,cadena); escribirDesbordado(cadena); ficheroD.EscribirBloque(clave, bloque_E); clave := 499+ desbordamiento; ficheroD.LeerBloque(clave,bloque_E); ficheroD.EscribirBloque(clave+1,bloque_E); c1024_E:= 0; codificarNumero(2,'0003',cadena); escribirCampo(cadena); codificarNumero(2,'0',cadena); escribirCampo(cadena); num := 3; num:=num+totalCaracteres; inc(desbordamiento); end; end; end;{if num3} end;{if num} str(num,cadenaNumero); codificarNumero(2,cadenaNumero,aux); escribirTamanyo(aux); c1024_E:=num-totalCaracteres; if ( c1024_E < 3 )then c1024_E:=3; importarReg; ficheroD.EscribirBloque(clave,bloque_E); //Indices auxliar := c1024_E - totalCaracteres; ficheroApellidoImportacion(clave, auxliar, estamos); ficheroTituloImportacion ( clave, auxliar, estamos2) ; limpiarRegLogico; leerRegIni; end; {WHILE} fichero.Cerrar; ficheroD.Cerrar; ficheroTitulo.Cerrar; ficheroApellido.Cerrar; ficheroD.abrir('C:\Temp\datos\reporter.dat'); contadorBloquesVacios:=0; FOR x:=0 to 499 DO BEGIN num := 0; ficheroD.LeerBloque(x, bloque_E); leerCampoLong(aux4); descodificarNumero(aux4,num2); if num2 = 3 then inc( contadorBloquesVacios ) ; end; writeln('Bloques Vacios ', contadorBloquesVacios); writeln('Regristos Desbordados ', contadorDesbordamientos); ficheroD.Cerrar; try ficheroD.abrir('C:\Temp\datos\reporter.dat'); ficheroApellido.Abrir('C:\Temp\datos\indice_apellido1.txt'); ficheroTitulo.Abrir('C:\Temp\datos\indice_titulo.txt'); except WriteLn('Se ha producido un error'); ExitCode:=1; end; End; Procedure dibujarMenu; begin writeln; writeln('1. ABRIR'); writeln('2. IMPORTAR'); writeln('3. LEER'); writeln('4. SALIR'); writeln; write('Seleccione una opcion: '); end; Procedure dibujarMenu2; begin writeln; writeln('Que tipo de consulta desea: '); writeln('1. Nombre y apellidos autor'); writeln('2. DNI autor'); writeln('3. Titulo de obra'); writeln('4. Nombre autor'); writeln('5. Primer apellido autor'); writeln('6. Titulos que han escrito los autores que tienen apellido'); writeln('7. Volver al primer menu') ; writeln; write('Seleccione una opcion: '); end; Procedure abrir ; begin try writeln('Abriendo/Creando ficheros de datos'); ficheroD.abrir('C:\Temp\datos\reporter.dat'); ficheroTitulo.Abrir('C:\Temp\datos\indice_titulo.txt'); ficheroApellido.Abrir('C:\Temp\datos\indice_apellido1.txt'); writeln('Ficheros abiertos/creados.'); except WriteLn('Se ha producido un error'); ExitCode:=1; end; end; Procedure importar; begin try writeln('Abriendo fichero antiguo.txt'); fichero.abrir('C:\Temp\original\antiguo.txt'); except WriteLn('Se ha producido un error'); ExitCode:=1; end; ficheroD.leerbloque(0,bloque_E); inicializarFichero; ficheroD.Cerrar; //fichero.leerbloque(bloque); { writeln('Importando fichero...'); leerRegIni; WHILE control DO BEGIN importarReg; leerRegIni; end; marcaFinFichero; fichero_E.Cerrar; fichero.Cerrar;} end; Procedure PedirInformacion(Var nom:string;var ap1:string; var ap2:string); Begin writeln('Introduzca el nombre del periodista que desee: '); readln(nom); writeln('Introduzca el primer apellido: '); readln(ap1); writeln('Introduzca el segundo apellido: '); readln(ap2); end; Procedure PedirNombre(Var nom:string); Begin writeln('Introduzca el nombre del periodista que desee: '); readln(nom); end; Procedure PedirApellido(Var nom:string); Begin writeln('Introduzca el apellido del periodista que desee: '); readln(nom); end; Procedure PedirDNI(Var nom:string); Begin writeln('Introduzca el DNI del periodista que desee: '); readln(nom); end; Procedure PedirTitulo(Var nom:string); Begin writeln('Introduzca el Titulo del articulo que desee: '); readln(nom); end; Procedure leerRegCodDireccionadoDNI(); Var DNI,aux : String ; regristoIgual, final, iguales : boolean ; clave,bloqueAcaba, contador : integer; Begin final := false; contador := 0; clave := 0; regristoIgual := false; DNI:= ''; PedirDNI(DNI); while (not regristoIgual) and (not final)do begin c1024_E:= 3; ficheroD.leerBloque(clave, bloque_E); inc(contador); leerCampoLong(aux); descodificarNumero(aux,bloqueAcaba); if(clave > 499 ) and (bloqueAcaba = 3)then begin final := true; end else begin while (c1024_E < bloqueAcaba) and not (regristoIgual) do begin limpiarRegLogico; leerRegCod; compararDNI(DNI,iguales); if iguales then regristoIgual:= true; end; inc(clave); end; end; if regristoIgual then begin mostrarRegPantalla(1); writeln('Leidos: ',contador,' bloques'); end; if final then begin writeln('El DNI no se encuentra entre nuestros autores.'); writeln('Leidos: ',contador,' bloques'); end; end; procedure leerRegApellidoIndice(Var apellido : string ; var clave : string; var pos : string; var ent: integer); begin leerCampoI(ficheroApellido, apellido, ent); leerCampoIN(2,ficheroApellido,clave, ent); leerCampoIN(2,ficheroApellido,pos, ent ); end; procedure leerRegTituloIndice(Var apellido : string ; var clave : string; var pos : string; var ent: integer); begin leerCampoI(ficheroTitulo, apellido, ent); leerCampoIN(2,ficheroTitulo,clave, ent); leerCampoIN(2,ficheroTitulo,pos, ent ); end; procedure leerRegCodDireccionadoTituloIndice(); var clav1,pos1,ape, clav, pos, encontrado,DNI: String ; iguales : boolean ; aux2, position, i, ent, contador : integer; begin ent := 0; ficheroTitulo.LeerBloque(ent, bloque_E); i := 1 ; encontrado := ''; contador:=1; iguales := false; position := 0; DNI:= ''; PedirTitulo(DNI); c1024_E:=2; pos1:=''; clav1:=''; while (not iguales) and (contador<999) do begin leerRegTituloIndice(ape, clav, pos, ent); if(pos <> pos1 ) or (clav1 <> clav) then begin pos1:= pos; clav1:=clav; inc(contador); end; compararApellido2(DNI,ape,iguales); if iguales then begin iguales := true; encontrado := encontrado + clav + pos; end; end; while( i <= length(encontrado) ) do begin inc(position); clav := ''; clav := encontrado[i]+encontrado[i+1]; i:=i+2; descodificarNumero(clav,aux2); str(aux2, clav); ficheroD.leerBloque(aux2, bloque_E); pos := ''; pos := encontrado[i]+encontrado[i+1]; i:=i+2; descodificarNumero(pos,aux2); c1024_E:= aux2; limpiarRegLogico; leerRegCod; mostrarRegPantalla(position); writeln('Leidos: ',( position + ent +1 ) ,' bloques'); end; if not iguales then writeln('Titulo no encontrado'); end; Procedure leerRegCodDireccionadoTitulo(); Var DNI,aux : String ; regristoIgual, final, iguales : boolean ; clave,bloqueAcaba, contador : integer; Begin final := false; contador := 0; clave := 0; regristoIgual := false; DNI:= ''; PedirTitulo(DNI); while (not regristoIgual) and (not final)do begin c1024_E:= 3; ficheroD.leerBloque(clave, bloque_E); inc(contador); leerCampoLong(aux); descodificarNumero(aux,bloqueAcaba); if(clave > 499 ) and (bloqueAcaba = 3)then begin final := true; end else begin while (c1024_E < bloqueAcaba) and not (regristoIgual) do begin limpiarRegLogico; leerRegCod; compararTitulo(DNI,iguales); if iguales then regristoIgual:= true; end; inc(clave); end; end; if regristoIgual then begin mostrarRegPantalla(1); writeln('Leidos: ',contador,' bloques'); end; if final then begin writeln('El Titulo no se encuentra entre nuestros articulos.'); writeln('Leidos: ',contador,' bloques'); end; end; Procedure leerRegCodDireccionadoApellido1Indice(); var aux2: longint; DNI,pos,ape, clav, encontrado : String ; iguales : boolean ; ent, contador,position, i : integer; begin ent := 0; ficheroApellido.LeerBloque(ent, bloque_E); i := 1 ; encontrado := ''; contador:=1; iguales := false; position := 0; DNI:= ''; PedirApellido(DNI); c1024_E:=2; while ( contador < 1000 ) do begin leerRegApellidoIndice(ape, clav, pos, ent); compararApellido2(DNI,ape,iguales); inc(contador); if iguales then begin encontrado := encontrado + clav + pos; end; iguales := false; end; while( i <= length(encontrado) ) do begin inc(position); clav := ''; clav := encontrado[i]+encontrado[i+1]; i:=i+2; descodificarNumero(clav,aux2); str(aux2, clav); ficheroD.leerBloque(aux2, bloque_E); pos := ''; pos := encontrado[i]+encontrado[i+1]; i:=i+2; descodificarNumero(pos,aux2); c1024_E:= aux2; limpiarRegLogico; leerRegCod; mostrarRegPantalla(position); writeln('Leidos: ',( position + ent ) ,' bloques'); writeln('Pulse enter para el siguiente autor.'); readln; end; writeln('No existen mas autores con ese apellido.'); end; Procedure leerRegCodDireccionadoApellido1Titulo(); var clav2, pos2, DNI,pos,ape, clav, encontrado : String ; iguales : boolean ; p, o, ent, contador,position, i : integer; begin ent := 0; ficheroApellido.LeerBloque(ent, bloque_E); i := 1 ; encontrado := ''; contador:=1; iguales := false; DNI:= ''; PedirApellido(DNI); c1024_E:=2; while ( contador < 1000 ) do begin leerRegApellidoIndice(ape, clav, pos, ent); compararApellido2(DNI,ape,iguales); inc(contador); if iguales then begin encontrado := encontrado + clav + pos; end; iguales := false; end; position := ent; ent := 0; ficheroTitulo.LeerBloque(ent, bloque_E); c1024_E:=2; o:=0; while( i <= length(encontrado) ) do begin inc(o); inc(position); clav := ''; clav2 := encontrado[i]+ encontrado[i+1]; i:=i+2; pos2 := encontrado[i]+encontrado[i+1]; i:=i+2; iguales := false; writeln(o,' autor'); while (not iguales) do begin leerRegTituloIndice(ape, clav, pos, ent); if(pos = pos2 ) and (clav2 = clav) then begin p:=0; while (pos = pos2) and (clav = clav2) do begin inc(p); writeln(p ,' titulo : ', ape ); leerRegTituloIndice(ape, clav, pos, ent); iguales:= true; end; end; end; writeln('Pulse enter para mostrar el siguiente regristo.'); readln; end; writeln('No existen mas autores con ese apellido.'); writeln('Bloques leidos', ent + position ); end; Procedure leerRegCodDireccionadoApellido1(); Var DNI,aux : String ; regristoIgual, final, iguales : boolean ; clave,bloqueAcaba, contador,x : integer; Begin final := false; x := 1; contador := 0; clave := 0; regristoIgual := false; DNI:= ''; PedirApellido(DNI); while (not final)do begin c1024_E:= 3; ficheroD.leerBloque(clave, bloque_E); inc(contador); leerCampoLong(aux); descodificarNumero(aux,bloqueAcaba); if(clave > 499 ) and (bloqueAcaba = 3)then begin final := true; end else begin while (c1024_E < bloqueAcaba) do begin limpiarRegLogico; leerRegCod; compararApellido(DNI,iguales); if iguales then begin regristoIgual := true; mostrarRegPantalla(x); writeln('Leidos: ',contador,' bloques'); inc(x) ; writeln('Pulse enter para continuar la busqueda'); readln; end; end; inc(clave); end; end; if regristoIgual then begin writeln('No hay mas autores con ese nombre.'); writeln('Leidos: ',contador,' bloques'); end else begin writeln('El autor no se encuentra en nuestra base de datos.'); writeln('Leidos: ',contador,' bloques'); end; end; Procedure leerRegCodDireccionadoNombre(); Var DNI,aux : String ; regristoIgual, final, iguales : boolean ; clave,bloqueAcaba, contador,x : integer; Begin final := false; x := 1; contador := 0; clave := 0; regristoIgual := false; DNI:= ''; PedirNombre(DNI); while (not final)do begin c1024_E:= 3; ficheroD.leerBloque(clave, bloque_E); inc(contador); leerCampoLong(aux); descodificarNumero(aux,bloqueAcaba); if(clave > 499 ) and (bloqueAcaba = 3)then begin final := true; end else begin while (c1024_E < bloqueAcaba) do begin limpiarRegLogico; leerRegCod; compararNombre(DNI,iguales); if iguales then begin regristoIgual := true; mostrarRegPantalla(x); writeln('Leidos: ',contador,' bloques'); inc(x) ; writeln('Pulse enter para continuar la busqueda'); readln; end; end; inc(clave); end; end; if regristoIgual then begin writeln('No hay mas autores con ese nombre.'); writeln('Leidos: ',contador,' bloques'); end else begin writeln('El autor no se encuentra en nuestra base de datos.'); writeln('Leidos: ',contador,' bloques'); end; end; Procedure leerRegCodificadoEnDireccionado(); Var nom,ap1,ap2,aux, auxiliar :String; clave,bloqueAcaba,num, numclave : integer ; regristoIgual, iguales : boolean; Begin nom:=''; ap1:=''; ap2:=''; regristoIgual:= false; PedirInformacion(nom,ap1,ap2); conseguirClave(nom,ap1,ap2,clave); while ( clave <> -1 ) and not (regristoIgual) do begin ficheroD.LeerBloque(clave, bloque_E); leerCampoLong(aux); descodificarNumero(aux,num); bloqueAcaba := num; if (num = 3 ) then begin writeln('Regristo no existente.'); end else begin c1024_E:=3; while (c1024_E < bloqueAcaba) and not (regristoIgual) do begin limpiarRegLogico; leerRegCod; comparar(nom,ap1,ap2,iguales); if iguales then regristoIgual := true; if ( c1024_E = bloqueAcaba ) and not (regristoIgual) then begin leerDesbordado(auxiliar); descodificarNumero(auxiliar,numclave); if(numclave <> 0 ) then begin clave := 499 + numclave; end else begin clave:= -1; end; end; end; {while} end;{if} end;{while} if regristoIgual then begin mostrarRegPantalla(1); end else begin writeln('Autor no existente. '); end; end;{metodo} Procedure leerRegistoCodificado; VAR contador:integer; Begin c1024:=0; control:=TRUE; try fichero.abrir('C:\Temp\ficheros\serial.txt'); except WriteLn('Se ha producido un error'); ExitCode:=1; end; fichero.leerbloque(bloque); limpiarRegLogico; leerRegCod; contador:=1; WHILE control DO BEGIN mostrarRegPantalla(contador); limpiarRegLogico; leerRegCod; readln; inc(contador); end; writeln('Todos los registros han sido mostrados'); End; Procedure consultar; Var opcion:byte; BEGIN dibujarMenu2; readln(opcion); If (opcion<1)OR(opcion>7)then writeln('Opcion incorrecta.') else begin case opcion of 1:leerRegCodificadoEnDireccionado; 2:leerRegCodDireccionadoDNI; 3:leerRegCodDireccionadoTituloIndice; 4:leerRegCodDireccionadoNombre; 5:leerRegCodDireccionadoApellido1Indice; 6:leerRegCodDireccionadoApellido1Titulo; 7:; end; end; END; Procedure ejecutarMenu; Var opcion:byte; BEGIN Repeat dibujarMenu; readln(opcion); If (opcion<1)OR(opcion>4)then writeln('Opcion incorrecta, elija una opcion valida.') else begin case opcion of 1:abrir; 2:direccionar; 3:Consultar; 4:begin writeln('El usuario ha decidido abandonar la aplicacion. Adios'); ficheroD.Cerrar(); end; end; end; Until opcion = 4; write('Fin'); readln; END; begin {programa principal} c1024:=0; control:=TRUE; ejecutarMenu; WriteLn('Presione ENTER...'); end.