Allow to command different things (pizza, bevarages) in a school cafeteria (open at lunch time) using uniquely the arrows of the keyboard and make the total to pay automatically

Kategória: KMP (Klub mladých programátorov)
cafet.jpgProgram: Cafet.pas
Súbor exe: Cafet.exe
Potrebné: Cafet.lst

Allow to command different things (pizza, bevarages) in a school cafeteria (open at lunch time) using uniquely the arrows of the keyboard and make the total to pay automatically. At the end of the week, recapitulate all the totals of the week (before year 2000 !) . 
{ CAFET.PAS                                                         }
{ Allow to command different things (pizza, bevarages) in a school  }
{ cafeteria (open at lunch time) using uniquely the arrows of the   }
{ keyboard and make the total to pay automatically.                 }
 
{                                                                   }
{ At the end of the week, recapitulate all the totals of the week   }
{ (before year 2000 !)                                              }
{                                                                   }
{ Author: Unknown                                                   }
{ Datum: 20.01.2009                            http://www.trsek.com }
 
program caf44cga;
uses crt,dos;
const
  max = 40;
var
  col0, col1, col14, col15            : integer;
  t1, t2, ch, cat                     : char;
  n, no, col, lig, x, y, code, fl, i  : integer;
  tot, ben, total, benef              : real;
  totsem, bensem, num                 : real;
  strn                                : string;
  mot_p, pw                           : string[5];
  nom_f, jjmm                         : string[6];
  des                                 : string[16];
  fic                                 : text;
  suite                               : boolean;
  nbr                                 : array [1..max] of real;
  totj, benj                          : array[1..10] of real;
  datjour, totjour, benjour           : array[1..10] of string;
  ch1, ch2, ch3                       : array [0..max] of string[16];
  fich                                : array [0..10] of string[6];
  regs                                : registers;
  keyflag                             : byte absolute $40:$17;
 
Function Frs(rl:real):real;
var
  i:longint;  s:string;
begin
  i :=round(rl);
  str(i,s);
  case length(s) of
    1 :  s:=' 0.0'+s;
    2 :  s:=' 0.'+s;
    else s:=copy(s,1,length(s)-2)+'.'+copy(s,length(s)-1,2);
  end;
  write(' ':8-length(s),s);
end;
 
Function Chfr(ch:string):string;
begin
write(' ':6-length(ch));
if length(ch)=2 then write('0')else write(' ');
write(copy(ch,1,length(ch)-2),',');
write(copy(ch,length(ch)-1,2));
end;
 
Function FFrs(rl:real):real;
var  i:longint;  s:string;
begin
  write(Fic,'FS ');
  i :=round(rl);
  str(i,s);
  case length(s) of
    1 :  s:=' 0.0'+s;
    2 :  s:=' 0.'+s;
    else s:=copy(s,1,length(s)-2)+'.'+copy(s,length(s)-1,2);
  end;
  writeln(Fic,' ':8-length(s),s);
end;
 
Procedure CursOff;
Begin
  FillChar(Regs,SizeOf(Regs),0);
  With Regs Do
    Begin
    AH:=$01;
    CH:=20;
    CL:=0;
    End;
  Intr($10,Regs);
End;
 
Procedure CursOn;
Begin
  FillChar(Regs,SizeOf(Regs),0);
  With Regs Do
    Begin
    CH:=6;
    CL:=7;
    AH:=$01;
    End;
  Intr($10,Regs);
End;
 
procedure mot_de_passe;
begin
  ch := ' ';
  gotoxy(15,19);
  writeln('Veuillez taper le mot de passe ( ESC pour terminer )');
  writeln;
  mot_p := '';
  gotoxy(37,21);
  ch:=upcase(readkey);
  if ch <> #27 then
  repeat
    mot_p := mot_p + ch;write('.');
    gotoxy(37,21);
    for n:= 1 to 4 do
    begin
      gotoxy(37+2*n,21);
      ch:=upcase(readkey);
      mot_p := mot_p + ch;write('.');
    end;
    if mot_p <> pw then
    begin
      write(#7); write('.'); gotoxy(37,21);clreol;
      mot_p := '';
      ch := upcase(readkey);
    end;
  until mot_p = pw
  else
  begin
    curson;
    clrscr; writeln; writeln;
    write('Avec le bonjour de Jean-Daniel Greub !');
    writeln; writeln;
  end;
  gotoxy(37,21);clreol;
end;
 
procedure saisir_nom_fichier;
{seuls noms de fichiers admis: DATES DU TYPE JJMMAA}
begin
  ch := ' ';
  while ch <> 'O' do
    begin
    nom_f:='';
    gotoxy(57,19);write('      ');gotoxy(57,19);
    repeat ch:=readkey until ch in ['0'..'3'];
    write(ch); nom_f:=nom_f + ch;
    repeat ch:=readkey until ch in ['0'..'9'];
    write(ch); nom_f:=nom_f + ch;
    repeat ch:=readkey until ch in ['0'..'1'];
    write(ch); nom_f:=nom_f + ch;
    repeat ch:=readkey until ch in ['0'..'9'];
    write(ch); nom_f:=nom_f + ch;
    repeat ch:=readkey until ch = '9';
    write(ch); nom_f:=nom_f + ch;
    repeat ch:=readkey until ch in ['5'..'9'];
    write(ch); nom_f:=nom_f + ch;
    gotoxy(15,21);write('Cette date est-elle correcte  ( O / N )  ? ');
    repeat ch :=upcase(readkey) until ch in['O','N']; writeln(ch);
    gotoxy(14,21);clreol;
    end;
  clrscr;
end;
 
procedure ouvrir_fichier;
var i     : integer;
    ch    : char;
begin
  gotoxy (15,19);clreol; curson;
  write('Veuillez taper la date au format JJMMAA  [      ]');
  textcolor(col15);
  saisir_nom_fichier; cursoff;
  assign(fic,nom_f);
  {$I-}
    reset(fic);
    i := ioresult;
  {$I+}
  if i<>0 then rewrite(fic);
  gotoxy(1,24);clreol;
  gotoxy(76,23);
end;
 
Procedure lire_fichier_donnees;
(***
Cette proc‚dure commence par lire les donn‚es du fichier < CAFET.LST >
qui fichier DOIT ˆtre constitu‚ de 40 groupes de 3 ‚l‚ments :
LIGNE 1  : d‚signation (doit contenir 16 caractŠres ou espaces)
LIGNE 2  : prix en centimes (min = 0), suivi imm‚diatement d'un <return>
LIGNE 3  : b‚n‚fice en centimes (min = 0), suivi imm‚diatement d'un <return>
***)
begin
clrscr;
  no := 1;
  Assign(Fic, 'cafet.lst');  { Standard output }
  Reset(Fic);
  des := ' ';
  for n:= 1 to max do
  begin
    Readln(Fic,des); ch1[no] := des;
    Readln(Fic,des); ch2[no] := des;
    Readln(Fic,des); ch3[no] := des;
    inc(no);
  end;
  Close(Fic);
end;
 
procedure titre;
begin
cursoff;
ch:=' ';
textcolor(col14);
textbackground(col1);
clrscr;
gotoxy(28,05);writeln('COLLEGE  DE  LA  FLORENCE');
gotoxy(32,07);writeln('Jean-Daniel Greub');
gotoxy(14,09);write(#218);for n:=1 to 51 do write(#196);writeln(#191);
gotoxy(14,10);write(#179);for n:=1 to 51 do write(#032);writeln(#179);
gotoxy(14,11);writeln(#179,'    ÛÛÛÛÛÛ±  ÛÛÛÛÛÛ±  ÛÛÛÛÛÛ±  ÛÛÛÛÛÛ±  ÛÛÛÛÛÛ±    ',#179);
gotoxy(14,12);writeln(#179,'    ÛÛ±      ÛÛ± ÛÛ±  ÛÛ±      ÛÛ±        ÛÛ±      ',#179);
gotoxy(14,13);writeln(#179,'    ÛÛ±      ÛÛÛÛÛÛ±  ÛÛÛÛ±    ÛÛÛÛ±      ÛÛ±      ',#179);
gotoxy(14,14);writeln(#179,'    ÛÛ±      ÛÛ± ÛÛ±  ÛÛ±      ÛÛ±        ÛÛ±      ',#179);
gotoxy(14,15);writeln(#179,'    ÛÛÛÛÛÛ±  ÛÛ± ÛÛ±  ÛÛ±      ÛÛÛÛÛÛ±    ÛÛ±      ',#179);
gotoxy(14,16);write(#179);for n:=1 to 51 do write(#032);writeln(#179);
gotoxy(14,17);write(#192);for n:=1 to 51 do write(#196);writeln(#217);
gotoxy(31,19);textcolor(col14);
pw := #84+#69+#70+#65+#67;
end;
 
procedure enregistrer;
{sauvegarde des donn‚es sur disque dans un fichier ayant une date pour titre}
begin
  Assign(Fic,nom_f);
  Rewrite(Fic);
  Writeln(Fic,'------------------------------');
  Writeln(Fic,'Date du jour     : ',nom_f);
  Writeln(Fic,'------------------------------');
  Write(Fic,'Total des ventes : '); FFrs(Total);
  Write(Fic,'B‚n‚fice total   : '); FFrs(Benef);
  Writeln(Fic,'------------------------------');
  num := 1;
  for n := 1 to 40 do
  begin
    if nbr[trunc(num)] > 0 then
    Writeln(Fic,ch1[trunc(num)],'  ',nbr[trunc(num)]:3:0);
    num := num + 1;
  end;
  Writeln(Fic,'------------------------------');
  Close(Fic);
  clrscr;
  gotoxy(01,4);
  for n:=1 to 79 do write('-');
  gotoxy(01,6);
  writeln('Le nom du fichier de sauvegarde est < ',nom_f,' >');
  writeln('                                      ------');
  writeln;
  writeln('Il peut ˆtre ais‚ment visualis‚ en tapant < L > pour L.COM');
  writeln;
  for n:=1 to 79 do write('-');
  gotoxy(01,13); writeln ('avec le bonjour de Jean-Daniel Greub !');
  textcolor(col15);textbackground(col1);
end;
 
procedure recap;
begin
 
  { ENTREE DES NOMS DES n FICHIERS }
  curson;
  n:=1; clrscr; gotoxy(1,2);
  writeln('R‚capitulation des r‚sultats de plusieurs journ‚es');
  writeln('--------------------------------------------------');
  write('Taper  0000  pour terminer !            ');
  writeln('Ann‚e 19',copy(nom_f,5,2));
  while jjmm <> '0000' do
  begin
    writeln;
    write('Taper sous la forme JJMM la date du ');
    write ('fichier num‚ro ',n,'   [    ]');
    gotoxy(57,wherey);
    jjmm := '';
    repeat ch:=readkey until ch in ['0'..'3']; write(ch);jjmm := jjmm + ch;
    repeat ch:=readkey until ch in ['0'..'9']; write(ch);jjmm := jjmm + ch;
    repeat ch:=readkey until ch in ['0'..'1']; write(ch);jjmm := jjmm + ch;
    repeat ch:=readkey until ch in ['0'..'9']; write(ch);jjmm := jjmm + ch;
    fich[n] := jjmm + copy(nom_f,5,2);
    assign(fic,fich[n]);
    {$I-}
    reset(fic);
    i := ioresult;
    {$I+}
    if i<>0 then rewrite(fic);
    if i=2 then begin gotoxy(63,wherey); write(' N''EXISTE PAS !'); end;
    if i= 0 then
      begin
        if eof(fic) = true then
          begin
            gotoxy(63,wherey); write(' FICHIER VIDE !');
          end;
        inc(n);
      end;
    close(fic);
  end;
 
 
  gotoxy(01,5+n);clreol;writeln;
  clrscr;
  totsem := 0; bensem := 0;
  writeln('R‚capitulation des r‚sultats de la semaine');
  writeln('------------------------------------------'); writeln;
  writeln('Date         Total    B‚n‚fice'); writeln;
 
 
  { LECTURE LIGNE PAR LIGNE DES NOMS DES n FICHIERS }
  for n := 1 to n - 1 do
  begin
    assign(fic,fich[n]);
    {$I-}
    reset(fic);
    i := ioresult;
    {$I+}
    strn := '';
    Readln(Fic,strn);                                           {LIGNE 1}
    Readln(Fic,strn);                                           {LIGNE 2}
    datjour[n]:=copy(strn,length(strn)-5,6);                    {LIGNE 3}
    Readln(Fic,strn);                                           {LIGNE 4}
    Readln(Fic,strn);                                           {LIGNE 5}
    totjour[n]:=copy(strn,length(strn)-7,5) + copy(strn,length(strn)-1,2);
    { writeln; writeln(totjour[n]) }
    Readln(Fic,strn);                                           {LIGNE 7}
    benjour[n]:=copy(strn,length(strn)-7,5) + copy(strn,length(strn)-1,2);
    val(totjour[n],totj[n],code); totj[n] := totj[n]/100;
    val(benjour[n],benj[n],code); benj[n] := benj[n]/100;
    gotoxy (01,wherey); write(datjour[n]);
    gotoxy (12,wherey); write(totj[n]:8:2);
    gotoxy (24,wherey); write(benj[n]:7:2); writeln;
    totsem := totsem + totj[n];
    bensem := bensem + benj[n];
  close(Fic);
  end;
  writeln('------------------------------');
  gotoxy (12,wherey); write(totsem:8:2);
  gotoxy (24,wherey); write(bensem:7:2); writeln;
  curson;
  writeln; writeln;
  write('Avec le bonjour de Jean-Daniel Greub !');
  writeln; writeln;
end;
 
procedure lire_nombre;
begin
strn := '';
ch := ' ';
while ch <> #13 do
  begin
    repeat ch:= readkey until ch in ['0'..'9',#13];
    if ch <> #13 then begin write(ch); strn:=strn + ch; end;
  end;
val(strn,n, Code);
{les caractŠres num‚riques de la chaŒne passe dans l'integer n}
end;
 
procedure saisie;
begin
fl := 0; cursoff; clrscr;
 
{ affichage des articles … choisir }
textcolor(col15); textbackground(col1); clrscr; no := 1; lig:=1;
repeat
  gotoxy(01,lig); write(ch1[no]); inc(no);
  gotoxy(21,lig); write(ch1[no]); inc(no);
  gotoxy(41,lig); write(ch1[no]); inc(no);
  gotoxy(61,lig); write(ch1[no]); inc(no);
  lig := lig + 2;
until no > max;
gotoxy(01,22);
writeln('Utiliser les flŠches pour choisir puis presser < RETURN >');
GOTOXY(01,24);
writeln('Presser la touche < ESC > quand tout est saisi');
 
{*********************************************************************}
 
{SAISIES MULTIPLES, SORITE AVEC <ESC>}
 
no := 1; col := 01; lig := 01; gotoxy(col,lig);
t1:=' ';t2:=' ';
while t1 <> #27 do
begin
  repeat t1:=readkey until t1 in [#0,#13,#27];
  if ord(t1)= 0 then
  begin
    t2 := readkey;
    textcolor(col15); textbackground(col1); writeln(ch1[trunc(num)]);
    if ord(t2)=72 then fl:=1; if ord(t2)=75 then fl:=1;
    if ord(t2)=77 then fl:=1; if ord(t2)=80 then fl:=1;
    if (ord(t2)=72) and (lig > 01) then lig := lig - 02;
    if (ord(t2)=75) and (col > 01) then col := col - 20;
    if (ord(t2)=77) and (col < 60) then col := col + 20;
    if (ord(t2)=80) and (lig < 19) then lig := lig + 02;
    num := (col + 19) / 20 + (lig-1) * 2; gotoxy(col, lig);
    x := wherex; y := wherey;
    textcolor(col1); textbackground(col15); writeln(ch1[trunc(num)]);
    gotoxy(01,23);clreol;{write('col ',col,'  lig ',lig,'  num ',num:3:0);}
    gotoxy(x,y);
  end else
  if (ord(t1)=13) and (fl = 1) then
  begin
    des := ch1[trunc(num)]; n := 0; gotoxy(01,22); clreol;
    writeln('Taper le nombre d''articles, puis presser < RETURN >');
    gotoxy(1,23); clreol;
    curson; write('Nb de < ',des,'>  ');
    lire_nombre; cursoff;
    gotoxy(1,23); clreol; gotoxy(01,22); clreol;
    writeln('Utiliser les flŠches pour choisir puis presser < RETURN >');
    nbr[trunc(num)] := n;
  end;
end;
clrscr; total := 0; benef := 0;
for n:=1 to 79 do write('-'); writeln;
 
{affichage des valeurs venant d'ˆtre saisies}
textcolor(col15); textbackground(col1); clrscr;
num := 1;          {real}
lig := 1;
for n := 1 to 40 do
begin
  if (nbr[trunc(num)] > 0) and (ch2[trunc(num)] <> '0') then
  begin
    write(nbr[trunc(num)]:3:0,' ',ch1[trunc(num)],' … ');
    chfr(ch2[trunc(num)]);
    val(ch2[trunc(num)], Tot, Code); gotoxy(34,wherey);
    write (' Prix total : '); Frs(Tot * nbr[trunc(num)]);
    val(ch3[trunc(num)], Ben, Code); gotoxy(60,wherey);
    write ('B‚n‚fice : ');   Frs(Ben * nbr[trunc(num)]);
    writeln;
    Total := Total + Tot * nbr[trunc(num)];
    Benef := Benef + Ben * nbr[trunc(num)];
    inc(lig);
  end;
  num := num + 1;
  IF lig = 21 THEN
  BEGIN
  WRITELN; WRITE('Presser une touche pour continuer !');
  READKEY; WRITELN; WRITELN;
  END;
end;
 
for n:=1 to 79 do write('-'); writeln;
gotoxy(01,wherey); write('DATE  : ',nom_f);
gotoxy(35,wherey); write('TOTAL      : '); Frs(Total);
gotoxy(60,wherey); write('BENEFICE : ');   Frs(Benef);
writeln;
ch := ' ';
curson;
writeln;
write('Les donn‚es ci-dessus sont-elles correctes (O / N) ? ');
ch := upcase(readkey);
if upcase(ch) = 'O' then
begin write (ch);enregistrer;end
else begin write (ch);saisie;end;
end;
 
procedure choix;
begin
clrscr;
gotoxy(16,09);write('Voulez-vous...');
gotoxy(16,12);write('1. Enr‚gistrer les r‚sultats d''une journ‚e ?');
gotoxy(16,14);write('2. R‚capituler les r‚sultats de plusieurs journ‚es ?');
gotoxy(16,18);write('Taper  1  ou  2');
repeat ch:=readkey until ch in ['1'..'2'];
if ch = '1' then saisie;
if ch = '2' then recap;
end;
 
procedure choix_ecran;
begin
 
col0 := 0;
col1 := 0;
col14:= 2;
col15:= 3;
 
{0, 1, 14, 15 pour ‚cran VGA 16 couleurs }
{0, 0,  2,  3 pour ‚cran CGA monochrome  }
 
{ en VGA 16 couleurs text=14 back=1  ... jaune sur fond bleu  }
{ en VGA 16 couleurs text=15 back=0  ... blanc sur fond noir  }
{ en VGA 16 couleurs text=0  back=15 ... noir  sur fond blanc }
 
end;
 
begin
choix_ecran;
lire_fichier_donnees;
titre;
mot_de_passe;
  if ch <> #27 then
  begin
    ouvrir_fichier;
    choix;
    curson;
  end;
end.