zk34

TURBO PASCAL 5.5

МЭСИ. По специальности "Вычислительные сети, средства и систе-

мы". Вечернее отделение. 3-ий курс 1-ый семестр. Курсовая.

Задание: есль людишки на заводе. Нужно их ввести. Вводятся или

с клавиатуры или из файла MEN.INP . Нужно их отсортировать по фами-

лиям. Отдельно для исходных данных сделать таблицу, чтобы народ там

торчал по возрасту. И при этом для лиц с одинаковым возрастом и ко-

дом образования подсчитать среднюю зарплату. В вводе данных вроде-бы

все ясно кроме кода образования:

1 - начальное

2 - н.среднее

3 - среднее

4 - cреднее специальное

5 - высшее

Таб.N - номер по ведомости. Номер - номер с списке.

Таблица в Men.tab . Отсортированные фамилии в Men.sfn .

KURSOV - програмка оттуда же, но несколько не то суммирует, и дополни-

тельные данные вводятся.

Андропов

Брежнев

Горбачев

Ельцин

Жириновский

Ленин

Маленков

Сталин

Хрущев

Черненко

-------T------T-----T-------------------T------T----------T-------T------¬

¦Номер ¦ Возр ¦ Обр ¦ Фамилия ¦Таб.N ¦Дата рожд.¦ З/П ¦ Стаж ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ 01 ¦ 18 ¦ 3 ¦ Черненко ¦ 07 ¦ 750101 ¦ 100 ¦ 04 ¦

¦ 02 ¦ 18 ¦ 3 ¦ Горбачев ¦ 08 ¦ 750404 ¦ 200 ¦ 03 ¦

¦ 03 ¦ 18 ¦ 3 ¦ Жириновский ¦ 10 ¦ 750606 ¦ 200 ¦ 04 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ Средние арифметические ¦ 167 ¦ 04 ¦

+------T------T-----T-------------------T------T----------+-------+------+

¦ 04 ¦ 18 ¦ 5 ¦ Ельцин ¦ 09 ¦ 750404 ¦ 999 ¦ 04 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ Средние для одного возраста ¦ 375 ¦ 04 ¦

+------T------T-----T-------------------T------T----------+-------+------+

¦ 05 ¦ 33 ¦ 3 ¦ Брежнев ¦ 05 ¦ 600606 ¦ 100 ¦ 02 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ 06 ¦ 33 ¦ 5 ¦ Андропов ¦ 06 ¦ 600606 ¦ 005 ¦ 10 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ Средние для одного возраста ¦ 053 ¦ 06 ¦

+------T------T-----T-------------------T------T----------+-------+------+

¦ 07 ¦ 78 ¦ 5 ¦ Ленин ¦ 01 ¦ 151010 ¦ 100 ¦ 40 ¦

¦ 08 ¦ 78 ¦ 5 ¦ Сталин ¦ 02 ¦ 150101 ¦ 200 ¦ 50 ¦

¦ 09 ¦ 78 ¦ 5 ¦ Хрущев ¦ 04 ¦ 150707 ¦ 600 ¦ 60 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ Средние арифметические ¦ 300 ¦ 50 ¦

¦ Средние для одного возраста ¦ 300 ¦ 50 ¦

+------T------T-----T-------------------T------T----------+-------+------+

¦ 10 ¦ 81 ¦ 4 ¦ Маленков ¦ 03 ¦ 150505 ¦ 300 ¦ 40 ¦

L------+------+-----+-------------------+------+----------+-------+--------------T------T-----T-------------------T------T----------T-------T------¬

¦Номер ¦ Возр ¦ Обр ¦ Фамилия ¦Таб.N ¦Дата рожд.¦ З/П ¦ Стаж ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ 01 ¦ 18 ¦ 3 ¦ Черненко ¦ 07 ¦ 750101 ¦ 100 ¦ 04 ¦

¦ 02 ¦ 18 ¦ 3 ¦ Горбачев ¦ 08 ¦ 750404 ¦ 200 ¦ 03 ¦

¦ 03 ¦ 18 ¦ 3 ¦ Жириновский ¦ 10 ¦ 750606 ¦ 200 ¦ 04 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ Средние арифметические ¦ 167 ¦ 04 ¦

+------T------T-----T-------------------T------T----------+-------+------+

¦ 04 ¦ 18 ¦ 5 ¦ Ельцин ¦ 09 ¦ 750404 ¦ 999 ¦ 04 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ Средние для одного возраста ¦ 375 ¦ 04 ¦

+------T------T-----T-------------------T------T----------+-------+------+

¦ 05 ¦ 33 ¦ 3 ¦ Брежнев ¦ 05 ¦ 600606 ¦ 100 ¦ 02 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ 06 ¦ 33 ¦ 5 ¦ Андропов ¦ 06 ¦ 600606 ¦ 005 ¦ 10 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ Средние для одного возраста ¦ 053 ¦ 06 ¦

+------T------T-----T-------------------T------T----------+-------+------+

¦ 07 ¦ 78 ¦ 5 ¦ Ленин ¦ 01 ¦ 151010 ¦ 100 ¦ 40 ¦

¦ 08 ¦ 78 ¦ 5 ¦ Сталин ¦ 02 ¦ 150101 ¦ 200 ¦ 50 ¦

¦ 09 ¦ 78 ¦ 5 ¦ Хрущев ¦ 04 ¦ 150707 ¦ 600 ¦ 60 ¦

+------+------+-----+-------------------+------+----------+-------+------+

¦ Средние арифметические ¦ 300 ¦ 50 ¦

¦ Средние для одного возраста ¦ 300 ¦ 50 ¦

+------T------T-----T-------------------T------T----------+-------+------+

¦ 10 ¦ 81 ¦ 4 ¦ Маленков ¦ 03 ¦ 150505 ¦ 300 ¦ 40 ¦

L------+------+-----+-------------------+------+----------+-------+-------

{**************************************************

Курсовая работа

по

Основам Алгоритмизации и

Алгоритмическим Языкам

(с) 1993 Росляков Владимир ВИ-304

Программа написана на языке

Turbo Pascal Version 6.0

***************************************************}

PROGRAM KursovWork;

Uses

CRT, {управление текстовым режимом работы экрана}

Dos, {возможность получить машинную дату и время}

Printer; {упрощает вывод текстов на матричный принтер}

Type

{структура для файла фамилий (1)}

Struct1 = record

{+} FIO : string[15]; {фамилия и.о.}

end;

{структура для файла данных (2)}

Struct2 = record

TimeSheetNumber : word; {табельный номер}

{к1} Sex : byte; {пол (0-1)}

CodePost : byte; {код должности}

DateEntryToFactory : string[8]; {дата поступления на завод (дд/мм/гг)}

{и} Pay : word; {заработная плата (руб.)}

{и} TotalLengthOfService : byte; {общий стаж работы (полных лет)}

LengthOfService : byte; {стаж работы на заводе (полных лет)}

CodeEducation : byte; {код образования (1-7)}

{+} BirthDay : string[8]; {дата рождения (дд/мм/гг)}

{+} PartyMembership : byte; {партийность (1-3)}

DateEntryToParty : string[5]; {дата вступления в партию (мм/гг)}

FamilySituation : byte; {семейное положение (1-4)}

{учитывая задание введено в структуру}

{к2} Age : byte; {возраст (полных лет)}

end;

Var

ff1 : file of Struct1; {файл списка фамилий}

ff2 : file of Struct2; {файл данных}

Record1 : Struct1; {запись для файла фамилий}

Record2 : Struct2; {запись для файла данных}

pr : text; {временно это "принтер"}

{**********************************************************************}

{ввод исходной записи из входного потока

(входным потоком является клавиатура)}

PROCEDURE InputRecordFromInputStream;

Const

{длина полей ввода}

LengthOfField : array [1..13] of string[15] =

('···············', {фамилия и инициалы}

'·', {пол (0-1)}

'······', {дата рождения (ддммгг)}

'·', {код образования (1-7)}

'···', {табельный номер}

'··', {код должности}

'····', {заработная плата}

'······', {дата поступления на завод (ддммгг)}

'··', {стаж работы на заводе (полных лет)}

'··', {общий стаж работы (полных лет)}

'·', {партийность (1-3)}

'····', {дата вступления в партию (ммгг)}

'·'); {семейное положение (1-4)}

Var

PrevFIO : string[15]; {предыдущая фамилия}

Field : string; {поле для ввода информации}

i : byte; {номер запрашиваемого поля}

RightField : boolean; {верно ли введенное поле}

Code : integer; {вспомогательная переменная для преобразования}

{====================================================================}

{очищает окно сообщений от текста}

PROCEDURE ClearMessageBox;

BEGIN

Window(02,17,55,23); {установить границы активного окна}

ClrScr; {очистить экран в этих пределах}

Window(01,01,80,25); {восстановить прежние границы}

END;

{====================================================================}

{приводит строку к виду даты (дд/мм/гг, мм/гг)}

FUNCTION DataImage(Field : string) : string;

BEGIN

Case (length(Field)) of

4 : begin {ммгг}

insert('/',Field,3);

end; {4}

6 : begin {ддммгг}

insert('/',Field,3);

insert('/',Field,6);

end; {6}

end; {case}

DataImage := Field;

END;

{====================================================================}

{вычисление количества полных лет между текущей датой и

датой-параметром}

FUNCTION CalculationAge(Date : string) : integer;

Var

Year,Month,Day : integer; {переменные для даты-параметра}

YearC,MonthC,DayC,DayOfWeekC : word; {переменные для машинной даты}

Age : integer; {возраст}

BEGIN

{"расщепление" даты-параметра}

Case (length(Date)) of

4 : begin {ммгг}

val(copy(Date,1,2),Month,Code);

val(copy(Date,3,2),Year,Code);

end; {4}

6 : begin {ддммгг}

val(copy(Date,1,2),Day,Code);

val(copy(Date,3,2),Month,Code);

val(copy(Date,5,2),Year,Code);

end; {6}

8 : begin {дд/мм/гг}

val(copy(Date,1,2),Day,Code);

val(copy(Date,4,2),Month,Code);

val(copy(Date,7,2),Year,Code);

end; {8}

end; {case}

{считывание машинной (системной) даты}

GetDate(YearC,MonthC,DayC,DayOfWeekC);

YearC := YearC - 1900; {избавляемся от столетия}

Age := YearC - Year; {расчитываем количество лет}

{корректировка возраста с учетом месяца и дня}

If length(Date) = 4 then

{нет дня}

If MonthC < Month then dec(Age)

Else

If (MonthC < Month) or ((MonthC = Month) and (DayC < Day)) then dec(Age);

CalculationAge := Age;

END;

{====================================================================}

{контроль значений в исходной записи на достоверность}

PROCEDURE ControlSignificance;

Var

j : byte; {вспомогательная переменная}

{------------------------------------------------------------------}

{преобразование числа-строки в число}

FUNCTION Num(sValue : string) : integer;

Var

Value : integer;

BEGIN

val(sValue,Value,Code);

Num := Value;

END;

{------------------------------------------------------------------}

{печать сообщения о типе ошибки в поле ввода}

PROCEDURE MessageError(Message : string);

Var

Key : char;

BEGIN

RightField := false; {поле ошибочно}

{печать отцентрированного в окне сообщения}

GotoXY(2 + ((54-length(Message)) div 2),18);

Write(Message);

{ожидание и очистка бокса}

GotoXY(05,22);

Write('Нажмите любую клавишу, чтобы повторить ввод...');

While not(KeyPressed) do; {пустой цикл "ПОКА" не нажата клавиша}

Key := ReadKey; {очистить буфер клавиатуры}

ClearMessageBox; {очистить бокс сообщений}

END;

{------------------------------------------------------------------}

{контроль на цифры}

PROCEDURE Check1;

Var

j : byte;

BEGIN

For j := 1 to length(Field) do begin

If not(Field[j] in ['0'..'9']) then begin

MessageError('Поле может содержать только цифры.');

Exit;

end; {if}

end; {for}

END;

{------------------------------------------------------------------}

{контроль на принадлежность поля-параметра интервалу

Top <= Variable <= Bottom}

PROCEDURE Check2(Variable : integer;

Top,Bottom : integer;

Message : string);

BEGIN

If not((Top <= Variable) and (Variable <= Bottom)) then begin

MessageError(Message);

end; {if}

END;

{------------------------------------------------------------------}

{контроль на корректность даты}

PROCEDURE Check3;

Var

Year,Month,Day : byte; {переменные для даты}

BEGIN

{контроль на недостаточное количество символов}

If length(Field) < length(LengthOfField[i]) then begin

MessageError('Длина поля меньше необходимой.');

Exit;

end; {if}

{контроль на цифры}

Check1; If not(RightField) then Exit;

{"расщепление" даты}

Case (length(Field)) of

4 : begin {ммгг}

val(copy(Field,1,2),Month,Code);

val(copy(Field,3,2),Year,Code);

end; {4}

6 : begin {ддммгг}

val(copy(Field,1,2),Day,Code);

val(copy(Field,3,2),Month,Code);

val(copy(Field,5,2),Year,Code);

end; {6}

end; {case}

{проверка месяца}

Check2(Month,1,12,'Ошибка при указании месяца.');

If not(RightField) then Exit;

{проверка дня, если он есть}

If length(Field) = 6 then begin

Case (Month) of

1,3,5,7,8,10,12 :

Check2(Day,1,31,'Ошибка при указании дня.');

4,6,9,11 :

Check2(Day,1,30,'Ошибка при указании дня.');

2 :

{если год високосный, то...}

If (Year mod 4) = 0 then

Check2(Day,1,29,'Ошибка при указании дня.')

Else

Check2(Day,1,28,'Ошибка при указании дня.');

end; {case Month}

If not(RightField) then Exit;

end; {if}

{проверка на непревышение даты-параметра текущей даты}

If CalculationAge(Field) < 0 then

MessageError('Дата не должна превышать текущую.');

END;

{------------------------------------------------------------------}

{проверка на превышение датой-параметра даты рождения на

некоторое количество лет}

PROCEDURE Check4(ExceedValue : byte);

Var

sValue : string;

BEGIN

str(ExceedValue:2,sValue);

If not(CalculationAge(Field) <= Record2.Age - ExceedValue) then

MessageError('Дата должна превышать дату рождения на ' + sValue + ' лет.');

END;

{------------------------------------------------------------------}

BEGIN

RightField := true; {предположим, что поле верно}

{контроль на отсутствие информации в поле}

If length(Field) = 0 then begin

MessageError('Необходимо заполнить поле.');

Exit;

end;

{контроль на превышение полем положенной длины}

If length(Field) > length(LengthOfField[i]) then begin

MessageError('Длина поля превышает допустимую.');

Exit;

end;

Case (i) of

1 : begin {фамилия и инициалы *********************************}

{контроль на буквы}

For j := 1 to length(Field) do begin

If not(Field[j] in ['А'..'п','р'..'я',' ','.']) then begin

MessageError('Поле может содержать только русские буквы, "." и " ".');

Exit;

end; {if}

end; {for}

{проверка на алфавитное следование фамилий}

If Field < PrevFIO then begin

MessageError('Нарушен алфавитный порядок следования фамилий.');

end; {if}

end; {1}

2 : begin {пол (0-1) ******************************************}

Check1; If not(RightField) then Exit;

Check2(Num(Field),0,1,'Значение поля должно быть в интервале 0 - 1.');

end; {2}

3 : begin {дата рождения (ддммгг) *****************************}

Check3; If not(RightField) then Exit;

{если пол женский, то один интервал (14-55),

если мужской, то другой (14-65)}

If Record2.Sex = 0 then

Check2(CalculationAge(Field),14,55,'Дата должна давать возраст 14 - 55 лет.')

Else

Check2(CalculationAge(Field),14,60,'Дата должна давать возраст 14 - 60 лет.');

end; {3}

4 : begin {код образования (1-7) ******************************}

Check1; If not(RightField) then Exit;

Check2(Num(Field),1,7,'Значение поля должно быть в интервале 1 - 7.');

end; {4}

5, {табельный номер}

6, {код должности}

7 : begin {заработная плата ***********************************}

Check1;

end; {5,6,7}

8 : begin {дата поступления на завод (ддммгг) *****************}

Check3; If not(RightField) then Exit;

Check4(14);

end; {8}

9 : begin {стаж работы на заводе (полных лет) *****************}

Check1; If not(RightField) then Exit;

If Num(Field) <> CalculationAge(Record2.DateEntryToFactory) then

MessageError('Стаж не подтверждается датой поступления.');

end; {9}

10 : begin {общий стаж работы (полных лет) *********************}

Check1; If not(RightField) then Exit;

If Num(Field) < Record2.LengthOfService then

MessageError('Поле не может быть меньше поля "Стаж".');

end; {10}

11 : begin {партийность (1-3) **********************************}

Check1; If not(RightField) then Exit;

Check2(Num(Field),1,3,'Значение поля должно быть в интервале 1 - 3.');

end; {11}

12 : begin {дата вступления в партию (ммгг) ********************}

Check3; If not(RightField) then Exit;

{проверка возраста во время вступления}

Case (Record2.PartyMembership) of

1 : Check4(18); {член партии}

2 : Check4(16); {член ВЛКСМ}

end; {case}

end; {12}

13 : begin {семейное положение *********************************}

Check1; If not(RightField) then Exit;

Check2(Num(Field),1,4,'Значение поля должно быть в интервале 1 - 4.');

end; {13}

end; {case}

END;

{====================================================================}

BEGIN

PrevFIO := ''; {предыдущей фамилии не было}

{бесконечный цикл, выход по 'Exit'}

While True do begin

ClrScr;

Write('г======================================================¬--------- Пол --------¬ ');

Write('¦ Фамилия и инициалы : ··············· ¦¦0 - женский ¦ ');

Write('¦ Пол : · ¦¦1 - мужской ¦ ');

Write('¦ Дата рождения (ддммгг) : ······ ¦L---------------------- ');

Write('¦ Код образования : · ¦----- Образование ----¬ ');

Write('¦ Табельный номер : ··· ¦¦1 - начальное ¦ ');

Write('¦ Код должности : ·· ¦¦2 - неполное среднее ¦ ');

Write('¦ Заработная плата (руб) : ···· ¦¦3 - среднее ¦ ');

Write('¦ Дата поступления на завод (ддммгг) : ······ ¦¦4 - ПТУ ¦ ');

Write('¦ Стаж работы на заводе (полных лет) : ·· ¦¦5 - среднеспециальное¦ ');

Write('¦ Общий стаж работы (полных лет) : ·· ¦¦6 - неполное высшее ¦ ');

Write('¦ Партийность : · ¦¦7 - высшее ¦ ');

Write('¦ Дата вступления в партию (ммгг) : ···· ¦L---------------------- ');

Write('¦ Семейное положение : · ¦----- Партийность ----¬ ');

Write('L======================================================-¦1 - член партии ¦ ');

Write('---------------------- Сообщения ----------------------¬¦2 - член ВЛКСМ ¦ ');

Write('¦ ¦¦3 - беспартийный ¦ ');

Write('¦ Заполните поля необходимой информацией. ¦L---------------------- ');

Write('¦ ¦-- Семейное положение -¬');

Write('¦ При вводе записей, фамилии ¦¦1 - не замужем/холост ¦');

Write('¦ должны следовать в алфавитном порядке. ¦¦2 - замужем/женат ¦');

Write('¦ ¦¦3 - разведена/разведен¦');

Write('¦ Если хотите закончить ввод, нажмите <Enter>. ¦¦4 - вдова/вдовец ¦');

Write('L-------------------------------------------------------L-----------------------');

With Record2 do begin

{ввод информации}

For i := 1 to 13 do begin

{если Партийность = "Беспартийный", то не запрашивать дату}

If not((i = 12) and (PartyMembership = 3)) then begin

{повторять, пока введенное поле не будет верно}

Repeat

GotoXY(40,01+i); {установить курсор}

WriteLn(LengthOfField[i]); {обозначить размер поля}

GotoXY(40,01+i); {установить курсор}

ReadLn(Field); {запросить поле}

{если введена пустая фамилия, то прекратить ввод}

If (i = 1) and (Field = '') then

Exit {выход из процедуры}

Else

ClearMessageBox; {очистить бокс сообщений}

{контроль поля}

ControlSignificance;

Until RightField;

{формирование выходных записей}

Case (i) of

1 : begin

{дополнить поле пробелами до 15 символов}

While length(Field) < 15 do Field := Field + ' ';

Record1.FIO := Field;

end;

2 : val(Field,Sex,Code);

3 : begin

BirthDay := DataImage(Field);

{расчет возраста сотрудника}

Age := CalculationAge(Field);

end;

4 : val(Field,CodeEducation,Code);

5 : val(Field,TimeSheetNumber,Code);

6 : val(Field,CodePost,Code);

7 : val(Field,Pay,Code);

8 : DateEntryToFactory := DataImage(Field);

9 : val(Field,LengthOfService,Code);

10 : val(Field,TotalLengthOfService,Code);

11 : val(Field,PartyMembership,Code);

12 : DateEntryToParty := DataImage(Field);

13 : val(Field,FamilySituation,Code);

end; {case i}

end {if}

Else begin

DateEntryToParty := '00/00';

end; {else}

end; {for i}

end; {with Record2}

PrevFIO := Record1.FIO; {запоминаем фамилию как предыдущую}

{вывод записей на диск}

Write(ff1,Record1); {вывод фамилии в соответствующий файл}

Write(ff2,Record2); {вывод записи в файл данных}

end; {while True}

END;

{**********************************************************************}

{ожидание нажатия на клавишу}

PROCEDURE WaitingForKeyPressed;

Var

Key : char;

BEGIN

(* WriteLn(#7); {звуковой сигнал} *)

WriteLn;

Write('Нажмите любую клавишу, чтобы продолжить...':60);

{пустой цикл "ПОКА" не нажата клавиша}

While not(KeyPressed) do;

Key := ReadKey; {очистить буфер клавиатуры}

WriteLn;

END;

{**********************************************************************}

{предупреждение о начале печати}

PROCEDURE WarningOfPrinting(Name : string);

BEGIN

ClrScr;

WriteLn(Name:50);

WriteLn;

WriteLn('г===============================¬':56);

WriteLn('¦ Подготовьте принтер к работе: ¦':56);

WriteLn('¦ заправьте бумагу и ¦':56);

WriteLn('¦ установите режим On Line ¦':56);

WriteLn('L===============================-':56);

WaitingForKeyPressed;

WriteLn('Идет печать. Ждите...':50);

END;

{**********************************************************************}

{печать сформированных файлов}

PROCEDURE PrintDataFiles;

BEGIN

WarningOfPrinting('Печать Списка фамилий.');

WriteLn(pr,'Сформирован Список фамилий:');

WriteLn(pr,'---------------------------');

Reset(ff1);

{пока не достигнут конец файла, выполнять...}

While not(EOF(ff1)) do begin

Read(ff1,Record1);

WriteLn(pr,Record1.FIO);

end; {while}

WriteLn(pr,#12); {перевод страницы}

WarningOfPrinting('Печать Файла данных. ');

WriteLn(pr,'Сформирован Файл данных:');

WriteLn(pr,'------------------------');

Reset(ff2);

{пока не достигнут конец файла, выполнять...}

While not(EOF(ff2)) do begin

Read(ff2,Record2);

With Record2 do begin

Write(pr,TimeSheetNumber:3,' ');

Write(pr,Sex:1,' ');

Write(pr,CodePost:2,' ');

Write(pr,DateEntryToFactory:8,' ');

Write(pr,Pay:4,' ');

Write(pr,TotalLengthOfService:2,' ');

Write(pr,LengthOfService:2,' ');

Write(pr,CodeEducation:1,' ');

Write(pr,BirthDay:8,' ');

Write(pr,PartyMembership:1,' ');

Write(pr,DateEntryToParty:5,' ');

Write(pr,FamilySituation:1,' ');

WriteLn(pr,Age:2);

end; {with Record2}

end; {while}

WriteLn(pr,#12); {перевод страницы}

END;

{**********************************************************************}

{сортировка сформированных файлов}

PROCEDURE SortingDataFiles;

Var

Top, Bottom : integer; {начало и конец сортируемого файла}

i, j ,k : integer;

iRecord1, kRecord1 : Struct1;

iRecord, jRecord, MinRecord : Struct2;

BEGIN

ClrScr;

WriteLn('Сортировка файлов данных.':52);

WriteLn('Ждите...':43);

Top := 0; {номер первой записи файла}

Bottom := FileSize(ff2)-1; {номер последней записи файла}

For i := Top to Bottom-1 do begin

Seek(ff2,i); Read(ff2,iRecord);

MinRecord := iRecord;

k := i;

For j := i+1 to Bottom do begin

Seek(ff2,j); Read(ff2,jRecord);

If (jRecord.Sex < MinRecord.Sex) or ((jRecord.Sex = MinRecord.Sex) and (jRecord.Age < MinRecord.Age)) then begin

MinRecord := jRecord;

k := j;

end; {if}

end; {for j}

{обмен записей}

If k > i then begin

Seek(ff1,i); Read(ff1,iRecord1);

Seek(ff1,k); Read(ff1,kRecord1);

Seek(ff1,i); Write(ff1,kRecord1);

Seek(ff1,k); Write(ff1,iRecord1);

Seek(ff2,i); Write(ff2,MinRecord);

Seek(ff2,k); Write(ff2,iRecord);

end; {if}

end; {for i}

END;

{**********************************************************************}

{печать ведомости}

PROCEDURE PrintTable;

Const

{расшифровка кодов}

TextForSex : array [0..1] of string[7] =

('Женщины',

'Мужчины');

TextForPartyMembership : array [1..3] of string[11] =

('член партии',

'член ВЛКСМ ',

' б/п ');

Var

nList : byte; {номер листа ведомости}

CountLine : byte; {количество напечатанных пар строк}

nContributor : word; {номер сотрудника по порядку}

PrevSex, PrevAge : byte; {значения предыдущей записи}

SumPayForAge, {сумма по зарплате для возраста}

SumTotalLengthOfServisForAge, {сумма по об.стажу для возраста}

QuantityForAge, {число позиций для возраста}

SumPayForSex, {сумма по зарплате для пола}

SumTotalLengthOfServisForSex, {сумма по об.стажу для пола}

QuantityForSex, {число позиций для пола}

SumPayForTable, {сумма по зарплате для таблицы}

SumTotalLengthOfServisForTable, {сумма по об.стажу для таблицы}

QuantityForTable : word; {число позиций для таблицы}

BreakPage : boolean; {был ли переведен лист}

{====================================================================}

{печать текущих даты, времени и номера листа}

PROCEDURE PrintDate_Time_NumberList;

Var

Year,Month,Day,DayOfWeek : word; {переменные для машинной даты}

Hour,Minute,Second,Sec100 : word; {переменные для машинного времени}

BEGIN

GetDate(Year,Month,Day,DayOfWeek);

GetTime(Hour,Minute,Second,Sec100);

Write (pr,' Дата ', Day:2, '-', Month:2, '-', Year:4);

Write (pr,' Время ', Hour:2, ':', Minute:2, ':', Second:2, '.', Sec100:2);

Write (pr,' ');

WriteLn(pr,' Лист ', nList:2);

END;

{====================================================================}

{печать заголовка ведомости

(печатается на первом листе ведомости)}

PROCEDURE PrintTitle;

BEGIN

WriteLn(pr,''); {чтобы число строк в шапке было четным}

WriteLn(pr,' Группировка рабочих ');

WriteLn(pr,' по полу и возрасту на N-ском заводе ');

WriteLn(pr,' по состоянию рабочего фонда на ".." ........ 19.. года ');

WriteLn(pr,' ');

PrintDate_Time_NumberList; {печать текущих даты, времени и номера листа}

WriteLn(pr,'г===T=======T============T===============T=========T===========T==========T=======¬');

WriteLn(pr,'¦ N ¦Группы ¦ Группы ¦ Фамилия и ¦ Дата ¦Партийность¦Заработная¦ Общий ¦');

WriteLn(pr,'¦п/п¦рабочих¦ рабочих ¦ инициалы ¦рождения,¦ ¦ плата, ¦ стаж ¦');

WriteLn(pr,'¦ ¦по полу¦по возрасту,¦ ¦дд/мм/гг ¦ ¦ тыс.руб. ¦работы,¦');

WriteLn(pr,'¦ ¦ ¦ полных лет ¦ ¦ ¦ ¦ ¦ п.лет ¦');

WriteLn(pr,'¦---+-------+------------+---------------+---------+-----------+----------+-------¦');

WriteLn(pr,'¦ 1 ¦ А ¦ Б ¦ 2 ¦ 3 ¦ 4 ¦ 5 ¦ 6 ¦');

WriteLn(pr,'¦===+=======+============+===============+=========+===========+==========+=======¦');

CountLine := 7; {напечатано семь пар строк}

END;

{====================================================================}

{следит за переводом листа}

PROCEDURE WatchToPageBreak;

{------------------------------------------------------------------}

{печать шапки ведомости

(печатается на последующих листах ведомости)}

PROCEDURE PrintHeading;

BEGIN

PrintDate_Time_NumberList; {печать текущих даты, времени и номера листа}

WriteLn(pr,'г===T=======T============T===============T=========T===========T==========T=======¬');

WriteLn(pr,'¦ 1 ¦ А ¦ Б ¦ 2 ¦ 3 ¦ 4 ¦ 5 ¦ 6 ¦');

WriteLn(pr,'¦===+=======+============+===============+=========+===========+==========+=======¦');

CountLine := 2; {напечатано две пары строк}

END;

{------------------------------------------------------------------}

{печать "подвала" таблицы}

PROCEDURE PrintFooter;

BEGIN

{лист закончился после обычной строки}

If (Record2.Sex = PrevSex) and (Record2.Age = PrevAge) then begin

WriteLn(pr,'¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦');

WriteLn(pr,'L===¦=======¦============¦================¦=========¦===========¦==========¦=======-');

end {if}

Else begin

{лист закончился после среднего по возрасту}

If (Record2.Sex = PrevSex) and (Record2.Age <> PrevAge) then begin

WriteLn(pr,'¦ ¦ ¦ ¦');

WriteLn(pr,'L===¦=======¦============¦================¦=========¦===========¦==========¦=======-');

end {if}

{лист закончился после среднего по полу}

Else begin

WriteLn(pr,'¦ ¦ ¦');

WriteLn(pr,'L===¦=======¦============¦================¦=========¦===========¦==========¦=======-');

end; {else}

WriteLn(pr,#12); {перевод страницы}

END;

{------------------------------------------------------------------}

BEGIN

{нарастить количество напечатанных пар строк}

inc(CountLine);

{если напечатана 30-я пара, то перевести лист}

If CountLine = 30 then begin

PrintFooter;

ClrScr;

WriteLn('г===============================¬':56);

WriteLn('¦ Заправьте новый лист и ¦':56);

WriteLn('¦ установите режим On Line ¦':56);

WriteLn('L===============================-':56);

WaitingForKeyPressed;

WriteLn('Идет печать. Ждите...':50);

inc(nList); {увеличить номер листа}

PrintHeading; {печать шапки ведомости}

BreakPage := True; {лист переведен}

end {if}

Else begin

BreakPage := false; {не было перевода листа}

end; {else}

END;

{====================================================================}

{подсчет средних значений и вывод их на печать}

{Sum1,Sum2 - суммы группы по двум колонкам}

{Quantity - количество сотрудников в группе}

{n - тип среднего}

PROCEDURE CalculationAverage(var Sum1,Sum2,Quantity : word;

n : byte);

Var

AverageSum1,AverageSum2 : word;

BEGIN

{подсчет средних арифметических}

AverageSum1 := round(Sum1/Quantity);

AverageSum2 := round(Sum2/Quantity);

Case (n) of

1 : begin

WriteLn(pr,'¦ ¦ ¦ ¦');

Write (pr,'¦ ¦ ¦Среднее по возрасту :');

end;

2 : begin

WriteLn(pr,'¦ ¦ ¦');

Write (pr,'¦ ¦Среднее по полу : ');

end;

3 : begin

WriteLn(pr,'¦ ¦');

Write (pr,'¦Среднее по таблице : ');

end;

end; {case n}

WriteLn(pr,AverageSum1:37,AverageSum2:9,' ¦');

{если это не итог по таблице, то подчеркнуть средние}

If n < 3 then begin

WatchToPageBreak;

{если лист не переведен, то подчеркнуть ср. арифметические}

If not(BreakPage) then begin

Case (n) of

1 : begin

WriteLn(pr,'¦ ¦ ¦ ¦');

WriteLn(pr,'¦ ¦ +------------+---------------+---------+-----------+----------+-------¦');

end;

2 : begin

WriteLn(pr,'¦ ¦ ¦');

WriteLn(pr,'¦ +-------+------------+---------------+---------+-----------+----------+-------¦');

end;

end; {case n}

WatchToPageBreak;

end; {if}

end;

{обнулить значения для следующего подсчета}

Sum1 := 0;

Sum2 := 0;

Quantity := 0;

END;

{====================================================================}

BEGIN

WarningOfPrinting('Печать Ведомости. ');

nList := 1; {номер листа ведомости}

nContributor := 0; {номер сотрудника по порядку}

CountLine := 0; {число напечатанных пар строк}

{начальные присваивания}

Reset(ff2);

Read(ff2,Record2);

PrevSex := Record2.Sex;

PrevAge := Record2.Age;

SumPayForAge := 0;

SumTotalLengthOfServisForAge := 0;

QuantityForAge := 0;

SumPayForSex := 0;

SumTotalLengthOfServisForSex := 0;

QuantityForSex := 0;

SumPayForTable := 0;

SumTotalLengthOfServisForTable := 0;

QuantityForTable := 0;

PrintTitle; {печать заголовка ведомости}

{непосредственно печать ведомости}

Reset(ff1);

Reset(ff2);

{пока не достигнут конец файла, выполнять...}

While not(EOF(ff1)) do begin

Read(ff1,Record1);

Read(ff2,Record2);

With Record2 do begin

{сменился ключ Возраст?}

If Age <> PrevAge then begin

CalculationAverage(SumPayForAge,SumTotalLengthOfServisForAge,QuantityForAge,1);

PrevAge := Age;

end; {if}

{сменился ключ Пол?}

If Sex <> PrevSex then begin

CalculationAverage(SumPayForSex,SumTotalLengthOfServisForSex,QuantityForSex,2);

PrevSex := Sex;

end; {if}

inc(nContributor); {нарастить номер сотрудника}

{напечатать очередную строчку}

WriteLn(pr,'¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦');

Write(pr,'¦',nContributor:2,'.');

If SumTotalLengthOfServisForSex = 0 then Write(pr,'¦',TextForSex[Sex]:7)

else Write(pr,'¦ ');

If SumTotalLengthOfServisForAge = 0 then Write(pr,'¦ ',Age:2)

else Write(pr,'¦ ');

Write(pr,' ¦',Record1.FIO:15);

Write(pr,'¦',BirthDay:8);

Write(pr,' ¦',TextForPartyMembership[PartyMembership]:11);

Write(pr,'¦ ',Pay:4);

WriteLn(pr,' ¦ ',TotalLengthOfService:2,' ¦');

WatchToPageBreak;

{нарастить значания для средних арифметических}

inc(SumPayForAge,Pay);

inc(SumTotalLengthOfServisForAge,TotalLengthOfService);

inc(QuantityForAge);

inc(SumPayForSex,Pay);

inc(SumTotalLengthOfServisForSex,TotalLengthOfService);

inc(QuantityForSex);

inc(SumPayForTable,Pay);

inc(SumTotalLengthOfServisForTable,TotalLengthOfService);

inc(QuantityForTable);

end; {with Record2}

end; {while}

{подвести итоги по всей таблице}

CalculationAverage(SumPayForAge,SumTotalLengthOfServisForAge,QuantityForAge,1);

CalculationAverage(SumPayForSex,SumTotalLengthOfServisForSex,QuantityForSex,2);

CalculationAverage(SumPayForTable,SumTotalLengthOfServisForTable,QuantityForTable,3);

WriteLn(pr,'¦ ¦');

WriteLn(pr,'L===¦=======¦============¦===============¦=========¦===========¦==========¦=======-');

WriteLn(pr,#12); {перевод страницы}

END;

{**********************************************************************}

{************************ Основная программа **************************}

{**********************************************************************}

BEGIN

{в отладочных целях вводится печать в файл}

Assign(pr,'Printer.txt');

Rewrite(pr);

{определяется файл для списка фамилий}

Assign(ff1,'Surname.dat');

Rewrite(ff1);

{определяется файл данных для записи вводимой информации}

Assign(ff2,'DataSet.dat');

Rewrite(ff2);

{ввод информации (внутри - контроль и запись на диск)}

InputRecordFromInputStream;

ClrScr;

WriteLn('Введено записей : ':46,FileSize(ff1):5);

WaitingForKeyPressed;

{если файл не пуст (введено больше 0 записей), то...}

If FileSize(ff1) > 0 then begin

{печать сформированных файлов}

PrintDataFiles;

{сортировка сформированных файлов}

SortingDataFiles;

{печать ведомости}

PrintTable;

end;

Close(ff1);

Close(ff2);

Close(pr);

END.

Uses

Crt,Dos;

Type

Men = record

Name : String[15] ;

TabNumber : Byte;

PayMent : Word;

Stage : Byte;

Education : Byte ;

Burndate : Longint ; { по типу 930211 }

Age : Byte ;

End;

Var

F : File of Men;

F1 : Text;

I,T : Integer;

ColMen : Integer;

Table : array [1..99] of Men;

{ --=================================================================-- }

{ --===================== Описания процедур ========================-- }

{ --=================================================================-- }

Procedure Input_Database;

{ Процедура ввода исходных данных }

Const

sDay : Array [1..12] of Byte = (31,28,31,30,31,30,31,31,30,31,30,31);

Label

Name_Repeat,Date_Repeat,Stage_Repeat,Education_Repeat,Pay_Repeat;

Var

S : String;

W : Longint;

Error : Boolean;

Year : Word;

Month,Day : Byte;

C : Char;

Procedure Strike;

{ Процедура убирает с экрана неправильную надпись и сообщение об ошибке }

Begin

C:=ReadKey;

GoToXY(1,WhereY);

ClrEol;

GoToXY(1,WhereY-1);

ClrEol;

End;

Procedure Look_Age;

{ процедура вычисляет по дате рождения и сегодняшней дате возраст человека }

Var

Year,Day,Month,DayofWeek : Word ;

Y,D,M : Integer ;

S1,S2,S3,S : String ;

Len : Integer ;

V : Integer ;

Begin

GetDate(Year,Month,Day,DayOfWeek);

Year:=Year-1900;

Str(Table[t].BurnDate,S);

Len:=Length(S);

S1:=Copy(S,Len-1,2);

S2:=Copy(S,Len-3,2);

S3:=Copy(S,Len-5,2);

Val(S1,D,I);

Val(S2,M,I);

Val(S3,Y,I);

V:=Day-D;

If V<0 Then Dec(Month);

V:=Month-M;

If V<0 Then Dec(Year);

V:=Year-Y;

Table[t].Age:=V;

End;

Begin

Assign(F,'Men.inp');

{$I-}

Reset(f);

{$I+}

IF IOResult<>0 Then

Begin

WriteLn('Файл данных не найден, введите данные с клавиатуры :');

Repeat

Write('Сколько всего рабочих (1..99):');ReadLn(ColMen);

Until (ColMen<100) and (ColMen>0);

WriteLn;

For t:=1 to ColMen Do

Begin

WriteLn('Вводятся данные о человеке N',t,'.');

WriteLn('Порядковый номер :',t);

Table[t].TabNumber:=t;

Name_Repeat:

Write('Фамилия :');ReadLn(S);

If (Length(S)>15) or (Length(S)<1) then

Begin

Write('Фамилия не должна быть длиннее 15 символов.');

Strike;

GoTo Name_Repeat;

End;

Table[t].Name:=S;

Pay_Repeat:

Write('Зарплата :');ReadLn(W);

If (W<1) or (W>999) Then

Begin

Write('Зарплата не должна быть <0 или >999 рублей.');

Strike;

GoTo Pay_Repeat;

End;

Table[t].PayMent:=W;

Education_Repeat:

Write('Код образования :');ReadLn(W);

If (W<1) or (W>5) Then

Begin

Write('Код образования - это число в интервале от 1 до 5.');

Strike;

GoTo Education_Repeat;

End;

Table[t].Education:=W;

Date_Repeat:

Error:=False;

Write('Дата роджения (ГГММДД) :');ReadLn(W);

If W>921212 Then Error:=True;

If W<100101 Then Error:=True;

Str(W,S);

Val(Copy(s,1,2),Year,i);

Year:=Year+1900;

Val(Copy(S,3,2),Month,i);

Val(Copy(S,5,2),Day,i);

If (Month<1) or (Month>12) then Error:=True;

If (sDay[Month]<Day) or (Day<1) then Error:=True;

If (Year/4=Trunc(Year/4)) and (Month=2) and (Day=29) then Error:=False;

If Error Then

Begin

Write('Такие люди нетрудоспособны !');

Strike;

GoTo Date_Repeat;

End;

Table[t].BurnDate:=W;

Look_Age;

WriteLn('Возраст :',Table[t].Age);

Stage_Repeat:

Write('Общий стаж :');ReadLn(W);

If (W<0) or (W>Table[t].Age-14) then

Begin

Write('Такого стажа не может быть !');

Strike;

GoTo Stage_Repeat;

End;

Table[t].Stage:=W;

Writeln;

End;

WriteLn;Write('Сохранить все в файле ?(Y/N)');

Repeat

C:=ReadKey;

C:=UpCase(C);

Until (C='Y') or (C='N');

WriteLn;

If C='Y' then

Begin

ReWrite(F);

For t:=1 to ColMen Do Write(F,Table[t]);

Close(F);

End;

End Else

Begin

WriteLn('Файл данных найден. Читаю из файла ...');

T:=1;

While not eof(F) Do

Begin

Read(F,Table[t]);

Inc(t);

End;

ColMen:=t-1;

End;

Procedure Swap;

{ Вызывается из Sort и Sort_Name }

{ Меняет местами двух людей в массиве при сортировке }

Var

Temple : Men;

Begin

Temple:=Table[i];

Table[i]:=Table[i+1];

Table[i+1]:=Temple;

End;

Procedure Sort;

{ В качестве процедуры сортировки используется т.н. пузырьковая сортировка }

Begin

WriteLn('Сортируем данные по возрасту и образованию ...');

For t:=ColMen-1 DownTo 1 Do

For i:=1 to t Do

If Table[i].Age>Table[i+1].Age Then Swap;

For t:=ColMen-1 DownTo 1 Do

For i:=1 to t Do

If Table[i].Age=Table[i+1].Age Then

If Table[i].Education>Table[i+1].Education Then Swap;

End;

Procedure Sort_Name;

{ Сделана по образу и подобию предыдущей, но сортирует все по именам }

Begin

For t:=ColMen-1 DownTo 1 Do

For i:=1 to t Do

If Table[i].Name>Table[i+1].Name then Swap;

End;

Procedure Write_Table;

{ Записывает в файл получившиеся рез-ты и выводит их на экран }

Const

VVV = ' ¦ ';

Mes1 = 'Средние арифметические ';

Mes2 = 'Средние для одного возраста ';

Var

First,Second : Byte ;

Len : Byte ;

S,Full : String ;

AE_Pay,AE_Stage : Longint;

F_Pay,F_Stage : Longint;

AE_CountMen : Byte ;

F_CountMen : Byte ;

Summing,F_Summing : Boolean;

Writing,F_Writing : Boolean;

Double : Boolean;

Procedure Add_Space(Count : Byte);

{ Процедура добавляет к строке Full заданное количество пробелов }

{ Эта процедура используется при центроровании фамилии }

Var

Cyc : Byte;

Begin

Cyc:=0;

While Cyc<Count Do

Begin

Inc(Cyc);

Full:=Full+' ';

End;

Procedure P1;

Begin

Full:=Full+S+VVV;

End;

Procedure Add_One;

Begin

AE_Stage:=AE_Stage+Table[t].Stage;

AE_Pay:=AE_Pay+Table[t].PayMent;

Inc(AE_CountMen);

End;

Procedure ADD_One_F;

Begin

F_Stage:=F_Stage+Table[t].Stage;

F_Pay:=F_Pay+Table[t].PayMent;

Inc(F_CountMen);

End;

Procedure Clear_AE;

Begin

AE_CountMen:=0;

AE_Stage:=0;

AE_Pay:=0;

Summing:=False;

End;

Procedure Clear_F;

Begin

F_Pay:=0;

F_Stage:=0;

F_CountMen:=0;

F_Summing:=False;

End;

Procedure Clear_Writing;

Begin

Writing:=False;

F_writing:=False;

End;

Procedure Out_Sum(Mes : String ; Pay,Stage : Longint; CountMen : Byte);

{ Процедура выводит средние арифметические для стажа и зарплаты }

Var

Middle : Word;

Begin

If Not Double then

WriteLn(F1,'+------+------+-----+-------------------+------+----------+-------+------+');

If F_Writing then Double:=True;

Full:='¦ '+Mes+' ¦ ';

Middle:=Round(Pay/CountMen);

Str(Middle,S);

If Middle<10 then S:='0'+S;

If Middle<100 then S:='0'+S;

p1;

Middle:=Round(Stage/CountMen);

Str(Middle,S);

If Middle<10 then S:='0'+S;

Full:=Full+S+' ¦';

WriteLn(F1,Full);

If (Summing=False) and (F_Summing=True) then Double:=False;

If Not Double then

WriteLn(F1,'+------T------T-----T-------------------T------T----------+-------+------+');

End;

Begin

WriteLn('Идет создание файлов ...');

Double:=False;

Clear_AE;

Clear_F;

Clear_Writing;

Assign(F1,'men.tab');ReWrite(F1);

WriteLn(F1,'-------T------T-----T-------------------T------T----------T-------T------¬');

WriteLn(F1,'¦Номер ¦ Возр ¦ Обр ¦ Фамилия ¦Таб.N ¦Дата рожд.¦ З/П ¦ Стаж ¦');

For t:=1 to ColMen Do

Begin

If Not Summing And Not Writing And not F_Writing then

WriteLn(F1,'+------+------+-----+-------------------+------+----------+-------+------+');

Clear_Writing;

If (Table[t].Age=Table[t+1].Age) And (Table[t].Education=Table[t+1].Education) Then

Begin

Summing:=True;

Add_One;

End Else

If Summing then

Begin

Add_One;

Writing:=True;

End;

If Table[t].Age=Table[t+1].Age then

Begin

F_Summing:=True;

Add_One_F;

End Else

If F_Summing then

Begin

Add_One_F;

F_Writing:=True;

End;

Full:='¦ ';

Str(T,S);

If T<10 then S:='0'+S;

p1;

Str(Table[t].Age,S);

p1;

Str(Table[t].Education,S);

p1;

S:=Table[t].Name;

Len:=Length(S);

First:=15-Len;

First:=Trunc(First/2);

Second:=15-First-Len;

Add_Space(First);

Full:=Full+S;

Add_Space(Second);

Full:=Full+VVV;

Str(Table[t].TabNumber,S);

If Table[t].TabNumber<10 then S:='0'+S;

p1;

Str(Table[t].BurnDate,S);

p1;

Str(Table[t].PayMent,S);

If Table[t].PayMent<10 then S:='0'+S;

If Table[t].PayMent<100 then S:='0'+S;

p1;

Str(Table[t].Stage,S);

If Table[t].Stage<10 then S:='0'+S;

p1;

WriteLn(F1,Full);

If (Summing and (t=ColMen)) or Writing Then

Begin

Out_Sum(Mes1,AE_Pay,AE_Stage,AE_CountMen);

Clear_AE;

End;

If (F_Summing and (t=ColMen)) or F_Writing then

Begin

Out_Sum(Mes2,F_Pay,F_Stage,F_CountMen);

Clear_F;

End;

WriteLn(F1,'L------+------+-----+-------------------+------+----------+-------+-------');

Close(f1);

WriteLn('Таблица записана под именем ''MEN.TAB''.');

WriteLn('Сортируем по фамилиям ...');

Sort_Name;

Assign(F1,'men.sfn');ReWrite(F1);

For t:=1 to ColMen do WriteLn(F1,Table[t].Name);

Close(F1);

WriteLn('Файл отсортированных фамилий записан как ''MEN.SFN''.');

Assign(f1,'men.tab');ReSet(F1);

While not Eof(f1) Do

Begin

ReadLn(F1,S);

WriteLn(S);

End;

{ ---============================================================--- }

{ ---==================== ОСНОВНАЯ ПРОГРАММА ====================--- }

{ ---============================================================--- }

Begin

Clrscr;

Input_Database;

Sort;

Write_Table;

End.