Jump to content

Desafio Leilão em Pascal.


Junior Mayer
 Share

Recommended Posts

Menor lance único é um sistema de leilão, no qual o apostador informa um valor que ele acredita será o menor e único, ou seja, não possui repetição. O ganhador leva o produto leiloado pelo valor

que foi apostado.

Escreva um sistema para cadastrar os lances dos apostadores (um apostador pode apostar vários lances), cada aposta deverá conter: data da aposta (obter do sistema), nome do apostador, telefone para contato e o valor apostado.

Ao final o sistema deverá fazer a verificação das apostas e identificar o menor valor apostado e único. Caso haja, o sistema exibirá o nome do apostador, telefone para contato e o valor apostado.

No caso de não haver ganhador, o sistema deverá exibir uma mensagem indicando o prêmio está acumulado.

O prêmio equivale a 60% (sessenta) do montante arrecadado com os lances.

Logo abaixo esta o meu código. Não conseguir. Quem quiser aproveita, corrigir os bugs e concluir agradeço.

program lance_unico;

uses crt,dos;

type Tdata = record
     dia,mes,ano: integer;
end;

type
     TApostador = record
     nome : string[20];
     lance: real;
     fone : string[10];
     data:Tdata;
end;

var
    arquivo: file of TApostador;
    reg:TApostador;
    opcao:char;
    qtde_depois, qtde_antes: integer;
    dia,mes,ano,dia_semana:word;


procedure menu_principal;
var i:integer;
begin
clrscr;

   //tabela com menu principal
  for i := 30 to 60 do
      begin
         textbackground(7);
         textcolor(7);
         gotoxy(i,8);   write(#196);
         textbackground(1);
         textcolor(1);
         gotoxy(i,9);   write(#196);
         textbackground(7);
         textcolor(7);
         gotoxy(i,10);   write(#196);
         textbackground(1);
         textcolor(1);
         gotoxy(i,11);   write(#196);
         textbackground(7);
         textcolor(7);
         gotoxy(i,12);   writeln(#196);

      end;
   textbackground(7);
   textcolor(0);
   gotoxy(36,8);   writeLN('  MENU PRINCIPAL ');
   textbackground(1);
   textcolor(14);
   gotoxy(34,9);   writeLN(' 1 - CADASTRAR APOSTAS  ');
   textbackground(7);
   textcolor(0);
   gotoxy(34,10);   writeLN(' 2 - LISTAR APOSTAS   ');
   textbackground(1);
   textcolor(14);
   gotoxy(34,11);   writeLN(' 3 - EXIBIR GANHADOR  ');
   textbackground(7);
   textcolor(0);
   gotoxy(34,12);   writeLN(' 4 - SAIR DO JOGO ');

end;

procedure cadastrar_apostadores;
begin
   //nomear o arquivo
   assign(arquivo,'c:\Users\JUNIOR\Downloads\Unititled1.pas');

   //tentar abrir o arquivo binario

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

   // verificar se arquivo foi aberto, ou seja, não houve erro
   if (IOResult <> 0) then

   // houve erro, arquivo foi criado
   rewrite(arquivo);

   write ('Informe Seu Nome:');
   readln (reg.nome);

   write ('Informe o valor do lance:(De 0.01 a 100.00 R$): ');
   readln (reg.lance);
   while(reg.lance <=0 ) or (reg.lance >100) do
   begin
      writeln('lance invalido!');
      write('digite o valor correto: ');
      readln (reg.lance);
   end;

   write('Informe Fone:');
   readln (reg.fone);

   getdate(ano, mes, dia, dia_semana);
   reg.data.ano:=ano;
   reg.data.mes:=mes;
   reg.data.dia:=dia;

   // obter a quantidade de registros, antes de gravar
   qtde_antes := filesize(arquivo);

   // deslocar para o final do arquivo
   seek(arquivo, filesize(arquivo));

   //persistir no arquivo
   write(arquivo,reg);

   // obter a quantidade de registros, depois de gravar
   qtde_depois := filesize(arquivo);

   if (qtde_depois > qtde_antes) then
   writeln('Registro gravado com sucesso!')
   else
   writeln('Erro: Registro nao gravado com sucesso!');

   close(arquivo);
end;

procedure listar_apostas;
var i:integer;

begin
    //tentar abrir o arquivo binario

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

    // verificar se arquivo foi aberto, ou seja, não houve erro
    if (IOResult <> 0) then
    // houve erro
    write(' nao existe apostas feitas') else
    begin

       // deslocar para o início do arquivo
       seek(arquivo, 0);
       for i := 1 to filesize(arquivo) do
       begin
          // ler do arquivo
          read(arquivo, reg);

          // exibir a informação que foi lida
          writeln('REG',i - 1,':NOME : ', reg.nome,'       LANCE: ', reg.lance:2:2);
          writeln('     TELEFONE: ', reg.fone,'     DATA: ', reg.data.dia,'/',reg.data.mes,'/',reg.data.ano);
          writeln('========================================');
          writeln;
       end;
    end;
    close(arquivo);
end;

procedure verificar_ganhador;

var i,j,posicao,qtd:integer;
    menor_lance:real;

begin
    //tentar abrir o arquivo binario
    {$I-}
    reset(arquivo);
    {$I+}
    // verificar se arquivo foi aberto, ou seja, nao houve erro
    if (IOResult <> 0) then
    // houve erro
    write('nao existe aposta') else
    begin
       menor_lance:=100;
       qtd:=0;

       //deslocar para o início do arquivo
       seek(arquivo, 0);

       for i := 1 to filesize(arquivo) do
       begin

          // ler do arquivo
          read(arquivo, reg);

          if(reg.lance < menor_lance) then
          begin
             qtd:= qtd +1;
             menor_lance:= reg.lance;
             posicao:= i-1;
          end;
       end;
     end;
    //deslocar para posicao do ganhador no arquivo
    seek(arquivo,posicao);

    //ler o registro ganhador
    read(arquivo,reg);
    writeln('ganhador: ', reg.nome);
    writeln('menor_lance:',menor_lance:2:2);
    close(arquivo);
end;

begin
clrscr;
repeat
    clrscr;
    menu_principal;
    writeln;
    gotoxy(34,14);  write('digite sua opcao: ');
    opcao:=readkey;
    writeln(opcao);
    textbackground(0);
    case (opcao) of

    '1': begin
            textcolor(12);
            writeln;
            writeln('CADASTRAR APOSTAS');
            writeln;
            textcolor(9);
            cadastrar_apostadores;
         end;
    '2': begin
            textcolor(12);
            writeln;
            writeln(' APOSTAS CADASTRADAS ');
            textcolor(9);
            listar_apostas;
         end;
    '3': begin
            textcolor(12);
            writeln;
            writeln(' GANHADOR ');
            textcolor(9);
            verificar_ganhador;
         end;
    '4': begin
            textcolor(12);
            writeln;
            write(' volte sempre');
         end;
     end;//fim do case

readkey;
until(opcao='4');
end.
Link to comment
Share on other sites

Logo abaixo esta o meu código. Não conseguir. Quem quiser aproveita, corrigir os bugs e concluir agradeço.

Não estás a conseguir... o quê, exactamente?

Agradeces porque assim te faziam a paparoca toda - detectar os erros, corriji-los e colocar aqui o código novo.

Por isso, o que é que não está a funcionar e em que parte do código é que não está a funcionar correctamente? Desbobina isso.

Knowledge is free!

Link to comment
Share on other sites

Não estou conseguindo validar os dados. Por exemplo: Na parte nome só aceitar letras e na parte valor só aceitar números, se digitar algo diferente voltar e pedir denovo. No final pegar o menor lance e único e colocar com vencedor, o Nuno aqui do forum me deu uma dica bacana mas não conseguir fazer. Já lendo aqui um livro achei interessante pegar os menores e repetidos lances e separar, dai sobrariam os lances que não se repetem, neles percorria para ver qual o menor, então seria o campeão. E fazer a soma das apostas e colocar 60% para o ganhador.

Se alguém puder usar meu código e conseguir agradeço.

Link to comment
Share on other sites

Como eu disse, para o primeiro problema tens de usar o val para impedir letras ao ler o valor.

Para o segundo, fazer uma pesquisa completa para verificar potenciais duplicatas.

1º problema

Em primeiro lugar, livra-te do While neste caso. Sempre que tens de fazer algo pelo menos uma vez (no caso, ler o input do utilizador), deves usar o Repeat (salvo alguma situação especial).

   .
   .
var
   s:String;
   ErrCode:integer;
   Invalido:Boolean;
   .
   .
   .
   write ('Informe Seu Nome:');
   readln (reg.nome);

   repeat
      write ('Informe o valor do lance:(De 0.01 a 100.00 R$): ');
      readln (s);   // Le o input do utilizador para uma string
      Val(s,reg.Lance,ErrCode);  // Converte a string para um valor real em reg.Lance: Se correr bem, ErrCode será 0
      Invalido:=(ErrCode>0) or (reg.Lance<0.01) or (reg.Lance>100);  // Verifica se o valor inserido é valido
      if Invalido then writeln('lance invalido!');  // Se não for, avisa o utilizador
   until not Invalido;  // Repete até encontrar um valor válido.

   write('Informe Fone:');
   readln (reg.fone);
   .
   .
   .

Para o segundo problema, sugiro ordenar os registos todos por valor do lance, do menor para o maior.

Depois, é só encontrar o primeiro que seja diferente do anterior e do seguinte.

"A humanidade está a perder os seus génios... Aristóteles morreu, Newton já lá está, Einstein finou-se, e eu hoje não me estou a sentir bem!"

> Não esclareço dúvidas por PM: Indica a tua dúvida no quadro correcto do forum.

Link to comment
Share on other sites

Valeu Nuno!!!  🙂

Deu certo em lance, como faço para colocar em reg.nome não aceitar números só letras, de preferencia mais de três. E em reg.fone tb, cria o repeat para cada um?

E sobre comparação no final não estou conseguindo, esta é a verdade. O raciocínio eu entendi. Mas colocar no Pascal é que não consigo.

Obrigado Nuno.

Link to comment
Share on other sites

Verifica se só tem letras e tem o número mínimo de caracteres

function OnlyLetters_And_HigherThanLimit(Line : String; Limit : word) : Boolean;
var i : integer;
begin
     if (Length(Line) >= Limit) then begin  // está acima do limite mínimo?
        OnlyLetters := true;
        for i:=1 to Length(Line) do begin
            if (Line[i] in ['0'..'9']) then  // tem algarismos?
               OnlyLetters := false;
        end;
     end else OnlyLetters := false;
end;

Knowledge is free!

Link to comment
Share on other sites

- Dos testes se é só letras é como disse o Thoga.

- Sim, tens de fazer um repeat para cada um.

- Criar um array para guardar os dados:

Exemplo:

var
   ListaOrdenada:array[1..100] of TApostador;

Uma vez todos os registos no array, corre um algoritmo de ordenação (Bubblesort por exemplo) no array

(se não souberes nenhum, fica atento ao forum, vou ver se faço um e crio um tópico à parte para ele)

Depois com um ciclo começas a pesquisar o array. Dentro do ciclo, testas o lance da posição actual com o anterior e o proximo. Se algum deles for igual, passa ao proximo. Se ambos forem diferentes, é esse que precisas.

Por fim, mostras o valor.

"A humanidade está a perder os seus génios... Aristóteles morreu, Newton já lá está, Einstein finou-se, e eu hoje não me estou a sentir bem!"

> Não esclareço dúvidas por PM: Indica a tua dúvida no quadro correcto do forum.

Link to comment
Share on other sites

Nuno, tenha calma comigo, como explicado minha situação é complicada.

Olha o que vc me mandou, coloquei e ficou perfeito.

write ('Informe Seu Nome:');
   readln (reg.nome);

   repeat
     write ('Informe o valor do lance:(De 0.01 a 100.00 R$): ');
     readln (s);   // Le o input do utilizador para uma string
     Val(s,reg.Lance,ErrCode);  // Converte a string para um valor real em reg.Lance: Se correr bem, ErrCode será 0
     Invalido:=(ErrCode>0) or (reg.Lance<0.01) or (reg.Lance>100);  // Verifica se o valor inserido é valido
     if Invalido then writeln('lance invalido!');  // Se não for, avisa o utilizador
   until not Invalido;  // Repete até encontrar um valor válido.

   write('Informe Fone:');
   readln (reg.fone);

Sobre o que thoga31 colocou não conseguir acrescentar aqui. Teria como fazer usando este meu código como o Nuno fez?

E só ficaria faltando a ultima parte com o lance menor e único. Aqui no meu só mostra o menor.

procedure verificar_ganhador;

var i,j,posicao,qtd:integer;
    menor_lance:real;

begin
    //tentar abrir o arquivo binario
    {$I-}
    reset(arquivo);
    {$I+}
    // verificar se arquivo foi aberto, ou seja, nao houve erro
    if (IOResult <> 0) then
    // houve erro
    write('nao existe aposta') else
    begin
       menor_lance:=100;
       qtd:=0;

       //deslocar para o início do arquivo
       seek(arquivo, 0);

       for i := 1 to filesize(arquivo) do
       begin

          // ler do arquivo
          read(arquivo, reg);

          if(reg.lance < menor_lance) then
          begin
             qtd:= qtd +1;
             menor_lance:= reg.lance;
             posicao:= i-1;
          end;
       end;
     end;

Obs.: O que significa

Agradeces porque assim te faziam a paparoca toda
e
Desbobina isso.
Link to comment
Share on other sites

Nuno, tenha calma comigo, como explicado minha situação é complicada.

Tudo calmo... 🙂 Mas como não sabemos o teu nivel de conhecimento de pascal, por vezes podemos dizer algo que esteja acima.

Olha o que vc me mandou, coloquei e ficou perfeito.

Ainda bem. Para os restantes é inserires aquela função do Thoga no programa, e depois testar:

   repeat   
      write ('Informe Seu Nome:');
      readln (reg.nome);
      if not OnlyLetters_And_HigherThanLimit(reg.Nome,3) then writeln('Nome inválido...');   
   until OnlyLetters_And_HigherThanLimit(reg.Nome,3);  // = True se a string só tiver letras e for maior que 3


   repeat
     write ('Informe o valor do lance:(De 0.01 a 100.00 R$): ');
     readln (s);   // Le o input do utilizador para uma string
     Val(s,reg.Lance,ErrCode);  // Converte a string para um valor real em reg.Lance: Se correr bem, ErrCode será 0
     Invalido:=(ErrCode>0) or (reg.Lance<0.01) or (reg.Lance>100);  // Verifica se o valor inserido é valido
     if Invalido then writeln('lance invalido!');  // Se não for, avisa o utilizador
   until not Invalido;  // Repete até encontrar um valor válido.

   write('Informe Fone:');
   readln (reg.fone);

E só ficaria faltando a ultima parte com o lance menor e único. Aqui no meu só mostra o menor.

Divide o problema em vários. Por exemplo, este método é talvez o mais simples:

1ª questão: Recolhes numa matriz todos os valores únicos e a sua posição no ficheiro

- Sabes trabalhar com arrays e matrizes? Se sim, é só usares um ciclo FOR para ler todos os dados do ficheiro, e de cada vez que lês um registo, percorres a matriz (com outro ciclo FOR por exemplo). Se encontrar na matriz o valor lido, apaga-o de lá. Se não o encontrar, insere-o lá.

2ª questão: Procuras na matriz qual o menor valor.

3ª Questão: mostras o valor

Dos 3 problemas, qual é que tens duvidas?

PS:

paparoca significa papa ou comida. Ter a paparoca feita é uma expressão que significa não ter trabalho a fazer algo.

Desbobina é uma palavra usada para indicar a alguém para se explicar melhor, para falar mais.

"A humanidade está a perder os seus génios... Aristóteles morreu, Newton já lá está, Einstein finou-se, e eu hoje não me estou a sentir bem!"

> Não esclareço dúvidas por PM: Indica a tua dúvida no quadro correcto do forum.

Link to comment
Share on other sites

o teu nivel de conhecimento de pascal

Fiz o projeto ate aqui com livro aqui do meu lado, estou vendo tudo agora. Como dizemos por aqui:

" A NECESSIDADE FAZ O SAPO PULAR."

Coloquei no meu projeto:

repeat   
      write ('Informe Seu Nome:');
      readln (reg.nome);
      if not OnlyLetters_And_HigherThanLimit(reg.Nome,3) then writeln('Nome inválido...');   
   until OnlyLetters_And_HigherThanLimit(reg.Nome,3);  // = True se a string só tiver letras e for maior que 3

Onde coloco este aqui:

function OnlyLetters_And_HigherThanLimit(Line : String; Limit : word) : Boolean;
var i : integer;

Não estou sabendo onde colocar no meu projeto. Por isso esta dando erro.

Se puderes fazer como acima agradeço.

E sobre:

- Sabes trabalhar com arrays e matrizes?

Estou lendo aqui agora, fiz uns exemplos e estou meio sem entender.

Sempre que me ajudar com alguma dica, coloca no projeto como exemplo.

E sobre as palavras foi bom, vai enriquecer meu vocabulário agora.

Mais uma vez obrigado pela atenção!  🙂

Link to comment
Share on other sites

O que o Thoga te deu foi uma função prontinha.

Terás de a colocar antes dos procedimentos todos:

.
.
.
var
    arquivo: file of TApostador;
    reg:TApostador;
    opcao:char;
    qtde_depois, qtde_antes: integer;
    dia,mes,ano,dia_semana:word;

<---   É aqui que inseres o código do Thoga

procedure menu_principal;
var i:integer;
begin
.
.
.

Do outro problema: Dizes que estás meio sem entender. Qual parte (das 3 que te mostrei)?

Sugiro-te que leias o tutorial de pascal cá do forum, de autoria do Thoga, que explica muito bem as bases do Pascal. Depois de o estudares, terás a tarefa muito facilitada.

"A humanidade está a perder os seus génios... Aristóteles morreu, Newton já lá está, Einstein finou-se, e eu hoje não me estou a sentir bem!"

> Não esclareço dúvidas por PM: Indica a tua dúvida no quadro correcto do forum.

Link to comment
Share on other sites

Nuno, estou fazendo errado com certeza, olha como fiz:

var
    s:String;
    ErrCode:integer;
    Invalido:Boolean;
    arquivo: file of TApostador;
    reg:TApostador;
    opcao:char;
    qtde_depois, qtde_antes: integer;
    dia,mes,ano,dia_semana:word;

function OnlyLetters_And_HigherThanLimit(Line : String; Limit : word) : Boolean;
var i : integer;

procedure menu_principal;
var i:integer;
begin

e a outra parte:

// houve erro, arquivo foi criado
   rewrite(arquivo);

   repeat   
      write ('Informe Seu Nome:');
      readln (reg.nome);
      if not OnlyLetters_And_HigherThanLimit(reg.Nome,3) then writeln('Nome inválido...');
   until OnlyLetters_And_HigherThanLimit(reg.Nome,3);  // = True se a string só tiver letras e for maior que 3

   repeat
     write ('Informe o valor do lance:(De 0.01 a 100.00 R$): ');
     readln (s);   // Le o input do utilizador para uma string
     Val(s,reg.Lance,ErrCode);  // Converte a string para um valor real em reg.Lance: Se correr bem, ErrCode será 0
     Invalido:=(ErrCode>0) or (reg.Lance<0.01) or (reg.Lance>100);  // Verifica se o valor inserido é valido
     if Invalido then writeln('lance invalido!');  // Se não for, avisa o utilizador
   until not Invalido;  // Repete até encontrar um valor válido.

Fica mostrando erro.

Entendi os FOR, só não sei como fazer.

Link to comment
Share on other sites

Está a dar erro porque não inseriste a função completa.

Tens a certeza que fizeste o resto do programa?  🙂 ?

Como fizeste os vários procedimentos, terás de inserir a função:

var
    s:String;
    ErrCode:integer;
    Invalido:Boolean;
    arquivo: file of TApostador;
    reg:TApostador;
    opcao:char;
    qtde_depois, qtde_antes: integer;
    dia,mes,ano,dia_semana:word;

function OnlyLetters_And_HigherThanLimit(Line : String; Limit : word) : Boolean;
var i : integer;
begin
     if (Length(Line) >= Limit) then begin  // está acima do limite mínimo?
        OnlyLetters := true;
        for i:=1 to Length(Line) do begin
            if (Line[i] in ['0'..'9']) then  // tem algarismos?
               OnlyLetters := false;
        end;
     end else OnlyLetters := false;
end;

procedure menu_principal;
var i:integer;
begin
.
.
.
 

O outro problema (e mesmo a função que o Thoga fez) é mais complexo, é certo, mas é mesmo por isso que precisas de o perceber bem, caso contrário quando chegares à aula, o professor vai ver aquilo e se desconfiar que não foste tu, vai-te perguntar sobre como fizeste, e aí sim, estás tramado ( = ferrado 😄 ).

Eu, e os outros do forum, podemos ajudar-te, mas se fizermos simplesmente o procedimento todo, não estarás a aprender nada, e estarás a colocar em risco toda a avaliação dessa aula.

Vamos por partes. Daqueles três pontos que falei para resolveres o problema, vamos começar por resolver o primeiro:

Citação

1ª questão: Recolhes numa matriz todos os valores únicos e a sua posição no ficheiro

- Sabes trabalhar com arrays e matrizes? Se sim, é só usares um ciclo FOR para ler todos os dados do ficheiro, e de cada vez que lês um registo, percorres a matriz (com outro ciclo FOR por exemplo). Se encontrar na matriz o valor lido, apaga-o de lá. Se não o encontrar, insere-o lá.

Já sabes declarar a matriz?

"A humanidade está a perder os seus génios... Aristóteles morreu, Newton já lá está, Einstein finou-se, e eu hoje não me estou a sentir bem!"

> Não esclareço dúvidas por PM: Indica a tua dúvida no quadro correcto do forum.

Link to comment
Share on other sites

Aproveito para informar que, na minha função, OnlyLetters deve ser substituído pelo nome da função, OnlyLetters_And_HigherThanLimit. Isto porque o nome original era OnlyLetters e só depois reparei que era necessário limite mínimo de caracteres. 🙂

Knowledge is free!

Link to comment
Share on other sites

Aproveito para informar que, na minha função, OnlyLetters deve ser substituído pelo nome da função, OnlyLetters_And_HigherThanLimit. Isto porque o nome original era OnlyLetters e só depois reparei que era necessário limite mínimo de caracteres. 🙂

LOL, nem reparei.

De qualquer maneira, convém o Junior usar a tua função para análise, e depois criar uma dele, caso contrário poderá ter problemas!

"A humanidade está a perder os seus génios... Aristóteles morreu, Newton já lá está, Einstein finou-se, e eu hoje não me estou a sentir bem!"

> Não esclareço dúvidas por PM: Indica a tua dúvida no quadro correcto do forum.

Link to comment
Share on other sites

Vamos agora para o menor e único, aqui esta quase saindo.

Isso é que eu gosto de ouvir... 🙂

"A humanidade está a perder os seus génios... Aristóteles morreu, Newton já lá está, Einstein finou-se, e eu hoje não me estou a sentir bem!"

> Não esclareço dúvidas por PM: Indica a tua dúvida no quadro correcto do forum.

Link to comment
Share on other sites

Já agora Junior, uma dica:

Se tentares listar os apostadores antes de os cadastrares (por exemplo, se saiste do programa e voltaste a entrar), dá erro.

A mesma coisa se tentares ver o vencedor.

Isto acontece porque estás a fazer o Assign ao ficheiro no procedimento de cadastrar, o que está mal.

O Assign deverá ser feito logo no programa principal, antes de qualquer outra coisa.

É aí que testas se o ficheiro existe, e crias um novo se não existir, e por fim fechas o ficheiro.

Assim, ele estará pronto para fazer o reset em qualquer dos procedimentos que chames.

"A humanidade está a perder os seus génios... Aristóteles morreu, Newton já lá está, Einstein finou-se, e eu hoje não me estou a sentir bem!"

> Não esclareço dúvidas por PM: Indica a tua dúvida no quadro correcto do forum.

Link to comment
Share on other sites

Fiz o seguinte:

Criei outro arquivo binário auxiliar para guardar os mesmos valores dos lances do arquivo principal;

Depois fiz um for i e dentro dele um for j comparado os valores do arquivo principal com o arquivo auxiliar.

Bugs:

1 - Quando clico em lista ele não lista.

2 - Quando clico em Ganhador ele não mostra.

3 - Não sei se o FOR esta do jeito que vc me pediu.

program lance_unico;

uses crt,dos;

type Tdata = record
     dia,mes,ano: integer;
end;

//ARQUIVO AUXILIAR
type TLance = record
      nome2 : string[20];
      lance_unico:real;
      fone2 : string[10];
      data2:Tdata;

end;
type
     TApostador = record
     nome : string[20];
     lance: real;
     fone : string[10];
     data:Tdata;
end;

var
    s:String;
    ErrCode:integer;
    Invalido:Boolean;
    arquivo: file of TApostador;
    reg:TApostador;
    arq_auxiliar: file of TLance;
    reg2:TLance;
    opcao:char;
    qtde_depois, qtde_antes: integer;
    dia,mes,ano,dia_semana:word;

function letras(Line : String; Limit : word) : Boolean;
var i : integer;
begin
     if (Length(Line) >= Limit) then begin  // está acima do limite mínimo?
        letras := true;
        for i:=1 to Length(Line) do begin
            if (Line[i] in ['0'..'9']) then  // tem algarismos?
               letras := false;
        end;
     end else letras := false;
end;

procedure menu_principal;
var i:integer;
begin
clrscr;

//nomear o arquivo
   assign(arquivo,'c:\teste.pas');

    //nomear o arquivo auxiliar
   assign(arq_auxiliar,'c:\auxiliar.binario');

   //tentar abrir o arquivo binario

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

   // verificar se arquivo foi aberto, ou seja, não houve erro
   if (IOResult <> 0) then

   // houve erro, arquivo foi criado
   rewrite(arquivo);

   //tentar abrir o arquivo auxiliar

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

   // verificar se arquivo auxiliar foi aberto
   if (IOResult <> 0) then

   // houve erro, arquivo foi criado
   rewrite(arq_auxiliar);


   //tabela com menu principal
  for i := 30 to 60 do
      begin
         textbackground(7);
         textcolor(7);
         gotoxy(i,8);   write(#196);
         textbackground(1);
         textcolor(1);
         gotoxy(i,9);   write(#196);
         textbackground(7);
         textcolor(7);
         gotoxy(i,10);   write(#196);
         textbackground(1);
         textcolor(1);
         gotoxy(i,11);   write(#196);
         textbackground(7);
         textcolor(7);
         gotoxy(i,12);   writeln(#196);

      end;
   textbackground(7);
   textcolor(0);
   gotoxy(36,8);   writeLN('  MENU PRINCIPAL ');
   textbackground(1);
   textcolor(14);
   gotoxy(34,9);   writeLN(' 1 - CADASTRAR APOSTAS  ');
   textbackground(7);
   textcolor(0);
   gotoxy(34,10);   writeLN(' 2 - LISTAR APOSTAS   ');
   textbackground(1);
   textcolor(14);
   gotoxy(34,11);   writeLN(' 3 - EXIBIR GANHADOR  ');
   textbackground(7);
   textcolor(0);
   gotoxy(34,12);   writeLN(' 4 - SAIR DO JOGO ');

end;

procedure cadastrar_apostadores;
begin

  repeat
   write ('Informe Seu Nome:');
   readln (reg.nome);
   reg2.nome2:=reg.nome;
   if not letras(reg.Nome,3) then writeln('Nome invalido...');
  until letras(reg.Nome,3);  // = True se a string só tiver letras e for maior que 3

  repeat
   write ('Informe o valor do lance: ');
   readln (s);
   reg2.lance_unico:= reg.lance;
   Val(s,reg.lance,ErrCode);  // Converte a string para um valor real em reg.Lance: Se correr bem, ErrCode será 0
     Invalido:=(ErrCode>0) or (reg.Lance<0.01) or (reg.Lance>100);  // Verifica se o valor inserido é valido
     if Invalido then writeln('lance invalido!');  // Se não for, avisa o utilizador
  until not Invalido;  // Repete até encontrar um valor válido.

   write('Informe Fone:');
   readln (reg.fone);
   reg2.fone2:=reg.fone;

   getdate(ano, mes, dia, dia_semana);
   reg.data.ano:=ano;
   reg.data.mes:=mes;
   reg.data.dia:=dia;
   reg2.data2.ano:=ano;
   reg2.data2.mes:=mes;
   reg2.data2.dia:=dia;

   // obter a quantidade de registros, antes de gravar
   qtde_antes := filesize(arquivo);

   // deslocar para o final do arquivo
   seek(arquivo, filesize(arquivo));
   seek(arq_auxiliar, filesize(arq_auxiliar));
   //persistir no arquivo
   write(arquivo,reg);
   write(arq_auxiliar,reg2);

   // obter a quantidade de registros, depois de gravar
   qtde_depois := filesize(arquivo);

   if (qtde_depois > qtde_antes) then
   writeln('Registro gravado com sucesso!')
   else
   writeln('Erro: Registro nao gravado com sucesso!');

   close(arquivo);
   close(arq_auxiliar);
end;

procedure listar_apostas;
var i,j:integer;

begin
    //tentar abrir o arquivo binario

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

    // verificar se arquivo foi aberto, ou seja, não houve erro
    if (IOResult <> 0) then
    // houve erro
    write(' nao existe apostas feitas') else
    begin

       // deslocar para o início do arquivo
       seek(arquivo, 0);
       for i := 1 to filesize(arquivo) do
       begin
          // ler do arquivo
          read(arquivo, reg);

          // exibir a informação que foi lida
          writeln('REG',i - 1,':NOME : ', reg.nome,'       LANCE: ', reg.lance:2:2);
          writeln('     TELEFONE: ', reg.fone,'     DATA: ', reg.data.dia,'/',reg.data.mes,'/',reg.data.ano);
          writeln('========================================');
          writeln;
       end;
    end;


   // ABRIR O ARQUIVO AUXILIAR /SO TESTANDO SE ELE GRAVOU NO SEGUNDO ARQUIVO
    writeln;  writeln;
   {$I-}
    reset(arq_auxiliar);
    {$I+}

    // verificar se arquivo foi aberto, ou seja, não houve erro
    if (IOResult <> 0) then
    // houve erro
    write(' nao existe apostas feitas') else
    begin
       writeln (' REGISTRO 2');
       writeln;

       // deslocar para o início do arquivo
       seek(arq_auxiliar, 0);
       for j := 1 to filesize(arq_auxiliar) do
       begin
          // ler do arquivo
          read(arq_auxiliar, reg2);

          writeln('REG',i - 1,':NOME : ', reg2.nome2,'       LANCE: ', reg2.lance_unico:2:2);
          writeln('     TELEFONE: ', reg2.fone2,'     DATA: ', reg2.data2.dia,'/',reg2.data2.mes,'/',reg2.data2.ano);
          writeln('========================================');
          writeln;
       end;
    end;
     close(arquivo);
    close(arq_auxiliar);

end;

procedure verificar_ganhador;

var i,j,posicao,qtd_igual:integer;
              menor:real;

begin
clrscr;
menor:=100;// maior valor possivel,qualquer lance sera menor ou igual

    //tentar abrir o arquivo binario
    {$I-}
    reset(arquivo);
    {$I+}

    // verificar se arquivo foi aberto, ou seja, nao houve erro
    if (IOResult <> 0) then

    // houve erro
    write('nao existe aposta');

     //tentar abrir o arq auxiliar
    {$I-}
    reset(arq_auxiliar);
    {$I+}

    // verificar se arquivo foi aberto, ou seja, nao houve erro
    if (IOResult <> 0) then

    // houve erro
    write('nao existe aposta');

    //deslocar para o inicio dos arquivos
    seek(arquivo, 0);
    seek(arq_auxiliar, 0);

       for i := 1 to filesize(arquivo) do
       begin
       qtd_igual:= 0;

          for j:= 1 to filesize(arq_auxiliar) do
          begin
              read(arquivo, reg); // ler do arquivo,essa parte que t  dando problema,
              read(arq_auxiliar, reg2); // se tirar, o programa executa a opcao 3,porem executa errado

              if (reg.lance = reg2.lance_unico) then
               qtd_igual:= qtd_igual + 1; //para um lance ser diferente dos outros a qtd
                                         // que ser igual a 1,que e o proprio numero no outro arquivo
          end;//fim do j

          if(qtd_igual = 1) then //so existe um numero igual,que e ele mesmo no outro arquivo
          if( reg.lance < menor)then

          begin
              menor:= reg.lance;
              posicao:= i; //posicao do menor no arquivo
          end;

          end;//fim do for i

          writeln('a quantidade de lances iguais e;', qtd_igual);

          if(menor=100) then //nao tem lance unico
          write('nao houve menor lance unico')

          else
          writeln('menor valor e unico: ',menor:2:2);

    //deslocar para posicao do ganhador no arquivo
    seek(arquivo,posicao);

    //ler o registro ganhador

    read(arquivo,reg);
    writeln('ganhador: ', reg.nome);
    writeln('menor_lance:',menor:2:2);

    close(arquivo);
    close(arq_auxiliar);

end;

begin
clrscr;
repeat
    clrscr;
    menu_principal;
    writeln;
    gotoxy(34,14);  write('digite sua opcao: ');
    opcao:=readkey;
    writeln(opcao);
    textbackground(0);
    case (opcao) of

    '1': begin
            textcolor(12);
            writeln;
            writeln('CADASTRAR APOSTAS');
            writeln;
            textcolor(9);
            cadastrar_apostadores;
         end;
    '2': begin
            textcolor(12);
            writeln;
            writeln(' APOSTAS CADASTRADAS ');
            textcolor(9);
            listar_apostas;
         end;
    '3': begin
            textcolor(12);
            writeln;
            writeln(' GANHADOR ');
            textcolor(9);
            verificar_ganhador;
         end;
    '4': begin
            textcolor(12);
            writeln;
            write(' volte sempre');
         end;
     end;//fim do case

readkey;
until(opcao='4');
end.
Link to comment
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
 Share

×
×
  • Create New...

Important Information

By using this site you accept our Terms of Use and Privacy Policy. We have placed cookies on your device to help make this website better. You can adjust your cookie settings, otherwise we'll assume you're okay to continue.