Pascal/Turbo Pascal - fichero binario

{Mira tienes implementados los procedimientos de guardar y cargar la cesta pero fíjate que se guarda una sola cesta

cada vez no el array de cestas tendrás que indicar cual guardas del 1 al  Tammaxcesta o si quieres todos tengras que

ejecutar un for.

cuando cargues una cesta se cargara en el array 1 si lo quieres en otro cámbialo a tu gusto   }

Program EJERCICIO29;

uses

    crt;

Const

Tammaxcesta=3;

Type

Tproducto=record

nombre:string;

num_unidades:integer;

precio_unidad:real;

en_cesta:boolean;

end;

Tcesta = array [0..Tammaxcesta] of Tproducto;

Tfichero = file of Tcesta;

Var

unacesta:Tcesta; (* variable del tipo cesta*)

opcion:integer;

pos:integer;

fichero:Tfichero;

f : file of tproducto;

procedure guarda_producto(g : Tproducto);

begin

   assign(f,'Producto.dat');

 {$I-} reset(f); {$I+}

  if ioresult <> 0 then

  begin

     rewrite(f);

     seek(f,0);

     write(f,g);

     close(f);

  end

else

    begin

      seek(f,filesize(f));

      write(f,g);

      close(f);

    end;

end;

procedure toma_producto(var una : tproducto);

var

   nom : string;

   i : integer;

   h : longint;

   encont : boolean;

   co : tproducto;

begin

   clrscr;

   encont := false;

   write('   Entre Naombre : ');

   readln(nom);

   for i := 1 to length(nom) do

   nom[i] := upcase(nom[i]);

   assign(f,'Producto.dat');

 {$I-} reset(f); {$I+}

  if ioresult <> 0 then

  begin

     writeln('  Error Archivo No Presente Pulse Una Tecla');

     readkey;

  end

else

    begin

   for h := 0 to filesize(f) - 1 do

   begin

      seek(f,h);

      read(f,co);

      for i := 1 to length(co.nombre) do

      co.nombre[i] := upcase(co.nombre[i]);

      if co.nombre = nom then

      begin

         close(f);

         encont := true;

         break;

      end;

   end;

      if encont = true then

      begin

         una := co;

      end

   else

      begin

         close(f);

         writeln('   Cesta No Encontrada Pulse Una Tecla');

         readkey;

         fillchar(una,sizeof(una),0);

      end;

  end;

end;

Procedure lee_producto (VAR producto:Tproducto);

Begin

producto.en_cesta:=true;

writeln('Escriba los datos del producto: ');

write('Nombre: ');

readln(producto.nombre);

write('Numero de unidades: ');

readln(producto.num_unidades);

write('Precio: ');

readln(producto.precio_unidad);

End;

Procedure inicializa_cesta;

var

i:integer;

Begin

for i:= 1 to TAMMAXCESTA do

begin

unacesta [i]. nombre := '';

unacesta [i]. num_unidades:= 0;

unacesta [i]. precio_unidad:= 0.0;

unacesta [i]. en_cesta := false;

end;

end;

Procedure mostrar_producto (var productocesta:Tproducto);

Begin

writeln;

writeln('El producto de la cesta es: ');

writeln;

writeln('Nombre: ',productocesta.nombre);

writeln('Unidades: ',productocesta.num_unidades);

writeln('Precio por unidad: ',productocesta.precio_unidad:0:2);

writeln('Precio total: ',(productocesta.num_unidades*productocesta.precio_unidad):0:2);

writeln;

End;

Procedure llenar_cesta (VAR unacesta:Tcesta);

Var

i:integer;

Begin

For i:= 1 to Tammaxcesta do

begin

lee_producto(unacesta[i]);

end;

End;

Procedure Mostrar_cesta (unacesta:Tcesta);

var

i:integer;

begin

For i:= 1 to Tammaxcesta do

mostrar_producto(unacesta[i]);

end;

Function busca_libre (unacesta:Tcesta):integer;

Var

i:integer;

Begin

for i:= 1 to Tammaxcesta do

if (unacesta[i].en_cesta = false) then

begin

busca_libre:=i;

writeln('La primera posicion libre de la cesta es la: ',i);

end

else

begin

busca_libre:= 0;

writeln('No hay ninguna posición libre en la cesta');

end;

end;

Procedure incluir_producto_en_cesta (Var unacesta:Tcesta);

Var

i:integer;

begin

i:=busca_libre(unacesta);

if (i <>0) then

lee_producto(unacesta[i])

else

begin

writeln;

writeln('La cesta esta llena');

end;

end;

Function buscar_producto (UnaCesta:Tcesta; nombre:string): integer;

Var

i:integer;

begin

for i:= 1 to tammaxcesta do

begin

if (unacesta[i].nombre = nombre) then

buscar_producto:=i

else

buscar_producto:=0;

end;

end;

Procedure Eliminar_producto (var UnaCesta:TCesta);

var

unproduc : string;

numaux: integer;

begin

Writeln;

Write ('Escriba el nombre del producto a eliminar: ');

Readln(unproduc);

numaux:= Buscar_producto (UnaCesta,unproduc);

If (numaux = 0) then

writeln ('Producto no encontrado')

else

begin

UnaCesta[numaux].en_cesta := false;

Writeln ('Producto numero: ',numaux,'encontrado y eliminado');

end;

End;

Procedure menu;

begin

   pos := 1;

   clrscr;

repeat

writeln(' *** M E N U *** ');

writeln;

writeln('1. Abrir la cesta de la compra exixtente.');

writeln('2. Comenzar cesta de compra nueva.');

writeln('3. Anadir producto a la cesta.');

writeln('4. Eliminar producto de la cesta.');

writeln('5. Guardar cesta.');

writeln('6. Pedir cesta.');

writeln('7. Salir del programa.');

writeln;

write('Introduzca una opcion: ');

readln(opcion);

writeln;

if (opcion=1) then

begin

writeln('Abrir cesta de la compra');

readln;

end

else

if (opcion=2) then

llenar_cesta(unacesta)

else

if (opcion=3) then

begin

pos:=busca_libre(unacesta);

incluir_producto_en_cesta(unacesta);

end

else

if (opcion=4) then

eliminar_producto(unacesta)

else

if (opcion=5) then

begin

writeln('Guardar cesta');

readln;

guarda_producto(unacesta[pos]);

end

else

if (opcion=6) then

begin

   toma_producto(unacesta[1]);

end

else

if (opcion=7) then

write('Salir');

until (opcion < 1) or (opcion >=7);

end;

Begin

inicializa_cesta;

opcion:=0;

menu;

readln;

End.