{////////////////////////////////////////////////////////////////////
//          Programa de cadastro de funcionarios                   //
//                                                                 //
//                                                                 //
//           ROBERTO JUNDI FURUTANI - 0061/02                      //
//                                                                 //
//            Ciencia da Computacao - 3 Termo                      //
////////////////////////////////////////////////////////////////////}

Program CADASTRO;
Uses CRT;

Type
campos = record
nome,endereco:string[40];
          cod:integer;
      salario:real;
end;

Lista = ^Elem;
Elem = record
dados : campos;
 prox : lista;
end;

ListaDupla = ^ElemDupla;

ElemDupla = record
dados : campos;
 prox : ListaDupla;
  ant : ListaDupla;
end;

Var
Anterior,L,Primeiro,Seguinte,A : Lista;
       Inicio,Atual,Ultimo,Aux : ListaDupla;
                         ficha : campos;
                            op : integer;
                       arquivo : file of campos;


{////////////////////////////////////////////////////////
///////////// LISTA COM LIGACOES DUPLAS /////////////////
/////////////////////////////////////////////////////////}

(**************************************
   DUPLA   Busca por Salario Ordenacao
***************************************)
Procedure DBusca(Salario:real);
var achou:boolean;
    v:listadupla;
begin
Atual := Inicio;
achou := false;

while (Atual <> NIL) and (not achou)  do
   if  Salario > Atual^.dados.salario  then begin
   Atual := Atual^.Prox;
    end
   else achou := true;
end;

(****************************
   DUPLA    APAGA A LISTA
******************************)
Procedure Remove_lista_Dupla;
begin
Atual := Inicio;

while Atual <> NIL do
  begin
  dispose(Atual);
  Atual := Atual^.prox;
  end;
end;

(*********************************
   DUPLA Insere elemento inicial
*********************************)
Procedure DIns_Inicio(DC:Campos);
begin
new(Aux);
Aux^.Prox := Nil;
Aux^.dados := DC;
Aux^.Ant := NIL;
Inicio := Aux;
Ultimo := Aux;
end;

(*******************************************
    DUPLA - Insere elemento Intermediario
********************************************)
Procedure DIns_Int(DC:Campos);
begin
new(Aux);
Aux^.dados := DC;
Aux^.Prox := Atual;
Aux^.Ant := Atual^.Ant;
Aux^.Ant^.Prox := Aux;
Atual^.Ant:= Aux;
end;


(*********************************
  DUPLA  Insere novo ultimo elemento
**********************************)
Procedure DIns_Ult(DC:Campos);
begin
new(Aux);
Aux^.dados := DC;
Ultimo^.Prox := Aux;
Aux^.Ant := Ultimo;
Aux^.Prox := NIL;
Ultimo := Aux;
end;

(***********************************
  DUPLA  Insere novo primeiro elemento
************************************)
Procedure DIns_Prim(DC:Campos);
begin
new(Aux);
Aux^.Prox := Inicio;
Aux^.dados := DC;
Aux^.Ant := NIL;
Inicio := Aux;
end;

(*************************************
   DUPLA MOSTRA EM ORDEM CRESCENTE
**************************************)
Procedure Mostra_Crescente;
var
   c,i:integer;
begin
clrscr;
c := 1;
i := 1;
Atual := Inicio;
while Atual <> NIL do begin
writeln('Codigo...:',Atual^.dados.cod);
writeln('Nome.....:',Atual^.dados.nome);
writeln('Endereco.:',Atual^.dados.endereco);
writeln('Salario..:R$',Atual^.dados.Salario:8:2);
Atual := Atual^.Prox;

            if (i >= 5*c) then
            begin
            textcolor(10);
            write('Pressione qualquer tecla para continuar...');
            textcolor(15);
            c := c + 1;
            readkey;
            clrscr;
            end else writeln;
i := i+1;
end;
end;

(*************************************
 DUPLA MOSTRA EM ORDEM DECRESCENTE
**************************************)
Procedure Mostra_Decrescente;
var
   c,i:integer;
begin
clrscr;
c := 1;
i := 1;
Atual := Ultimo;

while Atual <> NIL do begin
writeln('Codigo...:',Atual^.dados.cod);
writeln('Nome.....:',Atual^.dados.nome);
writeln('Endereco.:',Atual^.dados.endereco);
writeln('Salario..:R$',Atual^.dados.Salario:8:2);
Atual := Atual^.Ant;

            if (i >= 5*c) then
            begin
            textcolor(10);
            write('Pressione qualquer tecla para continuar...');
            textcolor(15);
            c := c + 1;
            readkey;
            clrscr;
            end else writeln;
i := i+1;
end;
end;
(********************************
  DUPLA  Ordena por Salario
*********************************)
Procedure Ordena_Salario;
Begin
Inicio := NIL;
reset(arquivo);

while not eof(arquivo) do
begin
read(arquivo,ficha);

  if Inicio = NIL then
   DIns_Inicio(ficha)
   else
      Begin
           Dbusca(ficha.salario);
                   if Atual = NIL then
                   DIns_Ult(ficha)
                   else if Atual = Inicio then
                        DIns_Prim(ficha)
                        else
                        DIns_Int(ficha);
      end;
end;
end;

(************************************************
  DUPLA  Remover cadastro da lista
*************************************************)
Procedure Remover_Cadastro;
Var codigo:integer;
    achou:boolean;
Begin
clrscr;
Writeln('REMOVER CADASTRO');
Write('Digite o c¢digo do Funcion rio :');
Readln(codigo);
Atual := Inicio;
achou := False;

while (Atual <> NIL) and (not achou) do
begin
   if Atual^.dados.cod = codigo then
   begin

      if Atual = Nil then
      begin
      Ultimo := Atual^.Ant;
      Ultimo^.prox := nil;
      achou := true;
      dispose(Atual);
      end
      else if Atual = Inicio then
      begin
      Inicio := Atual^.prox;
      Inicio^.Ant := Nil;

      dispose(Atual);
      achou := true;
      end
      else
         begin
         Atual^.Prox^.Ant := Atual^.Ant;
         Atual^.Ant^.Prox := Atual^.Prox;
         achou := true;
         dispose(Atual);
         end;
   end;
Atual := Atual^.prox;
end;

If not achou then
Writeln('Codigo nÆo encontrado')
end;

(********************************************************
       PROGRAMA DE CONTROLE PARA LISTAS LIG. DUPLAS
*********************************************************)
Procedure ListaLigDuplas;
var limpou:boolean;
BEGIN
limpou := false;
assign(arquivo,'c:\faculd~1\cadastro.dat');
     while op <> 5 do
     Begin
     clrscr;
     writeln('        MENU - Listas Com Ligacoes Dupla');
     writeln;
     writeln('1.Apagar cadastro');
     writeln('2.Relatorio em Ordem Crescente por Salario ');
     writeln('3.Relat¢rio em Ordem Descrescente por Salario');
     writeln('4.Apagar Lista da memoria');
     writeln('5.Sair');
     write('Opcao -> ');
     readln(op);

           case op of
           1:begin
             Remover_Cadastro;
             Mostra_Crescente;
             end;

           2:begin
             Ordena_Salario;
             Mostra_Crescente;
             end;

           3:begin
             Ordena_Salario;
             Mostra_Decrescente;
             end;

           4:begin
             Remove_lista_Dupla;
             limpou:=true;
             end;

           end;
end;
if not limpou then
Remove_lista_Dupla;
end;

{/////////////////////////////////////////////////////
//////////// FIM LISTA COM LIGACAO DUPLA /////////////
//////////////////////////////////////////////////////}

(**************************
      Busca por codigo
***************************)
Function achou(codigo:integer):boolean;
begin
L := Primeiro;
achou := false;
while L <> NIL do
begin
   if L^.dados.cod = codigo then begin
   achou := true;
   end;
L := L^.prox;
end;
end;

(********************************
      Busca por codigo Ordenacao
**********************************)
Procedure Busca(codigo:integer);
var achou:boolean;
begin
L := primeiro;
achou := false;
while (L <> NIL) and (not achou)  do
begin
   if  Codigo > L^.dados.cod  then begin
   Anterior := L;
   L := L^.prox;
   end
   else achou := true;


end;
end;
 (********************************
      Busca por Nome Ordenacao
**********************************)
Procedure BuscaNome(nome:string);
var achou:boolean;
begin
L := primeiro;
achou := false;
while (L <> NIL) and (not achou)  do
begin
   if  Nome > L^.dados.Nome  then begin
   Anterior := L;
   L := L^.prox;
   end
   else achou := true;


end;
end;

(********************************
      Busca por Salario Ordenacao
**********************************)
Procedure BuscaSAL(salario:real);
var achou:boolean;
begin
L := primeiro;
achou := false;
while (L <> NIL) and (not achou)  do
begin
   if  salario > L^.dados.salario  then begin
   Anterior := L;
   L := L^.prox;
   end
   else achou := true;


end;
end;

(*********************************
    Insere elemento inicial
*********************************)
Procedure Ins_Inicio(DC:Campos);
begin
new(A);
Primeiro := A;
A^.dados := DC;
A^.prox := NIL;
L := A;
end;

(*************************************
     Insere elemento Intermediario
**************************************)
Procedure Ins_Int(DC:Campos);
begin
new(A);
A^.dados := DC;
A^.prox := l;
Anterior^.prox := a;
L := A;
end;


(*********************************
    Insere novo ultimo elemento
**********************************)
Procedure Ins_Ult(DC:Campos);
begin
new(A);
A^.dados := DC;
A^.prox := NIL;
Anterior^.Prox := A;
Anterior := A;
L := A;
end;

(***********************************
    Insere novo primeiro elemento
************************************)
Procedure Ins_Prim(DC:Campos);
begin
new(A);
A^.dados := DC;
A^.prox := Primeiro;
Primeiro := A;
L := A;
end;
(********************************
        Ordena por Nome
*********************************)
Procedure Ordena_Nome;
Begin
Primeiro := NIL;
reset(arquivo);

while not eof(arquivo) do
begin
read(arquivo,ficha);

  if Primeiro = NIL then
   Ins_Inicio(ficha)
   else
      Begin
           buscaNome(ficha.nome);
                   if L = NIL then
                   Ins_Ult(ficha)
                   else if L = Primeiro then
                        Ins_Prim(ficha)
                        else
                        Ins_Int(ficha);
      end;


end;
end;

(********************************
        Ordena por Salario
*********************************)
Procedure Ordena_sal;
Begin
Primeiro := NIL;
reset(arquivo);

while not eof(arquivo) do
begin
read(arquivo,ficha);

  if Primeiro = NIL then
   Ins_Inicio(ficha)
   else
      Begin
           buscaSAL(ficha.salario);
                   if L = NIL then
                   Ins_Ult(ficha)
                   else if L = Primeiro then
                        Ins_Prim(ficha)
                        else
                        Ins_Int(ficha);
      end;


end;
end;


(********************************
        Ordena por codigo
*********************************)
Procedure Ordena_codigo;
Begin
Primeiro := NIL;
reset(arquivo);

while not eof(arquivo) do
begin
read(arquivo,ficha);

  if Primeiro = NIL then
   Ins_Inicio(ficha)
   else
      Begin
           busca(ficha.cod);
                   if L = NIL then
                   Ins_Ult(ficha)
                   else if L = Primeiro then
                        Ins_Prim(ficha)
                        else
                        Ins_Int(ficha);
      end;


end;
end;

(************************************************
  Cadastro dos Funcionarios ( GRAVA NO ARQUIVO )
*************************************************)
Procedure Cad_arq;
var
   cont : char;
begin
reset(arquivo);
cont := 'S';
while cont = 'S' do
begin
clrscr;
write('Digite o codigo...:');
readln (ficha.cod);
       if achou(ficha.cod) then begin
       write('Esse codigo ja esta cadastrado');
       end
       else begin
       write('Digite o nome.....:');
       readln (ficha.nome);
       write('Digite o endereco.:');
       readln (ficha.endereco);
       write('Digite o salario..:');
       readln (ficha.salario);
       Seek(arquivo,filesize(arquivo));
       write(arquivo,ficha);
       end;
writeln;
write('Deseja continuar cadastrando S/N...:');
readln(cont);
cont := Upcase(cont);
end;
end;

(****************************
       MOSTRA A LISTA
*****************************)
Procedure Mostra_lista;
var
   c,i:integer;
begin
clrscr;
c := 1;
i := 1;
L := Primeiro;

while L <> NIL do begin
writeln('Codigo...:',L^.dados.cod);
writeln('Nome.....:',L^.dados.nome);
writeln('Endereco.:',L^.dados.endereco);
writeln('Salario..:R$',L^.dados.Salario:8:2);
L := L^.prox;
            if (i >= 5*c) or (L = nil) then
            begin
            textcolor(10);
            write('Pressione qualquer tecla para continuar...');
            textcolor(15);
            c := c + 1;
            readkey;
            clrscr;
            end
            else
            writeln('');
i := i+1;
end;
end;

(***************************
     REMOVER CADASTRO
****************************)
Procedure Remover;
var
   achou : boolean;
   Ant,Ant2 : Lista;
   codigo:integer;
begin
write('Digite o codigo do funcionario....:');
readln(codigo);
L := Primeiro;
achou := false;

while (L <> NIL) and (not achou) do
begin
   if L^.dados.cod = codigo then
   begin
      if L = Nil then
      begin
      Ant^.prox := nil;
      achou := true;
      dispose(L);
      end
      else if L = Primeiro then
      begin
      Primeiro := L^.prox;
      dispose(L);
      achou := true;
      end
      else
         begin
         Ant^.Prox := L^.Prox;
         achou := true;
         dispose(L);
         end;
   end;
Ant := L;
L := L^.prox;
end;

if achou then
begin
rewrite(arquivo);
reset(arquivo);
L := Primeiro;
  while L <> NIL do
  begin
  write(arquivo,L^.dados);
  L := L^.prox;
  end;
mostra_lista;
end
else
begin
Write('Codigo nao encontrado');
readkey;
end;
end;

(****************************
       APAGA A LISTA
******************************)
Procedure Remove_lista;
begin
L := Primeiro;

while L <> NIL do
  begin
  dispose(L);
  L := L^.prox;
  end;
end;


(*****************************
     PROGRAMA PRINCIPAL
******************************)
Begin
Assign (arquivo,'c:\faculd~1\Cadastro.dat');
textcolor(15);
while op <> 7 do
Begin
clrscr;
writeln('            MENU');
writeln;
writeln('1.Cadastrar');
writeln('2.Relatorio Ordenado por Codigo');
writeln('3.Relat¢rio Ordenado por Salario');
writeln('4.Relat¢rio Ordenado por Nome');
writeln('5.Remover Cadastro');
writeln('6.Lista com Ligacoes Dupla');
writeln('7.Sair');
write('Opcao -> ');
readln(op);

           case op of
{Cadastrar}1:begin
             cad_arq;
             end;

           2:begin
             Ordena_codigo;
             mostra_lista;
             end;

           3:begin
             Ordena_sal;
             mostra_lista;
             end;
           4:begin
             Ordena_nome;
             mostra_lista;
             end;
 {Remover} 5:begin
             remover;
             end;

           6:ListaLigDuplas;

            end;
end;
close(arquivo);
End.