Правила форума
Прочтите прежде чем задавать вопрос!
Программа компилируется,работает,но не удаляет,не ищет и не редактирует товар.Пишет что товар не найден.
program sklad;
uses
crt;
const
n_items = 7;
l_name = 30;
type
str_name = string[l_name];
pTovar = ^Tovar;
Tovar = record
name: str_name;
kolvo: integer;
cena: real;
next: pTovar;
prev: pTovar;
end;
var
DefaultMode,
ActiveColor, InactiveColor: word;
key: char;
item: word;
prev: word;
beg: pTovar;
fin: pTovar;
p: pTovar;
name: str_name;
tovr: Tovar;
procedure Add(var beg, fin: pTovar; const tovr: Tovar); forward;
procedure Clear; forward;
procedure Del(var beg, fin, p: pTovar); forward;
procedure DlgWindow; forward;
procedure DrawItem(item, color: word); forward;
procedure Edit(beg: pTovar; const tovr: Tovar); forward;
procedure Error(message: string); forward;
function Find(p: pTovar; const tovr:str_name): pTovar; forward;
procedure Info(const tovr: Tovar); forward;
procedure InitMenu(ActvieColor, InactiveColor: word); forward;
procedure Message(message: string); forward;
procedure Query(var tovr: Tovar); forward;
procedure QueryName(var name: str_name); forward;
procedure ReadFile(var beg, fin: pTovar); forward;
procedure Select(beg: pTovar); forward;
procedure ShowBase(beg: pTovar); forward;
procedure Add(var beg, fin: pTovar; const tovr: Tovar);
var
p: pTovar;
begin
new(p);
p^ := tovr;
p^.next := nil;
p^.prev := fin;
if beg = nil then beg := p
else fin^.next := p;
fin := p;
end;
procedure Clear;
begin
window(1, 3, 80, 25);
TextColor(White);
Clrscr;
end;
procedure Del(var beg, fin, p: pTovar);
begin
if (p = beg) and (p = fin) then
begin
beg := nil;
fin := nil;
end
else
if p = beg then begin
beg := beg^.next;
beg^.prev := nil
end
else
if p = fin then begin
fin := fin^.prev;
fin^.next := nil;
end
else
begin
p^.prev^.next := p^.next;
p^.next^.prev := p^.prev;
end;
dispose(p);
end;
procedure DlgWindow;
begin
window(10, 6, 70, 12);
TextColor(Green);
TextBackground(LightGray);
clrscr;
end;
procedure DrawItem(item, color: word);
const
d = 12;
items: array[1..n_items] of string[d] = ('Vivod bazi dannix', 'Dobavlenie',
'Izmenenie', 'Udalenie', 'Poisk', 'Vibor', 'Vixod');
pos: array[1..n_items] of integer = (1 , d + 2, 2 * d + 3, 3 * d + 3, 4 * d + 3, 5 * d + 0, 6 * d - 6);
begin
window(1, 1, 80, 2);
TextBackGround(LightGray);
TextColor(Color);
gotoXY(pos[item], 1);
write(items[item]);
end;
procedure edit(beg: pTovar; const tovr: Tovar);
var
p: pTovar;
begin
p := Find(beg, tovr.name);
if p <> nil then begin
p^.kolvo := tovr.kolvo;
p^.cena := tovr.cena;
end;
end;
procedure error(message: string);
begin
window(1, 1, 80, 25);
TextColor(Red);
clrscr;
gotoXY(35, 12);
write(message);
repeat
until keypressed;
TextMode(DefaultMode);
halt;
end;
function Find(p: pTovar; const tovr:str_name): pTovar;
begin
while p <> nil do
begin
if tovr=p^.name then
begin
Find := p;
exit;
end;
p := p^.next;
end;
Message('Tovar ne naiden');
Find := nil;
end;
procedure Info(const tovr: Tovar);
begin
DlgWindow;
with tovr do
begin
gotoXY(2, 2);
writeln('Nazvanie tovara:', name);
gotoXY(2, 4);
writeln('Kolichestvo tovara:', kolvo);;
gotoXY(2, 6);
writeln('Cena tovara:', cena);
end;
readln;
end;
procedure InitMenu(ActvieColor, InactiveColor: word);
var
item: word;
begin
window(1, 1, 80, 2);
TextBackGround(lightGray);
clrscr;
DrawItem(1, ActiveColor);
for item := 2 to n_items do DrawItem(item, InactiveColor);
gotoXY(1, 2);
TextColor(InactiveColor);
write('----------------------------------------------------------------------');
gotoXY(1, 1);
end;
procedure Message(message: string);
begin
DlgWindow;
gotoXY(2, 4);
write(message);
readln;
end;
procedure Query(var tovr: Tovar);
var
s: string;
err: integer;
i, len: integer;
begin
DlgWindow;
with tovr do
begin
repeat
gotoXY(2, 2);
write('Nazvanie Tovara: ');
clreol;
readln(name);
len := length(name);
for i := len + 1 to l_name do name := name + ' ';
until len <> 0;
repeat
gotoXY(2, 4);
write('Kolichestvo tovara: ');
clreol;
readln(s);
val(s, kolvo, err);
until(err = 0) and (kolvo > 0);
repeat
gotoXY(2, 6);
write('Cena tovara: ');
clreol;
readln(s);
val(s, cena, err);
until(err = 0) and (cena > 0);
end;
end;
procedure QueryName(var name: str_name);
var
i, len: integer;
begin
DlgWindow;
gotoXY(2, 2);
write('Nazvanie tovara: ');
clreol;
readln(name);
len := length(name);
for i := len + 1 to l_name do name := name + '';
end;
procedure ReadFile(var beg, fin: pTovar);
var
f: text;
tovr: Tovar;
begin
{$I-}
assign(f, 'bazatovarov.txt');
rewrite(f);
reset(f);
if (IOResult <> 0) then Error('Fail bazatovarov.txt ne naiden');
{$I+}
while not eof(f) do
begin
with tovr do
readln(f, name, kolvo, cena);
Add(beg, fin, tovr);
end;
close(f);
end;
procedure Select(beg: pTovar);
procedure QueryCena(var cena: real);
var
s: string;
err: integer;
begin
DlgWindow;
repeat
gotoXY(2, 4);
write('Cena tovara: ');
clreol;
readln(s);
val(s, cena, err);
until (err = 0) and (cena > 0);
end;
var
begs, fins: pTovar;
p: pTovar;
cena: real;
begin
QueryCena(cena);
begs := nil;
fins := nil;
p := beg;
while p <> nil do
begin
if p^.cena > cena then Add(begs, fins, p^);
p := p^.next;
end;
ShowBase(begs);
end;
procedure ShowBase(beg: pTovar);
const
step = 18;
procedure ShowPage(var p: pTovar);
var
i: integer;
begin
clrscr;
gotoXY(1, 1);
writeln('Nazvanie tovara Kolichestvo Tovara Cena Tovara');
i := 0;
while p <> nil do
begin
with p^ do
writeln(' ', name, kolvo:5, cena:15:2);
p := p^.next;
inc(i);
if i > step then exit;
end;
end;
var
i: integer;
key: char;
p, pn: pTovar;
begin
if beg = nil then
begin
Message('Spisok pyst');
exit
end;
window(3, 4, 78, 24);
TextBackGround(LightGray);
TextColor(white);
p := beg;
while true do
begin
pn := p;
ShowPage(p);
key := readkey;
if key = #0 then key := readkey;
case ord(key) of
27: exit;
13, 80{down}, 81: if p = nil then p := pn;
72, 73{up}:
begin
p := pn;
for i := 1 to step do
begin
p := p^.prev;
if p = nil then
begin
p := beg;
break
end;
end;
end;
end;
end;
end;
begin
DefaultMode := LastMode;
TextMode(C80);
beg := nil;
fin := nil;
ReadFile(beg, fin);
clrscr;
ActiveColor := LightGreen;
InactiveColor := Green;
InitMenu(ActiveColor, InactiveColor);
item := 1;
prev := 1;
while true do
begin
key := readkey;
if key = #0 then key := readkey;
case ord(key) of
13:
case item of
1: ShowBase(beg);
2:
begin
Query(tovr);
Add(beg, fin, tovr);
end;
3:
begin
Query(tovr);
Edit(beg, tovr);
end;
4:
begin
QueryName(name);
p := Find(beg, name);
if p <> nil then Del(beg, fin, p);
end;
5:
begin
QueryName(name);
p := Find(beg, name);
if p <> nil then Info(p^);
end;
6: Select(beg);
7: exit;
end;
15{Shift+Tab}, 75{Left}:
begin
prev := item;
dec(item);
if item = 0 then item := n_items;
end;
9{Tab}, 77{Right}:
begin
prev := item;
inc(item);
if item = n_items + 1 then item := 1; end;
end;
Clear;
DrawItem(prev, InactiveColor);
DrawItem(item, ActiveColor);
end;
TextMode(DefaultMode);
end.
