Программа
program Lab_1;
Uses Crt,Dos;
Const N=15; { 1/2 кол-ва строк экрана }
D=3; { кво очередей }
OsnF='student.d'; { прг работает с 'student.d??'-файлamи,
в текущем каталоге }
Type T35=3..5;
srg=string[79];
arOFsrg=array[0..D] of srg;
stud=record { студент }
Fio:string[7];
Mat,Ph,TM:3..5
end;
StudS=^zap; { ссылка на объект типа stud ( студент ) }
zap=record
student:stud; { поле студента }
NEXT:StudS
end;
MasS=array[1..D] of StudS; { ТИП массив ссылок на начальные
элементы очередей студентов }
Var I,I2:byte; { д. выбора меню, , счетчик }
otvm:char;
Nal1,Flag,FlagFS:boolean; { IF поднят ТО просматривается
файл типа "student.dat";
ИНАЧЕ просматриваются
очереди студентов }
NameF:arOFsrg; { имена файлов:
0-й - типа "students.dat"
1..D-й - типа "student.d_k-й" }
A:MasS; { массив ссылок на очереди }
AIV:StudS;
procedure LN;
Begin writeln end;
function Nal(NameFNal:srg):boolean;
Var FSNal:file of stud;
Begin
Assign(FSNal,NameFNal);
{$I-}
Reset(FSNal);
{$i+}
if IOresult=0 then begin Close(FSNal); Nal:=true end
else Nal:=false
End;
procedure SoobSir(K:byte;Slovo:string;T,P,S,NY:integer);
Var D,I:integer;
Begin
K:=K div 3;
I:=K div 2;
while K>I do begin writeln; K:=K-1 end;
D:=(77-Length(Slovo)) div 2;
for I:=0 to D do write(' ');
write(Slovo);
while K>0 do begin writeln; K:=K-1 end;
T:=T div P;
for I:=1 to T do begin
Sound(NY);
Delay(P*S div 100);
NoSound;
Delay(P*(100-S) div 100)
end
End;
function Kategor(Pr1,Pr2,Pr3:T35):T35;
Begin
Kategor:=5;
if (Pr1=4)or(Pr2=4)or(Pr3=4) then Kategor:=4;
if (Pr1=3)or(Pr2=3)or(Pr3=3) then Kategor:=3
End;
procedure MakerStudDat(K:byte;NameF:srg);
Const J=D; { колво очередей }
Var I:byte; { счётчик }
B:3..5; { результат ф-ии Kategor }
Student:stud; { студент }
FS:file of stud;
Calc:array[3..J+2] of integer;
Kmin:byte; { min колво записей }
procedure Strnd(Var Snd:stud); { случайный студент }
Var R:1..7;
begin
with Snd do
begin
Fio:=''; { см. лист }
for R:=1 to (Random(6)+2) do Fio:=Fio+Chr(65+Random(26));
repeat
Mat:=Random(3)+3;Ph:=Random(3)+3;TM:=Random(3)+3
until 0=Random(6-Kategor(Mat,Ph,TM));
end
end;
Begin
Kmin:=K*3 div 4;
Assign(FS,NameF);Rewrite(FS);
for I:=3 to J+2 do Calc[I]:=0;
K:=Random(K-Kmin)+Kmin;
B:=3;
while Calc[B]<K do
begin
with Student do begin Fio:='';Mat:=3;Ph:=3;TM:=3 end;
Strnd(Student);
with Student do B:=Kategor(Mat,Ph,TM);
Calc[B]:=Calc[B]+1;
write(FS,student);
end;
Close(FS)
End;
procedure ReviewerFileStud(K:byte;Name:srg);
Var FS:file of Stud;
Student:Stud;
I:0..3;
J:byte;
Begin
ClrScr;
if Nal(Name)
then begin
I:=0;
Assign(FS,Name);
Reset(FS);
while not eof(FS) do
begin
read(FS,Student);
with Student do write(Fio:10,Mat:2,Ph:2,TM:2);
I:=I+1;
if I=3 then begin writeln; I:=0; K:=K-1 end
end;
if I<>3 then begin LN; K:=K-1 end;
Close(FS);
while K>0 do begin K:=K-1; Ln end;
end
else SoobSir(K,'Файл НЕ НАЙДЕН',1500,75,60,1000)
End;
procedure DisposeR(Var S:StudS);
Begin
if S<>nil then
begin
DisposeR(S^.NEXT);
Dispose(S); end; { @@@@@@@@@@@@@@ }
S:=nil
{ end }
End;
procedure MakerTurn(NameF:srg;Kat:T35;Var StudentS:StudS);
Var FN:file of stud;
St:Stud;
procedure SMT(Var S:StudS);
begin
while not eof(FN) do
begin
read(FN,St);
if Kat=Kategor(St.Mat,St.Ph,St.TM)
then begin
new(S);
S^.Student:=St;
S^.NEXT:=nil;
SMT(S^.NEXT)
end
end
end;
Begin
Assign(FN,NameF);
Reset(FN);
SMT(StudentS);
Close(FN)
End;
procedure ReviewerTurnS(K,J:byte; SubA:MasS);
Var P,I:integer;
function FullNil(L:byte; SSubA:MasS):boolean;
Var SFullNil:boolean;
begin
SFullNil:=true;
while L>0 do begin
SFullNil:=SFullNil and (SSubA[L]=nil);
L:=L-1
end;
FullNil:=SFullNil
end;
Begin
P:=1;
while (K>0) or (not FullNil(J,SubA)) do
begin
for I:=1 to J do
if SubA[I]<>nil
then
begin
with SubA[I]^.Student do
write((I*100+P):7,' ',Fio:8,Mat:2,TM:2,Ph:2);
SubA[I]:=SubA[I]^.NEXT
end
else write(' ');
if k<>0 then K:=K-1; { это финиш !!!!!!!! }
P:=P+1;
ln
end { оно глюкует }
End;
procedure ReaderTurn (NameF:srg; Var StudentS:StudS);
Var SNF:file of stud;
STS,STS2:StudS;
Begin
new(STS);
StudentS:=STS;
STS^.NEXT:=nil;
Assign(SNF,NameF);
Reset(SNF);
while not eof(SNF) do
begin
new(STS^.NEXT);
read(SNF,STS^.Student);
STS2:=STS;
STS:=STS^.NEXT
end;
Dispose(STS);
STS2^.NEXT:=nil;
Close(SNF)
End;
procedure WriterMainMenu(SubNameF:arOFsrg);
Const M0=' ГЛАВНОЕ МЕНЮ ';
M1='1.Создание Файла ';
M2='2.Просмотр Файла ';
M3='3.Создание очередей по файлу ';
M4='4.Считывание очередей из файлов ';
M5='5.Просмотр очередей ';
M6='6.Редактирование очередей ';
M7='7.Сохранение очередей ';
M8='8.Выход ';
Var I:byte; { счётчик }
Begin
writeln(M0); writeln(M1,SubNameF[0]); writeln(M2,SubNameF[0]);
writeln(M3,SubNameF[0]);
write(M4); for I:=1 to D do write(SubNameF[I],', ');
writeln; writeln(M5); writeln(M6);
writeln(M7); writeln(M8);
End;
procedure Editor (Var SubA:MasS);
Const M60=' РЕДАКТОР';
M61='1.Удаление';
M62='2.Вставка';
M63='3.Перенос';
M68='8.Выход';
Var OtvME,MarkCh:char;
GNum,Cod:integer;
Mat,Ph,TM:char;
Fio:string[7];
Suc:boolean;
StE:stud; { запись ''студент'' д. передачи между процедурами }
function Question(Soob:string):integer;
Var A1,A2,A3:char;
StrD:string[1];
NA1,NA2,NA3:0..9;
CodQ:integer;
begin
write(Soob,' ');
repeat
A1:=ReadKey;
Str(D,StrD)
until(A1>'0')and(A1<=StrD);
write(A1);
Val(A1,NA1,CodQ);
repeat
A2:=ReadKey;
Val(A2,NA2,CodQ)
until CodQ=0;
write(A2);
repeat
A3:=ReadKey;
until((A3>='0')and(A3<='9'))and((A2<>'0')or(A3<>'0'));
write(A3);
Val(A3,NA3,CodQ);
Question:=(NA1*10+NA2)*10+NA3
end;
procedure Delete(Var SubAV:MasS;Num:integer;
Var Stv:Stud;Var SucV:boolean);
{ передаеться ссылка на начало очереди если
удаляеться первый элемент то ссылка изменяеться,
выдает student }
Var StVP,VS:StudS;
I:0..100;
begin
if (Num mod 100)=1
then if SubAV[Num div 100]=nil
then SucV:=false
else begin
SucV:=true;
StVP:=SubAV[Num div 100];
StV:=StVP^.Student;
SubAV[Num div 100]:=StVP^.NEXT;
Dispose(StVP)
end
else begin
VS:=nil;
StVP:=SubAV[Num div 100];
for I:=1 to (Num mod 100-1) do
begin
VS:=StVP;
if StVP<>nil then StVP:=StVP^.NEXT
end;
if (VS=nil) or (StVP=nil)
then SucV:=false
else begin
StV:=StVP^.Student;
SucV:=true;
VS^.NEXT:=StVP^.NEXT;
Dispose(StVP)
end
end
end;
procedure Insert(Var SubAI:MasS;SNumI:integer;StEI:Stud);
{ получает student и адрес для записи }
Var VS,VS2,StEIS:StudS;
NZ:0..99;
NT:1..D;
begin
NT:=SNumI div 100;
NZ:=SNumI mod 100;
new(StEIS);
StEIS^.Student:=StEI;
if (NZ=1)or(SubAI[NT]=nil)
then begin
StEIS^.NEXT:=SubAI[NT];
SubAI[NT]:=StEIS
end
else begin
VS:=SubAI[NT];
while (NZ>1)and(VS<>nil) do
begin
VS2:=VS;
VS:=VS^.NEXT;
NZ:=NZ-1
end;
StEIS^.NEXT:=VS;
VS2^.NEXT:=StEIS
end
end;
procedure Move; { см. Insert,Delete }
begin
end;
Begin
repeat
ClrScr;
ReviewerTurnS(N,D,SubA);
Ln;
writeln(M60);
writeln(M61);
writeln(M62);
writeln(M63);
writeln(M68);
OtvME:=ReadKey;
case OtvME of
'1':begin
Delete(SubA,Question('НУ-У!?! которого?'),StE,Suc);
if not Suc then begin
writeln('объект не найден');
while not KeyPressed do;
OtvME:='9'
end
end;
'2':begin
write('ИМЯ ');
readln(StE.Fio);
write(' Maт ');
repeat
MarkCh:=ReadKey
until MarkCh in ['3'..'5'];
writeln(MarkCh);
Val(MarkCh,StE.Mat,Cod);
write(' Физ ');
repeat
MarkCh:=ReadKey
until MarkCh in ['3'..'5'];
writeln(MarkCh);
Val(MarkCh,StE.Ph,Cod);
write(' ТM ');
repeat
MarkCh:=ReadKey
until MarkCh in ['3'..'5'];
writeln(MarkCh);
Val(MarkCh,StE.TM,Cod);
Insert(SubA,Question(' куда'),StE)
end;
'3':begin
Delete(SubA,Question(' которого'),StE,Suc);
if not Suc
then begin
writeln(' объект не найден');
while not KeyPressed do;
OtvME:='9'
end
else Insert(SubA,Question(' куда'),StE)
end;
'8':;
end
until OtvME='8'
End;
procedure Saver(NameF:srg;SubA:StudS);
Var I:byte;
SNameF:file of stud;
Begin
Assign(SNameF,NameF);
Rewrite(SNameF);
while SubA<>nil do
begin
write(SNameF,SubA^.Student);
SubA:=SubA^.NEXT
end;
Close(SNameF)
End;
BEGIN
textbackground(0);
textcolor(15);
clrscr;
FlagFS:=false;
NameF[0]:=OsnF+'at';
for I:=1 to D do NameF[I]:=OsnF+'_'+Chr(50+I);
for I:=1 to D do
A[I]:=nil;
repeat
ClrScr;
if FlagFS then
if Nal(NameF[0])
then begin
ClrScr;
ReviewerFileStud(N,NameF[0])
end
else begin
ClrScr;
SoobSir(N,'ФАЙЛ '+NameF[0]+
' НЕ НАЙДЕН ',1500,75,60,1000);
end
else begin
ClrScr;
ReviewerTurnS(N,D,A)
end;
WriterMainMenu(NameF);
OtvM:=' ';
OtvM:=readkey;
case OtvM of
'1'..'2':Begin
FlagFS:=true;
if OtvM='1' then MakerStudDat(N,NameF[0]);
End;
'3':Begin
FlagFS:=false;
if Nal(NameF[0])
then for I:=1 to D do
begin
DisposeR(A[I]);
MakerTurn(NameF[0],I+2,A[I]);
end
else begin
ClrScr;
SoobSir(N,'ФАЙЛ '+NameF[0]+' НЕ НАЙДЕН',
1500,75,60,1000)
end
End;
'4':Begin
FlagFS:=false;
Flag:=true;
for I:=1 to D do Flag:=Flag and Nal(NameF[I]);
if Flag
then for I:=1 to D do
begin
DisposeR(A[I]);
ReaderTurn(NameF[I],A[I])
end
else begin
ClrScr;
for I:=1 to D do
if not Nal(NameF[I])
then SoobSir(N div 3,'ФАЙЛ '+NameF[I]+
' НЕ НАЙДЕН',1500,75,60,1000)
else for I2:=1 to (N div 3) do Ln;
for I2:=1 to (N mod 3) do Ln
end
End;
'5':FlagFS:=false;
'6':Begin FlagFS:=false;Editor(A) End;
'7':for I:=1 to D do Saver(NameF[I],A[I]);
'8':for I:=1 to D do DisposeR(A[I]);
else begin
ClrScr;
SoobSir(N,'ЧУШЬ',1000,100,20,3500)
end
ENd
until OtvM='8';
END.
Бесплатные примеры программ
Примеры написанных программ
Помощь студентам по программированию