GrMenu.pas - модуль меню
unit GrMenu;
interface
uses Graph,crt;
procedure Menu;
procedure SubMenu;
procedure ButtonGraph(param:byte);
procedure SubMenuButtonGraph(param:byte);
var KeyCount:byte;
implementation
procedure Menu;
var Xpos1,Xpos2,Xpos3,i:integer;
begin
cleardevice;
setcolor(1);
Xpos1:=10;
Xpos2:=47;
for i:=1 to 7 do
begin
rectangle(Xpos1,10,Xpos2,20);
Xpos1:=Xpos1+85;
Xpos2:=Xpos2+85;
end;
setcolor(2);
outtextxy(11,12,'add');
outtextxy(96,12,'show');
outtextxy(181,12,'save');
outtextxy(266,12,'sort');
outtextxy(351,12,'read');
outtextxy(438,12,'del');
outtextxy(521,12,'exit');
end;
procedure SubMenu;
var i,Xpos1:integer;
begin
setcolor(2);
Xpos1:=100;
line(280,20,280,35);
setlinestyle(0,0,1);
line(100,35,450,35);
for i:=1 to 8 do
begin
setcolor(2);
line(Xpos1,35,Xpos1,50);
setcolor(1);
rectangle(Xpos1-15,50,Xpos1+15,60);
Xpos1:=Xpos1+50;
end;
setcolor(2);
outtextxy(90,52,'A');
outtextxy(140,52,'B');
outtextxy(190,52,'C');
outtextxy(240,52,'D');
outtextxy(290,52,'E');
outtextxy(340,52,'F');
outtextxy(390,52,'G');
outtextxy(440,52,'esk');
end;
procedure ButtonGraph;
var FloodX,TextX:integer;text:string;
begin
setfillstyle(1,2);
if KeyCount>16 then KeyCount:=16;
if KeyCount<10 then KeyCount:=10;
case param of
10:begin
FloodX:=11;
TextX:=11;
text:='add';end;
11:begin
FloodX:=96;
TextX:=96;
text:='show';end;
12:begin
FloodX:=181;
TextX:=181;
text:='save';end;
13:begin
FloodX:=266;
TextX:=266;
text:='sort';end;
14:begin
FloodX:=351;
TextX:=351;
text:='read';end;
15:begin
FloodX:=436;
TextX:=438;
text:='del';end;
16:begin
FloodX:=521;
TextX:=521;
text:='exit';end;
end;
Menu;
floodfill(FloodX,18,1);
setcolor(0);
outtextxy(TextX,12,text);
end;
procedure SubMenuButtonGraph;
var FloodX,TextX:integer;text:string;
begin
if KeyCount>17 then KeyCount:=17;
if KeyCount<10 then KeyCount:=10;
case param of
10:begin
FloodX:=101;
TextX:=90;
text:='A';end;
11:begin
FloodX:=141;
TextX:=140;
text:='B';end;
12:begin
FloodX:=191;
TextX:=190;
text:='C';
end;
13:begin
FloodX:=241;
TextX:=240;
text:='D';
end;
14:begin
FloodX:=291;
TextX:=290;
text:='E';
end;
15:begin
FloodX:=341;
TextX:=340;
text:='F';
end;
16:begin
FloodX:=391;
TextX:=390;
text:='G';
end;
17:begin
FloodX:=441;
TextX:=440;
text:='esk';
end;
end;
Menu;
SubMenu;
floodfill(FloodX,51,1);
setcolor(0);
outtextxy(TextX,52,text);
end;
end.
PROJECT2.PAS - модуль выбора действия
program Project2;
{$I+}
uses
Unit1,Unit2,Graph,crt,GrMenu;
var c:char;
SubMenuFlag:boolean;
i,j:integer;
procedure MenuAction(param:byte);
begin
if param=10 then
add;
if param=11 then
show;
if param=12 then
savetof;
if param=13 then begin
setcolor(2);
if Blist=nil then
outtextxy(15,30,'Base is empty!')
else
begin
SubMenuFlag:=true;
KeyCount:=10;
SubMenu;
SubMenuButtonGraph(10);
end;
end;
if param=14 then
readfromf;
if param=15 then
DelElem;
if param=16 then
begin
closegraph;
halt;
end;
end;
procedure SubMenuAction(param:byte);
begin
if param<10 then param:=10;
if param>17 then param:=17;
if param=10 then
SortA('a');
if param=11 then
SortB('b');
if param=12 then
SortA('c');
if param=13 then
SortA('d');
if param=14 then
SortB('e');
if param=15 then
SortC('f');
if param=16 then
SortC('g');
if param=17 then begin
SubMenuFlag:=false;
KeyCount:=10;
Menu;
end;
end;
begin
SubMenuFlag:=false;
j:=0;
i:=detect;
InitGraph(i,j,'');
KeyCount:=10;
BList:=nil;
Menu;
ButtonGraph(10);
while 1=1 do
begin
c:=readkey;
case ord(c) of
77:KeyCount:=KeyCount+1;
75:KeyCount:=KeyCount-1;
end;
if SubMenuFlag=true then
SubMenuButtonGraph(KeyCount)
else
ButtonGraph(KeyCount);
if ord(c)=13 then
begin
if SubMenuFlag=true then
SubMenuAction(KeyCount)
else
MenuAction(KeyCount);
end;
end;
end.
UNIT1.PAS - процедуры добавления,вывода и удаления элементов
unit Unit1;
interface
uses graph,crt,GrMenu;
type Base = ^BD;
BD=record
Name :string;
Cost : real;
Low :byte;
Hight : byte;
Inum:byte;
Next : base;
end;
{----------------------------------------------------------}
var
count,i:integer;
BList,p,q:base;
var MaxCost,MaxCostConstr:real;Myach:real;Flag:boolean;
Procedure Input(var text:string;OutX,OutY:integer);
procedure Add;
procedure PreSort;
procedure SortA(param:char);
procedure SortB(param:char);
procedure SortC(param:char);
procedure Show;
procedure RealToString (param4:real;var param2,param3:string);
procedure Del(param:integer);
procedure Reindex;
implementation
procedure Add;
var StrTemp:string;err:integer;RelTemp:real;
begin
setcolor(2);
count:=count+1;
new(p);
outtextxy(15,30,'Enter Name:');
Input(StrTemp,105,30);
p^.name:=StrTemp;
outtextxy(15,40,'Enter cost:');
Input(StrTemp,105,40);
val(StrTemp,RelTemp,err);
p^.cost:=RelTemp;
outtextxy(15,50,'Enter hight range:');
Input(StrTemp,160,50);
val(StrTemp,RelTemp,err);
p^.hight:=Trunc(RelTemp);
outtextxy(15,60,'Enter low range:');
Input(StrTemp,145,60);
val(StrTemp,RelTemp,err);
p^.low:=Trunc(RelTemp);
Menu;
OutTextxy(15,30,'Added complete.');
p^.Inum:=count;
p^.Next:=Blist;
Blist:=p;
end;
{----------------------------------------------------------}
procedure PreSort;
begin
p:=BList;
Myach:=5;
MaxCost:=p^.Cost;
MaxCostConstr:=0;
for i:=1 to count do
begin
if (p^.name='constructor') and (p^.cost>MaxCostConstr) then
MaxCostConstr:=p^.Cost;
if (p^.name='myach') and (p^.cost
myach:=p^.cost;
if (MaxCost
MaxCost:=p^.Cost;
p:=p^.next;
end;
end;
{----------------------------------------------------------}
procedure SortA;
var Ans:string;
begin
presort;
p:=Blist;
setcolor(2);
ans:='';
for i:=1 to count do
begin
if (param='a') and (p^.cost<=4) and (p^.low<=5) then
begin
outtextxy(15,65+(i*10),p^.name);
ans:='p^.name';
end;
if (param='c') and (p^.cost+1>=MaxCost) then
begin
outtextxy(15,65+(i*10),p^.name);
ans:='p^.name';
end;
if (param='d') and (p^.low<=4) and (p^.hight>=10) then
begin
outtextxy(15,65+(i*10),p^.name);
ans:='p^.name';
end;
p:=p^.next;
end;
if ans=''then outtextxy(15,65,'None.');
end;
{----------------------------------------------------------}
Procedure SortB;
var StrTemp1,StrTemp2:string;
begin
presort;
setcolor(2);
p:=Blist;
for i:=1 to count do
begin
if param='b' then
begin
RealToString(MaxCostConstr,StrTemp1,StrTemp2);
if MaxCostConstr=0 then
outtextxy(15,65,'None.')
else
outtextxy(15,65,'Cost of most expensive constructor is:'+Strtemp1+'.'+strtemp2);
break; end
else if p^.name='kub' then begin
RealToString(p^.cost,StrTemp1,StrTemp2);
outtextxy(15,65+(i*10),'Cost of kubs is:'+StrTemp1+'.'+StrTemp2);
end;
p:=p^.next;
end;
end;
{----------------------------------------------------------}
Procedure SortC;
var col:byte;row:byte;strtemp:string;
begin
presort;
setcolor(2);
flag:=false;
row:=40;
setcolor(2);
p:=Blist;
for i:=1 to count do
begin
if (param='f') and (p^.name<>'myach') and (p^.Cost+Myach<=5) and (p^.low<=3) and (p^.hight>=3) then
begin
flag:=true;
outtextxy(15,65,'Yes.');
break;
end;
if (param='g')and (p^.cost=2.50) and (p^.low=3) and (p^.hight=8) then
begin
flag:=true;
outtextxy(15,30,'Name:');
outtextxy(105,30,'Cost:');
outtextxy(155,30,'Low:');
outtextxy(205,30,'Hight:');
outtextxy(15,row,p^.name);
str(p^.cost,strtemp);
outtextxy(95,row,strtemp);
str(p^.low,strtemp);
outtextxy(155,row,strtemp);
str(p^.hight,strtemp);
outtextxy(205,row,strtemp);
p:=p^.next;
row:=row+10;
break;
end;
p:=p^.Next;
end;
if flag=false then outtextxy(15,65,'None.');
end;
{----------------------------------------------------------}
procedure show;
var col:byte;row:byte;StrTemp1,StrTemp2:string;
begin
row:=40;
p:=BList;
setcolor(2);
outtextxy(15,30,'Name:');
outtextxy(125,30,'Cost:');
outtextxy(175,30,'Low:');
outtextxy(215,30,'Hight:');
outtextxy(265,30,'Index:');
for i:=1 to count do
begin
outtextxy(15,row,p^.name);
RealToString(p^.cost,StrTemp1,StrTemp2);
outtextxy(125,row,StrTemp1+'.'+StrTemp2);
str(p^.low,strtemp1);
outtextxy(175,row,strtemp1);
str(p^.hight,strtemp1);
outtextxy(215,row,strtemp1);
str(p^.Inum,strtemp1);
outtextxy(265,row,strtemp1);
p:=p^.next;
row:=row+10;
end;
end;
{----------------------------------------------------------}
procedure RealToString;
var param1:real;IntI:longint;
begin
param1:=int(param4);
IntI:=trunc(param1);
str(inti,param2);
param1:=frac(param4);
param1:=param1*100;
inti:=trunc(param1);
str(inti,param3);
end;
{----------------------------------------------------------}
Procedure Input;
var Buf:char;
begin
text:='';
while ord(buf)<>13 do
begin
setcolor(2);
buf:=readkey;
if ord(buf)<>13 then begin
outtextxy(OutX,OutY,buf);
text:=text+buf;
end;
OutX:=OutX+10;
end;
end;
{----------------------------------------------------------}
procedure Del;
var BYTEtemp:byte;
begin
p:=blist;
q:=blist;
while (p^.inum<>param) do
begin
q:=p;
p:=p^.next;
end;
if param<>count then
begin
q^.next:=p^.next;
dispose(p);
end
else
begin
q:=blist;
blist:=blist^.next;
dispose(q);
end;
count:=count-1;
Reindex;
end;
{----------------------------------------------------------}
Procedure Reindex;
var i:byte;
begin
p:=blist;
for i:=count downto 1 do
begin
p^.Inum:=i;
p:=p^.next;
end;
end;
end.
UNIT2.PAS - процедуры чтения и записи в файл
unit Unit2;
interface
uses Unit1,GrMenu,graph,crt;
var f1:text;STRtemp:string;RELtemp:real;INTtemp:integer;
procedure SaveToF;
procedure ReadFromF;
procedure DelElem;
procedure EraseF;
implementation
procedure SaveToF;
var i:byte;
begin
{$I-}
assign(f1,'base.dat');
rewrite(f1);
{$I+}
if ioresult <> 0 then
begin rewrite(f1); outtextxy(15,30,'File do not exist.'); end;
p:=Blist;
for i:=1 to count do
begin
writeln(f1,p^.name);
writeln(f1,p^.cost:0:2);
writeln(f1,p^.hight);
writeln(f1,p^.low);
p:=p^.next;
end;
close(f1);
setcolor(2);
outtextxy(15,30,'Save complete.');
end;
{----------------------------------------------------------}
procedure ReadFromF;
begin
{$I-}
assign(f1,'base.dat');
reset(f1);
{$I+}
if Ioresult <> 0 then
begin rewrite(f1);outtextxy(15,30,'File do not exist.'); end;
while not eof(f1) do
begin
count:=count+1;
new(p);
readln(f1,STRtemp);
p^.name:=STRtemp;
readln(f1,RELtemp);
p^.cost:=RELtemp;
readln(f1,INTtemp);
p^.hight:=INTtemp;
readln(f1,INTtemp);
p^.low:=INTtemp;
p^.Inum:=count;
p^.Next:=Blist;
BList:=p;
end;
setcolor(2);
outtextxy(15,30,'Read complete.');
close(f1);
end;
{----------------------------------------------------------}
procedure DelElem;
var STRtemp:string;INTtemp:integer;err:integer;
begin
setcolor(2);
if count=0 then
outtextxy(15,30,'Base is empty!')
else begin
outtextxy(15,30,'Enter number:');
input(Strtemp,130,30);
val(strtemp,inttemp,err);
case inttemp of
99:EraseF;
else Del(inttemp);
end;
end;
end;
{----------------------------------------------------------}
procedure EraseF;
begin
Menu;
assign(f1,'base.dat');
rewrite(f1);
setcolor(2);
outtextxy(15,30,'Erase complete.');
end;
end.
|
Главная
Каталог файлов
