Добавить в код обработку комбинаций клавиш

program KP_15;
 
{$M $1000, 0, 0}
 
uses
  Crt, Dos;
 
type
  Status = (Assigned, Wait, Suspended);
 
const
  MaxBufferSize = 15; { Размер буфера }
  Infinity = MaxLongint; { Бесконечность }
  Line: String[30] = 'Бегущая строка...';{Текст бегущей строки }
 
var
  Buffer: Array[1..MaxBufferSize] of Longint; 
  top: Integer; 
  StMusic, StPNS, StPNP, StCL, StClock: Status; 
  SaveInt8, _SaveInt8, SaveInt9: Procedure;
  T_Delay: Integer;                        
  PN_CTime, M_Ctime, C_Ctime, cnt, cnt_d, _cnt: Word;
  time: Word;                               
  CurPrimeNumber: Longint;                  
  X_Clock, Y_Clock: Integer;                
  discr: Integer;                         
  CorrectSecond: Byte;                    
  Hour, Minute, Second: Byte;             
  RunSec: Byte;                           
  M_Refresh: Integer;                     
  CLPos: Word;                            
  CX, CY: Byte;    
  CLSpeed: Byte;   
  fl_next: Boolean;
  StartPos, CurPos, LL: Integer;
  temp_str: String[30];
  ScrM: Array[1..25, 1..80] of Record
    symbol: Char;
    attr: Byte;
  end Absolute $B800:$0000;
  _TheEnd: Boolean;  
  PNS_Extra_Time, PNP_Extra_Time: Integer;
 
{ Вывод строки __Str на экран начиная с положения заданного
  координатами (__X; __Y). Использует прямой доступ к видеопамяти  }
procedure WriteLine(const __Str: String; const __X, __Y: Integer);
var
  __CurPos: Integer;
  __ScrM: Array[1..25, 1..80] of Record
    symbol: Char;
    attr: Byte;
  end Absolute $B800:$0000;
begin
  __CurPos := __X;
  while (__CurPos <= 80) and (__CurPos - __X + 1<= Length(__Str)) do
  begin
    __ScrM[__Y, __CurPos].attr := White;
    __ScrM[__Y, __CurPos].symbol := __Str[__CurPos - __X + 1];
    Inc(__CurPos);
  end;
end;
 
{ Процедура обработки прерываний таймера для процесса поиска и печати
  простых чисел }
{$F+}
procedure _IntProc;
Interrupt;
begin
  Inc(PN_CTime);
  Inline($9C);
  _SaveInt8;
end;
{$F-}
 
{ Обновление показаний заполненности буфера }
procedure ProgressBarRefresh;
var
  BufferProgressBar: String[35];
begin
  BufferProgressBar := '';
  while Length(BufferProgressBar) < 35 * top div MaxBufferSize do
    BufferProgressBar := BufferProgressBar + Chr(219);
  while Length(BufferProgressBar) < 35 do
    BufferProgressBar := BufferProgressBar + Chr(176);
  WriteLine('Заполняемость буфера:', 3, 9);
  WriteLine(BufferProgressBar, 3, 10);
end;
 
{ Возвращает True, если x - простое число }
function PrimeNumber(const x: Longint): Boolean;
var
  i: Integer;
begin
  PrimeNumber := False;
  if x <= 1 then Exit;
  for i := 2 to Trunc(Sqrt(x)) do
    if x mod i = 0 then Exit;
  PrimeNumber := True;
end;
 
{ Поиск простых чисел и занасение их в буфер }
procedure PrimeNumberSearch;
var
  S, ThreadTime: String;
begin
  case StPNS of { Выводим на экран состояние потока }
    Assigned:  WriteLine('Активен    ', 3, 4);
    Wait:      WriteLine('Ожидание   ', 3, 4);
    Suspended: WriteLine('Остановлен ', 3, 4);
  end;
  if (StPNS = Suspended) or ((StPNS = Wait) and (top >= MaxBufferSize)) then Exit;
  GetIntVec($8, @_SaveInt8);
  SetIntVec($8, Addr(_IntProc));
  PN_CTime := 0;                  { Текущее местное время для потока }
  while PN_CTime < time + PNS_Extra_Time do { пока не исчерпано стандартное и дополнительное время этого потока }
  begin
    Str(time, S);
    WriteLine('Выделенное время: ' + S + '       ', 3, 6);
    Str(PNS_Extra_Time, S);
    WriteLine('Дополнительное время: ' + S + '      ', 3, 7);
    if top >= MaxBufferSize then { Буфер полон }
    begin
      StPNS := Wait;       { Переходим в режим ожидания }
      WriteLine('Ожидание   ', 3, 4); { Обновляем состояние на экране }
      Break;
    end
    else
    begin
      if StPNS = Wait then { Переходим в активный режим, если ждали }
      begin
        StPNS := Assigned;
        WriteLine('Активен    ', 3, 4); { Обновляем состояние на экране }
      end;
      repeat  { ищем следующее за CurPrimeNumber простое число }
        Inc(CurPrimeNumber);
      until PrimeNumber(CurPrimeNumber) or (CurPrimeNumber >= Infinity);
      { Если найденное число не простое, то это значит, что следующее
        простое число не помещается в тип Longint. Выходим             }
      if not PrimeNumber(CurPrimeNumber) then Exit;
      { Добавляем число в буфер в позицию top }
      Inc(top);
      Buffer[top] := CurPrimeNumber;
      ProgressBarRefresh; { Обновляем показания нашего ProgressBar'а }
    end;
    Delay(T_Delay);  { Заданная задержка }
  end;
  { Сообщаем, что поток отработал свое время }
  WriteLine('Время вышло', 3, 4);
  SetIntVec($8, Addr(_SaveInt8));
end;
 
{ Вывод на экран простых чисел из буфера }
procedure PrimeNumberPrint;
var
  i: Integer;
  X, Y: Integer;
  tmp, S: String;
begin
  case StPNP of  { Выводим на экран состояние потока }
    Assigned:  WriteLine('Активен    ', 41, 4);
    Wait:      WriteLine('Ожидание   ', 41, 4);
    Suspended: WriteLine('Остановлен ', 41, 4);
  end;
  if (StPNP = Suspended) or ((StPNP = Wait) and (top <= 0)) then Exit;
  GetIntVec($8, @_SaveInt8);
  SetIntVec($8, Addr(_IntProc));
  PN_CTime := 0;                  { Текущее местное время для потока }
 
  while PN_CTime < time + PNP_Extra_Time do  { пока не исчерпано стандартное и дополнительное время этого потока }
  begin
    Str(time, S);
    WriteLine('Выделенное время: ' + S + '       ', 41, 6);
    Str(PNP_Extra_Time, S);
    WriteLine('Дополнительное время: ' + S + '      ', 41, 7);
    if top > 0 then { Если буфер не пуст }
    begin
      if StPNP = Wait then { Переходим в активный режим, если ждали }
      begin
        WriteLine('Активен    ', 41, 4);
        StPNP := Assigned;
      end;
      Str(Buffer[1], tmp);
      { Если число не помещается в текущей строке - переходим на следующую }
      if CX + Length(tmp) + 1 > 34 then
      begin
        CX := 1; { И пишем с начала строки }
        Inc(CY);
      end;
      { Если следующей строки нет - очищаем область окна и пишем по новому }
      if CY > 13 then
      begin
        CY := 9;
        Window(41, 5, 78, 16);
        TextBackGround(Black);
        ClrScr;
      end;
      WriteLine(tmp + ' ', 40 + CX, CY); { Собственно пишем }
      CX := CX + Length(tmp) + 1; { Фиксируем текущую свободную позицию }
      { Удаляем первое число из буфера. Это FIFO структура. Можно
        было реализовать лучше, не используюя сдвиг элементов массива,
        но здесь это особой роли не играет }
      Dec(top);
      for i := 1 to top do
        Buffer[i] := Buffer[i + 1];
      ProgressBarRefresh; { Обновляем показания нашего ProgressBar'а }
    end
    else  { Буфер пуст. Переходим в состояние ожидания }
    begin
      StPNP := Wait;
      WriteLine('Ожидание   ', 41, 4);
      Break;
    end;
    Delay(T_Delay);
  end;
  { Сообщаем, что процесс отработал свое время }
  WriteLine('Время вышло', 41, 4);
  SetIntVec($8, Addr(_SaveInt8));
end;
 
{ Добавляет нули слева (при необходимости) для времени }
function LeadingZero(const W: Word): String;
var
  S: String;
begin
  Str(W:0, S);
  if Length(S) = 1 then S := '0' + S;
  LeadingZero := S;
end;
 
{ переводит время в "человеческий" формат }
procedure CheckTime;
begin
  if Second = 60 then
  begin
    Second := 0;
    Inc(Minute);
    if Minute = 60 then
    begin
      Minute := 0;
      Inc(Hour);
      if Hour = 24 then
        Hour := 0;
    end;
  end;
end;
 
{ Получает системное время и начинает собственный отсчет с помощью прерываний
  таймера                                                }
procedure TimeRefresh;
var
  CH, CM, CS, CS100: Word;
begin
  RunSec := 0;
  GetTime(CH, CM, CS, CS100);
  discr := 1;
  cnt_d := discr;
  Hour := CH;
  Minute := CM;
  Second := CS;
  CorrectSecond := 5;
  cnt := Trunc((99 - CS100) * 0.18);
end;
 
{ Сдвигает бегущую строку }
procedure CreepingLine;
begin
  if StartPos > 1 then
    Dec(StartPos)
  else
    StartPos := 80;
  CurPos := StartPos;
  temp_str := ScrM[CLPos, CurPos].symbol + temp_str;
  while (CurPos <= 80) and (CurPos - StartPos <= LL) do
  begin
    ScrM[CLPos, CurPos].attr := LightRed;
    ScrM[CLPos, CurPos].symbol := Line[CurPos - StartPos + 1];
    Inc(CurPos);
  end;
  if StartPos + LL <= 80 then
  begin
    ScrM[CLPos, StartPos + LL].attr := LightGray;
    ScrM[CLPos, StartPos + LL].symbol := temp_str[Length(temp_str)];
    Delete(temp_str, Length(temp_str), 1);
  end;
  if (StartPos >= 81 - LL) and (ScrM[CLPos, 1].attr = LightRed) then
  begin
    CurPos := 1;
    while CurPos <= LL - (80 - StartPos + 1) do
    begin
      ScrM[CLPos, CurPos].attr := LightRed;
      ScrM[CLPos, CurPos].symbol := Line[80 - StartPos + 1 + CurPos];
      Inc(CurPos);
    end;
    ScrM[CLPos,LL-(80-StartPos+1)+1].attr := LightGray;
    ScrM[CLPos,LL-(80-StartPos+1)+1].symbol := temp_str[length(temp_str)];
    Delete(temp_str,length(temp_str),1);
  end;
end;
 
 
{ Процедура обработки прерываний таймера для часов, музыки и бегущей строки }
{$F+}
procedure IntProc;
Interrupt;
begin
  if StMusic <> Suspended then { Если процесс "Музыка" не остановлен }
  begin
    Inc(M_CTime);
    if M_CTime = M_Refresh then
    begin
      M_CTime := 0;
      Randomize;
      NoSound;
      Sound(Random(6000));
    end;
  end;
  if StClock <> Suspended then { Если процесс "Часы" не остановлен }
  begin
    if cnt = 0 then
    begin
      Inc(Second);
      CheckTime;
      Inc(RunSec);
      Inc(cnt_d);
      Dec(CorrectSecond);
      if CorrectSecond = 0 then
      begin
        CorrectSecond:=5;
        cnt := 19;
      end
      else
        cnt := 18;
      if cnt_d >= discr then
      begin
        cnt_d := 0;
        WriteLine(LeadingZero(Hour) + ':' + LeadingZero(Minute) +
          ':' + LeadingZero(Second), X_Clock, Y_Clock);
      end;
      if RunSec mod 20 = 0 then
      begin
        Inc(Second);
        CheckTime;
        if (20 mod discr = 0) or (discr mod 20 = 0) then
          WriteLine(LeadingZero(Hour) + ':' + LeadingZero(Minute) +
            ':' + LeadingZero(Second), X_Clock, Y_Clock);
      end;
      if RunSec = 100 then
      begin
        RunSec := 0;
        Inc(Second);
        CheckTime;
        if (20 mod discr = 0) or (discr mod 20 = 0) then
          WriteLine(LeadingZero(Hour) + ':' + LeadingZero(Minute) +
            ':' + LeadingZero(Second), X_Clock, Y_Clock);
      end;
    end
    else
      Dec(cnt);
  end;
  if StCL <> Suspended then { Если процесс "Бегущая строка" не остановлен }
  begin
    Inc(_cnt);
    if _cnt > round(18.2 / CLSpeed) then
    begin
      _cnt := 0;
      CreepingLine;
    end;
  end;
  Inline($9C);
  SaveInt8;
end;
{$F-}
 
{ Инициализация переменных перед запуском основных процедур }
procedure Initialize;
begin
  _TheEnd := False;
  StMusic := Assigned;
  StPNS := Assigned;
  StPNP := Wait;
  StCL := Assigned;
  StClock := Assigned;
  M_CTime := 0;
  M_Refresh := 2;
  CLSpeed := 12;
  LL := Length(Line);
  _cnt := 0;
  StartPos := 81;
  top := 0;
  CurPrimeNumber := 1;
  CX := 1;
  CY := 9;
  PNS_Extra_Time := 0;
  PNP_Extra_Time := 0;
  TimeRefresh;
end;
 
{ Процедура завершения работы программы }
procedure TheEnd;
begin
  StPNS := Suspended; { Останавливаем поток поиска простых чисел }
  time := 0;
  PNS_Extra_Time := 0;
  StPNP := Assigned;
  while top > 0 do    { Считываем всё оставшееся из буфера }
  begin
    time := 2;
    PrimeNumberPrint;
  end;
  StPNP := Suspended;
  StMusic := Suspended;
  StClock := Suspended;
  StCL := Suspended;
  Window(1, 1, 80, 25);
  TextBackGround(White);
  ClrScr;
  TextColor(LightRed);
  GotoXY(36, 12);
  WriteLn('HAPPY END');
  GotoXY(1, 24);
  NoSound;
  Halt(0);
end;
 
{ Процедура обработки прерываний клавиатуры }
{$F+}
procedure IntProcKeyboard;
Interrupt;
begin
  case Port[$60] of
    1: { нажата Esc }
      begin
        PN_CTime := High(PN_CTime); { Время работы потоков. Принудительно завершаем поток. }
        _TheEnd := True; { Устанавливаем флаг выхода }
      end;
    2: if PNS_Extra_Time > 0 then Dec(PNS_Extra_Time);   { нажата 1 }
    3: if PNS_Extra_Time < 10 then Inc(PNS_Extra_Time);  { нажата 2 }
    4: if PNP_Extra_Time > 0 then Dec(PNP_Extra_Time);   { нажата 3 }
    5: if PNP_Extra_Time < 10 then Inc(PNP_Extra_Time);  { нажата 4 }
    51: if CLSpeed < 16 then Inc(CLSpeed);       { нажата < }
    52: if CLSpeed > 1 then Dec(CLSpeed);        { нажата > }
    59: { нажата F1 }
      if StMusic = Assigned then
      begin
        NoSound;
        StMusic := Suspended;
      end 
      else StMusic := Assigned;      
    60: { нажата F2 }
      if StClock = Assigned then
        StClock := Suspended
      else
      begin
        TimeRefresh;
        StClock := Assigned;
      end;
    61: if StCL = Assigned then StCL := Suspended else StCL := Assigned;           { нажата F3 }
    62: if StPNS <> Suspended then StPNS := Suspended else StPNS := Assigned;      { нажата F4 }
    63: if StPNP <> Suspended then StPNP := Suspended else StPNP := Assigned;      { нажата F5 }
  end;
  Inline($9C);
  SaveInt9;
end;
 
var
  Code: Integer;
  _CLPos: String;
begin
  Val(ParamStr(1), X_Clock, Code);
  Val(ParamStr(2), Y_Clock, Code);
  _CLPos := ParamStr(3);
  if ParamCount = 0 then
  begin
    WriteLn;
    WriteLn('Не были указаны параметры командной строки.');
    WriteLn('Программа будет запущена с параметрами по умолчанию');
    WriteLn;
    WriteLn('Для продолжения нажмите любую клавишу...');
    ReadKey;
    X_Clock := 73;
    Y_Clock := 1;
    _CLPos := 'B';
  end
  else if (ParamCount <> 3) or (X_Clock <= 0) or (X_Clock > 73) or
    (Y_Clock <= 0) or (Y_Clock > 25) or
      ((Upcase(_CLPos[1]) <> 'A') and (Upcase(_CLPos[1]) <> 'B')) then
  begin
    WriteLn;
    WriteLn('Неверные параметры.');
    WriteLn;
    WriteLn('Правильный формат:');
    WriteLn(' имя_файла X Y P');
    WriteLn('где X, Y - координаты положения часов,');
    WriteLn('P - символ - положение бегущей строки:');
    WriteLn('a - вверху экрана, b - внизу.');
    Halt;
  end;
  if Upcase(_CLPos[1]) = 'A' then CLPos := 1 else CLPos := 25;
  { Заполняем экран начальными данными и окнами }
  TextBackGround(Black);
  ClrScr;
  Window(2, 2, 38, 17);
  TextBackGround(1);
  ClrScr;
  Window(3, 3, 37, 16);
  TextBackGround(Black);
  ClrScr;
  WriteLine('Поток 1. Поиск простых чисел.', 3, 3);
  Window(40, 2, 79, 17);
  TextBackGround(2);
  ClrScr;
  Window(41, 3, 78, 16);
  TextBackGround(Black);
  ClrScr;
  WriteLine('Поток 2. Печать найденных чисел.', 41, 3);
  Window(2, 19, 79, 24);
  TextBackGround(3);
  ClrScr;
  WriteLn('Esc - завершение работы программы, F1 - запустить/остановить музыку,');
  Write('F2 - запустить/остановить часы, ');
  WriteLn('F3 - запустить/остановить бегущую строку,');
  WriteLn('F4 - изменить состояние ("Активен"/"Остановлен") потока поиска простых чисел,');
  WriteLn('F5 - изменить состояние ("Активен"/"Остановлен") потока печати простых чисел,');
  WriteLn('1/2 - увеличить/уменьшить время работы потока поиска простых числел,');
  Write('3/4 - аналогично для печати п. чис., </> - увелич./уменьш. скорости бег. стр.');
  T_Delay := 9000;
 
  Initialize;
 
  Randomize;
 
  GetIntVec($8, @SaveInt8);
  SetIntVec($8, Addr(IntProc));
 
  GetIntVec($9, @SaveInt9);
  SetIntVec($9, Addr(IntProcKeyboard));
 
  while True do
  begin
    if _TheEnd then TheEnd;
    time := Random(2) + 1;
    case Random(2) + 1 of
      1: PrimeNumberSearch;
      2: PrimeNumberPrint;
    end;
  end;
end.