Registros en Pascal 7.0

javier_83
13 de Abril del 2006
Hola a todos en este foro, necesito un ejemplo de como programar registros en Turbo Pascal 7.0
por favor

se los agradeceria mucho

jesus
13 de Abril del 2006
{ ORDENACION Y BUSQUEDA

DESCRIPCION

Aqui se han implementado algunos de los mas importantes algoritmos
para ordenación de vectores y busqueda de un elemento en estos.
La forma de manejo es sencilla, en primera instancia debes escoger
la opción "GENERAR VECTOR", en esta se implementa un procedimiento
que aleatoriamente llena las posiciones de un vector de 10 campos;
Una vez hecho esto ya se pueden seleccionar ORDENACION o BUSQUEDA
y escoger el tipo de estos deseado, en cualquier caso el resultado
sera siempre el mismo, la diferencia entre uno u otro radica en la
velocidad, por ejemplo no es lo mismo ordenar 10000 números con el
método de la BURBUJA que con el metodo de la SACUDIDA, porque el
primero es mas lento, para un mayor entendimiento se muestra en
forma gráfica el vector ordenado y desordenado.

MANUAL DE USO DEL PROGRAMA

1) Asegurese de que este correctamente la ruta en donde se encuentran
ubicados los archivos con extensión *.BGI y *.CHR, esta va en la
sentencia InitGraph(GD, GM,''); del procedimiento INICIALIZA_GRAFICAS.
Por ejemplo si los archivos *.BGI y *.CHR estan en la siguiente
dirección de tu computadora : C:tpbgi, entonces la sentencia
quedará InitGraph(GD, GM, 'c:tpbgi');.

2) Se debe correr con [CTRL] + [F9]

3) Inicialmente se muestra la pantalla de presentación, presione
cualquier tecla para continuar.

4) Escoger la opcion #3 "Generar Vector" para tener datos con que
trabajar.

5) Escoger entre Ordenación o Búsqueda y seleccionar el metodo deseado.

6) Para terminar el programa escoger la opcion #5 Salir.

}

program arreglos;
uses Crt,graph;
const
Tam = 10;
Max = 1000;
cifra = 10;

type
List = array[1..Max] of Integer;
xvec = array[1..Tam] of integer;
var
Data : List;
caso,I,j,col,fil,op,opc1,opc2,opc3,origmodo,
x,y,tempo,numero : Integer;
GraphDriver, GraphMode, ErrorCode : integer;
vec1,copia,vec2,res : xvec;
band,band1,band2,band3,verdad : boolean;
cuadro,cuadro1 : pointer;

procedure Inicializa_graficas;
begin{esta funcion inicializa el modo grafico}
GraphDriver := DETECT; { Se autodetecta el tipo de tarjeta gráfica}
initgraph(GraphDriver, GraphMode,'' );
ErrorCode := graphresult; { Lee el resultado de la inicialización}
if( ErrorCode <> grOk ) then
begin
clrscr;
writeln(' Error,no encuentro archivos para inicializar el modo gráfico');
writeln(' Asegurese de que los archivos con extension *.chr y *.bgi');
writeln(' Esten disponibles en el directorio BGI de su lenguaje Turbo Pascal');
writeln(' Presione cualquier tecla para terminar');
readkey;
halt(1);
end;
end;

function opcion(op,col,fil: integer): integer;
var
op1: integer;
begin
repeat
{$I-}
gotoxy(col,fil);write('Digite su opcion : ');clreol;
read(op1);
{$I+}
until (ioresult=0) and(op1>=0)and(op1<=op);
opcion:=op1;
end;

procedure menu_principal(col,fil : integer);
begin
clrscr;
gotoxy(col,fil);write('˙˙*** MANEJO DE ARREGLOS ***˙˙');
gotoxy(col,fil+1);write('˙˙**** MENU PRINCIPAL ****˙˙');
gotoxy(col,fil+3);write(' 1............ORDENACION');
gotoxy(col,fil+4);write(' 2............BUSQUEDA ');
gotoxy(col,fil+5);write(' 3............GENERAR VECTOR');
gotoxy(col,fil+6);write(' 4............EXPLICACION');
gotoxy(col,fil+7);write(' 5............SALIR');
end;

procedure menu_ordenacion(col,fil : integer);
begin
clrscr;
gotoxy(col,fil); write('***** MANEJO DE ARREGLOS *****');
gotoxy(col,fil+1);write('** ORDENACION DE ARREGLOS **');
gotoxy(col,fil+3);write(' 1......BURBUJA');
gotoxy(col,fil+4);write(' 2......SHELL ');
gotoxy(col,fil+5);write(' 3......INSERCION');
gotoxy(col,fil+6);write(' 4......SACUDIDA');
gotoxy(col,fil+7);write(' 5......SALIR');
end;


procedure menu_busqueda(col,fil : integer);
begin
clrscr;
gotoxy(col,fil); write('**** MANEJO DE ARREGLOS ****');
gotoxy(col,fil+1);write('** BUSQUEDA DE ELEMENTOS **');
gotoxy(col,fil+3);write(' 1......LINEAL');
gotoxy(col,fil+4);write(' 2......BINARIA');
gotoxy(col,fil+5);write(' 3......SALIR');
end;

procedure intercambio(var x,y : integer);
var
temp : integer;
begin
temp:=x;
x:=y;
y:=temp;
end;

procedure shell(var vec1:xvec);
var
intervalo,i,j,k,temp : integer;
begin
intervalo:=tam div 2;
while intervalo > 0 do
begin
for i:=(intervalo+1) to tam do
begin
j:=i-intervalo;
while(j>0) do
begin
k:=j+intervalo;
if vec1[j] <= vec1[k] then j:=0
else
intercambio(vec1[j],vec1[k]);
j:=j-intervalo;
end;{while}
end;
intervalo:=intervalo div 2;
end;
end;

procedure generar(var vec1,vec2:xvec);
var
i,tempo: integer;
cad : string;
begin
setgraphmode(getgraphmode);
randomize;
x:=100;y:=210;
for i := 1 to tam do
begin
vec1[i]:=Random(cifra);
vec2[i]:=Random(cifra);
copia[i]:=0;
end;
setcolor(YELLOW);
settextstyle(0,0,1);
outtextxy(x,y-120,'VECTOR GENERADO ALEATORIAMENTE');
outtextxy(x+210,y+15,'Contenido');
outtextxy(x+210,y+30,'Posicion');

setcolor(LIGHTGREEN);
line(x,y+10,x+200,y+10);
line(x,y+25,x+200,y+25);
line(x,y+40,x+200,y+40);
for i:=1 to tam do
begin
cad:='';
str(i,cad);
setcolor(CYAN);
outtextxy(x,y+30,cad);
tempo:=vec1[i];
cad:='';
str(tempo,cad);
setcolor(WHITE);
outtextxy(x,y+15,cad);
for j:=1 to tempo do putimage(x,y-j*10,cuadro^,copyput);
x:=x+20;
end;
readkey;
restorecrtmode;
end;

procedure copiar(vec1:xvec;var copia: xvec);
var
i: integer;
begin
for i:=1 to tam do
copia[i]:=vec1[i];
end;

procedure escribir(vec1,copia:xvec;col,fil:integer);
var
i,lon: integer;
begin
gotoxy(col-2,fil-1);write('Ordenado');
gotoxy(col+8,fil-1);write('Desordenado');
for i:=1 to tam do
begin
gotoxy(col,fil+i);write(vec1[i]);
gotoxy(col+8,fil+i);write(copia[i]);
end;
readln;
end;

procedure burbuja(var vec1:xvec);
var
i,j,temp : integer;
begin
for i:=1 to tam-1 do
for j:=i+1 to tam do
if (vec1[i]>vec1[j]) then
begin
temp:=vec1[i];
vec1[i]:=vec1[j];
vec1[j]:=temp;
end;
end;

procedure sacudida(var vec1:xvec);
var
der,izq,k,i : integer;
begin
der:=tam;
izq:=2;
repeat
for k:=der downto izq do
if vec1[k-1]>vec1[k] then
begin
i:=vec1[k];
vec1[k]:=vec1[k-1];
vec1[k-1]:=i;
end;
izq:=izq+1;
for k:=izq to der do
if vec1[k-1] > vec1[k] then
begin
i:=vec1[k];
vec1[k]:=vec1[k-1];
vec1[k-1]:=i;
end;
der:=der-1;
until izq>der;
end;

procedure usqueda_lineal(vec1:xvec;col,fil: integer);
var
elemento,i,k : integer;
begin
clrscr;k:=0;
repeat
{$I-}
clrscr;
gotoxy(col,fil); write('* Busqueda lineal de un elemento *');
gotoxy(col,fil+2);write(' Digite el numero a buscar : ' );
read(elemento);
{$I+}
until (ioresult=0)and(elemento>=0)and(elemento<=cifra);
writeln;
for i:=1 to tam do
begin
if vec1[i]=elemento then
begin
k:=k+1;
writeln('':2,'El numero ',elemento,' esta en la posicion ',i);
end;
end;
textcolor(yellow);
writeln;
writeln('':2,'CONCLUSION');
writeln('':2,'El numero ',elemento,' estuvo ',k,' veces');
textcolor(white);
readln;readln;
end;

procedure insercion(var vec1:xvec);
var
band : boolean;
k,pos,aux : integer;
begin
for k:=2 to tam do
begin
aux:=vec1[k];
pos:=k-1;
band:=true;
while(pos>=1) and (band) do
begin
if vec1[pos]>aux then
begin
vec1[pos+1]:=vec1[pos];
pos:=pos-1;
end
else
band:=false;
end;
vec1[pos+1]:=aux;
end;
end;


function lee_numero(col,fil : integer):integer;
var
num1 : integer;
begin
repeat
{$I-}
gotoxy(col,fil);write('Digite numero a buscar : ');clreol;
read(num1);
{$I+}
until (ioresult=0)and(num1>=0)and(num1<=cifra);
lee_numero:=num1;
end;

function binaria(vec1:xvec;num: integer):boolean;
var
inf,sup,mitad : integer;
band : boolean;
begin
inf:=1;sup:=tam;
band:=false;
while(inf<=sup)and(not(band)) do
begin
mitad:=(inf+sup) div 2;
if num>vec1[mitad] then
inf:=mitad+1
else
if num < vec1[mitad] then
sup:=mitad-1
else
band:=true;
end;
binaria:=band;
end;


procedure pegar(var res:xvec;vec1,vec2:xvec;col,fil:integer);
var
i,j : integer;
begin
textbackground(lightblue);
textcolor(yellow);
clrscr;
gotoxy(col,fil-1);write('Vector 1 - Vector 2');
textcolor(white);
for i:=1 to tam do
begin
res[i]:=vec1[i];
gotoxy(col,fil+i);write(vec1[i]);
end;
readln;
for i:=1 to tam do
begin
res[tam+i]:=vec2[i];
gotoxy(col+10,fil+i);write(vec2[i]);
end;
j:=tam+tam;
for i:=1 to j do
begin
if i=(j div 2 +1)then textcolor(red);
gotoxy(col+i,fil+tam+2);write(res[i]);
end;
textcolor(cyan);
gotoxy(col+1,fil+tam+4);write('CONCATENADO');
textcolor(white);

end;

procedure grafica(vec1,copia:xvec;caso:integer);
var
cad : string;
k,k1 : byte;
begin

setgraphmode(getgraphmode);
x:=10;y:=110;
setcolor(white);
rectangle(0,0,getmaxx,getmaxy);
setcolor(blue);
rectangle(1,1,getmaxx-1,getmaxy-1);
setcolor(white);
outtextxy(10,140,'Vector ordenado');
outtextxy(250,140,'Vector desordenado');
settextstyle(10,0,1);
setcolor(white);
k:=10;
k1:=50;
setcolor(yellow);
outtextxy(40,getmaxy-50,'METODOS DE ORDENACION');
settextstyle(10,1,1);
case caso of
1:outtextxy(getmaxx-k1,k,'BURBUJA');
2:outtextxy(getmaxx-k1,k,'SHELL');
3:outtextxy(getmaxx-k1,k,'INSERCION');
4:outtextxy(getmaxx-k1,k,'SACUDIDA');
5:outtextxy(getmaxx-k1,k,'QUICKSORT');
end;
settextstyle(defaultfont,0,1);
for i:=1 to tam do
begin
tempo:=vec1[i];
for j:=1 to tempo do
begin
setcolor(white);
putimage(x,y-j*10,cuadro^,copyput);
str(tempo,cad);
outtextxy(x,120,cad);
end;
x:=x+20;
end;
x:=250;
for i:=1 to tam do
begin
tempo:=copia[i];
for j:=1 to tempo do
begin
setcolor(white);
putimage(x,y-j*10,cuadro1^,copyput);
str(tempo,cad);
outtextxy(x,120,cad);
end;
x:=x+20;
end;
readkey;
restorecrtmode;
end;

procedure cuadros;
var i,j:integer;
begin
for i:=1 to getmaxx div 22 do
for j:=1 to getmaxy div 22 do
begin
setcolor(LIGHTBLUE);
{delay(5);}
rectangle(i*20+10,j*20+10,i*20+50,j*20+50);
end;
end;

procedure presentacion;
var i,j,y:byte;
begin
cuadros;
setcolor(WHITE);
settextstyle(3,0,5);
outtextxy(35,50,' TUTOR DE PROGRAMACION ');
setcolor(WHITE);
settextstyle(3,0,4);
outtextxy(70,350,' Operaciones con Vectores ');
outtextxy(70,400,' Por :Hector Conde ');
setcolor(YELLOW);
setfillstyle(1,YELLOW);
circle(getmaxx div 2,getmaxy div 2,100);
floodfill(getmaxx div 2,getmaxy div 2,YELLOW);
setcolor(BLACK);
arc(getmaxx div 2,getmaxy div 2,180,360,60);
setfillstyle(1,BLACK);
fillellipse(getmaxx div 2-30,getmaxy div 2-40,10,20);
fillellipse(getmaxx div 2+30,getmaxy div 2-40,10,20);
setcolor(green);
settextstyle(0,0,1);
outtextxy(getmaxx div 4,getmaxy-20,'Presione cualquier tecla para continuar');
readkey;
for y:=20 downto 0 do
begin
setcolor(YELLOW);
fillellipse(getmaxx div 2-30,getmaxy div 2-40,10,y);
delay(50);
end;
end;

procedure construye_imagenes(var cuadro,cuadro1:pointer);
begin
cleardevice;
setcolor(blue);
setfillstyle(1,blue);
bar(0,0,10,10);
setcolor(lightblue);
rectangle(0,0,10,10);
getmem(cuadro,imagesize(0,0,10,10));
getimage(0,0,10,10,cuadro^);
cleardevice;
setcolor(lightred);
setfillstyle(1,lightred);
bar(0,0,10,10);
setcolor(red);
setfillstyle(1,red);
rectangle(0,0,10,10);
getmem(cuadro1,imagesize(0,0,10,10));
getimage(0,0,10,10,cuadro1^);
cleardevice;
end;
procedure ordena_vectores;
begin
band1:=true;opc1:=0;
repeat
col:=4;fil:=2;
menu_ordenacion(col,fil);
opc1:=opcion(6,4,12);
case opc1 of
1:begin
caso:=1;
burbuja(vec1);
grafica(vec1,copia,caso);
end;
2:begin
caso:=2;
shell(vec1);
grafica(vec1,copia,caso);
end;
3:begin
caso:=3;
insercion(vec1);
grafica(vec1,copia,caso);
end;
4:begin
caso:=4;
sacudida(vec1);
grafica(vec1,copia,caso);
end;
5:band1:=false;
end;
until band1=false;
end;

procedure busqueda_en_vectores;
begin
band2:=true;opc2:=0;
repeat
col:=4;fil:=2;
menu_busqueda(col,fil);
opc2:=opcion(3,4,9);
case opc2 of
1:begin
col:=3;fil:=2;
usqueda_lineal(vec1,col,fil);
end;
2:begin
clrscr;
numero:=lee_numero(1,2);
verdad:=binaria(vec1,numero);
if verdad = true then
writeln('Numero fue enontrado');
readln;
readln;
end;
3:band2:=false;
end;
until band2=false;
end;
procedure explicacion;
begin
clrscr;
textcolor(yellow);
writeln('':5,'Explicacion de Manejo del Programa');
textcolor(WHITE);
writeln;
writeln('':5,'Aqui se han implementado algunos de los mas importantes algoritmos');
writeln('':5,'para ordenación de vectores y busqueda de un elemento en estos.');
writeln('':5,'La forma de manejo es sencilla, en primera instancia debes escoger');
writeln('':5,'la opción "GENERAR VECTOR", en esta se implementa un procedimiento');
writeln('':5,'que aleatoriamente llena las posiciones de un vector de 10 campos;');
writeln('':5,'Una vez hecho esto ya se pueden seleccionar ORDENACION o BUSQUEDA');
writeln('':5,'y escoger el tipo de estos deseado, en cualquier caso el resultado');
writeln('':5,'sera siempre el mismo, la diferencia entre uno u otro radica en la');
writeln('':5,'velocidad, por ejemplo no es lo mismo ordenar 10000 números con el');
writeln('':5,'método de la BURBUJA que con el metodo de la SACUDIDA, porque el ');
writeln('':5,'primero es mas lento.');
writeln;
textcolor(yellow);
write('':5,'Presiona cualquier tecla para volver a la pantalla anterior');
readkey;
textcolor(WHITE);
end;

procedure control_total;
begin
restorecrtmode;
band:=true;
repeat
clrscr;
col:=8;fil:=4;op:=0;
menu_principal(col,fil);
op:=opcion(5,8,12);
case op of
1:ordena_vectores;
2:busqueda_en_vectores;
3:begin
generar(vec1,vec2);
copiar(vec1,copia);
end;
4:explicacion;
5:band:=false;
end;
until band=false;
closegraph;
end;
begin {Principal}

Inicializa_graficas;
construye_imagenes(cuadro,cuadro1);
presentacion;
control_total;
end. {Final del programa principal}