Crear cuenta
{Mira esto es una forma espero te sirva}
program vagones;
uses
crt;
const
vagon = 'Vagones.txt';
paquete = 'Paquetes.txt';
resulta = 'Resultad.txt';
idv : array[1..3] of string[4] = (
'V201','V321','V202');
pesos : array[1..3] of integer = (
500,1000,2000);
idp : array[1..13] of string[4] = (
'P301','P302','P205','P560','P561','P600','P601','P602',
'P603','P701','P702','P703','P704');
pes : array[1..13] of integer = (
250,270,320,100,75,430,420,450,100,270,30,500,400);
type
identificador = string[200];
regtexto = record id : identificador; va : integer;end;
var
iden : regtexto; fichero : text; vag : identificador; dato : char;ub, h : integer;
arch : longint;procedure tomadatos(var d : regtexto; k : integer; e : char);
begin
(* if upcase(e) = 'V' then
begin
writeln('**** Entrada Datos Vagones ****');
writeln;
write(' Entre Identificador Vagon : ');
readln(d.id);
write(' Entre Cargamax : ');
repeat
{$I-} readln(d.va); {$I+}
until ioresult = 0;end;
if upcase(e) = 'C' then
begin
writeln('**** Entrada Datos Paquetes ****');
writeln;
write(' Entre Identificador Paquete : ');
readln(d.id);
write(' Entre Peso Paquete : ');
repeat
{$I-} readln(d.va); {$I+}
until ioresult = 0;end; *)
if upcase(e) = 'V' then {Con esto cargo el ejemplo tienes}
begin {que anularlo y activar la parte}
d.id := idv[k]; {superior quitando (* y *)}
d.va := pesos[k]; {y los datos pasaran a manual}
end; {el dato de entrada k solo es para}
if upcase(e) = 'C' then {el ejemplo despues no realiza nada}
begin
d.id := idp[k];
d.va := pes[k];
end;
end;
procedure guardadatos(var f : text; c : regtexto; nom : string);
begin
assign(f,nom);
{$I-} reset(f); {$I+}
if ioresult <> 0 then
begin
rewrite(f);
writeln(f,c.id,' ',c.va);
close(f);
end
else
begin
close(f);
Append(f);
writeln(f,c.id,' ',c.va);
close(f);
end;
end;
function carga_max_del_vagon(var f : text; l : integer) : integer;
var
i : longint; dat1 : string;num : string[8];
error, xc, rd : integer;
begin
i := 0;
carga_max_del_vagon := 0;
while i <> l do
begin
i := i + 1;
end;
readln(f,dat1);
i := 1;
for xc := 1 to length(dat1) do
begin
if dat1[xc] = ' ' then
begin
repeat
xc := xc + 1;
until dat1[xc] > ' ';
num := copy(dat1,xc,length(dat1));
vag := copy(dat1,1,xc - 1);
break;
end;
end;
val(num,rd,error);
if error <> 0 then
begin
delete(num,error,1);
val(num,rd,error);
end;
carga_max_del_vagon := rd;
end;
function peso_del_paquete(var id : identificador; pos : longint) : integer;
var
fp : text; gg : longint; linea : string; ids : identificador;nrt : string[8];
error, jj : integer;
begin
assign(fp,paquete);
{$I-} reset(fp); {$I+}
if ioresult <> 0 then
begin
writeln('Error De Archivo Falta O Da¤ado');
end
else
begin
gg := -1;
while gg < pos dobegin
readln(fp,linea);
gg := gg + 1;
end;
if gg = pos thenbegin
for jj := 1 to length(linea) do
begin
if linea[jj] <> ' ' then
begin
ids[jj] := linea[jj];
ids[0] := chr(jj);
end
else
break;
end;
id := copy(ids,1,length(ids));
nrt := copy(linea,jj,length(linea));
for jj := 1 to length(nrt) do
if nrt[jj] = ' ' then
delete(nrt,jj,1);
val(nrt,jj,error);
peso_del_paquete := jj;
end;
close(fp);
end;
end;
procedure entrada_paquetes(cc : identificador);
var
fr : text;begin
assign(fr,resulta);
{$I-} reset(fr); {$I+}
if ioresult <> 0 then
begin
rewrite(fr);
writeln(fr,cc);
close(fr);
end
else
begin
close(fr);
Append(fr);
writeln(fr,cc);
close(fr);
end;
end;
function size : longint;var
tx : text; bv : longint;begin
assign(tx,paquete);
{$I-} reset(tx); {$I+}
if ioresult <> 0 then
begin
writeln('Error De Archivo Falta O Da¤ado');
end
else
begin
bv := 0;
while not eof(tx) do
begin
readln(tx);
bv := bv + 1;
end;
size := bv;
close(tx);
end;
end;
procedure carga_paquetes_a_vagon;
var
fb : text;paq, da1, da2 : identificador;
n, sz, p, z, t : longint;
vv, total, pes, gd, vak : integer;
begin
assign(fichero,vagon);
{$I-} reset(fichero); {$I+}
if ioresult <> 0 then
begin
writeln('Error De Archivo Falta O Da¤ado');
end
else
begin
z := 0;
p := 0;
sz := size;
vv := 0;
total := 0;
t := 0;
while not eof(fichero) do
begin
vak := carga_max_del_vagon(fichero,t);
t := t + 1;
da1 := vag;
entrada_paquetes(da1);
fillchar(paq,sizeof(identificador),' ');
paq[0] := chr(0);
total := 0;
for gd := p to sz do
begin
pes := peso_del_paquete(da2,gd);
if vak >= (total + pes) then
begin
vv := vv + length(da2);
insert(da2,paq,vv);
insert(' ',paq,vv + 1);
paq[0] := chr(vv + 1);
vv := vv + 1;
total := total + pes;
z := z + 1;
end
else
begin
p := z;
entrada_paquetes(paq);
vv := 0;
total := 0;
break;
end;
end;
end;
end;
close(fichero);
writeln(' Tiene Paquetes : ',sz,' Se Cargan : ',p);
if sz > p thenbegin
write(' Quedan Para Cargar = ');
for vv := p to sz - 1 do
begin
pes := peso_del_paquete(da2,vv);
write(da2,' ');
end;
end
else
begin
writeln(' Todos Los Paquetes Cargados');
end;
end;
begin
clrscr;
assign(fichero,vagon);
{$I-} reset(fichero); {$I+}
if ioresult = 0 thenbegin
close(fichero); {Esto quitalo solo es para el}
erase(fichero); {borrado de los archivos pero}
end; {tu no lo necesitas creo yo}
assign(fichero,paquete);
{$I-} reset(fichero); {$I+}
if ioresult = 0 thenbegin
close(fichero);
erase(fichero);
end;
for h := 1 to 3 do {Esto lo tienes que activar quitando}
begin {?los for h y begin end? esto para manual}
tomadatos(iden,h,'v'); {como esta es para el ejemplo}
guardadatos(fichero,iden,vagon);
end;
for h := 1 to 13 do
begin
tomadatos(iden,h,'c');
guardadatos(fichero,iden,paquete);
end;
assign(fichero,resulta);
{$I-} reset(fichero); {$I+}
if ioresult = 0 thenbegin
close(fichero);
erase(fichero);
end;
carga_paquetes_a_vagon;
readkey;
end.{Te paso lo mismo pero con algunas nuevo procedimientos para que lo puedas manejar mejor y sin array perolos array solo eran para el ejemplo no para el programa suerte.}
program vagones;
uses
crt;
const
vagon = 'Vagones.txt';
paquete = 'Paquetes.txt';
resulta = 'Resultad.txt';
type
identificador = string[200];
regtexto = record id : identificador; va : integer;end;
var
iden : regtexto; fichero : text; vag : identificador; dato : char;ub, h : integer;
arch : longint;procedure tomadatos(var d : regtexto; e : char);
begin
if upcase(e) = 'V' then
begin
writeln('**** Entrada Datos Vagones [ESC]=Final Entradas ****');
writeln;
write(' Entre Identificador Vagon : ');
readln(d.id);
write(' Entre Cargamax : ');
repeat
{$I-} readln(d.va); {$I+}
until ioresult = 0;end;
if upcase(e) = 'C' then
begin
writeln('**** Entrada Datos Paquetes [ESC]=Final Entradas ****');
writeln;
write(' Entre Identificador Paquete : ');
readln(d.id);
write(' Entre Peso Paquete : ');
repeat
{$I-} readln(d.va); {$I+}
until ioresult = 0;end;
end;
procedure guardadatos(var f : text; c : regtexto; nom : string);
begin
assign(f,nom);
{$I-} reset(f); {$I+}
if ioresult <> 0 then
begin
rewrite(f);
writeln(f,c.id,' ',c.va);
close(f);
end
else
begin
close(f);
Append(f);
writeln(f,c.id,' ',c.va);
close(f);
end;
end;
function carga_max_del_vagon(var f : text; l : integer) : integer;
var
i : longint; dat1 : string;num : string[8];
error, xc, rd : integer;
begin
i := 0;
carga_max_del_vagon := 0;
while i <> l do
begin
i := i + 1;
end;
readln(f,dat1);
i := 1;
for xc := 1 to length(dat1) do
begin
if dat1[xc] = ' ' then
begin
repeat
xc := xc + 1;
until dat1[xc] > ' ';
num := copy(dat1,xc,length(dat1));
vag := copy(dat1,1,xc - 1);
break;
end;
end;
val(num,rd,error);
if error <> 0 then
begin
delete(num,error,1);
val(num,rd,error);
end;
carga_max_del_vagon := rd;
end;
function peso_del_paquete(var id : identificador; pos : longint) : integer;
var
fp : text; gg : longint; linea : string; ids : identificador;nrt : string[8];
error, jj : integer;
begin
assign(fp,paquete);
{$I-} reset(fp); {$I+}
if ioresult <> 0 then
begin
writeln('Error De Archivo Falta O Da¤ado');
end
else
begin
gg := -1;
while gg < pos dobegin
readln(fp,linea);
gg := gg + 1;
end;
if gg = pos thenbegin
for jj := 1 to length(linea) do
begin
if linea[jj] <> ' ' then
begin
ids[jj] := linea[jj];
ids[0] := chr(jj);
end
else
break;
end;
id := copy(ids,1,length(ids));
nrt := copy(linea,jj,length(linea));
for jj := 1 to length(nrt) do
if nrt[jj] = ' ' then
delete(nrt,jj,1);
val(nrt,jj,error);
peso_del_paquete := jj;
end;
close(fp);
end;
end;
procedure entrada_paquetes(cc : identificador);
var
fr : text;begin
assign(fr,resulta);
{$I-} reset(fr); {$I+}
if ioresult <> 0 then
begin
rewrite(fr);
writeln(fr,cc);
close(fr);
end
else
begin
close(fr);
Append(fr);
writeln(fr,cc);
close(fr);
end;
end;
function size : longint;var
tx : text; bv : longint;begin
assign(tx,paquete);
{$I-} reset(tx); {$I+}
if ioresult <> 0 then
begin
writeln('Error De Archivo Falta O Da¤ado');
end
else
begin
bv := 0;
while not eof(tx) do
begin
readln(tx);
bv := bv + 1;
end;
size := bv;
close(tx);
end;
end;
procedure carga_paquetes_a_vagon;
var
fb : text;paq, da1, da2 : identificador;
n, sz, p, z, t : longint;
vv, total, pes, gd, vak : integer;
begin
assign(fichero,vagon);
{$I-} reset(fichero); {$I+}
if ioresult <> 0 then
begin
writeln('Error De Archivo Falta O Da¤ado');
end
else
begin
z := 0;
p := 0;
sz := size;
vv := 0;
total := 0;
t := 0;
while not eof(fichero) do
begin
vak := carga_max_del_vagon(fichero,t);
t := t + 1;
da1 := vag;
entrada_paquetes(da1);
total := 0;
for gd := p to sz do
begin
pes := peso_del_paquete(da2,gd);
if pes > 0 thenbegin
if vak >= (total + pes) then
begin
vv := vv + length(da2);
insert(da2,paq,vv);
insert(' ',paq,vv + 1);
paq[0] := chr(vv + 1);
vv := vv + 1;
total := total + pes;
z := z + 1;
end
else
begin
p := z;
entrada_paquetes(paq);
vv := 0;
total := 0;
fillchar(paq,sizeof(identificador),' ');
paq[0] := chr(0);
break;
end;
end
else
begin
if paq > ' ' then
begin
p := z;
entrada_paquetes(paq);
end;
end;
end;
end;
end;
close(fichero);
writeln(' Tiene Paquetes : ',sz,' Se Cargan : ',p);
if sz > p thenbegin
write(' Quedan Para Cargar = ');
for vv := p to sz - 1 do
begin
pes := peso_del_paquete(da2,vv);
write(da2,' ');
end;
end
else
begin
writeln(' Todos Los Paquetes Cargados');
end;
end;
procedure entradavagones;
begin
tomadatos(iden,'v');
guardadatos(fichero,iden,vagon);
end;
procedure entradapaquetes;
begin
tomadatos(iden,'c');
guardadatos(fichero,iden,paquete);
end;
procedure presentaresultadoscargas;
begin
assign(fichero,resulta);
{$I-} reset(fichero); {$I+}
if ioresult = 0 thenbegin
close(fichero);
erase(fichero);
end;
carga_paquetes_a_vagon;
end;
procedure Muestra_archivos_vagon_paquetes;
var
vt : text;conte : string[20];
begin
writeln('***** Vagones Capacidad *****');
writeln;
assign(vt,vagon);
{$I-} reset(vt); {$I+}
if ioresult <> 0 then
begin
writeln('Error De Archivo Falta O Da¤ado');
end
else
begin
while not eof(vt) do
begin
readln(vt,conte);
writeln(' ',conte);
end;
close(vt);
end;
writeln;
writeln('**** Paquetes Y Peso ****');
writeln;
assign(vt,paquete);
{$I-} reset(vt); {$I+}
if ioresult <> 0 then
begin
writeln('Error De Archivo Falta O Da¤ado');
end
else
begin
while not eof(vt) do
begin
readln(vt,conte);
writeln(' ',conte);
end;
close(vt);
end;
end;
procedure menu;
var
ts, tec : char;
sal : boolean;begin
sal := false;
repeat
clrscr;
writeln(' **** Menu Jeneral ****');
writeln;
writeln(' V = Asignacion Vagones');
writeln(' P = Asignacion Paquetes');
writeln(' R = Presentacion Resultados');
writeln(' M = Mostrar Vagones Y Paquetes');
writeln(' S = Salir');
writeln;
writeln(' >>> Elija Opcion <<<');
repeat
tec := upcase(readkey);
until tec in['V','P','R','M','S'];
clrscr;
case tec of
'V' : begin
repeat
entradavagones;
writeln;
writeln(' Pulse [ESC]=Salir Otra Segir');
ts := readkey;
until ts = #27;
end;
'P' : begin
repeat
entradapaquetes;
writeln;
writeln(' Pulse [ESC]=Salir Otra Segir');
ts := readkey;
until ts = #27;
end;
'R' : begin
clrscr;
presentaresultadoscargas;
writeln;
writeln(' ***** Pulse Una Tecla *****');
readkey;
end;
'M' : begin
clrscr;
Muestra_archivos_vagon_paquetes;
writeln;
writeln('***** Pulse Una Tecla *****');
readkey;
end;
'S' : sal := true;
end;
until sal = true;end;
begin
clrscr;
menu;
end.program inversa;
const
MAX = 10; EXT = 20;type matriz = recordvalores: array[1..MAX,1..MAX] of real;
dim: 0.. MAX;
end;
type matrizextendida = recordvalores: array[1..MAX,1..2*MAX] of real;
dim: 0..MAX;
end;
var
mInicial,mInvertida,mInv,m:matriz;
mExtendida:matrizextendida; dimen:integer;x,y,i,j:integer;
{Obtiene una matriz del teclado}
procedure leerMatriz(var mInicial:matriz);
var i,j,num: integer;
begin
writeln(' ****** Entrada Numeros Matriz ******');
writeln;
write(' Entre dimension Matriz Max 10 : ');
readln(mInicial.dim);
for i := 1 to mInicial.dim do begin
for j := 1 to mInicial.dim do begin
write(' Num.[',i,'|',j,'] : ');
readln(mInicial.valores[i,j]);
end;
end;
end;
procedure mostrarMatriz(var m:matriz);
var i, j: integer;
begin
writeln(' **** La Matriz Cargada Es ****');
writeln;
for i := 1 to m.dim do begin
for j := 1 to m.dim do begin
write(' ', m.valores[i,j]:2:1);
end;
writeln;
end;
writeln;
end;
{Divide la fila indicada por un valor}
procedure divideFila( var mExtendida:matrizextendida; fila:integer; valor:real);
var j: integer;begin
for j:=1 to mExtendida.dim * 2 do begin
valor:=mExtendida.valores[fila,j];
mExtendida.valores[fila, j] := mExtendida.valores[fila, j] / valor;
end;
end;
{Genera un cero en una fila,columna dada}
procedure generaCero( var mExtendida:matrizextendida; filaCero,filaUno:integer);
var
aux:real;begin
for filaUno:=1 to mExtendida.dim * 2 do
if filaUno <> filaCero then
begin
aux:=mExtendida.valores[filaUno,filaCero];
for filaCero:=1 to mextendida.dim do
begin
mExtendida.valores[filaUno,filaCero]:=mExtendida.valores[filaUno,filaCero]-aux*mExtendida.valores[filaCero,filaCero];
end;
end;
end;
{Rellena una matriz extendida con la matriz original y la identidad}
procedure rellenaMatrizExt(var mInicial:matriz;var mExtendida:matrizextendida);
begin
for i:=1 to mExtendida.dim do
for j:=1 to mExtendida.dim * 2 do begin
if j<=mExtendida.dim then
mExtendida.valores[i,j]:=mInicial.valores[i,j]
else
if j=mExtendida.dim + i then
mExtendida.valores[i,j]:=1
else
mExtendida.valores[i,j]:=0;
end;
end;
{Extrae la inversa de una matriz extendida}
procedure obtenerInversa(mExtendida:matrizextendida; var mInv:matriz; i,j:integer);
begin
for i:=1 to mInicial.dim do begin
for j:=1 to mInicial.dim do begin
mInv.valores[i,j]:=mExtendida.valores[i+mInicial.dim,j+mInicial.dim];
end;
end;
end;
{invierte una matriz}
procedure invertirMatriz( mInicial:matriz; mInv:matriz);
var mExtendida:matrizextendida; i,j,filaUno,filaCero:integer;
begin
rellenaMatrizExt(mInicial,mExtendida);
for i:=1 to mExtendida.dim do
begin
divideFila(mExtendida,i,mExtendida.valores[i,j]);
for j:=1 to mExtendida.dim do
begin
if(i<>j) then
begin
generaCero(mExtendida,filaUno,filaCero);
end
end
end ;
obtenerInversa(mExtendida,mInv,i,j);
end;
{programa que realiza la inversión de una matriz}
begin
leerMatriz(mInicial);
invertirMatriz(mInicial,mInv);
writeln('Matriz Inicial');
mostrarMatriz(mInicial);
writeln('Matriz Invertida');
mostrarMatriz(mInv);
readln;
end.{Mira compara los dos y veras el error cometido por ti}
program inversa;
uses
crt;
const
MAX = 10; EXT = 20;type
matriz = recordvalores : array[1..MAX,1..MAX] of real;
dim : 0..MAX;
end;
matrizextendida = recordvalores: array[1..MAX,1..(2 * MAX)] of real;
dim: 0..MAX;
end;
var
mInicial, mInvertida, mInv, m : matriz;
mExtendida : matrizextendida; dimen : integer;x, y, i, j : integer;
{Obtiene una matriz del teclado}
procedure leerMatriz(var mm : matriz);
var
i, j, num : integer;
begin
writeln(' ****** Entrada Numeros Matriz ******');
writeln;
write(' Entre dimension Matriz Max 10 : ');
readln(mm.dim);
for i := 1 to mm.dim do
begin
for j := 1 to mm.dim do
begin
write(' Num.[',i,'|',j,'] : ');
readln(mm.valores[i,j]);
end;
end;
end;
procedure mostrarMatriz(m : matriz);
var
i, j : integer;
begin
writeln(' **** La Matriz Cargada Es ****');
writeln;
for i := 1 to mInicial.dim do
begin
for j := 1 to mInicial.dim do
begin
write(' ', m.valores[i,j]:2:1);
end;
writeln;
end;
writeln;
end;
{Divide la fila indicada por un valor}
procedure divideFila(var mExtendida : matrizextendida;
fila : integer; valor : real);
var
j : integer;begin
for j := 1 to mInicial.dim do
begin
mExtendida.valores[fila, j] := mExtendida.valores[fila, j] / valor;
end;
end;
{Genera un cero en una fila,columna dada}
procedure generaCero( var mExtendida:matrizextendida; filaCero,
filaUno:integer);
var
aux:real;begin
for filaUno := 1 to (mInicial.dim * 2) do
if filaUno <> filaCero then
begin
aux := mExtendida.valores[filaUno,filaCero];
for filaCero := 1 to mInicial.dim do
begin
mExtendida.valores[filaUno,filaCero] := mExtendida.valores[filaUno,
filaCero] - aux * mExtendida.valores[filaCero,filaCero];
end;
end;
end;
{Rellena una matriz extendida con la matriz original y la identidad}
procedure rellenaMatrizExt(mInicial : matriz;
var mExtendida : matrizextendida);
begin
for i := 1 to mInicial.dim do
begin
for j := 1 to (mInicial.dim * 2) do
begin
if j <= mInicial.dim then
mExtendida.valores[i,j] := mInicial.valores[i,j]
else
if j = mInicial.dim + i then
mExtendida.valores[i,j] := 1
else
mExtendida.valores[i,j] := 0;
end;
end;
end;
{Extrae la inversa de una matriz extendida}
procedure obtenerInversa(mExtendida:matrizextendida; var mInv:matriz;
i,j:integer);
begin
for i := 1 to mInicial.dim do
begin
for j := 1 to mInicial.dim do
begin
mInv.valores[i,j] := mExtendida.valores[i,j];
end;
end;
end;
{invierte una matriz}
procedure invertirMatriz( mInicial:matriz;var mInv:matriz);
var
mExtendida : matrizextendida;i,j,filaUno,filaCero:integer;
begin
rellenaMatrizExt(mInicial,mExtendida);
for j := 1 to mInicial.dim do
begin
if (i <> j) then
begin
generaCero(mExtendida,filaUno,filaCero);
end;
for i := 1 to mInicial.dim do
begin
divideFila(mExtendida,i,mInicial.valores[i,j]);
end;
obtenerInversa(mExtendida,mInv,i,j);
end;
end;
{programa que realiza la inversión de una matriz}
begin
clrscr;
leerMatriz(mInicial);
invertirMatriz(mInicial,mInv);
writeln('Matriz Inicial');
mostrarMatriz(mInicial);
writeln('Matriz Invertida');
mostrarMatriz(mInv);
readln;
end.