{Al parecer se detectan algunas dudas sobre ordenación sin vectores o array en este ejemplo espero puedan ser anuladas dichas dudas}
program ordefich;
uses
crt;
type
fichero = record
nombre : string[80];
numero : integer;
end;
pfiche = ^ficheroreg;
ficheroreg = record
nomb : string[80];
nume : integer;
sig : pfiche;
end;
const
elarchivo = 'datosreg.dat';
elpuntero = 'datosput.dat';
var
f : file of fichero;
dato : fichero;
f1 : file of ficheroreg;
prim, sigien, actual : pfiche;
procedure entramosdatos;
begin
clrscr;
with actual^ do
begin
write('Introduzca Nombre : '); readln(nomb);
write('Introduzca Numero : '); readln(nume);
end;
end;
procedure otroregistroentra;
begin
if prim = nil then
begin
new(actual);
entramosdatos;
prim := actual;
actual^.sig := nil;
end
else
begin
sigien := actual;
new(actual);
entramosdatos;
sigien^.sig := actual;
actual^.sig := nil;
end;
assign(f1,elpuntero);
{$I-} reset(f1); {$I+} if ioresult <> 0 then
begin
rewrite(f1);
seek(f1,0);
write(f1,actual^);
close(f1);
end
else
begin
seek(f1,filesize(f1));
write(f1,actual^);
close(f1);
end;
end;
procedure cargapuntero;
var
i : longint;
begin
assign(f1,elpuntero);
{$I-} reset(f1); {$I+} if ioresult <> 0 then
begin
writeln('Error El Fichero No Existe Pulse [Enter]'); readln;
exit;
end
else
begin
if prim <> nil then
dispose(actual);
prim := nil;
for i := 0 to filesize(f1) - 1 do
begin
if prim = nil then
begin
new(actual);
seek(f1,i);
read(f1,actual^);
prim := actual;
actual^.sig := nil;
end
else
begin
sigien := actual;
new(actual);
seek(f1,i);
read(f1,actual^);
sigien^.sig := actual;
actual^.sig := nil;
end;
end;
end;
close(f1);
end;
procedure listardatos;
var
ver : pfiche;
begin
clrscr;
if prim = nil then
cargapuntero;
ver := prim;
while ver <> nil do
begin
with ver^ do
writeln(nomb,' ',nume);
ver := ver^.sig;
end;
writeln;
writeln('Pulse [Enter]'); readln;
end;
procedure ordenapuntero;
var
orde, sige : pfiche;
temp : ficheroreg;
begin
clrscr;
writeln('Ordenando Registros Punteros Espere'); if prim = nil then
cargapuntero;
orde := prim;
while orde <> nil do
begin
new(sige);
sige := orde^.sig;
while sige <> nil do
begin
if orde^.nume > sige^.nume then
begin
temp.nomb := orde^.nomb;
temp.nume := orde^.nume;
orde^.nomb := sige^.nomb;
orde^.nume := sige^.nume;
sige^.nomb := temp.nomb;
sige^.nume := temp.nume;
end;
sige := sige^.sig;
end;
orde := orde^.sig;
end;
delay(500);
end;
procedure entadatos;
begin
clrscr;
writeln('*** Entrada Datos ***'); writeln;
write(' Nombre = '); readln(dato.nombre);
write(' Numero = '); readln(dato.numero);
assign(f,elarchivo);
{$I-} reset(f); {$I+} if ioresult <> 0 then
begin
rewrite(f);
seek(f,0);
write(f,dato);
close(f);
end
else
begin
seek(f,filesize(f));
write(f,dato);
close(f);
end;
end;
procedure ordenaarchivos;
var
da, tempo : fichero;
i, t : longint;
begin
writeln('Ordenando Registros Punteros Espere'); assign(f,elarchivo);
{$I-} reset(f); {$I+} if ioresult <> 0 then
begin
writeln(' Error de archivo pulse [Enter]'); readln;
exit;
end
else
begin
writeln('**** Ordenando Archivos *****'); for i := 0 to filesize(f) - 1 do
begin
seek(f,i);
read(f,dato);
for t := filesize(f) - 1 downto i + 1 do
begin
seek(f,t);
read(f,da);
if dato.numero > da.numero then
begin
tempo := dato;
dato := da;
da := tempo;
seek(f,i);
write(f,dato);
seek(f,t);
write(f,da);
end;
end;
end;
close(f);
end;
delay(500);
end;
procedure presentaordenados;
var
d : longint;
begin
assign(f,elarchivo);
{$I-} reset(f); {$I+} if ioresult <> 0 then
begin
writeln(' Error de archivo pulse [Enter]'); readln;
exit;
end
else
begin
writeln('*** Datos Del Archivo ***'); writeln;
writeln(' Nombre Numero'); for d := 0 to filesize(f) - 1 do
begin
seek(f,d);
read(f,dato);
gotoxy(3,4 + d);write(dato.nombre);
gotoxy(25,4 + d);write(dato.numero);
end;
close(f);
end;
readln;
end;
procedure menu;
var
tec : char;
begin
repeat
clrscr;
writeln('**** Menu Principal ****'); writeln;
writeln('****** Menu Registros Archivo ******'); writeln;
writeln(' 1 : Entrada Datos registros'); writeln(' 2 : Ordenar Archivo registros'); writeln(' 3 : Ver Archivos registros'); writeln;
writeln('****** Menu Registros Punteros ******'); writeln;
writeln(' 4 : Entrada Datos Puntero'); writeln(' 5 : Ordenar Archivo Puntero'); writeln(' 6 : Ver Archivos Punteros'); writeln;
writeln(' 7 : Salir'); writeln;
writeln('<<<< Elija Opcion >>>>'); repeat
tec := readkey;
until tec in['1','2','3','4','5','6','7'];
clrscr;
case tec of
'1' : entadatos;
'2' : ordenaarchivos;
'3' : presentaordenados;
'4' : otroregistroentra;
'5' : ordenapuntero;
'6' : listardatos;
end;
until tec = '7';
if prim <> nil then
dispose(actual);
end;
begin
prim := nil;
menu;
end.
{Tengan presente que esto es un ejemplo que se puede mejorar }
Crear cuenta