Algoritmos tipicos sobre estructuras de datos #listas #arboles #vectores #busqueda #ordenamiento #merge #recursion

algoritmos.pas

{ ----- MODELOS -----}

program modelosPascal;
const	
dimF=3;

type
rango = 1..dimF;

reg = record
	campo1: integer;
	campo2: integer;
	campo3: real;
end;

lista = ^nodol;
nodol = record
	dato: reg; // verificar tipo registro
	sig: lista;
end;

arbol = ^nodoa;
nodoa = record
	izq: arbol;
	dato: reg; // verificar tipo registro
	der: arbol;
end;

vector = array [rango] of reg;
vectorl = array [rango] of lista; // para insertar ordenado

procedure leer(var r: reg);
begin
	writeln('Ingrese AAAA: ');
	readln(r.campo1);
	if (r.campo1 <> -1) then begin
		writeln('Ingrese BBBB: ');
		readln(r.campo2);
		writeln('Ingrese BBBB: ');
		readln(r.campo3);
	end;
end;

procedure imprimirReg (r:reg);
begin
	writeln('', r.campo1);
	writeln('', r.campo2);
	writeln('', r.campo3);
end;

// ----------------------------------------------------------------- //
// -------------------- PROCEDURES DE LISTAS ----------------------- //
// ----------------------------------------------------------------- //

	

procedure agregarAdelante (var l: lista; r:reg);
var
    aux:lista;
begin
    new(aux);
    aux^.dato := r;
    aux^.sig:=l;
    l:=aux;
end;

procedure agregarAtras (var l:lista; r:reg); //verificar tipo registro
var
	aux, act:lista;
begin
	new(aux); 
    aux^.dato:=r;
    aux^.sig:=nil;
    if (l=nil) then
		l:=aux
	else begin
		act:=l;
		while (act^.sig <> nil) do
			act:=act^.sig;
		act^.sig:=aux;
	end;
end;

procedure agregarAtrasUlt (var l,ult:lista; r:reg); // verificar tipo registro
var
	aux:lista;
begin
	new(aux); 
    aux^.dato:=r;
    aux^.sig:=nil;
    if (l=nil) then
		l:=aux
    else
		ult^.sig:=aux;
    ult:=aux;
end;

procedure insertarOrdenado (var l:lista; r:reg);
var
    aux, ant, act: lista;
begin
    new(aux); 
    aux^.dato:=r;
    aux^.sig:=nil;
    ant:=l; 
    act:=l;
    while (act<>nil) and (r.campo1 > act^.dato.campo1) do begin
		ant:=act;
		act:=act^.sig;
    end;
    if (ant=act) then
		l:=aux
    else
		ant^.sig:=aux;
    aux^.sig:=act;
end;

procedure cargarLista (var l: lista);
var
	aux: reg;
	ult: lista; // solo si se carga atras
begin
	leer(aux);
	while (aux.campo1<>-1) do begin
		agregarAtrasUlt(l, ult, aux); // elejir la forma de insertar adecuada
		leer(aux)
	end;
end;

function buscarOrdenadoLista (l:lista; n:integer):boolean; // puede devolver el puntero
var
	encontrado:boolean;
begin
    encontrado:=false;
	while (l<>nil) and (not encontrado) do begin
		if (n = l^.dato.campo1) then
			encontrado := true;
		l:=l^.sig;
    end;
    buscarOrdenadoLista := encontrado;
end;

procedure eliminar (var l:lista; r:reg); 
var
	ant,act:lista;
begin
	ant:=l;
	act:=l;
	while (act<>nil) and (r.campo1 <> act^.dato.campo1) do begin
		ant:=act;
		act:=act^.sig;
    end;
	if (act<>nil) then begin
		if (act=l) then
			l:=l^.sig
		else
			ant^.sig:=act^.sig;
		dispose(act);
    end;
end;

procedure imprimirLista (l:lista);
begin
	while (l<>nil) do begin
		imprimirReg(l^.dato);
		l:=l^.sig;
    end;
end;

procedure imprimirListaRec (l:lista);
begin
	if (l<>nil) then begin
		imprimirReg(l^.dato);
		imprimirListaRec(l^.sig);
    end;
end;

// ----------------------------------------------------------------- //
// -------------------- PROCEDURES DE MERGE ------------------------ //
// ----------------------------------------------------------------- //

procedure minimo (var L1, L2: lista; var rMin:reg);
var
	i, iMin: integer;
begin
	rMin.campo1:=9999;
	if (L1 <> nil and L2 <> nil) then
		if (L1^.dato.campo1 < L2^.dato.campo1) then begin
			rMin:=L1^.dato;
			L1:= L1^.sig;
		end
		else begin
			rMin:=L2^.dato;
			L1:= L2^.sig;
		end;
	else begin
		if (L1 <> nil) and (L2 = nil) then begin
			rMin:=L1^.dato;
			L1:= L1^.sig;
		end
		else
			if (L1 = nil) and (L2 <> nil) then begin
				rMin:=L2^.dato;
				L1:= L2^.sig;
			end;
	end;
	writeln('El minimo es: ', rMin.campo1);  // eliminar verificacion
end;

procedure merge (L1,L2:lista; var L3: lista);
var
	rMin: reg;
begin
	minimo(L1,L2, rMin);
	while (rMin.campo <> 9999) do begin
		agregarAtras(L3, rMin);
		minimo(L1,L2, rMin);
	end;
end;

procedure minimoVector (var v: vectorl; var rMin:reg);
var
	i, iMin: integer;
begin
	rMin.campo1:=9999;
	iMin:=-1;
	for i:=1 to 7 do
		if (v[i]<>nil) and (v[i]^.dato.campo1 < rMin.campo1) then begin
			rMin.campo1 := v[i]^.dato.campo1;
			iMin:=i;
		end;
	if (rMin.campo1 <> 9999) then begin
		rMin:=v[i]^.dato;  //copiar datos necesarios s/registro
		v[iMin]:=v[iMin]^.sig;
	end;
	writeln('El minimo es: ', rMin.campo1);  // eliminar verificacion
end;

procedure mergeContador (v: vectorl; var l: lista);
var
	rMin, rActual: reg;
	ult: lista;
begin
	minimoVector(v, rMin);
	while (rMin.campo1 <> 9999) do begin 
		rActual.campo1:=rMin.campo1;
		rActual.campo2:=0;
		while (rMin.campo1 <> 9999) and (rMin.campo1 = rActual.campo1) do begin
			rActual.campo2 := rActual.campo2 + 1;
			minimoVector(v, rMin);
		end;
		agregarAtrasUlt(l, ult, rActual);
	end;
end;

// ----------------------------------------------------------------- //
// -------------------- PROCEDURES DE ARBOLES ---------------------- //
// ----------------------------------------------------------------- //

procedure agregarHoja (var a:arbol; r:reg);
begin
	if (a=nil) then begin
		new(a); 
		a^.dato:=r; 
		a^.izq:=nil;
		a^.der:=nil;
    end
    else begin
		if (r.campo1 < a^.dato.campo1) then
			agregarHoja(a^.izq, r)
		else
			agregarHoja(a^.der, r);
    end;
end;

procedure cargarArbol(var a:arbol);
var
	aux: reg;
begin
	leer(aux);
	while (aux.campo1 <> -1) do begin
		agregarHoja(a, aux);
		leer(aux);
	end;
end;

procedure busquedaAcotada (a:arbol; inf, sup:integer); 
begin
	if (a<>nil) then begin
		if (a^.dato.campo1 >= inf) and (a^.dato.campo1 <= sup) then begin
			busquedaAcotada(a^.izq,inf,sup);
			imprimirReg(a^.dato); // o lo que sea que haya q hacer
			busquedaAcotada(a^.der,inf,sup);
		end
		else begin
			if (a^.dato.campo1 < inf) then
				busquedaAcotada(a^.der,inf,sup)
			else
				busquedaAcotada(A^.izq,inf,sup);
		end;
	end;
end; 

procedure imprimirEnOrden (a:arbol);
begin
	if (A<>nil) then begin
		imprimirEnOrden(a^.izq);
		imprimirReg(a^.dato);
		imprimirEnOrden(a^.der);
  end;
end;

procedure maxCampo (a:arbol; var r:reg);
begin
	if (a <> nil) then begin
		if (a^.der <> nil) then
			maxCampo (a^.der, r)
		else
			r := a^.dato;      
	end;
end;

function buscarEnArbol (a:arbol; n:integer): arbol;
begin
	if (a=nil) then
		buscarEnArbol:=nil
	else begin
		if (n = a^.dato.campo1) then
			buscarEnArbol:=a
		else begin
			if (n < a^.dato.campo1) then
				buscarEnArbol:=buscarEnArbol(a^.izq, n)
			else
				buscarEnArbol:=buscarEnArbol(a^.der, n);
		end;
	end;
end;

// ----------------------------------------------------------------- //
// ------------------ PROCEDURES DE VECTORES ----------------------- //
// ----------------------------------------------------------------- //

procedure inicializarVector (var v: vector);
var
	i: integer;
begin
	for i:=1 to dimF do
		v[i].campo1:=0;
		v[i].campo2:=0;
		v[i].campo3:=0;
end;

procedure inicializarVectorL (var v: vectorl);
var
	i: integer;
begin
	for i:=1 to dimF do
		v[i]:=nil;
end;

procedure ordenarVector (var v: vector);
var
	i,j:integer;
	actual: reg;
begin
	for i:=2 to dimF do begin
		actual:=v[i];
		j:=i-1;
		while (j>0) and (v[j].campo1 > actual.campo1) do begin // de menor a mayor
			v[j+1]:=v[j];
			j:=j-1;
		end;
		v[j+1]:=actual;
	end;
end;

function busquedaDicotomicaRec (v:vector; ini,fin,num:integer): integer;
var
	medio:integer;
begin
	medio:=(ini+fin) div 2;
	if (ini<=fin) then begin
		if (num = v[medio].campo1) then
			busquedaDicotomicaRec:=medio
		else begin
			if (num < v[medio].campo1) then
				fin:=medio-1
			else 
				ini:=medio+1;
			busquedaDicotomicaRec:=busquedaDicotomicaRec(v,ini,fin,num);
		end;
	end
	else
		busquedaDicotomicaRec:=-1;
end; 

procedure busquedaDicotomicaRec (v:vector; ini,fin: integer; var pos: integer; num:integer);
var
	medio:integer;
begin
	medio:=(ini+fin) div 2;
	if (ini<=fin) then begin
		if (num = v[medio].campo1) then
			pos:=medio
		else begin
			if (num < v[medio].campo1) then
				fin:=medio-1
			else 
				ini:=medio+1;
			busquedaDicotomicaRec(v,ini,fin,pos,num);
		end;
	end
	else
		pos:=-1;
end; 

procedure busquedaDicotomica (v: vector; ini, fin, id:integer; var ok: boolean; var dni: integer);
var
	medio: integer;
begin
	medio:=(ini+fin) div 2;
	while ( (ini <= fin) and (id <> v[medio].campo1) ) do begin
		if (id < v[medio].campo1) then
			fin:=medio-1
		else
			ini:=medio+1;
	medio:=(ini+fin) div 2;
	end;
	if ( (ini <= fin) and (id = v[medio].campo1) ) then begin
		ok := true;
		dni:= v[medio].campo2;
	end;
end;

var
	l: lista;
	a: arbol;

BEGIN
	l:=nil;
	a:=nil;
	cargarLista(l);
	cargarArbol(a);
	
END.