Umiestnenie súboru www.TrSek.com/cover/neznamy/cafet.pas{ 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');
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.