Indice:

2. Introducción .................................................................... 2

3. Desarrollo ......................................................................... 3

Tema 3: Estructuras de control .................................... 4

Tema 4: Entrada / Salida de datos ................................ 6

Tema 5: Tipos de datos definidos por el

Usuario, y conjuntos ....................................... 8

Tema 6: Subprogramas ................................................... 11

Tema 7: Arrays .............................................................. 17

Tema 8: Registros ......................................................... 34

Tema 9: Ficheros .......................................................... 42

Tema 10: Punteros ......................................................... 58

Tema 11: Recursividad ................................................... 100

4. Conclusiones .................................................................... 105

5. Bibliografía ..................................................................... 106

INTRODUCCIÓN

Con el trabajo propuesto, se pretende afianzar los conocimientos obtenidos durante todo el curso, y sobre todo adquirir mayor grado de conocimientos que el exigido por la asignatura. El trabajo consiste en la solución mediante programación en Pascal de diversos problemas, propuestos como ejercicios. Dichos ejercicios están clasificados por temas, según las estructuras de control y/o de datos necesarias para su resolución. Asimismo, dentro de cada tema, los ejercición están ordenados según su grado de dificultad, de manera que para resolver los últimos de cada tema será necesario un nivel de conocimientos mayor que el exigido por la asignatura.

Para la realización del trabajo, se ha contado con el compilador de pascal de Borland ®, TURBO PASCAL 7.0, cuyo manejo no es el objetivo del presente trabajo, pero que ha requerido de un estudio específico a nivel de funciones y procedimientos propios de las unidades que incluye, especialmente de la unidad “Crt”, para el control de las entradas y salidas de datos.

El presente trabajo, puede servir de ayuda a aquellos alumnos que quieran consurtarlo, ya que los programas están comentados, y están disponibles en soporte magnético. Además se ha realizado un esfuerzo por hacer que la interacción de los mismos con el usuario sea agradable, con presentaciones por pantalla estudiadas, e introducción de datos en muchos casos controladas para evitar errores en tiempo de ejecución (“run time errors”).

Con el presente trabajo, se ha conseguido adquirir conocimientos más alla de los exigidos por la asignatura, en cuanto a que ya no se limita a la programación de Pascal estándar, y que se ha adquirido práctica en métodos de presentación por pantalla, y de entradas de datos desde el teclado, cuestiones que quedan fuera de los requisitos específicos de la asignatura.

DESARROLLO

A lo largo del curso se han realizado una serie de ejercicios, destinados a la asimilación de técnicas para la programación, así como de adquirir la metodología necesaria. En la realización de estos ejercicios, sin embargo, no se tubieron en cuenta aspectos de la programación tales como la comunicación entre el programa y el usuario, aunque sea éste un aspecto fundamental en la programación de aplicaciones hoy en día.

Además, los ejercicios realizados a continuación, han sido programados en Turbo Pascal, habiendo sido compilados con éxito, estando por tanto disponibles en soporte magnético, para ser revisados.

El trabajo podría dividirse en dos partes: Una primera en la que se resuelven problemas sin excesiva dificultad, y que tienen como objetivo el afianzamiento de las nociones teóricas sobre el tema al que pertenecen, y una segunda parte en la que se resuelven problemas con mayor grado de dificultad, con lo que se consigue un mayor grado de conocimientos sobre el tema específico.

Sin más comenzamos con el desarrollo del trabajo:

Ejercicios tema 3

8. Escribir un programa que lea 7 valores de temperatura, y escriba el número de veces que esta tuvo un valor inferior a 0º. Hacer una traza del código para las siguientes entradas:

• 10, 0, -3. 12. 18, 5, 1

• 20, 15, 18, 5, -5, -3, -2

• 5, 10, 12, 18, 22, 30, 35

program t3e8(Input, Output);

var cont, temp, index: integer;

begin

cont := 0;

{Contador, nº de veces que la temperatura es inferior a 0 grados.}

for index := 1 to 7 do

begin

write('Dime temperatura(',index,'): ');

readln(temp);

{ Leer temperatura desde teclado}

if temp < 0 then cont := cont + 1

{ Si es menor que cero, incrementar el contador}

end;

write('La temperatura fue ',cont);

{ Escribir resultado por pantalla.}

if cont = 1 then write(' vez ') else write(' veces ');

writeln('inferior a cero.')

end.

12. Calcular los M primeros factoriales de un valor N entero.

program t3e12(Input, Output);

Uses Crt;

var index1, index2, N, M: integer;

fac: longint;

begin

ClrScr;

writeln('Calcular los factoriales de los números entre N y M:');

write('Dime N: ');

readln(N);

repeat

{Para no aceptar M > N }

write('Dime M (ha de ser M <= N): ');

readln(M);

{Se lee desde teclado hasta que sea M <= N}

until (M <= N);

for index1 := N downto M do

{Calcular el factorial de los números

comprendidos entre N y M ambos inclusive.}

begin

fac := 1;

{inicializar la variable que acumular  los productos}

for index2 := index1 downto 1 do fac := fac * index2;

{Cálculo del factorial}

writeln('El factorial de ',index1,' es ',fac,'.');

{Escribir resultado.}

end;

readkey

end.

Ejercicios tema 4

4. Escribir un programa que lea un número entero, lo multiplique por dos y a continuación lo escriba en la pantalla:

program t4e4(Input, Output);

Uses Crt;

var num: integer;

begin

ClrScr;

{Borrar la pantalla. Rutina de la unidad Crt}

write('Dime un número entero: ');

{Se pide por pantalla lo que ha de introducir el usuario (write),

y se lee desde teclado (readln).}

readln(num); num := 2 * num;

{Se opera y se guarda el resultado en la misma variable.}

writeln('Tu número multiplicado por 2 es ',num);

{Se Muestra el resultado.}

readkey

{Lee un carácter desde teclado, y no lo muestra por pantalla

(rutina de la unidad Crt)}

end.

6. Escribir un programa que lea dos números enteros A y B, y obtenga los valores A div B, A mod B.

program t4e6(Input, Output);

Uses Crt;

var A, B, aDb, aMb: integer;

begin

ClrScr;

write('Dime un número entero:');

readln(A);

write('Dime otro número entero:');

readln(B);

aDb := A div B;

aMb := A mod B;

writeln('A div B = ',aDb);

writeln('A mod B = ',aMb);

readkey

end.

8. Escribir un programa que convierta un número de segundos en su equivalente en minutos y segundos.

program t4e8(Input, Output);

uses Crt;

var iniseg, segundos, minutos: integer;

begin

ClrScr;

write('Dime un número de segundos:');

readln(iniseg);

minutos := iniseg div 60;

{Cada 60 segundos, son 1 minuto}

segundos := iniseg mod 60;

{Son los segundos que sobran de hacer grupos de 60 segundos}

writeln(iniseg,' segundos son ',minutos,' minutos y ',segundos,' segundos.');

readkey

end.

Ejercicios tema 5

4. Implementar en Pascal un algoritmo que solicitando al usuario una hora de un determinado día en el formato hora (de 1 a 24), minutos (de 1 a 60) y segundos (de 1 a 60), el programa calcule y visualice la hora un segundo más. Usar para ello los tipos mas apropiados.

program t5e4(Input, Output);

uses Crt;

var Horas, horasf: 0..23;

minutos, segundos, minf, segf: 0..59;

{formatos: Horas (de 0 a 23), Minutos y segundos (de 0 a 59)}

begin

ClrScr;

write('Dime horas: ');

readln(horas);

write('Dime minutos: ');

readln(minutos);

write('Dime segundos: ');

readln(segundos);

segf := segundos;

minf := minutos;

horasf := horas;

{Para no perder los valores iniciales, se asignan a las variables segf,

minf y horasf, y se opera con ellas. Así, los valores que introduzca

el usuario no se modifican, y se pueden usar luego}

if segundos < 59 then segf := segundos + 1

{si los segundos son menos de 59 se suma uno m s.}

else begin

{si son 59, al sumarle uno, habrá  que sumar un minuto y poner los

segundos a cero.}

segf := 0;

if minutos < 59 then minf := minutos + 1

{Si los minutos eran menos de 59, se suma el minuto.}

else begin

{Si eran 59 habrá  que sumar una hora, y poner a cero los minutos}

minf := 0;

if horas < 23 then horasf := horas + 1

{Si las horas eran menos de 23, se suma una hora más,

y si eran 23, se ponen a cero.}

else horasf := 0

end

end;

write(horas, 'h ',minutos, 'm ',segundos, 's + 1s = ');

writeln(horasf, 'h ',minf, 'm ',segf, 's.');

readkey

end.

10. Análisis de un texto. El usuario introduce una serie de caracteres por teclado, hasta finalizar con un asterisco. Obtener las letras del alfabeto que han aparecido y las que no han aparecido.

program t5e10(Input, Output);

Uses Crt;

var Estan: Set of Char;

Entrada: Char;

begin

clrscr;

Writeln('Introduce una frase, y termina con un * (asterisco):');

writeln;

Estan := [];

{Se inicializa el conjunto "Estan" como vacío}

repeat

entrada := upcase(readkey);

{Se lee de teclado un carácter, y se pasa a mayúsculas con

la función upcase().}

if entrada in ['A'..'Z',' ',',','.',';'] then write(entrada);

{Si el carácter introducido es una letra, un signo de puntuación,

o un espacio en blanco, entonces se muestra por pantalla. }

if not(entrada in Estan) then Estan := Estan + [entrada]

{Si el carácter no est  en el conjunto "Estan", entonces se añade}

until entrada = '*';

{Se repite el proceso hasta que se introduzca un *}

writeln;

writeln;

writeln('Las siguientes letras han aparecido:');

{Se procede a mostrar los caracteres que pertenecen al conjunto}

for entrada := 'A' to 'Z' do

{Se recorren los valores desde la A hasta la Z}

if entrada in Estan then write(entrada,' ');

{para cada letra, si est  en el conjunto "Estan", significa

que ha sido introducido por teclado, y entonces se muestra

por pantalla}

writeln;

writeln;

writeln('Las siguientes letras NO han aparecido:');

{Ahora se procede a mostrar los que no pertenecen al conjunto. Para ello

se sigue el mismo proceso que antes, pero mostrando la letra sólo si NO

pertenece al conjunto. }

for entrada := 'A' to 'Z' do

if not(entrada in Estan) then write(entrada,' ');

readkey

end.

12. Las notas de un examen pueden ser únicamente enteras, del 0 al 10. Obtener el numero de veces que ha aparecido el 0, el 5 y el 10 en el examen. Obtener las notas que no ha obtenido ningún alumno en la clase. El usuario debe introducir tantas notas como alumnos tenga la clase.

program t5e12(Input, Output);

Uses Crt;

var Notas: Set of 0..10;

index, alumno, veces0, veces5, veces10, N: integer;

begin

clrscr;

Notas := [];

{Se inicializa a conjunto vacío el conjunto donde se guardar n

las calificaciones obtenidas por los alumnos}

write('Cuántos alumnos hay en clase?: ');

readln(N);

veces0 := 0;

veces5 := 0;

veces10 := 0;

{Se inicializan a cero los contadores que guardarán las veces que

se obtuvieron puntuaciones de 0, 5, y 10 }

for index := 1 to N do

{N es el número de alumnos.}

{Repetir N veces el siguiente proceso:}

begin

write('Nota de alumno(',index,'): ');

readln(alumno);

{Leer la nota del alumno. Si la nota no esta en el conjunto,

entonces se añade:}

if not(alumno in notas) then notas := notas + [alumno];

case alumno of

{si la nota es cero, cinco o diez, se incrementa en uno el contador

correspondiente: veces0, veces5 o veces10}

0: veces0 := veces0 + 1;

5: veces5 := veces5 + 1;

10: veces10 := veces10 + 1

end

end;

writeln;

writeln('Número de alumnos con un cero: ',veces0); {Se muestran los }

writeln('Número de alumnos con un cinco:',veces5); {resultados }

writeln('Número de alumnos con un diez: ',veces10);

writeln;

writeln('Ningún alumno ha obtenido ninguna de las siguientes puntuaciones:');

{Se muestran las notas que no est n en el conjunto, que no estar n, porque

ningún alumno habrá  obtenido esa calificación.}

for index := 0 to 10 do

if not(index in notas) then write(index,' ');

readkey

end.

Ejercicios tema 6

2. Escribir un programa que lea dos números enteros A y B, y obtenga los valores A div B, A mod B, utilizando subprogramas.

Program t6e2(Input, Output);

Uses Crt;

Var A, B: Integer;

Function XdivY(X, Y: Integer): Integer;

{Función de dos par metros, que devuelve un entero que es el resultado

de realizar la división entera de los par metros pasados:}

begin

XdivY := X div Y

end;

Function XmodY(X, Y: Integer): Integer;

{Función de dos par metros, que devuelve un entero que es el resultado

de realizar la operación resto (mod) de los par metros pasados:}

begin

XmodY := X mod Y

end;

Begin

ClrScr;

writeln('*** Escribe dos números enteros ***');

write('Numero A = ');

readln(A);

write('Numero B = ');

readln(B);

writeln;

writeln('Calculando la división entera (div), y el resto (mod) ...');

writeln;

write(A,' div ',B,' = ', XdivY(A, B));

write(' porque ',B,' x ',XdivY(A, B),' es ',B * XdivY(A, B));

writeln(' y ',B,' x ',XdivY(A, B)+1,' es ',B*(XdivY(A, B)+1),' que se pasa.');

writeln;

write(A,' mod ',B,' = ', XmodY(A, B),' porque es lo que sobra de dividir ');

writeln(A,' entre ',B);

writeln;

writeln(A,' = ',XdivY(A,B),' x ',B,' + ',XmodY(A,B));

readkey

end.

10. Escribir un programa que lea tres números enteros y emita un mensaje que indique si están o no en orden numérico.

Program t6e10(Input, Output);

Uses Crt;

Var n1, n2, n3: integer;

Function ordenados(i, j: Integer): Boolean;

{Función booleana de dos par metros enteros, que devuelve TRUE si el

primer número es menor o igual que el segundo y FALSE si es mayor:}

begin

ordenados := (i <= j)

end;

Begin

ClrScr;

writeln('*** Introduce tres números enteros ***');

write('Primero: ');

readln(n1);

write('Segundo: ');

readln(n2);

write('Tercero: ');

readln(n3);

writeln;

{Mediante la función, se comprueba si el primer número es menor que

el segundo, y si el segundo es además menor que el tercero.}

if ordenados(n1,n2) and ordenados(n2,n3)

then writeln('Los tres números est n en orden.')

else writeln('Los tres números NO est n en orden');

readkey

end.

14. Implementar un programa que calcule recursivamente el factorial de un número.

Program t6e14(Input, Output);

Uses Crt;

Var n: Longint;

Function Factorial(n: longint): longint;

{Función de un par metro entero, que devuelve un entero largo (longint)

que es el resultado de calcular recursivamente su factorial:}

begin

if n <= 1 then factorial := 1

else factorial := n * factorial(n-1)

end;

Begin

ClrScr;

repeat

write('Introduce un número entero positivo: ');

readln(n);

if n < 0 then writeln('­ Positivo significa mayor o igual que cero !')

until n >= 0;

writeln;

writeln('El factorial de ',n,' es: ',n,'! = ',factorial(n));

readkey

end.

16. Torres de Hanoi. Se tienen tres postes y una serie de discos de diferentes tamaños, cada disco tiene un agujero en el centro permitiendo que los discos de apilen en los postes. Inicialmente los discos están apilados en el poste de la izquierda, ordenados según su tamaño, el menor en la parte de abajo y el menor en la parte de arriba. El objetivo del juego es trasladar los discos desde el poste izquierdo al derecho sin colocar nunca un disco mayor sobre uno mas pequeño. Los discos se deben mover de uno en uno y las discos siempre deben estar en un poste.

La estrategia es considerar uno de los postes como origen y otro como destino, el tercer poste se utiliza como almacenamiento intermedio para permitir el traslado de discos. Por tanto si los discos se encuentran inicialmente en el poste izquierdo el problema se convierte en:

Trasladar los n-1 discos superiores al poste central, usando el poste derecho como almacenamiento intermedio.

Trasladar el disco restante al poste derecho.

Trasladar los n-1 discos del poste central al poste derecho, usando el poste izquierdo como almacenamiento intermedio.

El problema se define de forma recursiva.

Program t6e16(Input, Output);

Uses Crt;

Const Max = 9;

Type disco = String[max];

arrdisco = array [1..max] of disco;

Var vdiscos: arrdisco; {Array que contendrá  los discos}

poste: array [1..3] of arrdisco; {tres postes para mover los discos}

cima: array [1..3] of 0..max; {altura del último disco de cada poste}

maxdiscos: 1..max; {número de discos}

movimientos: word; {número de movimientos de disco efectuados.}

ralentizar: boolean; {Si es True la visualización ser  m s lenta}

Function sacardisco(numposte: integer): disco;

{Extrae el último disco de un poste, y devuelve un String con el disco

que ha extraído}

begin

gotoxy(20*numposte-maxdiscos, 24-cima[numposte] );

write(' ':maxdiscos, '³',' ':maxdiscos);

sacardisco := poste[numposte, cima[numposte]];

{Este es el último disco.}

poste[numposte, cima[numposte]] := '';

{En el poste ya no queda disco.}

dec(cima[numposte]);

{El último disco en el poste est  una posición m s abajo.}

end;

Procedure meterdisco(numposte: integer; nuevodisco: disco);

{Inserta un disco encima del último que haya en un poste.}

begin

inc(cima[numposte]);

{El último disco, está  ahora una posición más alta.}

gotoxy(20*numposte-length(nuevodisco), 24-cima[numposte] );

write(nuevodisco, '³', nuevodisco);

poste[numposte, cima[numposte]] := nuevodisco

{Este es el disco insertado}

end;

Procedure inicio;

{Prepara la posición inicial de los postes, y llena el primero con

los discos que se hayan determinado.}

var i: integer;

Procedure hacerdiscos;

{Crea los discos, que son Strings}

var i: integer;

begin

vdiscos[1] := 'ß';

{El primer disco: Radio = 1, di metro = 2}

for i:= 2 to maxdiscos do vdiscos[i] := vdiscos[i-1]+'ß'

{Cada disco es una unidad m s grande que el anterior.}

end;

Procedure verposte(numposte: integer);

{Visualiza por pantalla los postes y los discos que contienen.}

var i: integer;

begin

gotoxy(20*numposte-(maxdiscos+1), 24);

for i := 1 to 2*(maxdiscos+1)+1 do write('±');

{Base de los postes}

for i := 1 to maxdiscos do

begin

if length(poste[numposte, i]) = 0 then

{Si la altura "i" del poste est  vacía, entonces:}

begin

gotoxy(20*numposte, 24-i );

write('³')

{Solo est  el poste, no hay disco.}

end

else begin

{Si en la altura "i" hay un disco:}

gotoxy(20*numposte-length(poste[numposte, i]), 24-i );

write(poste[numposte, i],'³', poste[numposte, i])

{Se dibuja el disco: mitad-poste-mitad}

end

end

end;

begin

movimientos := 0;

{Inicializar el nº de movimientos de disco realizados.}

hacerdiscos;

cima[1] := maxdiscos;

{El primer poste empieza lleno.}

for i:= 1 to maxdiscos do

begin

{Los discos se sitúan el m s grande abajo, y en orden ascendente}

poste[1,i] := vdiscos[maxdiscos-i+1];

poste[2,i] := '';

poste[3,i] := ''

{Los postes 2 y 3, empiezan vacíos.}

end;

cima[2] := 0;

cima[3] := 0;

{No hay discos inicialmente en los postes 2 y 3.}

for i := 1 to 3 do verposte(i)

{Visualizar los 3 postes.}

end;

Procedure transferir (n, origen, destino, otro : integer);

{ Transfiere n discos del origen al destino (Recursivamente)}

Procedure moverdisco (origen, destino : integer);

{ Traslada un disco desde el origen al destino }

var dibu: disco;

{Contendrá  el disco que sale de un poste hasta que sea

introducido en el siguiente.}

begin

inc(movimientos);

{Incrementar el n§ de movimientos}

gotoxy(50,8);

write(movimientos:3);

dibu := sacardisco(origen);

{se saca el disco del poste origen}

meterdisco(destino, dibu);

{y se mete en el poste destino}

if ralentizar

{para que de tiempo a ver el proceso: }

then delay(25 + 100*(max-maxdiscos+1))

{La velocidad depende del n§ de discos.}

else delay(25)

end;

begin

if n > 0 then

begin

{transferir los discos que est n encima (que ser n "n-1" discos)

desde el poste origen al otro, utilizando el destino de apoyo.}

transferir(n-1, origen, otro, destino);

{Mover el disco deseado del origen al destino}

moverdisco(origen, destino);

{y transferir al destino los que se quedaron en el otro.}

transferir(n-1, otro, destino, origen)

end

end;

Begin

ClrScr;

write('Número de discos [Máximo 9]: ');

repeat

maxdiscos := ord(readkey) - ord('0')

until (maxdiscos <= 9) and (maxdiscos > 0);

writeln(maxdiscos);

write('¨ Ralentizar ? [S/N]:');

ralentizar := (upcase(readkey) = 'S');

inicio;

gotoxy(24,8);

write('Movimientos realizados ..:');

transferir(maxdiscos, 1, 3, 2);

gotoxy(1,3);

writeln('That`s All Folks ...');

readkey

end

Ejercicios tema 7

2. Contar el número de vocales que aparecen en un array. El array termina con un punto.

Program t7e2(Input, Output);

Uses Crt;

Const vocales: Set of Char = (['A','E','I','O','U',' ',' ','¡','¢','£','£']);

LetBuenas: Set of Char = (['a'..'z','A'..'Z','0'..'9',

' ','.',',',':',';','(',')','-','¨',' ',' ','¡','¢','£',

'£','?','­','!','"','%','/','<','>']);

Var letra: Char; {para guardar cada carácter introducido desde teclado.}

Frase: array [1..80] of Char;

index, numvocales: integer;

Begin

ClrScr;

Writeln('Escribe tu frase, y termina con un punto.');

index := 0;

numvocales := 0;

repeat

letra := readkey;

if letra in letbuenas then

{para no guardar caracteres especiales.}

begin

inc(index);

{incrementar el ¡índice del array.}

write(letra);

{Readkey no muestra por pantalla el carácter leído.}

frase[index] := letra;

{se asigna el carácter al array.}

if upcase(letra) in vocales then inc(numvocales)

{Si el carácter está en el conjunto "vocales" se incrementa el

contador de vocales "numvocales":}

end

until (index >= 80) or (letra = '.'); {La frase termina con un punto.}

writeln;

writeln;

writeln('La frase tiene ',numvocales,' vocales.');

readkey

end.

4. Comparar dos arrays de caracteres y obtener si son idénticos o no.

Program t7e4(Input, Output);

Uses Crt;

Const long_frase = 80; {Máxima longitud permitida para una frase.}

Type frase = array [1..long_frase] of Char;

Var Frase1, frase2: frase; {Arrays donde se almacenarán las frases.}

iguales: boolean;

index: integer;

Procedure leerfrase(var arraychar: frase);

{Lee desde teclado una frase, y la almacena en un array de caracteres.}

var letra: Char;

index: integer;

begin

index := 0;

repeat

letra := readkey;

inc(index);

write(letra);

arraychar[index] := letra;

until (index >= long_frase) or (letra = #13);

{La frase termina con INTRO }

writeln

end;

Begin

ClrScr;

Writeln('Escribe la primera frase, y termina con INTRO.');

leerfrase(frase1);

{Leer la primera frase}

Writeln('Escribe la segunda frase, y termina con INTRO.');

leerfrase(frase2);

{Leer la segunda frase}

index := 1;

iguales := (frase1[index] = frase2[index]);

{Se inicializa "iguales" a true o false según el primer carácter de

"frase1" sea igual al primer carácter de "frase2" }

while iguales and (index <= long_frase) and (frase1[index] <> #13) do

{Mientras que iguales sea true y no se alcance el final de la frase,

que puede ser porque se detecte un INTRO o porque se llegue a la

longitud máxima de frase "long_frase".}

begin

inc(index);

iguales := (frase1[index] = frase2[index])

end;

if iguales then writeln('Las dos frases son idénticas.')

else begin

writeln('Las frases NO son idénticas.');

writeln('Difieren a partir del carácter nº', index)

end;

readkey

end.

6. Mostrar una frase en el orden inverso en que se escribió. La frase termina con un punto.

Program t7e6(Input, Output);

Uses Crt;

Const long_frase = 80;

Type frase = array [1..long_frase] of Char;

Var Frase1: frase;

iguales: boolean;

index, max: integer;

Procedure leerfrase(var arraychar: frase; var index: integer);

{Lee una frase desde teclado, y la almacena en un array.

Además, devuelve en una variable entera la longitud de la frase.}

var letra: Char;

begin

index := 0;

repeat

letra := readkey;

inc(index);

write(letra);

arraychar[index] := letra;

until (index >= long_frase) or (letra = '.');

writeln

end;

Begin

ClrScr;

writeln('Visualizar una frase al revés.');

Writeln('Escribe la frase, y termina con un punto:');

leerfrase(frase1,max);

for index := max downto 1 do write(frase1[index]);

{Para visualizar la frase al revés, se recorre el array que la contiene

empezando desde el final, que se ha guardado en la variable "max".}

writeln;

readkey

end.

8. Imprimir la media de los elementos que se encuentran en las posiciones pares y la media de los elementos que se encuentran en las posiciones impares de un vector numérica.

Program t7e8(Input, Output);

uses Crt;

Const maxnum = 5;

Type listadenumeros = array [1..maxnum] of real;

Var lista: listadenumeros;

pares, impares, index: integer;

imedia, pmedia, isuma, psuma: real;

Begin

ClrScr;

writeln('Dada una lista de números, calcular la media de los que ocupan ');

writeln('posiciones pares, y la de los que ocupan posiciones impares.');

writeln;

writeln('Introduce los ',maxnum,' números de la lista:');

isuma := 0; {acumulador de impares}

psuma := 0; {acumulador de pares}

pares := 0; {contador de pares}

impares := 0; {contador de impares}

for index := 1 to maxnum do

begin

write('Elemento ',index,': ');

readln(lista[index]); {leer elemento de la lista.}

if odd(index) then

{si ocupa posición impar:}

begin

inc(impares);

{incrementar contador de números impares,}

isuma := isuma + lista[index]

{sumar al acumulador de impares}

end

else begin

{si no ocupa posición impar:}

inc(pares);

{incrementar contador de números pares,}

psuma := psuma + lista[index]

{sumar al acumulador de pares}

end

end;

imedia := isuma / impares; {calcular la media de impares}

pmedia := psuma / pares; {calcular la media de pares}

writeln;

writeln(impares,' elementos impares y ',pares,' elementos pares.');

writeln;

writeln('Media de los elementos impares: ',imedia:10:5);

writeln('Media de los elementos pares..: ',pmedia:10:5);

readkey

end.

10. Realizar un algoritmo que dada una oración de tamaño máximo N y terminada en punto, determine si es un palíndromo o no. Un palíndromo es una oración que, atendiendo sólo a sus letras e ignorando los espacios, acentos, signos de puntuación y tipo de letra (mayúscula o minúscula) expresa lo mismo leída de izquierda a derecha que de derecha a izquierda. “dábale arroz a la zorra el abad”.

Program t7e10(Input, Output);

uses Crt;

Const long_frase = 80;

Type frase = array [1..long_frase] of Char;

Var frase1, palin: frase;

conta, cont2, palindex: integer;

letra: Char;

palíndromo: boolean;

Procedure leerfrase(var arraychar: frase; var index: integer);

var letra: Char;

begin

writeln('La frase acaba con INTRO.');

index := 0;

repeat

letra := readkey;

inc(index);

write(letra);

arraychar[index] := letra;

until (index >= long_frase) or (letra = #13);

if letra = #13 then dec(index);

{Porque la marca de fin de frase no forma parte de ella.}

writeln

end;

Begin

ClrScr;

Writeln('Escribe una frase para comprobar si es un palíndromo:');

leerfrase(frase1,conta);

palindex := 0;

for cont2 := 1 to conta do

begin

letra := upcase(frase1[cont2]); {pasar a mayúsculas.}

inc(palindex);

case letra of {no tener en cuenta los acentos.}

'A'..'Z',

'0'..'9': palin[palindex] := letra;

' ': palin[palindex] := 'A';

' ': palin[palindex] := 'E';

'¡': palin[palindex] := 'I';

'¢': palin[palindex] := 'O';

'£': palin[palindex] := 'U'

else dec(palindex)

{Si no es ni un carácter o un número, no incluirlo en "palin",

para ello se decrementa el ¡índice del array para que no quede

ningún hueco.}

end

end;

palíndromo := true;

for cont2 := 1 to (palindex div 2) do

{Desde el primer elemento hasta el que ocupe la posición intermedia:}

begin

{"palíndromo" ser  true mientras que los caracteres sean simétricos

respecto al punto medio de la frase.}

palíndromo := palíndromo and (palin[cont2] = palin[palindex-cont2 + 1]);

gotoxy (palindex-cont2+1,5);

{Las posiciones "cont2" y "palindex-cont2 + 1" son simétricas

respecto al punto medio de la frase.}

write(palin[palindex-cont2 + 1]);

gotoxy (cont2,5);

write(palin[cont2]);

delay(500)

end;

if odd(palindex) then write(palin[(palindex div 2) + 1]);

writeln;

writeln;

if palíndromo then writeln('La frase es un palíndromo.')

else writeln('La frase NO es un palíndromo.');

writeln;

readkey

end.

12. Dado un vector que contiene un texto de tamaño N como máximo, eliminar los espacios que existen delante del carácter salto de carro. El texto no tiene porqué ocupar todo el vector. El final de texto se marca con el carácter *.

Program t7e12(Input, Output);

uses Crt;

Const long_frase = 80;

Type frase = array [1..long_frase] of Char;

Var frase1: frase;

numblancos, conta, cont2, long: integer;

letra: Char;

Procedure leerfrase(var arraychar: frase; var pos_intro, index: integer);

{Lee una frase y devuelve además la posición de la frase en la que

se pulsó el primer INTRO, y la longitud total de la frase.}

var letra: Char;

pulsado: boolean;

begin

writeln('La frase acaba con un *');

pulsado := false;

index := 0;

repeat

letra := readkey;

inc(index);

if letra <> #13 then

begin

write(letra);

arraychar[index] := letra

end

else begin

if not pulsado then

begin

pulsado := true;

write('<enter>');

arraychar[index] := letra;

pos_intro := index

end

else dec(index)

end

until (index >= long_frase) or (letra = '*');

if letra = '*' then dec(index);

writeln

end;

Begin

ClrScr;

Writeln('Escribe una frase con blancos y un INTRO en medio.');

leerfrase(frase1,conta,long);

cont2 := conta - 1; {Posición anterior a la del INTRO}

numblancos := 0;

while (frase1[cont2] = ' ') and (cont2 >= 1) do

{mientras que el carácter sea un blanco, y no se llegue al principio:}

begin

inc(numblancos);

{incrementar el contador de blancos}

dec(cont2)

{decrementar la posición del array para ser comprobada.}

end;

{Para eliminar los blancos, se copian los caracteres que ocupan las

posiciones siguientes a las del INTRO, encima de las que ocupan los blancos

hasta el final de la frase.}

for cont2 := (conta-numblancos) to (long-numblancos)

do frase1[cont2] := frase1[cont2+numblancos];

writeln;

writeln('La frase sin blancos antes del INTRO:');

writeln;

for cont2 := 1 to (long-numblancos) do

if frase1[cont2] <> #13 then write(frase1[cont2])

else write('<enter>');

writeln;

readkey

end.

14. Escribir un programa que cuente el número de palabras en un texto, que tengan al menos cuatro vocales diferentes.

Program t7e14(Input, Output);

Uses Crt;

Const long_frase = 80;

maxppf = 30;

vocales: Set of Char = (['A','E','I','O','U',' ',' ','¡','¢','£']);

puntsigns: Set of Char

= ([' ','.',',',':',';','(',')','?','¨','­','!']);

Type frase = array [1..long_frase] of Char;

lista = array [1..maxppf, 0..1] of integer;

Var texto: frase;

palabras: lista;

letra: Char;

vocs: Set of Char;

longtexto, numpal, pal4voc, index, index2, numvoc: integer;

Procedure leerfrase(var arraychar: frase; var index: integer);

var letra: Char;

begin

writeln('El texto acaba con un punto.');

writeln('Introducir texto: ');

index := 0;

repeat

letra := readkey;

if not(letra in [#13, #27]) then

begin

inc(index);

write(letra);

arraychar[index] := letra

end

until (index >= long_frase) or (letra = '.');

writeln

end;

Procedure contarpalabras(var texto: frase; longtexto: integer;

var pal: lista; var npal: integer);

{Cuenta las palabras que hay en el texto (una palabra es una sucesión

de caracteres seguidos), y almacena la posición de cada comienzo y

final de palabra, en la tabla "pal", con 2 columnas (una para la

posición de comienzo, y otra para la posición de final).}

var cont: integer;

enpal, anterior: boolean;

begin

npal := 0;

anterior := false;

for cont := 1 to longtexto do

begin

enpal := not(texto[cont] in puntsigns);

if enpal then {Estamos sobre una palabra}

begin

if not(anterior)

{Si en el paso anterior era "enpal" = false}

then begin

inc(npal); {Se trata de una palabra nueva.}

{se guarda la posición en donde empieza}

pal[npal,0] := cont

end

end

else if anterior then pal[npal,1] := cont;

{si ya no estamos sobre una palabra, se guarda

la posición donde termina.}

anterior := enpal

end

end;

Begin

ClrScr;

leerfrase(texto, longtexto);

contarpalabras(texto, longtexto, palabras, numpal);

{En "palabras", tenemos almacenadas las posiciones que ocupan en el texto

los comienzos y finales de las palabras que lo componen, y en "numpal" el

número de palabras que componen el texto.}

pal4voc := 0;

{Puesta a cero del contador de palabras con al menos 4 vocales.}

for index := 1 to numpal do

{Se repite el siguiente proceso para cada palabra:}

begin

vocs := vocales; {El conjunto "vocs" contiene ahora todas las vocales.}

numvoc := 0;

for index2 := palabras[index,0] to palabras[index,1] do

{"index2" toma valores desde la posición de comienzo de la palabra

"palabras[index,0]", hasta la posición de final de palabra [index,1]}

begin

if upcase(texto[index2]) in vocs then

begin

inc(numvoc);

vocs := vocs - [upcase(texto[index2])]

{Si el carácter es una vocal:}

{Se incrementa el contador de vocales, y se elimina la vocal

correspondiente del conjunto "vocs"}

end

end;

if numvoc >= 4 then inc(pal4voc)

{Si la palabra tenía m s de 4 vocales, se incrementa el contador de

palabras con 4 vocales.}

end;

writeln('longitud de texto: ',longtexto);

writeln('palabras en texto: ',numpal);

writeln('Palabras con al menos 4 vocales: ',pal4voc);

readkey

end.

16. Escribir un programa que lea una tabla de números reales (dos dimensiones), calcule la suma por filas y por columnas y muestre por pantalla la tabla y las sumas.

Si los datos de entrada son:

2.5	-6.3	14.7	4.0
10.8	12.4	-8.2	5.5
-7.2	3.1	17.7	-9.1

Los datos de salida son:

2.5	-6.3	14.7	4.0	14.9
10.8	12.4	-8.2	5.5	20.5
-7.2	3.1	17.7	-9.1	4.5
6.1	9.2	24.2	0.4	0.0

Program t7e16(Input, Output);

Uses Crt;

Const maxN = 6; {Máximo número de líneas y de columnas de la matriz}

Type matriz = array [1..maxN, 1..maxN] of real;

vector = array [1..maxN] of real;

Var col, afila, fN, cN: integer;

sumF, sumC: vector; {Almacenarán las sumas por filas y columnas.}

mat1: matriz; {Es la matriz que introduce el usuario.}

Begin

ClrScr;

write('Dime n§ de columnas (m x = 6): ');

repeat cN := ord(readkey) - ord('0') until (cN<=6) and (cN>=2);

writeln(cN);

write('Dime n§ de filas (m x = 6): ');

repeat fN := ord(readkey) - ord('0') until (fN<=6) and (fN>=2);

writeln(fN);

writeln('Introducir elementos de la matriz:');

for mfila := 1 to fN do { para cada fila, y }

for col := 1 to cN do { para cada columna:}

begin

gotoxy(1,5);

write('Fila:',mfila:2,' Columna:',mcol:2);

gotoxy(7*mcol,mfila+7);

read(mat1[mfila, col]);

{Se lee el elemento [ mfila, col ] }

gotoxy(7*mcol,mfila+7);

if mat1[mfila, col] < 0 then textcolor(9)

else textcolor(7);

write(mat1[mfila, col]:6:1)

end;

for mfila := 1 to fN do sumf[mfila] := 0;

for col := 1 to cN do sumc[col] := 0;

{Se inicializan la fila y la columna de sumas. }

for mfila := 1 to fN do

for col := 1 to cN do

begin {Se acumulan las sumas de los elementos por filas y cols.}

sumf[mfila] := sumf[mfila] + mat1[mfila, col];

sumc[col] := sumc[col] + mat1[mfila, col]

end;

textcolor(12);

for mfila := 1 to fN do

begin {Se escriben las sumas por filas}

gotoxy(7*(cN+1),mfila+7); {La columna donde se escribe es fija.}

write(sumf[mfila]:6:1); {A la derecha de la última.}

end;

for col := 1 to cN do

begin {Se escriben las sumas por columnas}

gotoxy(7*mcol,(fN+8)); {La fila donde se escribe es debajo de la última.}

write(sumc[col]:6:1);

end;

writeln;

readkey

end.

18. Dada una matriz A de orden NxN, girarla 90º en el sentido de las agujas del reloj y guardar el resultado en la matriz B.

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

Program t7e18(Input, Output);

Uses Crt;

Const N = 4;

mat1: array [1..N, 1..N] of integer { Matriz de entrada.}

= ( ( 1, 2, 3, 4),

( 5, 6, 7, 8),

( 9,10,11,12),

(13,14,15,16) );

Type matriz = array [1..N, 1..N] of integer;

Var col, mfila: integer;

mat2: matriz; {Matriz de salida}

Begin

ClrScr;

writeln;

writeln(' Se procede a girar la matriz 90 grados');

writeln(' en el sentido de las agujas del reloj:');

for mfila := 1 to N do

for col := 1 to N do

begin

gotoxy(4*mcol,mfila+4);

write(mat1[mfila,mcol]:2)

end;

gotoxy(22,6);

write('--->');

for mfila := 1 to N do

for col := 1 to N do

begin

mat2[mfila,mcol] := mat1[N-(mcol-1),mfila];

{lo que eran filas, ahora pasan a ser columnas, y además

al revés, o sea, la primera fila ser  la última columna ...}

gotoxy(4*mcol+25,mfila+4);

write(mat2[mfila,mcol]:2)

end;

writeln;

readkey

end.

20. Dado un array de NxN, sumar los elementos situados por encima de la diagonal principal. Es decir:

Program t7e20(Input, Output);

Uses Crt;

Const N = 4;

mat1: array [1..N, 1..N] of integer

= ( ( 1, 2, 3, 4),

( 5, 6, 7, 8),

( 9,10,11,12),

(13,14,15,16) );

Type matriz = array [1..N, 1..N] of integer;

Var col, mfila: integer;

suma: integer; {Ir  acumulando la suma de los elementos deseados.}

Begin

ClrScr;

writeln;

writeln(' Se procede a sumar los elementos de la matriz');

writeln(' que se encuentren por encima de la diagonal: ');

for mfila := 1 to N do

for col := 1 to N do

{Todos los elementos por encima de la diagonal, cumplen la propiedad

de ser su ¡índice de columna mayor que su ¡índice de fila}

begin

if col > mfila then textcolor(12)

else textcolor(7);

{se escribir n en rojo los elementos a sumar.}

gotoxy(4*mcol+18,mfila+4);

write(mat1[mfila,mcol]:2)

end;

suma := 0;

for mfila := 1 to N do

for col := mfila+1 to N do

suma := suma + mat1[mfila,mcol];

writeln;

writeln;

writeln(' La suma de los elementos');

write(' por encima de la diagonal es: ');

textcolor(12);

writeln(suma);

textcolor(7);

readkey

end.

23.- Implementar un subprograma que reciba como dato una frase (tira de longitud máx 80 caracteres) ya leída, y la procese de forma que a través de una ventana (array de 20 caracteres), aparezca dicha frase moviéndose de derecha a izquierda. Cuando por la ventana pase el último carácter de la frase, ésta volverá a desfilar de nuevo desde el principio. Así un número de veces. Dicho número debe ser facilitado al subprograma. También se le facilitará la longitud de la frase. Como salida para la visualización del array ventana, se hará simplemente invocando al procedimiento VISUALIZAR (sin argumentos) que se supondrá ya declarado.

Program t7e23(Input, Output);

Uses Crt;

Const Long_frase = 80;

Long_ventana = 20;

LetBuenas: Set of Char = (['a'..'z','A'..'Z','0'..'9',

' ','.',',',':',';','(',')','-','¨',' ',' ','¡','¢','£',

'£','?','­','!','"','%','/','<','>']);

Type frase = array [1..long_frase] of Char;

Var texto: frase;

veces, long_texto, rapido: integer;

Procedure leerfrase(var arraychar: frase; var index: integer);

{Lee una frase desde el teclado, sin permitir que se introduzcan

caracteres especiales, como <esc>, <ctrl+> ...Devuelve la longitud.}

var letra: Char;

begin

write('Introduce la frase: ');

writeln('La frase acaba con INTRO.');

index := 0;

{Se inicializa el ¡índice del array a llenar.}

repeat

{Se leen caracteres desde teclado hasta leer un INTRO}

letra := readkey;

if letra in letbuenas then

{Si el carácter leído no es de control:}

begin

inc(index);

{se incrementa el índice del array.}

write(letra);

arraychar[index] := letra

{Se guarda en el array.}

end

until (index >= long_frase) or (letra = #13);

repeat

{Si el texto leído tiene menor longitud que la ventana,}

inc(index);

arraychar[index] := ' '

until index >= long_ventana;

{se rellena hasta completar.}

writeln

end;

Procedure win(var texto: frase; textlenght, rep: integer);

{Visualiza "rep" veces una frase, a través de una ventana de texto.}

Type ventana = array [1..long_ventana] of Char;

var win1: ventana; {Esta es la porción de texto a visualizar}

index, ini, dentro: integer;

Procedure visualizar(var winx: ventana);

{visualiza un array de caracteres (tipo ventana)}

Const posY = 12; {Coordenada de fila.}

posX = 30; {Coordenada de columna.}

var index: integer;

begin

textbackground(4); {La ventana ser  de fondo de color rojo}

for index := 0 to long_ventana-1 do

begin

{Visualizar el array en pantalla.}

gotoxy(posX+index,posY);

write(winx[index+1])

end;

delay(20*rapido);

{Pausa entre "frames" para hacer que el mensaje aparezca más o

menos rápido en la ventana}

textbackground(0) {Devolver el fondo a color negro.}

end;

begin

repeat

{Repetir el número de veces que haya introducido el usuario.}

gotoxy(30,15);

write('Quedan ',rep-1,' repeticiones.');

for ini := 1 to long_ventana-1 do

{La frase comienza a entrar en la ventana por la derecha.}

begin

dentro := 0;

{controla el nº de caracteres del texto que entran en la ventana.}

for index := 1 to long_ventana-ini do

begin

win1[index] := ' ';

{La ventana comienza a llenarse con blancos por la izquierda.}

inc(dentro);

{ n§ de blancos que hay a la izquierda del texto}

end;

for index := dentro to long_ventana do

win1[index] := texto[index-dentro+1];

{El resto de caracteres pertenecen al texto.}

visualizar(win1) {Se visualiza la ventana.}

end;

for ini := 1 to textlenght do

{Toda la ventana es llenada por caracteres del texto.}

begin

for index := 1 to long_ventana

do win1[index] := texto[ini+index-1];

visualizar(win1) {Se visualiza la ventana.}

end;

dec(rep)

{Se decrementa el contador de repeticiones.}

until (rep <= 0)

end;

Begin

ClrScr;

writeln('Visualizar una frase en una ventana de texto.');

leerfrase(texto,long_texto);

writeln;

write('Introduce el número de repeticiones [1..9]: ');

repeat

veces := ord(readkey) - ord('0')

until veces in [1..9];

writeln(veces);

write('Velocidad [Rápido = 1 .... 9 = lento]: ');

repeat

rapido := ord(readkey) - ord('0')

until veces in [1..9];

ClrScr;

gotoxy(34,11);

write('V E N T A N A');

win(texto,long_texto,veces);

gotoxy(30,18);

write('That`s All Folks ...');

readkey

end.

Ejercicios tema 8

2. Leer los nombres y notas de parcial y final de N alumnos de una clase. Hacer un listado con cada una de las notas, la nota media de los dos exámenes y poner APTO si han aprobado y NO APTO si han suspendido. Utilizar un array de registros.

Program t8e2(Input, Output);

Uses Crt;

Const numalumnos = 5;

Type tiponotas = record

nombre: String;

parcial, final: real

end;

notasclase = array [1..Numalumnos] of tiponotas;

Var I3: notasclase;

nota1, nota2: real;

alumno: String;

index: integer;

Begin

ClrScr;

for index := 1 to numalumnos do

begin

write('Nombre de alumno(',index,'): ');

readln(alumno);

write('Nota del examen parcial: ');

readln(nota1);

write('Nota del examen final: ');

readln(nota2);

writeln;

with i3[index] do

begin

nombre := alumno;

parcial := nota1;

final := nota2

end

end;

ClrScr;

writeln('NOMBRE ':30,'Parcial':10,'Final':10,'Media':10,' CALIFICACION');

for index := 1 to 75 do write('-');

writeln;

for index := 1 to numalumnos do

with i3[index] do

begin

{Escribir la lista con los resultados.}

nota1 := (parcial+final)/2;

{Se calcula la media.}

write(nombre:30,parcial:10:2,final:10:2);

write(nota1:10:2);

{Si la nota media es superior a 5, el alumno est  aprobado:}

if nota1 >= 5 then writeln(' *** APTO *** ')

else writeln(' NO APTO')

end;

readkey

end.4. Un array de registros contiene la descripción de personas a efectos estadísticos. Cada registro tiene los campos: nombre, edad, sexo, altura, color de pelo, color de piel, color de ojos, nacionalidad y región. Escribir un programa que lea y almacene los datos en este array y visualice después su contenido.

Program t8e4(Input, Output);

Uses Crt;

Const totalmuestreo = 5;

Type datos = record

nombre: String[25];

nacion, region: String[11];

edad: integer;

altura: real;

sexo, ColOjos, colPelo, colPiel: Char

end;

estadistica = array [1..totalmuestreo] of datos;

Var Grupo1: Estadistica;

nom: String[25];

cont, index: integer;

Begin

ClrScr;

index := 1;

repeat

{Repetir hasta que se introduzca un nombre en blanco:}

with grupo1[index] do

begin

write('Nombre (',index,'): ');

readln(nom);

{Leer el nombre.}

if not(nom = '') then

{Si no se introdujo un nombre vacío, entonces leer el resto de datos.}

begin

nombre := nom;

write('País de origen: ');

readln(nacion);

write('región: ');

readln(region);

write('Sexo [V/M]: ');

repeat

sexo := upcase(readkey)

until sexo in ['V','M'];

{restringe la entrada a "V" o "M".}

writeln(sexo);

write('Altura [x.xx metros]: ');

readln(altura);

write('Color de ojos [V, A, M, N, G]: ');

repeat

colojos := upcase(readkey)

until colojos in ['V','A','M','N','G'];

writeln(colojos);

write('Color de piel [N, B, A, R]: ');

repeat

colpiel := upcase(readkey)

until colpiel in ['N','B','A','R'];

writeln(colpiel);

write('Color de pelo [N, B, C, R, P]: ');

repeat

colpelo := upcase(readkey)

until colpelo in ['N','B','C','R','P'];

writeln(colpelo);

writeln;

index := index + 1

{Se incrementa el número de muestras.}

end

end

until (index >= totalmuestreo) or (nom = '');

ClrScr;

write('NOMBRE':25,'NACION':12,'REGION':12,' EDAD',' SEXO',' ALT.');

writeln(' OJOS',' PIEL',' PELO');

for cont := 1 to 79 do write('Í');

writeln;

for cont := 1 to index do

{Presentar los resultados por pantalla.}

with grupo1[cont] do

{Cada elemento del array es un registro.}

begin

write(nombre:25,nacion:12,region:12,edad:5,sexo:5,altura:5:2);

writeln(colojos:4,colpiel:5,colpelo:5)

end;

readkey

end.

6. Se dispone de un array con la hora de finalización de un determinado experimento en cada uno de los días del año. Escribir las estructuras de datos necesarias. Implementar un subprograma que modifique la hora de un día en concreto.

Program t8e6(Input, Output);

Uses Crt;

Const diasmes: array [1..12] of integer =

(31,28,31,30,31,30,31,31,30,31,30,31);

Type experimento = record

dia, mes: integer;

hora, minuto, segundo: integer

end;

Var exp: array [1..365] of experimento; {Cada día un registro experimento}

index: integer;

control, correcto: Char;

nomascorrec: boolean;

Procedure llenararray;

{Para inicializar aleatoriamente los registros de cada día del año.}

var diadelmes, numdemes: integer;

begin

randomize;

diadelmes := 1; {Los meses tienen longitud distinta.}

numdemes := 1;

for index := 1 to 365 do

with exp[index] do

begin

mes := numdemes;

dia := diadelmes;

hora := random(24); {Valor de 0 a 23.}

minuto := random(60); {Valor de 0 a 59.}

segundo := random(60);

if diadelmes < diasmes[numdemes] then inc(diadelmes)

else begin {Si ya se ha completado un mes:}

diadelmes := 1; {El siguiente mes empieza en día 1}

numdemes := numdemes + 1 {Incrementar número del mes.}

end

end

end;

Procedure verarray;

{Visualiza los registros de experimento de todos los días.}

begin

for index := 1 to 365 do

with exp[index] do

begin

write(dia:2,'/',mes:2,' .......... Hora: ');

writeln(hora:2,':',minuto:2,':',segundo:2);

if (index mod 24) = 0 then readkey

end

end;

Function numdia(dia, mes: integer): integer;

{Calcula el número de día del año que corresponde a un día de un mes.}

var i, sum: integer;

begin

sum := 0;

for i := 1 to mes - 1 do sum := sum + diasmes[i];

{Todos los meses anteriores están completos.}

numdia := sum + dia

{Al número de día del mes, hay que sumarle el número de días de los

meses anteriores.}

end;

Procedure editarfecha;

var exp_erroneo: experimento;

begin

repeat

writeln('Introducir la fecha del experimento erróneo:');

with exp_erroneo do

begin

repeat

repeat

write('Mes: ');

readln(mes)

until (mes > 0) and (mes <= 12);

{El número de mes ha de estar entre 1 y 12.}

repeat

write('Día: ');

readln(dia)

until (dia > 0) and (dia <= diasmes[mes]);

{El número de día ha de estar entre 1 y el nº de días que

tenga el mes.}

index := numdia(dia, mes);

write('Hora a cambiar: ',exp[index].hora:2,':');

writeln(exp[index].minuto:2,':',exp[index].segundo);

write('¨Es este el experimento a modificar? [S/N]: ');

repeat

correcto := upcase(readkey)

until correcto in ['S','N'];

writeln(correcto);

until correcto = 'S';

writeln('Nueva hora: ');

write('Hora: ');

readln(hora);

write('Minuto: ');

readln(minuto);

write('Segundo: ');

readln(segundo);

end;

write('¨Todo correcto? [S/N]: ');

repeat control := upcase(readkey) until control in ['S','N'];

writeln(control)

until control = 'S';

with exp[index] do

begin

hora := exp_erroneo.hora;

minuto := exp_erroneo.minuto;

segundo := exp_erroneo.segundo

end;

writeln('Corrección guardada.')

end;

Begin

ClrScr;

llenararray;

repeat

verarray;

editarfecha;

write('¨Más cambios? [S/N]: ');

repeat control := upcase(readkey) until control in ['S','N'];

writeln(control);

nomascorrec := (control = 'N')

until nomascorrec;

writeln;

writeln('That`s All Folks ...');

readkey

end.

12. Se plantea subir el sueldo de los empleados de una empresa en un 20% si tienen una antigüedad mayor que 40 años y casados. Un 10% a los no casados y con igual antigüedad. Un 5% al resto. Escribir el programa con los tipos de datos mas apropiados.

Program t8e12(Input, Output);

uses Crt;

Const MaxEmpl = 5;

{Suficiente para contemplar todas las combinaciones de actualización.}

Type Empleado = record

nombre: String[25];

casado: Boolean;

Antiguedad: integer;

salario: longint

end;

Var nomina: array [1..MaxEmpl] of empleado;

Procedure hazplantilla;

{Lee desde teclado los datos referentes a los empleados.}

var numempleado: integer;

est_civil: Char;

begin

for numempleado := 1 to MaxEmpl do

with nomina[numempleado] do

begin

write('Nombre empleado(',numempleado,'): ');

readln(nombre);

write('Antigüedad [en años]: ');

readln(antiguedad);

write('Estado civil [S/C]: ');

repeat

est_civil:= upcase(readkey)

until est_civil in ['S','C'];

{Solo acepta como entradas S, o C}

writeln(est_civil);

casado := (est_civil = 'C');

write('Salario base: ');

readln(salario);

writeln;

end

end;

Procedure Subirsueldo;

{Actualiza los sueldos, y muestra por pantalla el listado de

los datos de los empleados.}

var numempleado: integer;

Procedure actualizar(var trabajador: empleado);

{Actualiza el salario de un trabajador.}

var incremento: integer;

Function porcentaje(antig: integer; estciv: boolean): integer;

{Devuelve el porcentaje de aumento en función de la

antigüedad y del estado civil del empleado.}

begin

if (antig >= 40)

then if estciv

then porcentaje := 20

else porcentaje := 10

else porcentaje := 5

end;

begin

with trabajador do

begin

incremento := porcentaje(antiguedad, casado);

{Guarda el porcentaje de aumento para el empleado.}

salario := salario + ((salario * incremento) div 100)

{Calcula el nuevo salario y lo guarda en su registro.}

end

end;

begin

ClrScr;

writeln('NOMBRE':25,'Ant':5,' E.civ',' Salario',' Actualizado');

for numempleado := 1 to MaxEmpl do

{Para cada empleado, hacer:}

with nomina[numempleado] do

{Con el registro de datos del empleado:}

begin

write(nombre:25,antiguedad:5);

if casado then write(' C ')

else write(' S ');

write(salario:8);

{Escribir los datos personales y el salario antiguo.}

actualizar(nomina[numempleado]);

{Actualizar el salario, y escribir el salario actualizado.}

writeln(salario:12)

end

end;

Begin

ClrScr;

hazplantilla;

subirsueldo;

readkey

end.

Ejercicios tema 9

2. Contar el número de vocales (cada una) que aparecen en un fichero de texto.

Program t9e2(Input, Output);

uses Crt;

Type vocales = (a,e,i,o,u);

Var acumulador: array [a..u] of integer;

fichero: Text;

letra: Char;

index: vocales;

archivo: String;

control: boolean;

contador: integer;

Begin

ClrScr;

for index := a to u do acumulador[index] := 0;

{Inicializa los elementos del acumulador a cero.}

contador := 0;

{Contar  el n§ de veces que se intente abrir un archivo de texto.}

repeat

write('Nombre de archivo: ');

readln(archivo);

inc(contador);

if archivo = '' then archivo := 'c:\tp\bin\temas\tema9\t9e2dat.txt';

{Si el usuario no introduce el nombre, se aplica uno por defecto. }

assign(fichero, archivo);

{Se asigna el nombre del archivo a la variable fichero de texto.}

{$I-}

reset(fichero);

{Antes de intentar abrir el archivo, se desactiva el control de errores

mediante la directiva del compilador $I- que ha de ir entre llaves.

Después se intenta abrir el archivo, y se vuelve a activar el control.}

{$I+}

control := (ioresult = 0);

if not control then writeln('Error en apertura de fichero.!!');

{Si se produjo un error en la apertura del archivo porque el archivo

no existe o cualquier otra causa, la variable "ioresult" contendrá un

valor distinto de cero, y si no se produjo ningún error y el archivo

pudo ser abierto, contendrá  el valor cero. }

writeln

until control or (contador >= 3);

if (contador >= 3) and not(control) then Halt(1);

{Si no se pudo abrir el archivo parar la ejecución del programa.}

while not eof(fichero) do

{Repetir el siguiente proceso hasta que se detecte la marca

de final de fichero.}

begin

while not eoln(fichero) do

{Para cada línea de texto se repite el siguiente proceso:}

begin

read(fichero, letra);

{Leer un carácter del archivo.}

write(letra);

{Escribir el carácter por pantalla.}

letra := upcase(letra);

{convertir el carácter a mayúsculas.}

case letra of

{Si el carácter es una vocal o una vocal acentuada,

se incrementa el acumulador correspondiente a dicha vocal.}

'A','á': inc(acumulador[a]);

'E','é': inc(acumulador[e]);

'I','í': inc(acumulador[i]);

'O','ó': inc(acumulador[o]);

'U','ú','ü': inc(acumulador[u])

end

end;

if not eof(fichero) then

{Se ha alcanzado una marca de final de línea, y si no es final de

archivo, hay que leer otro carácter, porque la marca de final de línea

se compone de dos: Avance de línea (#10) y retorno de carro (#13).}

begin

read(fichero, letra);

write(letra)

end

end;

close(fichero);

{Una vez se ha leído todo el archivo, hay que cerrarlo}

writeln;

for index := a to u do

{Presentar por pantalla los valores de los acumuladores:}

begin

case index of

a: write(' A: ');

e: write(' E: ');

i: write(' I: ');

o: write(' O: ');

u: write(' U: ')

end;

writeln(acumulador[index]:3,' veces.')

end;

readkey

end.

5. Escribir un programa que cuente el número de palabras de un texto. Las palabras terminan cuando hay un espacio en blanco, o un `.', `,', `;' o termina la línea o el fichero.

Program t9e5(Input, Output);

uses Crt;

Var fichero: Text;

letra: Char;

contador: integer;

palabra: String;

control: boolean;

Begin

ClrScr;

contador := 0;

{Contar  el nº de veces que se intente abrir un archivo de texto.}

repeat

write('Nombre de archivo: ');

readln(palabra);

inc(contador);

if palabra = '' then palabra := 'c:\tp\bin\temas\tema9\t9e2dat.txt';

{Si el usuario no introduce el nombre, se aplica uno por defecto. }

assign(fichero, palabra);

{Se asigna el nombre del archivo a la variable fichero de texto.}

{$I-}

reset(fichero);

{Antes de intentar abrir el archivo, se desactiva el control de errores

mediante la directiva del compilador $I- que ha de ir entre llaves.

Después se intenta abrir el archivo, y se vuelve a activar el control.}

{$I+}

control := (ioresult = 0);

if not control then writeln('Error en apertura de fichero.!!');

{Si se produjo un error en la apertura del archivo porque el archivo

no existe o cualquier otra causa, la variable "ioresult" contendrá un

valor distinto de cero, y si no se produjo ningún error y el archivo

pudo ser abierto, contendrá  el valor cero. }

writeln

until control or (contador >= 3);

if (contador >= 3) and not(control) then Halt(1);

{Si no se pudo abrir el archivo parar la ejecución del programa.}

contador := 0;

palabra := '';

control := false;

while not eof(fichero) do

{Mientras que no se encuentre el final de archivo:}

begin

while not eoln(fichero) do

{Para cada línea de texto hacer:}

begin

read(fichero, letra);

{Leer un carácter del archivo.}

if not(letra in [' ', ',', '.', ';', ':', #13, #10])

{Si el carácter no es un signo de puntuación o un blanco:}

then begin

if not control then inc(contador);

{"Control" vale true cuando el anterior carácter no era

un signo de puntuación, o sea, que la palabra ya había

empezado, y false si la palabra empieza en este carácter.}

control := true;

palabra := palabra + letra

{Se añade el carácter a la palabra.}

end

else begin

{El carácter leído es un signo de puntuación o un blanco,

por lo que la palabra ha terminado.}

control := false;

writeln('Palabra(',contador,'): ',palabra);

{Se escribe la palabra en pantalla.}

palabra := '';

{Se borra la palabra para empezar con la siguiente.}

if (contador mod 24) = 0 then readkey;

{Pausa para ver una pantalla (24 líneas)}

while ((letra in [' ', ',', '.', ';', ':', #13, #10])

or eoln(fichero)) and not(eof(fichero)) do

{Mientras que el carácter leído siga siendo un signo,

o un blanco, o una marca de final de línea o de fichero,

que son los que separan las palabras, hay que seguir leyendo

caracteres sin aumentar el n§ de palabras:}

begin

read(fichero, letra);

if not(letra in [' ', ',', '.', ';', ':', #13, #10])

{Se ha encontrado el comienzo de una nueva palabra.}

then begin

inc(contador);

palabra := palabra+letra;

{Se añade el carácter a la nueva palabra.}

control := true

{Se activa el control de palabra.}

end

end

end

end;

if not eof(fichero) then

{Se alcanzó el final de línea.}

begin

{Hay que leer el segundo carácter de la marca.}

read(fichero, letra);

write(letra)

end

end;

close(fichero);

{Una vez terminada la lectura del archivo, hay que cerrarlo.}

writeln;

writeln('Total: ',contador,' palabras.');

readkey

end.

6. Realizar un programa que lea un fichero de texto (entrada) y que escriba un fichero de texto (salida) que contenga solamente las palabras leídas que tengan un número impar de letras y además la del medio sea vocal. El fichero de entrada sólo contendrá caracteres alfabéticos, espacios en blanco y saltos de línea. Se supone que la longitud de las palabras no excede en ningún caso de 33 caracteres.

Program t9e6(Input, Output);

uses Crt;

Const vocales: Set of Char = (['A','E','I','O','U']);

Var fichero, ficsalida: Text;

letra: Char;

contletras, contpal, escritas: integer;

palabra: String;

control: boolean;

Begin

ClrScr;

contpal := 0;

repeat

write('Nombre de archivo: ');

readln(palabra);

inc(contpal);

if palabra = '' then palabra := 'c:\tp\bin\temas\tema9\t9e2dat.txt';

{Si el usuario no introduce el nombre, se aplica uno por defecto. }

assign(fichero, palabra);

{Se asigna el nombre del archivo a la variable fichero de texto.}

{$I-}

reset(fichero);

{Antes de intentar abrir el archivo, se desactiva el control de errores

mediante la directiva del compilador $I- que ha de ir entre llaves.

Después se intenta abrir el archivo, y se vuelve a activar el control.}

{$I+}

control := (ioresult = 0);

if not control then writeln('Error en apertura de fichero.!!');

{Si se produjo un error en la apertura del archivo porque el archivo

no existe o cualquier otra causa, la variable "ioresult" contendrá un

valor distinto de cero, y si no se produjo ningún error y el archivo

pudo ser abierto, contendrá  el valor cero. }

writeln

until control or (contpal >= 3);

if (contpal >= 3) and not(control) then Halt(1);

{Si no se pudo abrir el archivo parar la ejecución del programa.}

write('Nombre de archivo de salida: ');

readln(palabra);

if palabra = '' then

{Si el usuario no introduce el nombre, se aplica uno por defecto. }

begin

palabra := 't9e6out.txt';

writeln;

writeln('El archivo de salida es T9E6OUT.TXT');

readkey;

writeln

end;

assign(ficsalida, palabra);

{Se asigna el fichero de salida.}

rewrite(ficsalida);

{Se abre el fichero de salida. No hace falta controlar si ha habido un

error en la apertura, porque "rewrite" crea un nuevo archivo.}

palabra := '';

control := false;

contpal := 0;

contletras := 0;

escritas := 0;

while not eof(fichero) do

begin

while not eoln(fichero) do

begin

read(fichero, letra);

if not(letra in [' ', ',', '.', ';', ':', #13, #10])

then begin

if not control then inc(contpal);

control := true;

inc(contletras);

palabra := palabra + letra

end

else begin

control := false;

write('Palabra (',contpal,'): ',palabra);

if odd(contletras)

{Una vez separada la palabra del archivo, se comprueba

si la letra central es una vocal. Para ello, lo primero es

saber si existe una letra central comprobando si la palabra

tiene un número impar de letras.}

then begin

if (upcase(palabra[(contletras div 2)+1]) in vocales)

{Si hay una letra central, se comprueba si es una vocal.}

then begin

{En caso de serlo, se incrementa el n§ de palabras

que se escriben el fichero de salida, y se escribe

la palabra en el archivo.}

inc(escritas);

writeln(' ....... **** Escrita en fichero. **** ');

writeln(ficsalida,palabra)

end

else writeln

end

else writeln;

palabra := '';

{Se comienza el proceso con una nueva palabra.}

contletras := 0;

if (contpal mod 24) = 0 then readkey; {Pausa}

while ((letra in [' ', ',', '.', ';', ':', #13, #10])

or eoln(fichero)) and not(eof(fichero)) do

begin

read(fichero, letra);

if not(letra in [' ', ',', '.', ';', ':', #13, #10])

then begin

inc(contpal);

inc(contletras);

palabra := palabra+letra;

control := true

end

end

end

end;

if not eof(fichero) then

begin

read(fichero, letra);

write(letra)

end

end;

close(fichero);

close(ficsalida);

{Se cierran los dos ficheros, el de lectura y el de escritura.}

writeln;

writeln('Total: ',contpal,' palabras.');

writeln;

writeln(escritas,' palabras escritas en el archivo de salida.');

readkey

end.

7. Escribir un programa que cuente el número de palabras en un texto, que tengan al menos cuatro vocales diferentes. Se supone que las palabras no están cortadas al final de las líneas.

Program t9e7(Input, Output);

uses Crt;

Const vocales: Set of Char = (['A','E','I','O','U',' ',' ','¡','¢','£','£']);

separadores: Set of Char = ([' ', ',', '.', ';', ':', #13, #10,

'(',')','?','¨','­','!','"','-','+','[','''',']']);

Var fichero: Text;

vocenpal: Set of Char;

letra: Char;

contador, index, contletras, contpal, pal4voc, numvoc: integer;

palabra, archivo: String;

control: boolean;

Begin

ClrScr;

contador := 0;

{Contar  el nº de veces que se intente abrir un archivo de texto.}

repeat

write('Nombre de archivo: ');

readln(archivo);

inc(contador);

if archivo = '' then archivo := 'c:\tp\bin\temas\tema9\t9e7dat.txt';

{Si el usuario no introduce el nombre, se aplica uno por defecto. }

assign(fichero, archivo);

{Se asigna el nombre del archivo a la variable fichero de texto.}

{$I-}

reset(fichero);

{Antes de intentar abrir el archivo, se desactiva el control de errores

mediante la directiva del compilador $I- que ha de ir entre llaves.

Después se intenta abrir el archivo, y se vuelve a activar el control.}

{$I+}

control := (ioresult = 0);

if not control then writeln('Error en apertura de fichero.!!');

{Si se produjo un error en la apertura del archivo porque el archivo

no existe o cualquier otra causa, la variable "ioresult" contendrá un

valor distinto de cero, y si no se produjo ningún error y el archivo

pudo ser abierto, contendrá  el valor cero. }

writeln

until control or (contador >= 3);

if (contador >= 3) and not(control) then Halt(1);

{Si no se pudo abrir el archivo, parar la ejecución del programa.}

palabra := '';

control := false;

contpal := 0;

contletras := 0;

pal4voc := 0;

while not eof(fichero) do

begin

while not eoln(fichero) do

begin

read(fichero, letra);

if not(letra in separadores)

{Si el carácter leído no es un signo:}

then begin

if not control then inc(contpal);

control := true;

inc(contletras);

palabra := palabra + letra

end

else begin

control := false;

write('Palabra (',contpal,'): ',palabra);

numvoc := 0;

vocenpal := vocales;

{El conjunto vocenpal contiene ahora las 5 vocales}

for index := 1 to contletras do

{Hay que comprobar si la palabra contiene al menos

cuatro vocales distintas, para ello se recorren todos

los caracteres que componen la palabra.}

if (upcase(palabra[index]) in vocenpal)

{Si el carácter de la palabra est  en el conjunto,}

then begin

inc(numvoc);

{Se incrementa el contador de vocales,}

vocenpal := vocenpal - [upcase(palabra[index])]

{Se elimina la vocal del conjunto.}

end;

if numvoc >= 4

{Si se han contado al menos 4 vocales,}

then begin

inc(pal4voc);

{Se incrementa el contador de palabras con 4 vocales}

writeln(' ....... **** Palabra con 4 vocales ****')

end

else writeln;

palabra := '';

contletras := 0;

if (contpal mod 24) = 0 then readkey; {Pausa}

while ((letra in separadores)

or eoln(fichero)) and not(eof(fichero)) do

begin

read(fichero,letra);

if not(letra in separadores)

then begin

inc(contpal);

inc(contletras);

palabra := palabra+letra;

control := true

end

end

end

end;

if not eof(fichero) then

begin

read(fichero,letra);

write(letra)

end

end;

close(fichero);

{Se cierra el fichero.}

writeln;

writeln('Total: ',contpal,' palabras.');

writeln;

writeln('Palabras con al menos 4 vocales distintas: ',pal4voc,' palabras.');

readkey

end.

9. Se dispone de dos archivos de enteros, cada uno en una línea. Se desea sumar los valores de los números que ocupan la misma línea y llenar con ellos un archivo. Los archivos pueden tener longitudes distintas.

Program t9e9(Input, Output);

Uses Crt;

Type intfic = file of integer;

Var fic1, fic2, outfic: intfic;

int1, int2, suma, contador: integer;

Extension: String;

Begin

ClrScr;

writeln('Se trata de crear un archivo de números enteros ');

writeln('que son la suma de los que hay en otros dos archivos:');

writeln('Los números se suman por filas, y si los dos archivos');

writeln('no contienen el mismo número de filas, cuando se acabe');

writeln('el contenido de uno, se escribirá sólo lo que quede de el otro.');

writeln;

writeln('Pulsa una tecla para continuar ...');

readkey;

ClrScr;

extension := '\tp\bin\temas\tema9\';

assign(fic1, extension + 't9e9dat1.txt');

assign(fic2, extension + 't9e9dat2.txt');

assign(outfic, extension + 't9e9out.txt');

rewrite(fic1);

rewrite(fic2);

for contador := 1 to 15 do write(fic1,contador);

for contador := 20 to 30 do write(fic2,contador);

reset(fic1);

reset(fic2);

rewrite(outfic);

contador := 0;

{Cuenta la línea de archivo leída.}

while not(eof(fic1)) and not(eof(fic2)) do

{Mientras que no se llegue al final en alguno de los dos archivos:}

begin

inc(contador);

read(fic1,int1);

read(fic2,int2);

suma := int1+int2;

writeln('Línea ',contador:3,': ',int1:3,' + ',int2:3,' = ',suma:4);

write(outfic,suma)

end;

{Si uno de los archivos aun no ha llegado al final, hay que añadir

al archivo de salida los números que queden en el.}

if eof(fic1) then

begin

while not(eof(fic2)) do

begin

inc(contador);

read(fic2,int2);

writeln('Añadiendo de fichero 2 línea ',contador,': ',int2);

write(outfic,int2)

end

end

else while not(eof(fic1)) do

begin

inc(contador);

read(fic1,int1);

writeln('Añadiendo de fichero 1 línea ',contador,': ',int1);

write(outfic,int1)

end;

writeln;

writeln('Ficheros procesados.');

close(fic1);

close(fic2);

close(outfic);

readkey

end.

11. Se dispone de tres ficheros de alumnos, uno para cada grupo I1, I2, I3. Se quiere obtener un nuevo fichero con los alumnos no presentados en la convocatoria. Un alumno no presentado tiene como nota final un 0.

Program t9e11(Input, Output);

Uses Crt;

Const ficI1 = 'I1.dat';

ficI2 = 'I2.dat';

ficI3 = 'I3.dat';

Type alumno = record

nombre: String[25];

nota_exam, nota_final: real

end;

ficalumnos = file of alumno;

Var I1, I2, I3, NoPres: ficalumnos;

ficha: alumno;

Datosnuevos: Char;

Procedure llenarfic(archivo: String);

{Crea un archivo con los datos de los alumnos de un grupo.}

var fic: file of alumno;

ficha: alumno;

fin: boolean;

entrada: Char;

begin

writeln('Llenando archivo .... ',archivo);

assign(fic,archivo);

rewrite(fic);

repeat

with ficha do

begin

writeln;

writeln('*** Alumno Nuevo ***');

write('Nombre: ');

readln(nombre);

write('Nota de examen: ');

read(nota_exam);

write(' Nota final: ');

readln(nota_final)

end;

writeln;

write('¨Introducir otro alumno? [S/N]: ');

repeat

entrada := upcase(readkey)

until entrada in ['S','N'];

writeln(entrada);

fin := (entrada = 'N');

write(fic,ficha)

{Escribir el registro en el archivo.}

until fin;

close(fic)

end;

Procedure AddNoP(var fic, NoP: ficalumnos);

{Añade los alumnos de un grupo que sean no presentados

al archivo de no presentados.}

var ficha: Alumno;

begin

while not(eof(fic)) do

{mientras que no se llegue al final del fichero de alumnos del grupo:}

begin

read(fic,ficha);

{Lee los datos de un alumno, y los almacena en el registro "ficha"}

with ficha do

{Presenta por pantalla los datos del alumno.}

begin

write('Alumno: ',nombre);

write(' --- Nota final: ',nota_final:5:2)

end;

if ficha.nota_final = 0 then

{Si la nota final es cero, se considera como no presentado.}

begin

writeln(' *** NO PRESENTADO ***');

write(NoP,ficha)

end

else writeln

end;

writeln;

end;

Begin

ClrScr;

write('¨ Crear los archivos de los grupos ? [S/N]: ');

repeat

datosnuevos := upcase(readkey)

until datosnuevos in ['S','N'];

ClrScr;

if datosnuevos = 'S' then

begin

llenarfic(ficI1);

llenarfic(ficI2);

llenarfic(ficI3)

end;

assign(I1,ficI1);

assign(I2,ficI2);

assign(I3,ficI3);

reset(I1);

reset(I2);

reset(I3);

Assign(Nopres,'No_pres.dat');

rewrite(Nopres);

{Se abre para escritura el archivo de no presentados.}

writeln('Grupo I1:');

AddNoP(I1,Nopres);

writeln('Grupo I2:');

AddNoP(I2,Nopres);

writeln('Grupo I3:');

AddNoP(I3,Nopres);

close(I1);

close(I2);

close(I3);

{Se cierran los archivos de los grupos.}

reset(Nopres);

{Se abre para lectura el archivo de no presentados.}

writeln;

writeln('*** ALUMNOS NO PRESENTADOS ***');

while not(eof(Nopres)) do

begin

read(Nopres,ficha);

writeln(' -> ',ficha.nombre)

end;

close(Nopres);

{Se cierra el archivo de no presentados.}

readkey

end.

Ejercicios tema 10

2. Crear una lista enlazada con los datos de los alumnos de una clase. Los datos son: nombre, nota parcial, nota final, nota de trabajos y un campo booleano que indique si está suspendido o aprobado. Los datos los introduce el usuario. No se sabe el número de alumnos de la clase. Cada vez que el usuario introduzca los datos de un alumno el programa preguntará si quiere seguir introduciendo datos. Considerar primero que cada nuevo alumno que se inserta es el primero de la lista y después que es el ultimo de la lista. Al finalizar la inserción de datos, recorrer la lista mostrando el orden en el que han quedado los alumnos.

Program t10e2(Input, Output);

Uses Crt;

Type alumno = record

nombre: String[34];

parcial, final, trabajos: real;

apto: boolean

end;

Pnodo = ^nodo;

nodo = record

info: alumno;

enlace: Pnodo

{Listas simplemente enlazadas.}

end;

Var cabeza1, cabeza2, cola2: Pnodo;

Procedure iniciar1(var lista: Pnodo);

{Inicializa una lista poniendo a NIL su puntero cabeza.}

begin

lista := nil

end;

Procedure iniciar2(var lista,cola: Pnodo);

{Inicializa una lista poniendo a NIL sus punteros cabeza y cola.}

begin

lista := nil;

cola := nil

end;

Procedure introdatos;

{Lee los datos de los alumnos desde el teclado y los enlaza

en una lista}

var ficha: alumno;

nombrefic: String;

fic: file of alumno;

puntaux: Pnodo;

desdearchivo, terminar, correcto: boolean;

entrada: Char;

redondeo: integer;

notamedia: real;

Function si_no(pregunta: String): Char;

{Devuelve un carácter, que es la respuesta a una pregunta

del tipo SI - NO. Se le pasa como par metro un String que

contenga la pregunta a realizar al usuario.}

var oSioNo: Char;

begin

pregunta := pregunta + ' [S/N]: ';

{Se añade a la pregunta, las respuestas posibles, para

que el usuario las vea en pantalla.}

write(pregunta);

repeat

osiono := upcase(readkey)

until osiono in ['S','N'];

{La respuesta del usuario podrá  ser sólo S o N.}

writeln(osiono);

si_no := oSioNo

end;

Function creanodo(nuevaficha: alumno): Pnodo;

{A partir de un registro de tipo alumno, crea una variable

din mica de tipo nodo.}

var aux: Pnodo;

begin

new(aux);

{Se reserva memoria din mica para un nodo.}

aux^.info := nuevaficha;

{Se inicializa el campo info del nodo con el registro de

los datos del alumno.}

aux^.enlace := nil;

{Se inicializa el enlace del nodo a NIL}

creanodo := aux

end;

Procedure inscabeza(var lista: Pnodo; nuevo: Pnodo);

{Inserta un nodo en la cabeza de una lista.}

var aux: Pnodo;

begin

if lista = nil then lista := nuevo

{Si la lista estaba vacía, se asigna al puntero cabeza

para que apunte al nuevo nodo. No hace falta modificar el nodo

porque su campo enlace ya apunta a NIL.}

else begin

{La lista no estaba vacía.}

aux := lista;

{Se guarda en un puntero auxiliar la dirección del

primer nodo de la lista, que es el que apunta la cabeza.}

lista := nuevo;

{Se hace que la cabeza de la lista sea el nuevo nodo.}

nuevo^.enlace := aux

{Se hace que el puntero enlace del nodo insertado, apunte

al nodo que antes era la cabeza de la lista. De esta manera

la lista vuelve a quedar enlazada.}

end

end;

Procedure inscola(var lista, coladelista: Pnodo; nuevo: Pnodo);

{Inserta un nodo en el final de una lista.}

var aux: Pnodo;

begin

if lista = nil

{Si la lista estaba vacía:}

then begin

lista := nuevo;

coladelista := nuevo

{Se asigna tanto al puntero cabeza como al de cola, para

que apunten al nuevo nodo, ya que como es el único nodo en

la lista, es a la vez cabeza y cola de la lista.}

end

else begin

{La lista no estaba vacía, entonces:}

aux := coladelista;

{Se almacena en un puntero auxiliar, a donde apunta el

puntero de cola de la lista.}

coladelista := nuevo;

{Se asigna al puntero de cola, para que apunte al nuevo nodo.}

aux^.enlace := nuevo

{Se hace que el puntero enlace del nodo que antes era

la cola de la lista, apunte al nodo que se inserta, de esta

forma la lista vuelve a estar enlazada.}

end

end;

Procedure leerteclado;

{Si no se leen los datos desde un archivo, hay que leerlos

desde el teclado, y guardarlos en un archivo para que pueda

accederse a ellos posteriormente.}

begin

writeln('****** Nuevo alumno ******');

writeln;

repeat

with ficha do

begin

write('Nombre: ');

readln(nombre);

if nombre <> '' then

begin

write('Examen parcial (20%): ');

readln(parcial);

write('Examen final (60%): ');

readln(final);

write('Trabajos (20%): ');

readln(trabajos);

notamedia := (20*parcial+60*final+20*trabajos)/100;

{Se calcula la nota media según los pesos de cada nota.}

redondeo := round(notamedia);

{Se redondea la nota media.}

apto := redondeo >= 5;

{Se considera apto al alumno que como mínimo saque un 5.}

writeln('Nota media obtenida: ',notamedia:5:2);

write('Nota después del redondeo: ',redondeo);

if apto then writeln(' APROBADO')

else writeln(' SUSPENSO')

end

end;

entrada := si_no('¨Los datos son correctos?');

{Llamada a la función si_no, que devolverá la respuesta.}

correcto := (entrada = 'S');

writeln

until correcto;

write(fic,ficha);

{Se escribe la ficha en el archivo.}

writeln

end;

begin

terminar := false;

Entrada := si_no('¨Introducir datos desde archivo?');

desdearchivo := (entrada = 'S');

if desdearchivo

then write('Nombre del archivo de datos:')

else write('Escribir los datos en el archivo:');

readln(nombrefic);

if nombrefic = '' then nombrefic := 't10e2.dat';

writeln('Introduciendo datos de alumnos ...');

writeln;

assign(fic,nombrefic);

if desdearchivo

then begin

{$I-}

reset(fic);

{$I+}

if ioresult <> 0 then

begin

writeln('Error en la apertura del archivo ',nombrefic);

halt(1)

end

end

else rewrite(fic);

repeat

if not(desdearchivo) then Leerteclado

else begin

if not(eof(fic))

then read(fic,ficha)

else terminar := TRUE

end;

if not(terminar) then

begin

if ficha.nombre <> '' then

begin

puntaux := creanodo(ficha);

{El puntero auxiliar "puntaux", apunta ahora al nuevo nodo

creado por la función "creanodo" con los datos introducidos

por el usuario desde el teclado, que se guardan en "ficha".}

inscabeza(cabeza1,puntaux);

{Se inserta el nodo en cabeza de la lista 1 ("cabeza1" apunta

al nodo cabeza de la lista 1)}

puntaux := creanodo(ficha);

{Se crea otro nodo con los mismos datos, para insertarlo en

la cola de la segunda lista.}

inscola(cabeza2,cola2,puntaux)

{Se inserta el nodo en la cola de la lista 2. }

end

end;

if not(desdearchivo) then

begin

entrada := si_no('¨Introducir m s alumnos?');

writeln;

terminar := (entrada = 'N')

end

until terminar;

close(fic)

end;

Procedure Verlistas(lis1, lis2: Pnodo);

{Visualiza por pantalla las dos listas, mostrando cómo el orden

en que quedan las fichas de los alumnos insertando en la cabeza

de la lista, es al revés de como quedan insertando en la cola.

Los par metros "lis1" y "lis2" son los punteros cabeza de las listas.}

var orden: integer;

begin

ClrScr;

if lis1 = nil then writeln('No hay ningún alumno en la lista.')

{Si la lista 1 est  vacía, la otra también.

Como las dos listas tienen el mismo número de nodos, no es necesario

controlar m s que una de ellas.}

else begin

{Si las listas no est n vacías, entonces:}

write('INSERTANDO EN CABEZA':27);

writeln('INSERTANDO EN COLA':34);

for orden := 1 to 79 do write('Í');

writeln;

orden := 0;

while (lis1 <> nil) do

{Mientras que el puntero "lis1" no apunte a NIL, cosa que ocurrir 

cuando se alcance el último nodo de la lista.}

begin

inc(orden);

write(orden:3,' ');

write(lis1^.info.nombre,' ':36-length(lis1^.info.nombre));

{Escribir en pantalla el campo nombre del registro info

del nodo al que apunta el puntero "lis1".}

lis1 := lis1^.enlace;

{Asignar al puntero para que apunte al siguiente nodo

de la lista. Si el enlace del actual nodo al que apunta

"lis1", est  apuntando a NIL, entonces se ha llegado al

final de la lista 1.}

writeln(lis2^.info.nombre);

lis2 := lis2^.enlace

{Se sigue el mismo proceso que con la lista 1.}

end;

writeln;

writeln('Total: ',orden,' alumnos en las listas.');

readkey

end

end;

Procedure resetMem;

{Libera la memoria din mica reservada para los nodos de las listas.}

var aux: Pnodo;

cont: integer;

begin

ClrScr;

cont := 0;

while cabeza1 <> nil do

{Las dos listas tienen el mismo número de nodos, por lo que sólo es

necesario controlar el final de lista en una de ellas.

Mientras que el puntero cabeza sea distinto de NIL:}

begin

inc(cont);

writeln('Liberando nodo n§ ',cont);

aux := cabeza1;

{El puntero cabeza est  apuntando a un nodo. Se hace que el

puntero auxiliar "aux" apunte al mismo nodo, para que éste

no quede perdido cuando se avance en la lista.}

cabeza1 := cabeza1^.enlace;

{Se asigna al puntero cabeza el siguiente nodo de la lista.

El que antes era el nodo cabecera de la lista, no se ha

perdido, porque queda apuntado por el puntero auxiliar "aux".}

dispose(aux);

{Se libera la memoria reservada para el nodo al que apunta "aux"}

aux := cabeza2;

{Se repite el mismo proceso para la segunda lista.}

cabeza2 := cabeza2^.enlace;

dispose(aux)

end

end;

Begin

ClrScr;

iniciar1(cabeza1);

{En la lista 1 se va a insertar en la cabeza de la lista, por lo que no

hace falta inicializar la cola de la lista.}

iniciar2(cabeza2,cola2);

{Para insertar en cola, es aconsejable contar con un puntero que apunte

al último nodo de la lista, por ello se inicializan dos punteros para

la segunda lista: Uno de cabeza y otro de cola.}

introdatos;

{Introducir datos de los alumnos desde teclado.}

verlistas(cabeza1,cabeza2);

{Ver cómo han quedado las listas utilizando distinto tipo de inserción

en cada una de ellas.}

resetMem;

{Liberar la memoria din mica reservada.}

writeln;

writeln('That`s All Folks ...');

readkey

end.

4. Dada una lista de alumnos de una clase, doblemente enlazada, ordenada alfabéticamente, mostrar la lista en orden inverso. Cabeza es un puntero al primer elemento de la lista y cola un puntero al ultimo. La lista está declarada como se indica a continuación:

TYPE puntero = ^nodo;

nodo = record

nombre : String;

parcial, final, trabajos : real;

aprobado : booleano;

prox, ant : puntero

end;

VAR cabeza, cola : puntero;

Program t10e4(Input, Output);

Uses Crt;

Type alumno = record

nombre: String[34];

parcial, final, trabajos: real;

apto: boolean

end;

Pnodo = ^nodo;

nodo = record

info: alumno;

prox, ant: Pnodo

{Lista doblemente enlazada.}

end;

Var cabeza, cola: Pnodo;

Procedure iniciar(var lista, cola: Pnodo);

{Inicializa a nil los punteros de cabeza y de cola de una lista.}

begin

lista := nil;

cola := nil

end;

Procedure crealista;

{Crea una lista doblemente enlazada a partir de los datos

guardados en un archivo. La lista ser  doblemente enlazada

para poder recorrerla en sentido inverso: Cada nodo tendrá 

un puntero enlace hacia el nodo anterior en la lista.}

var ficha: alumno;

nombrefic: String;

fic: file of alumno;

puntaux: Pnodo;

terminar: boolean;

Function creanodo(nuevaficha: alumno): Pnodo;

{Reserva memoria din mica para un nodo, inicializa su campo de

información con los datos del nuevo alumno y devuelve un puntero

apuntando al nodo.}

var aux: Pnodo;

begin

new(aux);

{Reserva la memoria, y hace que el puntero apunte a la variable

din mica (nodo de la lista).}

aux^.info := nuevaficha;

{Inicializa el campo de información con los datos.}

aux^.prox := nil;

aux^.ant := nil;

{Inicializa a NIL los punteros de enlace del nodo con el nodo

siguiente y con el nodo anterior.}

creanodo := aux

end;

Procedure inscola(var lista, coladelista: Pnodo; nuevo: Pnodo);

{Inserta un nodo en la cola de una lista doblemente enlazada.}

var aux: Pnodo;

begin

if lista = nil then

{Si la lista est  vacía, }

begin

lista := nuevo;

coladelista := nuevo

{Hace que los punteros de cabeza y cola de la lista apunten

al nuevo nodo.}

end

else begin

{Si la lista no estaba vacía:}

aux := coladelista;

{El puntero auxiliar apunta ahora hacia el último nodo de

la lista, para no perder la referencia de este nodo.}

nuevo^.ant := aux;

{Se inicializa el enlace del nodo que se va a insertar hacia

el nodo anterior en la lista, que es el que antes era la cola.}

coladelista := nuevo;

{La cola de la lista es ahora el nodo insertado, y se hace

que el puntero de cola apunte a este nodo.}

aux^.prox := nuevo

{El enlace del que antes era el último nodo de la lista,

hacia el próximo nodo, se hace que apunte hacia el nodo

insertado, que es ahora el último, quedando as¡ la lista

de nuevo enlazada.}

end

end;

begin

terminar := false;

nombrefic := 't10e2.dat';

{Se utiliza el mismo archivo que para el ejercicio 2}

assign(fic,nombrefic);

reset(fic);

while not(eof(fic)) do

{Mientras que no se alcance el final de fichero:}

begin

read(fic,ficha);

{Se lee un registro del archivo.}

writeln('Leyendo ... ',ficha.nombre);

puntaux := creanodo(ficha);

{Puntaux apunta ahora al nodo creado por la función creanodo

con los datos del registro leído del archivo.}

inscola(cabeza,cola,puntaux)

{Se inserta el nodo en la lista.}

end;

close(fic);

{Se cierra el fichero.}

writeln;

writeln('Finalizada lectura de archivo ',nombrefic);

writeln;

writeln('Pulsa una tecla para continuar ...');

readkey

end;

Procedure Veralreves(findelista: Pnodo);

{Visualiza una lista en orden inverso. Hay que pasarle como

par metro el puntero que apunta al final de la lista.}

begin

ClrScr;

if findelista = nil then writeln('No hay ningún alumno en la lista.')

else begin

{Si la lista no est  vacía:}

writeln('La lista visualizada al revés:');

writeln;

while (findelista <> nil) do

{Mientras que el puntero que recorre la lista no apunte a NIL:}

begin

writeln(' ':6,findelista^.info.nombre);

{Escribir el nombre del alumno que almacena el nodo.}

findelista := findelista^.ant

{Hacer que el puntero que recorre la lista apunte al nodo

anterior, que est  apuntado por el enlace del nodo hacia

el nodo anterior en la lista. Si el nodo al que apuntaba

era ya el primero de la lista, su enlace al anterior

apuntar  a NIL, y el recorrido de la lista habrá  terminado.}

end;

writeln;

writeln('Pulsa una tecla para terminar ...');

readkey

end

end;

Procedure resetMem;

{Libera la memoria din mica reservada para los nodos de la lista.}

var aux: Pnodo;

cont: integer;

begin

ClrScr;

cont := 0;

writeln('Liberando la memoria din mica:');

while cabeza <> nil do

begin

inc(cont);

writeln('Eliminando nodo n§ ',cont);

aux := cabeza;

cabeza := cabeza^.prox;

dispose(aux)

end

end;

Begin

ClrScr;

iniciar(cabeza,cola);

{Inicializar los punteros de cabeza y cola de la lista.}

crealista;

{Leer los datos del archivo y crear la lista enlazada.}

veralreves(cola);

{Visualizar la lista en orden inverso, desde la cola hasta la cabeza.}

resetMem;

{Liberar la memoria reservada.}

writeln;

writeln('That`s All Folks ...');

readkey

end.

5. Dada la misma lista de alumnos, crear una nueva lista en orden inverso, pero esta vez simplemente enlazada.

Program t10e5(Input, Output);

Uses Crt;

Type alumno = record

nombre: String[34];

parcial, final, trabajos: real;

apto: boolean

end;

Pnodo = ^nodo;

nodo = record

info: alumno;

prox, ant: Pnodo

end;

Var cabeza, cola: Pnodo;

Procedure iniciar(var lista, cola: Pnodo);

begin

lista := nil;

cola := nil

end;

Procedure crealista;

var ficha: alumno;

nombrefic: String;

fic: file of alumno;

puntaux: Pnodo;

terminar: boolean;

Function creanodo(nuevaficha: alumno): Pnodo;

var aux: Pnodo;

begin

new(aux);

aux^.info := nuevaficha;

aux^.prox := nil;

aux^.ant := nil;

creanodo := aux

end;

Procedure inscola(var lista, coladelista: Pnodo; nuevo: Pnodo);

var aux: Pnodo;

begin

if lista = nil then

begin

lista := nuevo;

coladelista := nuevo

end

else begin

aux := coladelista;

nuevo^.ant := aux;

coladelista := nuevo;

aux^.prox := nuevo

end

end;

begin

terminar := false;

nombrefic := 't10e2.dat';

assign(fic,nombrefic);

reset(fic);

while not(eof(fic)) do

begin

read(fic,ficha);

writeln('Leyendo ... ',ficha.nombre);

puntaux := creanodo(ficha);

inscola(cabeza,cola,puntaux)

end;

readkey;

close(fic)

end;

PROCEDURE hazlistasimple(lis1: Pnodo);

{Crea una lista simplemente enlazada a partir de la lista

doblemente enlazada del ejercicio 4}

Type

Puntero = ^nodosimple;

nodosimple = record

info: alumno;

enlace: Puntero

{Lista simplemente enlazada.}

end;

var listasimple, colasimple, punteroaux: puntero;

Procedure inisimple(var lista: Puntero);

begin

lista := nil

end;

Function haznodosimple(nuevaficha: alumno): Puntero;

{Crea un nodo para lista simplemente enlazada.}

var aux: Puntero;

begin

new(aux);

aux^.info := nuevaficha;

aux^.enlace := nil;

haznodosimple := aux

end;

Procedure insnodo(var lista, cola: Puntero; nuevo: Puntero);

{Inserta un nodo en la cola de una lista simplemente enlazada.}

var aux: Puntero;

begin

if lista = nil then

begin

lista := nuevo;

cola := nuevo

end

else begin

aux := cola;

cola := nuevo;

aux^.enlace := nuevo

end

end;

Procedure SimpleResetMem;

{Libera la memoria din mica reservada para los nodos de

una lista simplemente enlazada.}

var aux: Puntero;

cont: integer;

begin

ClrScr;

cont := 0;

writeln('Liberando la memoria din mica (lista simple):');

while listasimple <> nil do

begin

inc(cont);

writeln('Eliminando nodo n§ ',cont);

aux := listasimple;

listasimple := listasimple^.enlace;

dispose(aux)

end

end;

begin

ClrScr;

inisimple(listasimple);

{Inicializar el puntero de cabeza de la lista.}

if lis1 = nil then writeln('No hay ningún alumno en la lista.')

else begin

{Si la lista doblemente enlazada, a partir de la cual se va

a construir la lista simplemente enlazada, no est  vacía:}

writeln('Fabricando la nueva lista:');

writeln;

while (lis1 <> nil) do

{Mientras que no se alcance el final de la lista doble:}

begin

punteroaux := haznodosimple(lis1^.info);

{Se crea el nodo de lista simple, y se apunta por el

puntero auxiliar "punteroaux".}

insnodo(listasimple, colasimple, punteroaux);

{Se inserta e nodo en la cola de la lista.}

lis1 := lis1^.ant

{La lista doblemente enlazada se recorre en orden inverso

de manera que la lista simple que se va creando queda

ya ordenada al revés que la doble.}

end;

punteroaux := listasimple;

{Se asigna al puntero auxiliar, la cabeza de la lista simple,

para que sirva de puntero de recorrido a través de la lista.}

writeln('As¡ queda la lista simple:');

writeln;

while punteroaux <> nil do

{Mientras que no se llegue al final de la lista simple:}

begin

writeln(' ':6,punteroaux^.info.nombre);

{Escribir el nombre del alumno.}

punteroaux := punteroaux^.enlace

{Recorrer la lista: "Punteroaux" va apuntando uno por uno

a todos los nodos de la lista, hasta llegar al último,

cuyo enlace apunta a NIL.}

end;

writeln;

writeln('Pulsa una tecla para continuar ...');

readkey

end;

SimpleResetMem;

{Liberar la memoria reservada para los nodos de la lista simple.}

writeln;

end;

Procedure resetMem;

{Libera la memoria reservada para los nodos de la lista doble.}

var aux: Pnodo;

cont: integer;

begin

cont := 0;

writeln('Liberando la memoria din mica:');

while cabeza <> nil do

begin

inc(cont);

writeln('Eliminando nodo n§ ',cont);

aux := cabeza;

cabeza := cabeza^.prox;

dispose(aux)

end

end;

Begin

ClrScr;

iniciar(cabeza,cola);

crealista;

{Crear la misma lista que la del ejercicio 4 (es doblemente enlazada).}

hazlistasimple(cola);

{Fabricar la lista simplemente enlazada a partir de la doble.}

resetMem;

{Liberar la memoria.}

writeln;

writeln('That`s All Folks ...');

readkey

end.

6. Dada una lista de libros, que contiene titulo, editorial, año de publicación. Mostrar todas las películas anteriores a un año determinado.

Program t10e6(Input, Output);

Uses Crt;

Type libro = record

titulo: String[35];

editorial: String[25];

ano: integer

end;

Pnodo = ^nodo;

nodo = record

info: libro;

enlace: Pnodo

{Lista simplemente enlazada.}

end;

Var cabeza: Pnodo;

Procedure iniciar(var lista: Pnodo);

begin

lista := nil

end;

Procedure introdatos;

var ficha: libro;

nombrefic: String;

fic: file of libro;

puntaux: Pnodo;

desdearchivo, terminar, correcto: boolean;

entrada: Char;

Function si_no(pregunta: String): Char;

var oSioNo: Char;

begin

pregunta := pregunta + ' [S/N]: ';

write(pregunta);

repeat

osiono := upcase(readkey)

until osiono in ['S','N'];

writeln(osiono);

si_no := oSioNo

end;

Function creanodo(nuevaficha: libro): Pnodo;

var aux: Pnodo;

begin

new(aux);

aux^.info := nuevaficha;

aux^.enlace := nil;

creanodo := aux

end;

Procedure inscabeza(var lista: Pnodo; nuevo: Pnodo);

var aux: Pnodo;

begin

if lista = nil then lista := nuevo

else begin

aux := lista;

lista := nuevo;

nuevo^.enlace := aux

end

end;

Procedure leerteclado;

begin

writeln;

writeln(' ****** Nuevo libro ******');

writeln;

repeat

with ficha do

begin

write('Título: ');

readln(titulo);

write('editorial: ');

readln(editorial);

write('Año de publicación: ');

readln(ano);

end;

entrada := si_no('¨Los datos son correctos?');

correcto := (entrada = 'S');

writeln;

until correcto;

write(fic,ficha);

writeln

end;

begin

terminar := false;

Entrada := si_no('¨Introducir datos desde archivo?');

desdearchivo := (entrada = 'S');

if desdearchivo

then write('Nombre del archivo de datos:')

else write('Escribir los datos en el archivo:');

readln(nombrefic);

if nombrefic = '' then nombrefic := 't10e6.dat';

writeln('Introduciendo datos de publicaciones ...');

writeln;

assign(fic,nombrefic);

if desdearchivo

then reset(fic)

else rewrite(fic);

repeat

if not(desdearchivo) then Leerteclado

else begin

if not(eof(fic))

then read(fic,ficha)

else terminar := TRUE

end; if not(terminar) then

begin

puntaux := creanodo(ficha);

inscabeza(cabeza,puntaux)

end;

if not(desdearchivo) then

begin

entrada := si_no('¨Introducir m s libros?');

writeln;

terminar := (entrada = 'N')

end

until terminar;

close(fic)

end;

Procedure buscaren(lis1: Pnodo);

{Muestra por pantalla los libros de la lista cuya fecha de publicación

sea anterior a una determinada fecha.}

var cont, fecha: integer;

begin

ClrScr;

if lis1 = nil then writeln('No hay ningún libro en la lista.')

else begin

{Si la lista no est  vacía:}

write('Mostrar todos los libros anteriores al año: ');

readln(fecha);

writeln('T¡tulo','Editorial':41,'A¤o pub.':27);

for cont := 1 to 75 do write('Í');

writeln;

while (lis1 <> nil) do

{Mientras que no se llegue al final de la lista:}

begin

if lis1^.info.ano <= fecha then

{Si el año de publicación es inferior a la fecha introducida:}

begin

write(lis1^.info.titulo,' ':38-length(lis1^.info.titulo));

write(lis1^.info.editorial,' ':30-length(lis1^.info.editorial));

writeln(lis1^.info.ano:6)

{Escribir todos los datos referentes al libro, que est n

almacenados en el campo información del nodo.}

end;

lis1 := lis1^.enlace

{Apuntar con el puntero de recorrido al siguiente nodo de la lista.}

end;

writeln;

writeln('Pulsa una tecla para terminar ...');

readkey

end

end;

Procedure resetMem;

{Liberar la memoria reservada.}

var aux: Pnodo;

cont: integer;

begin

ClrScr;

cont := 0;

writeln('Liberando la memoria din mica:');

while cabeza <> nil do

begin

inc(cont);

writeln('Nodo n§ ',cont);

aux := cabeza;

cabeza := cabeza^.enlace;

dispose(aux)

end

end;

Begin

ClrScr;

iniciar(cabeza);

introdatos;

{Fabricar la lista}

Buscaren(cabeza);

{Mostrar los libros anteriores a la fecha que el usuario introduzca.}

resetMem;

{Liberar la memoria.}

writeln;

writeln('That`s All Folks ...');

readkey

end.

8. Escribir un programa que cree una lista enlazada de número enteros ordenados de forma creciente. Los números los va introduciendo el usuario. Cuando introduzca el 0 significa que ha finalizado la introducción de datos. Visualizar el contenido de la lista.

Program t10e8(Input, Output);

Uses Crt;

Type Pnodo = ^nodo;

nodo = record

info: integer;

prox, ant: Pnodo

{Lista doblemente enlazada.}

end;

Var cabeza, cola, encontrado, nuevo: Pnodo;

numero: integer;

terminar: boolean;

Procedure iniciar(var lista, coladelista: Pnodo);

begin

lista := nil;

coladelista := nil

end;

Function creanodo(nuevonumero: integer): Pnodo;

var aux: Pnodo;

begin

new(aux);

aux^.info := nuevonumero;

aux^.prox := nil;

aux^.ant := nil;

creanodo := aux

end;

Procedure insantes(insertpoint, nuevonodo: Pnodo);

{Inserta un nodo en la posición anterior al nodo al que apunte

el puntero "insertpoint".}

var aux: Pnodo;

begin

aux := insertpoint^.ant;

{Se guarda en el puntero auxiliar el enlace hacia el nodo anterior

al que se va a insertar.}

if aux <> nil then aux^.prox := nuevonodo;

{Si la posición en la que se va a insertar no es la cabeza de

la lista, se hace que el enlace hacia el siguiente del nodo anterior

apunte hacia el nodo a insertar }

if insertpoint^.ant = nil then cabeza := nuevonodo;

{Si el enlace del nodo donde se va a insertar hacia el anterior, est 

apuntando a NIL, significa que se va a insertar en la cabeza de la

lista, por lo que hay que modificar el puntero de cabeza de lista

para que apunte al nodo que se va a insertar.

"cabeza" es la variable global.}

nuevonodo^.ant := insertpoint^.ant;

{El enlace hacia el anterior del nodo a insertar debe apuntar a donde

apuntaba el del nodo donde se inserta.}

nuevonodo^.prox := insertpoint;

{El enlace hacia el siguiente del nodo a insertar debe apuntar hacia

el nodo en donde se va a insertar.}

insertpoint^.ant := nuevonodo

{Por último el enlace del nodo donde se va a insertar hacia el

anterior, debe apuntar hacia el nodo que se inserta.}

end;

Procedure insencola(nuevonodo: Pnodo);

{Insertar en la cola de la lista.}

var aux: Pnodo;

begin

aux := cola;

{Se guarda el puntero hacia el nodo que actualmente el

último de la lista.}

cola := nuevonodo;

{El puntero de cola de la lista debe apuntar al nodo que

se inserta. "cola" es la variable global.}

nuevonodo^.ant := aux;

{El enlace hacia el anterior del nodo a insertar debe apuntar

al que antes era el nodo de cola de la lista, y que est  apuntado

por el puntero auxiliar.}

aux^.prox := nuevonodo

{Por último el que antes era el nodo de cola, debe enlazar al

nodo siguiente, que es el nodo que se inserta en la lista.}

end;

Function buscar(lis1: Pnodo; num: integer): Pnodo;

{Devuelve un puntero apuntando al primer nodo de la lista que

almacene un número mayor que el que se desee buscar.

Si no hay ningún número en la lista que sea mayor que el que

se desea buscar, devuelve NIL.}

var puntaux: Pnodo;

begin

puntaux := lis1;

{El puntero auxiliar, hará  de puntero de recorrido.}

if lis1 <> nil then

{Si la lista no est  vacía:}

while (puntaux^.info <= num) and (puntaux <> nil)

{Mientras que el número almacenado en el nodo sea menor o igual

que el que se busca, y no se acabe la lista:}

do puntaux := puntaux^.prox;

{Se salta al siguiente nodo de la lista.}

buscar := puntaux;

end;

Procedure verlista(lista: Pnodo);

{Visualiza la lista de números.}

begin

ClrScr;

if lista = nil

then writeln('No hay ningún número en la lista.')

else while lista <> nil do

{Si la lista no est  vacía, mientras que no se llegue al final:}

begin

writeln('Elemento de lista: ',lista^.info);

{Se escribe el número almacenado en el nodo.}

lista := lista^.prox

{Se salta al próximo nodo.}

end;

writeln;

writeln('Pulsa una tecla para continuar ...');

readkey

end;

Procedure resetMem(lista: Pnodo);

{Liberar la memoria reservada para la lista.}

var aux: Pnodo;

cont: integer;

begin

ClrScr;

cont := 0;

writeln('Liberando la memoria din mica:');

while lista <> nil do

begin

inc(cont);

writeln(' Nodo n§ ',cont);

aux := lista;

lista := lista^.prox;

dispose(aux)

end

end;

Begin

ClrScr;

iniciar(cabeza,cola);

repeat

write('Introducir número: ');

readln(numero);

{Se introduce un número:}

if numero <> 0 then

{Si el número es distinto de cero:}

begin

encontrado := Buscar(cabeza, numero);

{Se busca el número en la lista, y se guarda el resultado de la

búsqueda en el puntero "encontrado".}

nuevo := creanodo(numero);

{Se crea el nuevo nodo con el número introducido.}

if cabeza <> nil

{Si la lista no est  vacía:}

then begin

if encontrado = nil

{Si la búsqueda fue fallida:}

then insencola(nuevo)

{Entonces no hay en la lista ningún número mayor que

el que ha sido introducido, y habrá  que insertar el

nuevo nodo en la cola de la lista: El último.}

else insantes(encontrado, nuevo)

{Si la búsqueda no fue fallida, "encontrado" apuntar 

al nodo que almacena el primer número de la lista que

es mayor que el número introducido, y entonces para que

la lista est ordenada habrá  que insertar el nuevo

nodo justo antes que el nodo apuntado por "encontrado". }

end

else begin

{Si la lista estaba vacía, se inicializan cabeza y cola para que

apunten al nuevo nodo, porque no hay nada que ordenar.}

cabeza := nuevo;

cola := nuevo

end

end

else terminar := true

{Si el número introducido es el cero, se finaliza la introducción

de números.}

until terminar;

writeln;

writeln('Finalizó la introducción de números.');

writeln;

writeln('Pulsa una tecla para continuar ...');

readkey;

ClrScr;

verlista(cabeza);

{Se visualiza la lista de números para comprobar que est  ordenada.}

resetMem(cabeza);

{Se libera la memoria reservada para la lista.}

writeln;

writeln('That`s All Folks ...');

readkey

end.

10. Una lista contiene la información de los alumnos de una clase. Hacer un programa que presente un menú:

1. Nuevo alumno

2. Borrar alumno

3. Modificar alumno

Para cada alumno se mantiene la siguiente información: número, nombre y nota. Los alumnos en la lista están ordenados por número. Si se elige la opción 1 se piden los datos del alumno y se insertan en la posición adecuada. Si se borra un alumno se pide el número de alumno y se elimina de la lista. Modificar un alumno es cambiar el nombre de un número determinado.

Program t10e10(Input, Output);

Uses Crt;

Type alumno = record

numero: integer;

nombre: String[35];

nota: real

end;

Pnodo = ^Nodo;

Nodo = record

info: alumno;

prox, ant: Pnodo

{Lista doblemente enlazada.}

end;

Var cabeza, cola: Pnodo;

salir: boolean;

Procedure iniciarlista;

begin

cabeza := nil;

cola := nil

end;

Function si_no(pregunta: String): Char;

var oSioNo: Char;

begin

pregunta := pregunta + ' [S/N]: ';

write(pregunta);

repeat

osiono := upcase(readkey)

until osiono in ['S','N'];

writeln(osiono);

si_no := oSioNo

end;

Function menu: Char;

{Presenta por pantalla el menú con las opciones disponibles

y devuelve la opción seleccionada por el usuario.}

var opcion: Char;

begin

ClrScr;

writeln(' ***** M E N U *****');

writeln;

writeln(' 1. Nuevo alumno');

writeln(' 2. Borrar alumno');

writeln(' 3. Modificar alumno');

writeln(' 4. Listado de alumnos');

writeln;

writeln(' T. Terminar');

writeln;

write (' Selecciona opción: ');

repeat

opcion := upcase(readkey)

until opcion in ['1','2','3','4','T'];

writeln(opcion);

menu := opcion

end;

Procedure nuevo;

{Añade una ficha nueva a la lista de alumnos.}

var ficha: alumno;

puntaux, encontrado: Pnodo;

numlibre, correcto: boolean;

entrada: Char;

codigo: integer;

Function creanodo(nuevaficha: alumno): Pnodo;

var aux: Pnodo;

begin

new(aux);

aux^.info := nuevaficha;

aux^.prox := nil;

aux^.ant := nil;

creanodo := aux

end;

Procedure insantes(insertpoint, nuevonodo: Pnodo);

var aux: Pnodo;

begin

aux := insertpoint^.ant;

if aux <> nil then aux^.prox := nuevonodo;

if insertpoint^.ant = nil then cabeza := nuevonodo;

nuevonodo^.ant := insertpoint^.ant;

nuevonodo^.prox := insertpoint;

insertpoint^.ant := nuevonodo

end;

Procedure insencola(nuevonodo: Pnodo);

var aux: Pnodo;

begin

aux := cola;

cola := nuevonodo;

nuevonodo^.ant := aux;

aux^.prox := nuevonodo

end;

Function buscar (lis1:Pnodo;

num:integer;

var libre: boolean): Pnodo;

{Devuelve un puntero apuntando al primer número mayor que

el buscado en la lista, y de no haber ninguno mayor, apuntar 

a NIL. Ademá s devuelve en el par metro "libre" de tipo booleano

TRUE: si el número de alumno no est  siendo utilizado ya,

y FALSE si el número ya est  ocupado.}

var puntaux, AUX: Pnodo;

begin

puntaux := lis1;

if lis1 <> nil then

{Si la lista no est  vacía:}

begin

while (puntaux^.info.numero < num) and (puntaux <> nil)

do puntaux := puntaux^.prox

{Va saltando de nodo en nodo mientras que el número

buscado sea mayor que el almacenado en el nodo, o se

llegue al final de la lista.}

end;

if puntaux <> nil

{Si no se llegó al final de la lista:}

then begin

if puntaux^.ant <> nil

{Si el primer número que ya no es menor que el buscado

no es el primero de la lista:}

then begin

aux := puntaux^.ant;

{Se guarda un puntero apuntando al nodo anterior.}

if aux^.info.numero = num then libre := false

else libre := true

{Si este nodo (el anterior) contiene el número

buscado, se asigna FALSE a "libre", y si no

contiene al número (contendrá  uno menor) entonces

se asigna TRUE a "libre".}

end

else begin

{Si el primer número de la lista ya no es menor

que el buscado:}

if puntaux^.info.numero <> num then libre := true

{Si no es el número buscado (ser  mayor), entonces

el número buscado est  libre.}

end

end

else libre := true;

{Si la lista est  vacía, el número est  libre.}

buscar := puntaux

end;

begin

ClrScr;

writeln('****** Nuevo alumno ******');

writeln;

repeat

with ficha do

begin

write('Número de ficha: ');

readln(codigo);

{Se lee el número de alumno que se desea añadir.}

encontrado := buscar(cabeza, codigo, numlibre);

{Se busca el número en la lista.}

if numlibre then

{Si el número est  libre:}

begin

numero := codigo;

write('Nombre: ');

readln(nombre);

write('Nota: ');

readln(nota);

{Se leen los datos correspondientes al alumno.}

entrada := si_no('¨Los datos son correctos?');

correcto := (entrada = 'S')

end

else begin

{Si el número est  ocupado:}

writeln('­ El número ',codigo,' ya est  ocupado: !');

write('Utilice la OPCION 3 del MENU PRINCIPAL ');

writeln('si quiere modificar la ficha número ',codigo);

writeln;

entrada := si_no('¨Probar con otro número?');

correcto := (entrada = 'N')

end;

writeln

end

until correcto;

writeln;

if numlibre then

{Si el número estaba libre:}

begin

puntaux := creanodo(ficha);

{Se crea el nodo con los datos del alumno.}

if cabeza <> nil

{Si la lista no est  vacía:}

then begin

if encontrado = nil

{Si la función buscar devuelve NIL, significa que el

número que se desea introducir es el mayor de los que

hay ya en la lista:}

then insencola(puntaux)

{Entonces se inserta el nuevo nodo al final de la lista.}

else insantes(encontrado, puntaux)

{Si la función buscar no devuelve NIL, entonces se

inserta el nodo en la posición anterior al nodo

al que apunta el resultado de la búsqueda.}

end

else begin

{Si la lista estaba vacía:}

cabeza := puntaux;

cola := puntaux

{Se asignan los punteros de cabeza y cola de lista apuntando

al nuevo nodo, ya que el primero no hace falta ordenarlo.}

end

end

end;

Function buscar(lista: Pnodo; num: integer; var error: boolean): Pnodo;

{Devuelve un puntero al primer nodo de la lista que contenga

un número de alumno que no sea menor que el buscado. Si además este

nodo almacena el número buscado, entonces se devuelve en el

par metro por referencia el valor FALSE (no ha habido error),

y si el nodo almacena un número mayor que el buscado, devuelve

TRUE (si ha habido un error en la búsqueda). }

var puntaux, AUX: Pnodo;

begin

error := true;

puntaux := lista;

if lista <> nil

{Si la lista no est  vacía:}

then begin

while (puntaux^.info.numero < num) and (puntaux <> nil)

do puntaux := puntaux^.prox;

{Mientras que el nodo almacene un número menor que el

buscado, va saltando de nodo en nodo a través de la lista,

hasta que se llegue al final.}

if puntaux <> nil then

{Si no se llegó al final de la lista:}

if puntaux^.info.numero = num

then error := false

{Si el número almacenado en el nodo encontrado coincide

con el número buscado entonces no habrá  habido error.}

else error := true;

{Si por el contrario el número no coincide (ser  mayor que

el número buscado), habrá  habido un error en la búsqueda.}

end

else begin

{Si la lista est  vacía:}

writeln('No hay ninguna ficha en la lista.');

error := true

{Entonces est  claro que el número no est  en la lista

y habrá  ocurrido un error en la lista.}

end;

buscar := puntaux;

end;

Procedure borrar;

{Elimina un alumno de la lista.}

var codigo: integer;

seekerror: boolean;

encontrado: Pnodo;

Entrada: Char;

Procedure borrarnodo(punt: Pnodo);

{Elimina de la lista el nodo al que apunte el puntero par metro.}

var puntaux: Pnodo;

begin

write('Eliminando ... ');

if punt <> cabeza then

{Si el nodo a eliminar no es el de cabeza de la lista:}

begin

puntaux := punt^.ant;

puntaux^.prox := punt^.prox

{Hay que enlazar el nodo anterior con el posterior

al nodo a eliminar.}

end

else cabeza := punt^.prox;

{Si el nodo a eliminar es el nodo cabeza, el puntero cabeza

debe apuntar al siguiente nodo en la lista.}

if punt <> cola then

{Si el nodo a eliminar no es el último de la lista.}

begin

puntaux := punt^.prox;

puntaux^.ant := punt^.ant

{Hay que enlazar el nodo posterior con el anterior

al nodo que se va a eliminar.}

end

else cola := punt^.ant;

{Si el nodo a eliminar es el último de la lista, el puntero

de cola de la lista ha de apuntar al nodo anterior.}

dispose(punt);

{La lista ya est  de nuevo enlazada, y el nodo est  fuera de

ella, as¡ que se libera la memoria que tenía reservada.}

writeln;

writeln('Ficha eliminada!');

readkey

end;

begin

ClrScr;

write('Introduce el número de la ficha a eliminar: ');

readln(codigo);

writeln;

encontrado := buscar(cabeza, codigo, seekerror);

{Buscar el nodo a eliminar.}

if seekerror then

{Si el número de ficha buscada no est  en la lista:}

begin

writeln('No existe ninguna ficha con el número ',codigo);

readkey

end

else begin

{Si la ficha buscada ha sido encontrada:}

writeln('Se ha encontrado la siguiente ficha:');

writeln;

writeln('Número: ',encontrado^.info.numero);

writeln('Nombre: ',encontrado^.info.nombre);

writeln(' Nota: ',encontrado^.info.nota:5:2);

writeln;

entrada := si_no('¨Es esta la ficha buscada?');

if entrada = 'S' then borrarnodo(encontrado)

{Si el usuario confirma la eliminación, entonces se

elimina el nodo.}

end

end;

Procedure modificar;

{Permite modificar los datos referentes a un alumno cuya ficha

est en la lista.}

var codigo: integer;

ficha: alumno;

seekerror, correcto: boolean;

encontrado: Pnodo;

Entrada: Char;

begin

ClrScr;

write('Introduce el número de la ficha a modificar: ');

readln(codigo);

writeln;

encontrado := buscar(cabeza, codigo, seekerror);

{Se busca el número de la ficha que se desea modificar.}

if seekerror then

begin

writeln('No existe ninguna ficha con el número ',codigo);

readkey

end

else begin

{Si se encontró el número buscado en la lista:}

writeln('Se ha encontrado la siguiente ficha:');

writeln;

writeln('Número: ',encontrado^.info.numero);

writeln('Nombre: ',encontrado^.info.nombre);

writeln(' Nota: ',encontrado^.info.nota:5:2);

writeln;

entrada := si_no('¨Es esta la ficha buscada?');

writeln;

if entrada = 'S' then

{Si el usuario confirma que era la ficha buscada:}

begin

repeat

with ficha do

begin

numero := encontrado^.info.numero;

writeln('Sustituir por:');

writeln;

write('Nuevo nombre: ');

readln(nombre);

write('Nota: ');

readln(nota);

{Se modifican los datos.}

entrada := si_no('¨Confirma los cambios?');

correcto := (entrada = 'S')

end

until correcto;

encontrado^.info := ficha;

{Se sustituyen en la lista los datos modificados

por los antiguos.}

writeln;

writeln('Ficha modificada.');

readkey;

end

end

end;

Procedure listar(lista: Pnodo);

{Visualiza por pantalla el contenido de la lista de alumnos.}

var cont: integer;

begin

ClrScr;

writeln('******* L I S T A D O D E A L U M N O S *******');

writeln;

writeln('Número', 'N O M B R E':25,'Nota':22);

for cont := 1 to 53 do write('Ä');

writeln;

if lista = nil

then writeln('No hay ningún alumno en la lista.')

else while lista <> nil do

{Si la lista no est  vacía, mientras que no se llegue al final:}

begin

write(lista^.info.numero:6,' ',lista^.info.nombre);

write(' ':38-length(lista^.info.nombre));

writeln(' ':2,lista^.info.nota:5:2);

{Se muestran los datos del alumno.}

lista := lista^.prox

{Se salta al próximo nodo.}

end;

writeln;

write('Pulsa una tecla para regresar al MENU ...');

readkey;

writeln

end;

Procedure resetMem(lista: Pnodo);

{Liberar la memoria reservada para la lista.}

var aux: Pnodo;

cont: integer;

begin

ClrScr;

cont := 0;

if lista <> nil then writeln('Liberando la memoria din mica:');

while lista <> nil do

begin

inc(cont);

writeln(' Nodo n§ ',cont);

aux := lista;

lista := lista^.prox;

dispose(aux)

end

end;

Begin

ClrScr;

iniciarlista;

repeat

case menu of

{Llamada a la función menú, y selección en función del

valor que devuelva.}

'1': nuevo;

'2': borrar;

'3': modificar;

'4': listar(cabeza);

'T': salir := true

end

until salir;

writeln;

resetmem(cabeza);

{Liberar la memoria reservada para la lista.}

writeln('That`s All Folks ...');

readkey

end.

12. Generar una lista encadenada con todas las palabras de tres caracteres que aparecen en un fichero de tipo texto. Imprimir dicha lista.

Program t10e12(Input, Output);

Uses Crt;

Const letpal = 3;

separadores: Set of Char =([' ', ',', '.', ';','(',')', ':',

'''','?','¨','­','!','[',']','{','}',#13, #10]);

Type

Puntero = ^nodo;

nodo = record

info: String[letpal];

enlace: Puntero

{Lista simplemente enlazada.}

end;

Var fichero: Text;

letra: Char;

contletras, contpal: integer;

nombrefic, palabra: String;

control: boolean;

cabeza, cola, puntaux: Puntero;

Procedure iniciar(var lista, cola: Puntero);

begin

lista := nil;

cola := nil

end;

Function haznodo(nuevapal: String): Puntero;

var aux: Puntero;

begin

new(aux);

aux^.info := nuevapal;

aux^.enlace := nil;

haznodo := aux

end;

Procedure insertar(var lista, cola: Puntero; nuevo: Puntero);

var aux: Puntero;

begin

if lista = nil then

begin

lista := nuevo;

cola := nuevo

end

else begin

aux := cola;

cola := nuevo;

aux^.enlace := nuevo

end

end;

Procedure verlista(lista: Puntero);

{Visualiza la lista de palabras con 3 letras por pantalla.}

var cont: integer;

begin

writeln('As¡ queda la lista:');

cont := 0;

while lista <> nil do

begin

inc(cont);

writeln(cont:6,' ',lista^.info);

if (cont mod 24) = 0 then readkey;

lista := lista^.enlace

end;

writeln;

readkey

end;

Procedure ResetMem(lista: puntero);

var aux: Puntero;

cont: integer;

begin

ClrScr;

cont := 0;

writeln('Liberando la memoria din mica:');

while lista <> nil do

begin

inc(cont);

writeln('Eliminando nodo n§ ',cont);

aux := lista;

lista := lista^.enlace;

dispose(aux)

end

end;

Begin

ClrScr;

contpal := 0;

contletras := 0;

write('Nombre del fichero de entrada: ');

readln(nombrefic);

if nombrefic = '' then nombrefic := 'c:\tp\bin\temas\tema10\t10dat.txt';

assign(fichero,nombrefic);

{$I-}

reset(fichero);

{$I+}

if ioresult <> 0 then

begin

writeln('Error en apertura de fichero.!!');

halt(1)

end;

iniciar(cabeza, cola);

palabra := '';

control := false;

while not eof(fichero) do

begin

while not eoln(fichero) do

begin

read(fichero,letra);

if not(letra in separadores)

then begin

if not control then inc(contpal);

control := true;

inc(contletras);

palabra := palabra + letra

end

else begin

control := false;

if contletras = letpal then

{Si la palabra tiene 3 letras: }

begin

puntaux := haznodo(palabra);

{Se crea un nodo que contiene la palabra.}

insertar(cabeza, cola, puntaux)

{Se inserta el nodo en la lista.}

end;

palabra := '';

contletras := 0;

while ((letra in separadores)

or eoln(fichero)) and not(eof(fichero)) do

begin

read(fichero,letra);

if not(letra in separadores)

then begin

inc(contpal);

inc(contletras);

palabra := palabra+letra;

control := true

end

end

end

end;

if not eof(fichero) then

begin

read(fichero,letra)

end

end;

close(fichero);

writeln;

writeln('Total: ',contpal,' palabras.');

writeln;

verlista(cabeza);

resetmem(cabeza);

writeln;

writeln('That`s All Folks ...');

readkey

end.

14. Escribir un programa que lea un texto de longitud indeterminada y que produzca como resultado la lista de todas las palabras diferentes contenida en el texto, así como su frecuencia de aparición.

Program t10e12(Input, Output);

Uses Crt;

Const lenpal = 25;

separadores: Set of Char =([' ', ',', '.', ';','(',')', ':'

,'"','&','=','?','¨','­','!','{','}','[',']','''','+','-', #13, #10]);

Type

histograma = record

pal: String[lenpal];

frec: integer

end;

Puntero = ^nodo;

nodo = record

info: histograma;

enlace: Puntero

{Lista simplemente enlazada.}

end;

Var fichero: Text;

letra: Char;

contletras, contpal: integer;

nombrefic, palabra: String;

control, errorcode: boolean;

cabeza, cola, puntaux: Puntero;

Procedure iniciar(var lista, cola: Puntero);

begin

lista := nil;

cola := nil

end;

Function haznodo(nuevapal: String): Puntero;

{Crea un nuevo nodo para almacenar otra palabra y su frecuencia}

var aux: Puntero;

begin

new(aux);

aux^.info.pal := nuevapal;

{Guarda la palabra.}

aux^.info.frec := 1;

{Como la palabra es nueva, solo ha aparecido una vez.}

aux^.enlace := nil;

haznodo := aux

end;

Procedure insertar(var lista, cola: Puntero; nuevo: Puntero);

var aux: Puntero;

begin

if lista = nil then

begin

lista := nuevo;

cola := nuevo

end

else begin

aux := cola;

cola := nuevo;

aux^.enlace := nuevo

end

end;

Function buscar(lista: Puntero; palabra: String;

var error: boolean): Puntero;

{Busca una palabra en la lista, y devuelve un puntero apuntando

al nodo que contiene la palabra. Si la palabra buscada no se

encuentra en la lista, devuelve el puntero apuntando a NIL, y un

valor TRUE en el par metro de control de error.}

var puntaux: Puntero;

begin

error := true;

{Si la lista est  vacía, siempre ocurrir  un error de búsqueda.}

puntaux := lista;

if lista <> nil

{Si la lista no est  vacía:}

then begin

while (puntaux^.info.pal <> palabra) and (puntaux <> nil)

do puntaux := puntaux^.enlace;

{Mientras que el nodo no contenga la palabra buscada, y no

se llegue al final de la lista, se va saltando de nodo en nodo.}

if puntaux <> nil then

if puntaux^.info.pal = palabra

{Si no se llegó al final de la lista, y la palabra

almacenada en el nodo encontrado coincide con la palabra

buscada:}

then error := false

{Entonces no ha ocurrido un error de búsqueda.}

else error := true;

{Si las palabras no coinciden, entonces ha ocurrido

un error en la búsqueda.}

end;

buscar := puntaux;

end;

Procedure verlista(lista: Puntero);

{Visualiza el histograma con las palabras de la lista y

la frecuencia de aparición de cada una de ellas.}

var cont, aux: integer;

begin

cont := 0;

{Cuenta el n§ de nodos.}

ClrScr;

while lista <> nil do

{Mientras que no se llegue al final de la lista:}

begin

inc(cont);

{Se incrementa el contador de nodos.}

write(' ',cont:4,' ',lista^.info.pal,' ');

{Se escribe la palabra.}

for aux := 1 to 26-length(lista^.info.pal) do write('.');

case lista^.info.frec of

{Dependiendo de la frecuencia de aparición de la palabra

se selecciona un color distinto.}

1..4: textcolor(9);

5..9: textcolor(10);

10..14: textcolor(11);

14..19: textcolor(12)

else textcolor(14)

end;

write(lista^.info.frec:3);

{Se escribe el n§ de veces que aparece la palabra.}

textcolor(7);

writeln(' veces.');

if (cont mod 24) = 0 then readkey; {pausa }

lista := lista^.enlace

{Se salta al siguiente nodo.}

end;

writeln;

write('Pulsa una tecla para terminar ...');

readkey

end;

Procedure ResetMem(lista: puntero);

{Libera la memoria din mica reservada para la lista.}

var aux: Puntero;

cont: integer;

begin

ClrScr;

cont := 0;

writeln('Liberando la memoria din mica:');

writeln;

write('Eliminando nodos: (');

textcolor(9);

write('#');

textcolor(7);

writeln(' = 1 Nodo)');

writeln;

textcolor(9);

while lista <> nil do

begin

inc(cont);

delay(50);

{aunque tarde un poco más, queda más vistoso}

write('#');

if (cont mod 10) = 0 then

{Los símbolos que representan un nodo, se mostrar n

en grupos de 10.}

if (cont mod 50) = 0

{Cada cinco grupos de 10 nodos, se salta de línea.}

then writeln

else begin

{Los grupos se separan con un guión de color rojo.}

textcolor(12);

write('-');

textcolor(9)

end;

aux := lista;

{Se apunta el nodo con un puntero auxiliar para que no

quede perdido, sin enlace.}

lista := lista^.enlace;

{Se salta al siguiente nodo.}

dispose(aux)

{Se libera la memoria reservada para el nodo que ha

quedado atrás.}

end;

textcolor(7);

writeln;

writeln(cont,' nodos eliminados.');

writeln;

writeln('Memoria liberada.')

end;

Begin

ClrScr;

contpal := 0;

contletras := 0;

writeln('Listar todas las palabras de un archivo de texto');

writeln('y contar el número de veces que aparece cada una.');

writeln;

write('Nombre del fichero de entrada: ');

readln(nombrefic);

if nombrefic = '' then nombrefic := 'c:\tp\bin\temas\tema10\t10dat.txt';

assign(fichero,nombrefic);

{$I-}

reset(fichero);

{$I+}

if ioresult <> 0 then

begin

writeln('Error en apertura de fichero.!!');

readkey;

halt(1)

end;

iniciar(cabeza, cola);

palabra := '';

control := false;

while not eof(fichero) do

begin

while not eoln(fichero) do

begin

read(fichero,letra);

if not(letra in separadores)

then begin

if not control then inc(contpal);

control := true;

inc(contletras);

palabra := palabra + letra

end

else begin

{La palabra ha finalizado porque se encontró un separador.}

control := false;

puntaux := buscar(cabeza, palabra, errorcode);

{Se busca la palabra en la lista.}

if not(errorcode) then

{Si no ocurrió un error en la búsqueda, quiere decir que

que la palabra ya est  en la lista:}

begin

inc(puntaux^.info.frec)

{Entonces sólo hay que incrementar el número de veces

que ha aparecido la palabra.}

end

else begin

{Si ocurre un error en la búsqueda, quiere decir que

la palabra no estaba en la lista, y habrá  que meterla.}

puntaux := haznodo(palabra);

{Se crea el nodo con la palabra.}

insertar(cabeza, cola, puntaux)

{Y se inserta en la lista.}

end;

palabra := '';

contletras := 0;

while ((letra in separadores)

or eoln(fichero)) and not(eof(fichero)) do

begin

read(fichero,letra);

if not(letra in separadores)

then begin

inc(contpal);

inc(contletras);

palabra := palabra+letra;

control := true

end

end

end

end;

if not eof(fichero) then

begin

read(fichero,letra)

end

end;

close(fichero);

writeln;

writeln('Fichero procesado.');

writeln;

writeln('Total: ',contpal,' palabras.');

writeln;

write('Pulsa una tecla para ver el histograma ...');

readkey;

verlista(cabeza);

{Visualiza el histograma.}

resetmem(cabeza);

{Libera la memoria din mica.}

writeln;

writeln('That`s All Folks ...');

readkey

end.

Ejercicios tema 11

2. Hacer un programa con un procedimiento recursivo que tome un string como entrada y lo visualice en orden inverso.

Program t11e2(Input, Output);

Uses Crt;

Var frase: String;

Procedure verinver(pal: String);

begin

if length(pal) >= 1 then

{Si la longitud de la frase no es cero }

begin

write(pal[length(pal)]);

{Se escribe el último carácter de la frase.}

delete(pal, length(pal),1);

{Se elimina de la frase el último carácter.

El procedimiento delete es propio de Turbo-Pascal.}

verinver(pal)

{Se hace la llamada recursiva con la nueva frase

que ahora tiene un carácter menos de longitud.}

end

end;

Begin

ClrScr;

write('Introduce una frase: ');

readln(frase);

{Se lee la frase.}

verinver(frase);

{Se llama a la función que visualiza la frase en orden inverso.}

writeln;

writeln;

write('Pulsa una tecla para terminar ...');

readkey

end.

4. Comprobar si un String introducido por teclado es un palíndromo (capicúa).

Program t11e4(Input, Output);

Uses Crt;

Var frase: String;

i: integer;

Function capicua(pal: String): boolean;

{Devuelve TRUE si la frase es capicúa y false si no lo es.

Hay que tener en cuenta que la función distingue entre

mayúsculas y minúsculas, y no elimina los espacios en blanco

ni los signos de puntuación, etc. ..., por lo que habrá  que

controlarlo todo antes de llamar a la función.}

var aux: boolean;

begin

aux := true;

if length(pal) >= 1 then

{Si la frase no tiene longitud cero:}

begin

if pal[1] = pal[length(pal)]

{Si la primera letra es igual a la última de la frase:}

then begin

delete(pal,1,1);

delete(pal, length(pal),1);

{Se eliminan de la frase la primera y la última letra.}

aux := aux and capicua(pal)

{Se hace la llamada recursiva con la nueva frase.}

end

else aux := false

{Si la primera y última letra no son iguales, la función

devuelve FALSE.}

end;

capicua := aux

end;

Begin

ClrScr;

writeln('Introduce una palabra (sin acentos): ');

write('Por ejemplo: 1331, o 1k11k1, o 0-1-2-1-0 ...:');

readln(frase);

for i := 1 to length(frase) do frase[i] := upcase(frase[i]);

{Pasa todo a mayúsculas.}

writeln;

if capicua(frase)

then writeln('Resultado: CAPICUA.')

else writeln('Resultado: NO es capicúa.');

readkey

end.

6. Escribir dos funciones, una recursiva y otra no, que dado un valor x entero positivo, retorne true si x es una potencia de 2.

Program t11e4(Input, Output);

Uses Crt;

Var numero, maxiter: integer;

Function DosalaN(num: integer; var iter: integer): boolean;

{Función iterativa que devuelve true si el número el potencia

de 2, y además cuenta el número de iteraciones hasta llegar

al resultado.}

var control: boolean;

begin

control := true;

iter := 0;

while (num > 2) and control do

{Mientras que el número sea mayor que 2 y divisible por 2: }

begin

inc(iter);

{Se incrementa el número de iteraciones (n§ de veces que

se ejecuta el bucle).}

control := control and ((num mod 2) = 0);

{Ser  true si el número es divisible por 2.}

num := num div 2

{Se divide el número por 2.}

end;

DosalaN := control

end;

Function RecDosalaN(num: integer; var iter: integer): boolean;

{Función recursiva que devuelve true si el número es potencia de 2.}

var aux: boolean;

begin

aux := true;

inc(iter);

{El número de iteraciones en la función recursiva, se cuenta por

el n§ de veces que es llamada la función, por lo que se incrementa

cada vez que se ejecute la función.}

if (num > 2) and (num mod 2 = 0)

{Si el número es mayor que 2, y divisible por 2:}

then begin

num := num div 2;

{se divide el número por 2.}

aux := aux and RecDosalaN(num, iter)

{Se hace la llamada recursiva con el nuevo número.}

end

else if num > 2 then aux := false;

{Si el número no es divisible por dos, la función devuelve FALSE}

RecDosalaN := aux

end;

Begin

ClrScr;

write('Introduce un número entero: ');

readln(numero);

writeln;

writeln('-----------------------------------------');

writeln;

writeln('Cálculo mediante la función recursiva:');

maxiter := 0;

if RecDosalaN(numero, maxiter)

then write('Resultado: SI')

else write('Resultado: NO');

writeln(' es potencia de 2');

writeln;

writeln(numero,' = 2 elevado a ',maxiter);

writeln;

writeln('Calculado en ',maxiter,' iteraciones.');

writeln;

writeln('-----------------------------------------');

writeln;

writeln('Cálculo mediante la función NO recursiva:');

if DosalaN(numero, maxiter)

then write('Resultado: SI')

else write('Resultado: NO');

writeln(' es potencia de 2');

writeln;

writeln(numero,' = 2 elevado a ',maxiter + 1);

writeln;

writeln('Calculado en ',maxiter,' iteraciones.');

readkey

end.

8. Hacer un programa que calcule la suma de los n primeros números pares y la suma de los n primeros números impares. El número n lo introduce el usuario. Crear dos subprogramas que calculen recursivamente los números pares e impares.

Program t11e4(Input, Output);

Uses Crt;

Var numero: integer;

Function sumaP(num: integer): longint;

{Calcula la suma de los n primeros números pares.}

var sumaparcial: longint;

begin

if num > 0

{Si el número es mayor que cero:}

then sumaparcial := 2*num + sumaP(num - 1)

{La suma de los primeros n números pares, ser :

El número (2*n), que es el n-simo número par, m s

la suma de los primeros (n-1) números pares.}

else sumaparcial := 0;

{La suma de los primeros "cero" números pares, es cero.}

sumaP := sumaparcial

end;

Function sumaI(num: integer): longint;

{Calcula la suma de los n primeros números impares.}

var sumaparcial: longint;

begin

if num > 0

{Si el número es mayor que cero:}

then sumaparcial := (2*num-1) + sumaI(num - 1)

{La suma de los primeros n números impares, ser :

El número (2*n-1), que es el n-simo número impar, m s

la suma de los primeros (n-1) números impares.}

else sumaparcial := 0;

{La suma de los primeros "cero" números impares, es cero.}

sumaI := sumaparcial

end;

Begin

ClrScr;

write('Introduce un número entero: ');

readln(numero);

writeln;

write('Suma de los primeros ',numero,' números impares: ');

writeln(sumaI(numero));

writeln;

write('Suma de los primeros ',numero,' números pares .: ');

writeln(sumaP(numero));

readkey

end.

CONCLUSIONES

Con el presente trabajo se han conseguido los objetivos propuestos, en cuanto que se ha obtenido un nivel de conocimientos sobre técnicas y metodología de programación, superior al exigido por la asignatura, se han desarrollado aspectos de la programación que quedan fuera del alcance específico de ésta, y se han adquirido conocimientos valiosos sobre la herramienta de programación en Pascal de Borland ®, sobre funciones, procedimientos, constantes y variables implementadas en sus unidades, sobre el uso e unidades, sobre el uso del debugger etc...

BIBLIOGRAFÍA

• Luis Joyanes Aguilar, Programación en TURBO PASCAL 5.5, 6.0 y 7.0 Madrid, McGraw Hill, 1993.

• Arthur M. Keller, Programación en Pascal.

Madrid, McGraw Hill, 1983.

• Byron S. Gottfried, Programación en Pascal.

Madrid, McGraw Hill, 1986.

• M. Alpuente [ y otros ], Fundamentos de programación.

Valencia, Universidad Politécnica de Valencia, 1986.

• Stephen K. O'Brien, Steve Nameroff, Turbo Pascal 7, Manual de referencia. Madrid, McGraw Hill, 1993.

Programación en Turbo Pascal Metodología y técnicas de programación

Página 82