(* KEYS_FMS использует: OKHO_FMS *)
(* STAK_FMS *)
(* TYPE_FMS *)
(* UNIF_FMS *)
{$A+,B-,D-,E+,F+,G-,I+,L+,N-,O-,R+,S+,V+,X-}
{$M 1024,0,0}
unit Keys_FMS;
INTERFACE
uses CRT, DOS, UNIF_FMS, OKHO_FMS, STAK_FMS, TYPE_FMS;
CONST Witime : integer = 120; {Время ожидания в секундах }
UP =-72; Shift_UP =-72;
DOWN =-80; Shift_DOWN =-80;
LEFT =-75; Shift_LEFT =-75; Ctrl_LEFT =-115;
RIGHT=-77; Shift_RIGHT=-77; Ctrl_RIGHT=-116;
HOME =-71; Shift_HOME =-71; Ctrl_HOME =-119;
ENDD =-79; Shift_ENDD =-79; Ctrl_ENDD =-117;
PgUp =-73; Shift_PgUp =-73; Ctrl_PgUp =-132;
PgDn =-81; Shift_PgDn =-81; Ctrl_PgDn =-118;
BACK = 8; Shift_BACK = 8; Ctrl_BACK =-127;
DEL =-83; Shift_DEL = 46;
INS =-82; Shift_INS = 48;
TAB = 9; Shift_TAB =-15;
ESC = 27; Shift_ESC = 27; Ctrl_ESC =-117;
ENTER= 13; Shift_ENTER= 13; Ctrl_ENTER= 10;
BLANK= 32; Shift_BLANK= 32; Ctrl_BLANK= 32; Alt_BLANK= 32;
F1 =-59; Shift_F1 =-84; Ctrl_F1 = -94; Alt_F1 =-104;
F2 =-60; Shift_F2 =-85; Ctrl_F2 = -95; Alt_F2 =-105;
F3 =-61; Shift_F3 =-86; Ctrl_F3 = -96; Alt_F3 =-106;
F4 =-62; Shift_F4 =-87; Ctrl_F4 = -97; Alt_F4 =-107;
F5 =-63; Shift_F5 =-88; Ctrl_F5 = -98; Alt_F5 =-108;
F6 =-64; Shift_F6 =-89; Ctrl_F6 = -99; Alt_F6 =-109;
F7 =-65; Shift_F7 =-90; Ctrl_F7 =-100; Alt_F7 =-110;
F8 =-66; Shift_F8 =-91; Ctrl_F8 =-101; Alt_F8 =-111;
F9 =-67; Shift_F9 =-92; Ctrl_F9 =-102; Alt_F9 =-112;
F10 =-68; Shift_F10 =-93; Ctrl_F10 =-103; Alt_F10 =-113;
Ctrl_D = 4;
Ctrl_F = 6;
Ctrl_J = 10;
Ctrl_L = 12;
Ctrl_O = 15;
Ctrl_R = 18;
Ctrl_S = 19;
Ctrl_U = 21;
function Gey : integer;
function Gey777 : integer;
function Gek : integer;
procedure Fini_Gey;
procedure Init_Gey ;
procedure Wite_Gey;
procedure Putb_Gey(S : String);
procedure Terr_Gey(H : pHead; N : integer; C : String);
procedure B_Ko_Gey(K : integer);
procedure B_Ha_Gey(K : integer);
function Have_Gey : boolean;
procedure PressAnyKey;
procedure SODENO(S,P,N : integer);
procedure BadCode;
procedure AutoEnter;
procedure OnceMore; { Объявлен повторный ввод }
TYPE TypeOfEvents = record PE : LongInt; { Период опроса каталогов }
PS : LongInt; { Период звуковых сигналов}
TE : LongInt; { Время контроля событий }
TS : LongInt; { Время контроля звуков }
PK : LongInt; { Активный период опр.кат }
DR : String; { XXX/dir YYY/dir ...+' ' }
end;
pTypeOfEvents = ^TypeOfEvents;
CONST SKY: boolean = false; { Признак "звездного неба" }
EVENTS:pTypeOfEvents = NIL; { Управление проверками каталогов }
IMPLEMENTATION
TYPE TypeOfClock = procedure;
CONST Size_Gey = 60;
VAR Buff_Gey : array [0..Size_Gey] of integer;
Gbgn,Ghow : integer;
Pr25 : boolean;
Ln25 : LinSCR;
procedure GOLOS(S,D : integer);
begin Sound(S);
Delay(D);
NoSound end;
procedure B_Ko_Gey(K : integer);
var L : integer;
begin if Ghow < Size_Gey then begin
L:=(Gbgn+GHow) mod (Size_Gey+1);
Buff_Gey[L]:=K;
Inc(GHow)
end else GOLOS(200,1000) end;
procedure B_Ha_Gey(K : integer);
begin if Ghow < Size_Gey then begin
Gbgn:=(Gbgn+Size_Gey) mod (Size_Gey+1);
Buff_Gey[Gbgn]:=K;
Inc(Ghow)
end else GOLOS(200,1000) end;
function Have_Gey : boolean;
begin Have_Gey:=(0 < Ghow) or KeyPressed end;
procedure PressAnyKey;
var I : integer;
begin Init_Gey;
I:=Gey;
Init_Gey end;
procedure Putb_Gey(S : String);
var N : integer;
begin if Pr25 then Exit;
Pr25:=true;
Ln25:=SCR[25];
EmpWin(1,25,80,25,Cwait);
OnScrCYA(25,Cwait,S);
Save_Scurs end;
VAR H_prev,M_prev : word;
procedure Clock;
var S : String[3];
procedure O(T : word; A : char; X : integer);
begin Str(100+T,S);
S[1]:=A;
OnscrXYA(X,1,Ctime,S)
end;
begin if H_time <> H_prev then O(H_time,' ',72);
if M_time <> M_prev then O(M_time,':',75);
O(S_time,':',78);
H_prev:=H_time;
M_prev:=M_time end;
CONST AVVA:String[9] = '';
function Emp_Dirs : boolean;
var C,S,EV : String;
Dif : SearchRec;
begin EV:=EVENTS^.DR;
while Fin_Str(C,EV) do
if Fin_Str(S,EV) then begin
FindFirst(S+'*.*',Archive,Dif);
if DosError = 0 then begin
AVVA:=C;
Emp_Dirs:=false;
Exit
end
end;
Emp_Dirs:=true end;
procedure HyperClock(Pclock : TypeOfClock);
begin if EVENTS = NIL
then Pclock
else with EVENTS^ do begin
if PK <= 30 then begin { Короткий опрос }
if TimeOvr(TE,PK) then
if Emp_Dirs then begin
PK:=PE; { P_event:=Длинный }
Pclock;
Exit
end
end else begin { Длинный опрос }
if not TimeOvr(TE,PK) then begin Pclock; Exit end;
if Emp_Dirs then begin Pclock; Exit end;
PK:=10 {P_event:=Короткий }
end;
if AVVA = '' then Exit;
if 0 < PS then { Beep }
if TimeOvr(TS,PS) then GOLOS(220,200);
OnScrXYA(72,1,$CA,AVVA)
end end;
procedure Wite_Gey;
begin OnScrXYA(72,1,$3E,'= ЖДИТЕ =') end;
procedure Bill(var R : integer);
begin OnScrXYA(R,13,$00 ,' '); R:=79-R;
OnScrXYA(R,13,$0A+R and 1,'SFM') end;
function Gek : integer;
var K : integer;
begin K:= ord(ReadKey);
if K = 0 then K:=-ord(ReadKey);
Gek:=K end;
procedure eClock;
begin end;
procedure WaitKeyPressed;
var R : integer;
T : LongInt;
W : boolean;
begin T:=TimeSec;
H_prev:=H_time+1;
M_prev:=M_time+1;
HyperClock(Clock);
PgSCR(0); { Восстановить 0-ю = основную ВидеоСтраницу }
R:=Witime;
while (not KeyPressed) and (0 < R) do
if TimeOvr(T,1) then begin
HyperClock(Clock);
Dec(R)
end;
if KeyPressed then Exit;
PUSH(SCR,SizeOf(SCR));
R:=30;
EmpWin(1,1,80,25,$07);
Save_Scurs;
SKY:=true;
Bill(R);
repeat
HyperClock(eClock);
if TimeOvr(T,1) then Bill(R)
until KeyPressed;
POP(SCR);
Rest_Scurs;
Clock;
R:=Gek { Принять ключ } end;
procedure RepeatUntilKeyPressed;
begin while not KeyPressed do WaitKeyPressed end;
function FKR(var K : integer) : boolean;
begin if Pr25 then begin
while KeyPressed do B_Ko_Gey(Gek);
RepeatUntilKeyPressed; K := Gek;
Rest_Scurs;
Pr25:=false;
SCR[25]:=Ln25
end;
FKR:=false;
if 0 < Ghow then begin
FKR:=true;
K:=Buff_Gey[Gbgn];
Dec(Ghow);
Gbgn:=(Gbgn+1) mod (Size_Gey+1);
end end;
function Gey : integer;
var K : integer;
begin if FKR(K) then Gey:=K else begin
RepeatUntilKeyPressed;
Gey:=Gek
end end;
{ Gey777 : если ранее было объявлено "звездное небо", }
{ то процедура Gey777 выдает код 777 }
{ иначе - код клавиши }
function Gey777 : integer;
var K : integer;
begin if FKR(K) then Gey777:=K else begin
if not SKY then WaitKeyPressed;
if not SKY then Gey777:=Gek
else Gey777:=777;
SKY:=false
end end;
procedure Init_Gey;
var A : char;
begin Gbgn:=0;
Ghow:=0;
while KeyPressed do A:=ReadKey end;
procedure Fini_Gey;
begin Pr25:=false;
Init_Scurs;
Init_Gey end;
{ Terr_Gey : Сообщение об ошибке; Исп. при проверке на корректность }
{ H,N - точная спецификация поля, }
{ если H = NIL, то выводится только строка С }
procedure Terr_Gey(H : pHead; N : integer; C : String);
var S : String;
begin if Test_Diag then begin
if H <> NIL then begin
UnoStr(S,H,N,true);
C:=AlfaName(MEAD^.BDS[abs(FITEK)].CTP)+' НЕК: '+S+' *** '+C;
end;
Putb_Gey(C)
end end;
procedure SODENO(S,P,N : integer);
begin if Modes[Soun] then begin
GOLOS(S,P);
if 0 < N then Delay(N)
end end;
procedure BadCode;
CONST S1 = 50; { Sound }
S2 = 50; { Delay sound }
S3 = 50; { Delay pause }
var I,H,K : integer;
W : LinSCR;
begin if (not Modes[Soun]) and
(not Modes[Colo]) then begin
Init_Gey;
Exit;
end;
W:=SCR[25];
H:=45-S2 div 2;
K:=H-11+S2;
if Modes[Soun] then Sound(S1);
for I:=H to K do begin
if Modes[Colo] and
(1 <= I) and
(I <= 80) then ISC(I,25,chr(223),Csign or (W[I].att shr 4));
Delay(1);
end;
if Modes[Soun] then NoSound;
Delay(S3);
if Modes[Soun] then Sound(S1);
for I:=K downto H do begin
if Modes[Colo] and
(1 <= I) and
(I <= 80) then SCR[25,I]:=W[I];
Delay(1);
end;
if Modes[Soun] then NoSound;
Init_Gey end;
procedure AutoEnter;
var I : integer;
W : LinSCR;
begin if (not Modes[Soun]) and
(not Modes[Colo]) then Exit;
if Modes[Soun] then Sound(100);
if Modes[Colo] then
for I:=3 to 20 do begin
W[I]:=SCR[I,80];
SCR[I,80].att:=Csign
end;
Delay(100);
if Modes[Soun] then NoSound;
if Modes[Colo] then
for I:=3 to 20 do SCR[I,80]:=W[I] end;
procedure OnceMore; { Объявлен повторный ввод }
begin SODENO(75,75,75);
SODENO(75,75, 0) end;
end.
|