Witam. Napisałem prostą bazę danych artykułów spożywczych. Ogólnie sama w sobie działa tylko muszę do niej dodać typ funkcyjny. Mam wszystko zadeklarowane, funkcję o dwóch argumentach integer, procedure o argumencie integer i typie funkcyjnym i przy kompilacji wywala mi błąd w głównym programie w linii: screena(porownaj, liczba);
Oto cały kod:
{$ mode delphi}
program Projekt;
USES CRT;
type Baza = record
typ,nazwa:string;
ilosc:integer;
end;
type funkcja = function(liczba,ilosc:integer):boolean; // ------------------ moj typ funkcyjny
type wsk=^integer;
var f,t,g:file of Baza;
o: array [1..50] of Baza;
s:Baza;
a,x,liczba:integer;
Wwsk:wsk;
procedure dodaj;
var i,a:integer;
begin
clrscr;
assign(f,'baza.txt');
rewrite(f);
write('Podaj liczbe produktow: ');
readln(a);
for i:=1 to a do
begin
clrscr;
writeln;
write('Typ: ');
readln(o[i].typ);
write('Nazwa: ');
readln(o[i].nazwa);
write('Ilosc: ');
readln(o[i].ilosc);
write(f,o[i]);
clrscr;
end;
close (f);
end;
procedure usun;
var i,a:integer;
b:string[30];
begin
i:=1;
clrscr;
assign (f,'baza.txt');
assign (g,'bazatest.txt');
rewrite(g);
Reset (f);
writeln('ktory produkt chcesz usunac?');
readln(b);
while not eof (f) do
begin
read (f,o[i]);
if not (o[i].nazwa=b) then
write(g,o[i]);
i:=i+1;
end;
writeln('usuwanie ukonczone');
close(f);
close(g);
erase(f);
rename(g,'baza.txt');
end;
procedure usunall;
var i,a:integer;
b:string[30];
begin
i:=1;
clrscr;
assign (f,'baza.txt');
assign (g,'bazatest.txt');
rewrite(g);
Reset (f);
writeln('ktory typ produktow chcesz usunac?');
readln(b);
while not eof (f) do
begin
read (f,o[i]);
if not (o[i].typ=b) then
write(g,o[i]);
i:=i+1;
end;
writeln('usuwanie ukonczone');
close(f);
close(g);
erase(f);
rename(g,'baza.txt');
end;
procedure screen;
var i,a:integer;
begin
i:=1;
assign(f,'baza.txt');
reset(f);
while not Eof(f) do
begin
read(f,o[i]);
writeln;
write('Typ: ');
writeln(o[i].typ);
write('Nazwa: ');
writeln(o[i].nazwa);
write('Ilosc: ');
writeln(o[i].ilosc);
write(f,o[i]);
writeln;
inc(i);
end;
close (f);
end;
function porownaj(liczba,ilosc:integer):boolean; // ------------------ funkcja o zadeklarowanym wyżej typie
begin
if (liczba<=ilosc) then porownaj:=true
else porownaj:=false;
end;
procedure screena(Afunkcja:funkcja ; liczba:integer); // ------------------ przekazanie do procedury powyższej funkcji
var i,a:integer;
begin
i:=1;
assign(f,'baza.txt');
reset(f);
while not Eof(f) do
begin
read(f,o[i]);
if (Afunkcja(liczba, o[i].ilosc)) then // ------------------ uzycie funkcji
begin
writeln;
write('Typ: ');
writeln(o[i].typ);
write('Nazwa: ');
writeln(o[i].nazwa);
write('Ilosc: ');
writeln(o[i].ilosc);
write(f,o[i]);
writeln;
end;
inc(i);
end;
close (f);
end;
procedure dodajponownie;
var i,a:integer;
begin
clrscr;
assign(f,'baza.txt');
reset(f);
write('Podaj liczbe produktow do dopisania: ');
readln(a);
for i:=1 to a do
begin
clrscr;
Seek(f, FileSize(f));
writeln;
write('Typ: ');
readln(o[i].typ);
write('Nazwa: ');
readln(o[i].nazwa);
write('Ilosc: ');
readln(o[i].ilosc);
write(f,o[i]);
clrscr;
end;
close(f);
end;
procedure kopia;
var FromF, ToF: file;
NumRead, NumWritten: Word;
Buf: array[1..2048] of Char;
begin
Assign(FromF, ParamStr(1));
Reset(FromF, 1);
Assign(ToF, ParamStr(2));
Rewrite(ToF, 1);
Writeln('Skopiowano ', FileSize(FromF), ' bajtow');
repeat
BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
BlockWrite(ToF, Buf, NumRead, NumWritten);
until (NumRead = 0) or (NumWritten <> NumRead);
Close(FromF);
Close(ToF);
end;
Begin
clrscr;
repeat
writeln ('1 - Dodaj produkty');
writeln ('2 - Usun produkty');
writeln ('3 - Usun wszystkie produkty danego typu');
writeln ('4 - Dodaj ponownie produkty');
writeln ('5 - Wyswietl produkty');
writeln ('6 - Dodaj ilosc produktow');
writeln ('7 - Odejmij ilosc produktow');
writeln ('8 - Kopia bazy danych (baza.dat)');
writeln ('0 - Zakoncz program');
readln (x);
case x of
1:
begin
dodaj;
end;
2:
begin
usun;
end;
3:
begin
usunall;
end;
4:
begin
dodajponownie;
end;
5:
begin
screen;
end;
8:
begin
kopia;
end;
9:
begin
writeln ('aaa');
readln (liczba);
screena(porownaj, liczba); // ----------- wywolanie procedury z przekazaniem funkcji porownaj, w tej linii jest blad
end;
end;
until x=0;
end.