Основы алгоритмизации и алгоритмические языки

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;
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;
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,'ГДДДДДДВДДДДДДВДДДДДВДДДДДДДДДДДДДДДДДДДВДДДДДДВДДДДДДДДДДЕДДДДДДДЕДДДДДДґ');
End;
Begin
WriteLn('Идет создание файлов ...');
Double:=False;
Clear_AE;
Clear_F;
Clear_Writing;
Assign(F1,'men.tab');ReWrite(F1);

WriteLn(F1,'ЪДДДДДДВДДДДДДВДДДДДВДДДДДДДДДДДДДДДДДДДВДДДДДДВДДДДДДДДДДВДДДДДДДВДДДДДДї');
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;
End;

WriteLn(F1,'АДДДДДДБДДДДДДБДДДДДБДДДДДДДДДДДДДДДДДДДБДДДДДДБДДДДДДДДДДБДДДДДДДБДДДДДДЩ');
  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;
End;
{
---============================================================--- }
{
---==================== ОСНОВНАЯ ПРОГРАММА ====================--- }
{
---============================================================--- }
Begin
Clrscr;
Input_Database;
Sort;
Write_Table;
End.
{**************************************************
                 Курсовая работа
                       по
            Основам Алгоритмизации и
             Алгоритмическим Языкам
       (с) 1993 Росляков Владимир ВИ-304
           Программа написана на языке
            Turbo Pascal Version 6.0
   Copyright (c) 1983,90 Borland International
***************************************************}
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('є             Дата рождения (ддммгг) : ъъъъъъ          єАДДДДДДДДДДДДДДДДДДДДДЩ ');
      Write('є                    Код образования : ъ               єЪДДДД Образование ДДДДї ');
      Write('є                    Табельный номер : ъъъ             єі1 - начальное
');
      Write('є                      Код должности : ъъ              єі2 - неполное среднее і ');
      Write('є             Заработная плата (руб) : ъъъъ            єі3 - среднее          і ');
      Write('є Дата поступления на завод
(ддммгг) : ъъъъъъ          єі4 -
ПТУ              і ');
      Write('є Стаж работы на заводе (полных
лет) : ъъ              єі5 -
среднеспециальноеі ');
      Write('є    Общий стаж работы
(полных лет) : ъъ              єі6 -
неполное высшее і ');
      Write('є                        Партийность : ъ               єі7 - высшее           і ');
      Write('є    Дата вступления в партию (ммгг) : ъъъъ            єАДДДДДДДДДДДДДДДДДДДДДЩ ');
      Write('є                 Семейное положение : ъ               єЪДДДД Партийность ДДДДї ');

Write('ИННННННННННННННННННННННННННННННННННННННННННННННННННННННјі1 - член
партии      і ');
      Write('ЪДДДДДДДДДДДДДДДДДДДДД Сообщения
ДДДДДДДДДДДДДДДДДДДДДДїі2 - член ВЛКСМ
');
      Write('і                                                      іі3 -
беспартийный     і ');
      Write('і       Заполните поля необходимой информацией.        іАДДДДДДДДДДДДДДДДДДДДДЩ ');
      Write('і                                                      іЪД Семейное
положение Дї');
      Write('і             При вводе записей, фамилии               іі1 - не замужем/холост і');
      Write('і       должны следовать в алфавитном порядке.         іі2 - замужем/женат     і');
      Write('і                                                      іі3 -
разведена/разведені');
      Write('і     Если хотите закончить ввод, нажмите <Enter>.     іі4 - вдова/вдовец      і');
      Write('АДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДЩАДДДДДДДДДДДДДДДДДДДДДДЩ');
      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;
    WriteLn;
END;
{**********************************************************************}
{предупреждение о начале печати}
PROCEDURE WarningOfPrinting(Name : string);
BEGIN
    ClrScr;
    WriteLn(Name:50);
    WriteLn;

WriteLn('ЙННННННННННННННННННННННННННННННН»':56);
    WriteLn('є Подготовьте принтер к работе:
':56);
    WriteLn('є      заправьте бумагу и
':56);
    WriteLn('є   установите режим On Line
':56);

WriteLn('ИНННННННННННННННННННННННННННННННј':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,'ЙНННСНННННННСННННННННННННСНННННННННННННННСНННННННННСНННННННННННСННННННННННСННННННН»');
      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,'ЙНННСНННННННСННННННННННННСНННННННННННННННСНННННННННСНННННННННННСННННННННННСННННННН»');
       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,'ИНННПНННННННПННННННННННННПННННННННННННННННПНННННННННПНННННННННННПННННННННННПНННННННј');
        end {if}
        Else begin
          {лист закончился после среднего по
возрасту}
          If (Record2.Sex = PrevSex) and
(Record2.Age <> PrevAge) then begin
            WriteLn(pr,'є   і

                                 є');

WriteLn(pr,'ИНННПНННННННПННННННННННННПННННННННННННННННПНННННННННПНННННННННННПННННННННННПНННННННј');
          end {if}
          {лист закончился после среднего по
полу}
          Else begin
            WriteLn(pr,'є   і
');

WriteLn(pr,'ИНННПНННННННПННННННННННННПННННННННННННННННПНННННННННПНННННННННННПННННННННННПНННННННј');
          end; {else}
        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('ИНННННННННННННННННННННННННННННННј':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,'ИНННПНННННННПННННННННННННПНННННННННННННННПНННННННННПНННННННННННПННННННННННПНННННННј');
    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.
Курсовая работа на тему основы алгоритмизации и алгоритмическим языкам. Курсовая работа основы алгоритмизации и алгоритмическим языкам. Курсовая работа основы алгоритмизации и алгоритмических языков. Курсавая работа основы алгоритмизации и алгоритмическим языка. Реферат Основы алгоритмизации и алгоритмические языки. Курсовая работа по Основам алгоритмизации вариант. Основы алгоритмизации и алгоритмическим языкам. Основы алгоритмизации и алгоритмические языки. Примеры курсового по основам алгоритмизации. Основы алгоритмизации алгоритмические языки. Реферат на тему алгорефмические языки. Реферат на тему основы алгоритмизации. Темы курсовых работ по алгоритмизации. Основы алгоритмизации реферат. Алгоритмический язык реферат.