{$I KEYS}

unit Lib1;
interface
uses WinTypes;

const    _SUPERVALUE_ = 3.14159265358e27;
         _SUPMIN_     = 3.14e27;
         _SUPMAX_     = 3.15e27;

function  SelectUniKey_(var s :string; var ms :string) :string;
function  SelectTimeFromComment(var s :string) :string;
function  SelectUserFromComment(var s :string) :string;
function  StripFun(s :string) :string;
function  RptExt(var s :string) :string;
function  IsSuperValue(x :double) :boolean;
function  EqDouble(x,y :double) :boolean;
function  ISLETTER ( C :char ) :boolean;
function  AbsDay(d,m,y :integer) :double;
procedure AntiAbsDay(da :longint; var d,m,y :integer);
procedure ALLOC_CMD(var p :pointer; c :char);
procedure FREE_CMD(var p :pointer);
function  SIZE_CMD(p :pointer) :word;
function  SIZE_OF_PROG(Prg :pointer) :longint;
procedure DELETE_OUTRPT;
procedure CREATE_OUTRPT;
procedure CLOSE_OUTRPT;
procedure SetWindowTextStr(w :HWND; s :string);


implementation
uses Interna, Opt1, CompUni1, AsgnUnit, Pro1, WinProcs, Strings;


function SelectUniKey_(var s :string; var ms :string) :string;
label 1; var t :string; i :integer;
begin
i:=1; t:=''; ms:='';
while (i <= length(s)) and (s[i] <> 'ъ') do inc(i);
if i > length(s) then goto 1;
inc(i);
while (i <= length(s)) and (s[i] <> 'ъ') do inc(i);
if i > length(s) then goto 1;
inc(i);
while (i <= length(s)) and (s[i] <> 'ъ') do inc(i);
if i > length(s) then goto 1;
inc(i);
while i <= length(s) do begin t:=t + s[i]; inc(i) end;
ms:=copy(t, 1,   1);
t :=copy(t, 2, 255);
if length(t) = 7
then if t[1] in ['A'..'Z']
     then if t[2] in ['A'..'Z']
          then if t[3] in ['A'..'Z']
               then if t[4] = '-'
                    then if t[5] in ['0'..'9']
                         then if t[6] in ['0'..'9']
                              then if t[7] in ['0'..'9']
                                   then goto 1;
t:='';
1:
SelectUniKey_:=t;
end;



function SelectTimeFromComment(var s :string) :string;
label 1; var t :string; i :integer;
begin
i:=1; t:='';
while (i <= length(s)) and (s[i] <> 'ъ') do inc(i);
if i > length(s) then goto 1;
inc(i);
while (i <= length(s)) and (s[i] <> 'ъ') do inc(i);
if i > length(s) then goto 1;
inc(i);
while (i <= length(s)) and (s[i] <> 'ъ')
do begin t:=t + s[i]; inc(i); end;
1: SelectTimeFromComment:=t;
end;



function SelectUserFromComment(var s :string) :string;
label 1;
var t :string; i :integer;
begin
i:=1; t:='';
while (i <= length(s)) and (s[i] <> 'ъ') do inc(i);
if i > length(s) then goto 1;
inc(i);
while (i <= length(s)) and (s[i] <> 'ъ')
do begin t:=t + s[i]; inc(i) end;
1:
SelectUserFromComment:=t;
end;



function StripFun(s :string) :string;
label 1,2; var i,n :integer;
begin
n:=1;
for i:=length(s) downto 1
do if s[i] <> ' ' then begin n:=i; goto 1; end;
1: s:=copy(s, 1, n); if s = '' then s:=' ';
n:=1;
for i:=1 to length(s)
do if s[i] <> ' ' then begin n:=i; goto 2; end;
2: s:=copy(s, n, 255);
StripFun:=s;
end;


function RptExt(var s :string) :string;
label 1,2,3; var t :string[25]; i :integer;
begin
t:=s; for i:=1 to length(t) do t[i]:=upcase(t[i]); RptExt:=t;
for i:=length(t) downto 1 do if t[i] <> ' ' then goto 1;
goto 3;
1: if i >= 5
   then if t[i  ]='T' then if t[i-1]='P' then if t[i-2]='R' then if t[i-3]='.'
   then goto 3;
t:=t+'.RPT'; RptExt:=t;
3:
end;



function IsSuperValue(x :double) :boolean;
begin
IsSuperValue:= (x > _SUPMIN_) and (x < _SUPMAX_)
end;


function EqDouble(x,y :double) :boolean;
var xr,yr :real;
begin xr:=x; yr:=y; EqDouble:= xr = yr; end;


function ISLETTER ( C :char ) :boolean;
begin ISLETTER:= Upcase(C) in ['A'..'Z'] end;


function AbsDay(d,m,y :integer) :double;
const Y0 = 1900;
      ML :array [1..12] of integer
= (31,28,31,30,31,30,31,31,30,31,30,31);
var i :integer; S :longint;
begin
S:=0;
for i:=Y0 to y-1
do if i mod 4 = 0 then S:=S+366 else S:=S+365;
for i:=1 to m-1
do begin S:=S+ML[i]; if i=2 then if y mod 4 = 0 then S:=S+1 end;
S:=S+d-1;
AbsDay:=S-33176;
end;



procedure AntiAbsDay(da :longint; var d,m,y :integer);
label 1, 2, EX;
var i :integer;
begin
for i:=1901 to 2100
do if AbsDay(1,1,i) > da
   then begin y:=i-1; goto 1; end;

d:=0; m:=0; y:=0;
goto EX;
1:

for i:=1 to 12
do if AbsDay(MonthLen(i,y),i,y) >= da
   then begin m:=i; goto 2; end;

d:=0; m:=0; y:=0;
goto EX;

2:
for i:=1 to 31
do if AbsDay(i,m,y) = da
   then begin d:=i; goto EX; end;

d:=0; m:=0; y:=0;

EX:
end;


procedure ALLOC_CMD(var p :pointer; c :char);
var L :word;
begin
case c of
  '+','-','*','/','<','>','=','!','i' : L:= 9;
  'r'                                 : L:= 9+8;
  'v','s'                             : L:= 9+2;
  'f'                                 : L:= 9+3;
else L:=sizeof(CMD_TYPE);
end;
GetMem(p,L);
end;


procedure FREE_CMD(var p :pointer);
var c :char; L :word;
begin
c:=pCMD_TYPE(p)^.CMD;
case c of
  '+','-','*','/','<','>','=','!','i' : L:= 9;
  'r'                                 : L:= 9+8;
  'v','s'                             : L:= 9+2;
  'f'                                 : L:= 9+3;
else L:=sizeof(CMD_TYPE);
end;
FreeMem(p,L);
end;


function SIZE_CMD(p :pointer) :word;
var c :char; L :word;
begin
c:=pCMD_TYPE(p)^.CMD;
case c of
  '+','-','*','/','<','>','=','!','i' : L:= 9;
  'r'                                 : L:= 9+8;
  'v','s'                             : L:= 9+2;
  'f'                                 : L:= 9+3;
else L:=sizeof(CMD_TYPE);
end;
SIZE_CMD:=L;
end;


function SIZE_OF_PROG(Prg :pointer) :longint;
var OP :char; L :longint; cc :pCMD_TYPE;
begin
cc:=Prg;
L:=0;
while cc <> nil
do begin
   OP:=cc^.CMD;
   L := L + SIZE_CMD(cc);
   if (OP='p') or (OP='?') then L:=L+cc^.NFUN+2;
   cc:=cc^.NEXT_CMD;
   end;
SIZE_OF_PROG:=L;
end;


procedure DELETE_OUTRPT;
var i :integer;
begin assign(OutRpt,WorkDir(OutRptName)); erase(OutRpt); i:=ioresult; end;


procedure CREATE_OUTRPT;
begin
assign(OutRpt,WorkDir(OutRptName)); rewrite(OutRpt);
if ioresult <> 0 then ErrorText:= its_41001 
{ ' Не могу создать ' }
+OutRptName;
end;


procedure CLOSE_OUTRPT;
begin
close(OutRpt);
if ioresult <> 0 then ErrorText:= its_41002 
{ ' Не могу закрыть ' }
+OutRptName;
end;


procedure SetWindowTextStr(w :HWND; s :string);
var Buf :array [0..128] of char;
begin StrPcopy(@Buf, s); SetWindowText(w, @Buf); end;


begin
end.