unit GlProc;
{=================================================================}
{  Версия файла 3.0.000                                           }
{  от 4 декабря 2002 г.                                           }
{==========================} interface {==========================}

uses Windows,Messages,Classes,Math,SysUtils,GlType;

type
 TopType = (opEQ,opNE,opGT,opLT,opGE,opLE,opAND,opOR,opNOT,opUnkn);//Операции отношения
 PopType = ^TopType;
 TValueType = (TReal4,TReal8,TInt4,TInt2,TInt1,TBool,TStr,TOp);//Типы параметров
 TFPUPrecisionMode = (pmSingle, pmReserved, pmDouble, pmExtended);

 TFun = function (tx:RealType;const Pt:array of Pointer):RealType;

  //Функция для конвертации векторов в 4-ю версию
function ConvertVector(const S: string):string;
  //Функция для конвертации матриц в 4-ю версию
function ConvertMatrix(S: string):string;

function  ask(h:hwnd;pc:PChar):Integer;
function  asks(h:hwnd;S:String):Integer;
procedure tell(h:hwnd;pc:PChar);
procedure tells(h:hwnd;S:String);
procedure telle(h:hwnd;pc:RealType);
procedure telli(h:hwnd;pc:Integer);
procedure tellia(h:hwnd;var pc:array of Integer;n:Integer);
procedure tellea(h:hwnd;var pc:array of RealType;n:Integer);

function DelStrLeadSpaces(S:String;ch:Char):String;
function DelStrEndSpaces(S:String;ch:Char):String;

function Str2Args(var S:String;Count:Integer;
                   const Arg : array of Pointer;
                   const What: array of TValueType;c:Char):Boolean;
function StrFiltr(Filtr,S:String):Boolean;
function SecToDateStr(TimeInSec:RealType):String;


procedure DecodePChar(pc:PChar;k:integer);
{$IFDEF SDEMO}
procedure EncodePChar(pc:PChar;k:integer);
{$ENDIF}
procedure SaveString(var F:File;S:String);
procedure SavePChar(var F:File;pc:PChar);

procedure Load_String(var F:File;var S:String);
procedure LoadPChar(var F:File;var pc:PChar);
procedure LoadRstString(var F:File;var S:String);

function DirectoryExists(Name: string): Boolean;

function Find_Error(const What: array of Integer;
                    const Arg : array of Pointer;Count:Integer):Integer;

function ArcCos (x : realtype): realtype;
function ArcSin (x : realtype): realtype;
function Cub (x : realtype): realtype;
procedure SqrEq (a, b, c : realtype; var n : integer; var x1, x2 : realtype);
procedure CubEq (a, b, c, d : realtype; var n : integer;
                                                 var x1, x2, x3 : realtype);

FUNCTION Rank(AY : RealType):Integer;
FUNCTION Ranki(AY : Integer):Integer;
PROCEDURE Cmplx(a,b:realtype; var c:complex);
PROCEDURE cAdd(a,b:complex; var c:complex);
PROCEDURE cMul(a,b:complex; var c:complex);
PROCEDURE cDeg(a:complex; n:integer; var b:complex);
FUNCTION  amod(x,y:realtype):realtype;
FUNCTION  sign(x,y:realtype):realtype;
FUNCTION  sign_(x:realtype):realtype;
FUNCTION  RanVal1:Real;

function  MaxE(var AX;Count:Integer):RealType;
function  MinE(var AX;Count:Integer):RealType;
function  MeanValueE(var AX;Count:Integer):RealType;
function  MaxI(var AX;Count:Integer):Integer;
function  MinI(var AX;Count:Integer):Integer;
function  MeanValueI(var AX;Count:Integer):RealType;
function  PowerY(Y,X:RealType):RealType;
function  Pow(X,Y:RealType):RealType;

procedure InitSize( var Dest;Size:Integer;t_Size:Byte);
procedure ResetSize( var Dest; NewSize, OldSize : Integer;t_Size:Byte);
Procedure FreeSize( Dest : Pointer; Size : Integer;t_Size:Byte);

function _InitMem( var Buf;Count:Integer;t_Size:Byte):Integer;
function _ResetMem( var Buf;Count,Size:Integer;t_Size:Byte):Integer;
procedure _FreeMem( var Buf;Size:Integer;t_Size:Byte);


function UpdateStack(Index : Integer;abc,ord:RealType;x,y:PExtArr;eps:RealType):Integer;

Function GetReal( From : String; Var Dest : RealType ) : Boolean;
Function GetString( From : RealType ) : String;

Procedure SetErrorState( ErrorCode, ErrorPoint, ErrorDate : Integer );
Procedure SetErrorInText( ErrorPoint : PChar; ErrorCode, ErrorDate : Integer );
Procedure ClearErrorState;

function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;

function Aperiodika(dt,Tau,Yn,U:RealType):RealType;
{##############################################################################}

                         IMPLEMENTATION

{##############################################################################}

function Get8087CW: Word;
asm
        PUSH    0
        FNSTCW  [ESP].Word
        POP     EAX
end;

function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;
var
  CtlWord: Word;
begin
  CtlWord := Get8087CW;
  Set8087CW((CtlWord and $FCFF) or (Ord(Precision) shl 8));
  Result := TFPUPrecisionMode((CtlWord shr 8) and 3);
end;

{--------------------------------------------------------------------------}
function DirectoryExists(Name: string): Boolean;
var
  SR: TSearchRec;
begin
 if Name[Length(Name)] = '\' then SetLength(Name,Length(Name)-1);
 if (Length(Name) = 2) and (Name[2] = ':') then Name := Name + '\*.*';
 Result := FindFirst(Name, faDirectory, SR) = 0;
 Result := Result and (SR.Attr and faDirectory <> 0);
end;
{--------------------------------------------------------------------------}
function _InitMem;
Begin
  if Count > 0 then  GetMem( Pointer(Buf), Count*t_Size) else Pointer(Buf):=nil;
  Result:=Count
End;
{--------------------------------------------------------------------------}
procedure _FreeMem;
Begin
  if Size > 0 then  FreeMem( Pointer(Buf), Size*t_Size);
  Pointer(Buf):=nil;
End;
{--------------------------------------------------------------------------}
function _ResetMem;
var P : Pointer;
Begin
  if Count > Size then begin
   GetMem( P, Count*t_Size);
   if Size > 0 then Move(Pointer(Buf)^,P^,Size*t_Size);
   _FreeMem(Pointer(Buf),Size,t_Size);
   Pointer(Buf):=P;
   Result:=Count
  end else Result:=Size
End;
{--------------------------------------------------------------------------}
Procedure InitSize;
Begin
  if Size > 0 then GetMem( Pointer(Dest), Size*t_Size)
  else Pointer(Dest):=nil
End;
{--------------------------------------------------------------------------}
Procedure ResetSize;
var P : Pointer;
Begin
  InitSize( P, NewSize,t_Size );
  if OldSize > 0 then Move(Pointer(Dest)^,P^,t_Size*OldSize);
  FreeSize(Pointer(Dest), OldSize,t_Size );
  Pointer(Dest):=P
End;
{--------------------------------------------------------------------------}
Procedure FreeSize;
Begin if Size > 0 then FreeMem(Dest, Size*t_Size ) End;
{--------------------------------------------------------------------------}
function  MaxE;
var X:TExtArr absolute AX; Tmp:RealType; i:integer;
begin Tmp:=X[0]; for i:=1 to Count-1 do if Tmp < X[i] then Tmp:=X[i];MaxE:=Tmp end;
{--------------------------------------------------------------------------}
function  MinE;
var X:TExtArr absolute AX; Tmp:RealType; i:integer;
begin Tmp:=X[0]; for i:=1 to Count-1 do if Tmp > X[i] then Tmp:=X[i];MinE:=Tmp end;
{--------------------------------------------------------------------------}
function  MeanValueE;
var X:TExtArr absolute AX; Tmp:RealType; i:integer;
begin Tmp:=0.0; for i:=0 to Count-1 do Tmp:=Tmp+X[i];MeanValueE:=Tmp/Count end;
{--------------------------------------------------------------------------}
function  MaxI;
var XX:TIntArr absolute AX; Tmp,i:integer;
begin Tmp:=XX[0]; for i:=1 to Count-1 do if Tmp < XX[i] then Tmp:=XX[i];MaxI:=Tmp end;
{--------------------------------------------------------------------------}
function  MinI;
var XX:TIntArr absolute AX; Tmp,i:integer;
begin Tmp:=XX[0]; for i:=1 to Count-1 do if Tmp > XX[i] then Tmp:=XX[i];MinI:=Tmp end;
{--------------------------------------------------------------------------}
function  MeanValueI;
var XX:TIntArr absolute AX; Tmp,i:integer;
begin Tmp:=0; for i:=0 to Count-1 do Tmp:=Tmp+XX[i];MeanValueI:=Tmp/Count end;
{------------------------------------------------------------}
function PowerY(Y,X:RealType):RealType;
begin
  Result:=0;
  if x < 0.0 then begin
    tell(0,'Ошибка : функция (x в степени y) : x < 0');
    exit
  end;
  if x > 0.0 then
  Result := Power( x,y )
end;
{------------------------------------------------------------}
function Pow(X,Y:RealType):RealType;
begin
  Result:=0;
  if x < 0.0 then begin
    tell(0,'Ошибка : функция (x в степени y) : x < 0');
    exit
  end;
  if x > 0.0 then
  Result := Power( x,y )
end;
{-------------------------------------------}
PROCEDURE Cmplx;
BEGIN
  c.re:=a; c.im:=b
END {Cmplx};
{-----------------------------------------------}
PROCEDURE cAdd;
var
  d:complex;
BEGIN
  d.re:=a.re+b.re; d.im:=a.im+b.im;
  c:=d
END {cAdd};
{-----------------------------------------------}
PROCEDURE cMul;
var
  d:complex;
BEGIN
  d.re:=a.re*b.re-a.im*b.im;
  d.im:=a.re*b.im+a.im*b.re;
  c:=d
END {cMul};
{-----------------------------------------------}
PROCEDURE cDeg;
var
  i:integer;
BEGIN
  if n=0 then cmplx(1,0,b)
  else
    begin
      b:=a; for i:=1 to n-1 do cMul(a,b,b)
    end
END;
{--------------------------------------------------------------}
FUNCTION amod;
var
  a:realtype;
  c:longint;
BEGIN
  a:=x/y; c:=trunc(a); amod:=a-c
END;
{--------------------------------------------------------------}
FUNCTION sign;
BEGIN
  if y>0 then sign:=abs(x)
    else if y<0 then sign:=-abs(x)
      else sign:=0
END;
{--------------------------------------------------------------}
FUNCTION sign_;
BEGIN
  if x >= 0 then Result:=1.0 else Result:=-1.0
END;
{--------------------------------------------------------------}
function Rank(AY : RealType):Integer;
begin
  Result:=0;
  if ABS(AY) = 0.0 then exit;
  while (ABS(AY) < 1) or (ABS(AY) > 10) do begin
   if ABS(AY) > 10 then begin
    AY:=AY/10.0;
    inc(Result)
   end
   else if ABS(AY) < 1 then begin
    AY:=AY*10.0;
    dec(Result)
   end
   else break;
  end
end;
{-------------------------------------------------------------------------}
function Ranki(AY : Integer):Integer;
begin
  Result:=0;
  while ABS(AY) >= 10 do
   if ABS(AY) >= 10 then
   begin
    AY:=AY div 10;
    inc(Result)
   end
end;
{-------------------------------------------------------------------------}
FUNCTION RanVal1: Real;
Var j : integer;
  gly           : real;
  glv           : ARRAY [1..47] OF real;
BEGIN
   FOR j := 1 to 47 DO glv[j] := random;
   gly := random;
   j := 1 + trunc(47.0*gly);
   gly := glv[j];
   RanVal1 := gly
END;
{--------------------------------------------------------------------------}
function ArcCos (x : realtype): realtype;
var y, AbsX : realtype;
begin
 ArcCos :=0;
 AbsX := Abs(x);
 if AbsX > 1.0 then Exit;
 y := Sqrt(1.0 - Sqr(x));
 if AbsX < MachEps then ArcCos := Pi/2.0
  else begin
   y := ArcTan(y/x);
   if x < 0.0 then ArcCos := y + Pi else ArcCos := y
  end
end;
{--------------------------------------------------------------------------}
function ArcSin (x : realtype): realtype;
var y : realtype;
begin
 ArcSin:=0;
 if Abs(x) > 1.0 then Exit;
 y := Sqrt(1.0 - Sqr(x));
 if y < MachEps then ArcSin := Pi/2.0 else ArcSin := ArcTan(x/y)
end;
{--------------------------------------------------------------------------}
function Cub (x : realtype): realtype;
begin
    Cub := x*Sqr(x)
end;
{--------------------------------------------------------------------------}
procedure SqrEq (a, b, c : realtype; var n : integer; var x1, x2 : realtype);
var Discr, p, q, r : real;
begin
 if a <> 0.0 then begin
   p := b/a;
   q := c/a;
   Discr := Sqr(p)/4.0 - q;
   if Discr < 0.0 then n := 0
    else begin
      r := Sqrt(Discr);
      x1 := -p/2.0 + r;
      x2 := -p/2.0 - r;
      n := 2;
      if x1 < x2 then begin r := x2; x2 := x1; x1 := r end
    end
 end
 else if b <> 0.0 then begin x1 := -c/b; n := 1 end  else n := 0
end;
{--------------------------------------------------------------------------}
procedure CubEq (a, b, c, d : realtype; var n : integer;
                                                 var x1, x2, x3 : realtype);
  var Discr, p, q, r, s, t, u, v : real;
  begin
    if a <> 0.0
    then
      begin
        r := b/a;
        s := c/a;
        t := d/a;
        p := s - Sqr(r)/3.0;
        q := r*((2.0/27.0)*Sqr(r) - s/3.0) + t;
        Discr := (p/3.0)*Sqr(p/3.0) + Sqr(q/2.0);

        r := r/3.0;

        if Discr > 0
        then
          begin
            u := -q/2.0 + Sqrt(Discr);
            u := Sign_(u)*PowerY(1.0/3.0,Abs(u));
            v := -q/2.0 - Sqrt(Discr);
            v := Sign_(v)*PowerY(1.0/3.0,Abs(v));
            x1 := u + v - r;
            n := 1
          end
        else
          begin
            u := Sqrt(-p*Sqr(p)/27.0);
            v := 2.0*PowerY(1.0/3.0,u);
            u := ArcCos( -q/(2.0*u) );
            x1 := v*Cos( u /3.0 ) - r;
            x2 := v*Cos( (u + 2.0*Pi)/3.0 ) - r;
            x3 := v*Cos( (u + 4.0*Pi)/3.0 ) - r;
            n := 3;
            if x1 < x2 then begin v := x2; x2 := x1; x1 := v end;
            if x2 < x3 then begin v := x2; x2 := x3; x3 := v end;
            if x1 < x2 then begin v := x2; x2 := x1; x1 := v end
          end
      end
    else
      SqrEq(b, c, d, n, x1, x2);
  end; { CubEq }
{--------------------------------------------------------------}
function ask;
begin
 Result:=MessageBox(h,pc,'',mb_YesNo)
end;
{--------------------------------------------------------------}
function asks;
var pc:array[0..255] of Char;
begin
 StrPCopy(pc,S);
 Result:=MessageBox(h,pc,'',mb_YesNo)
end;
{--------------------------------------------------------------}
procedure tell;
begin
 MessageBox(h,pc,'',mb_ok)
end;
{--------------------------------------------------------------}
procedure tells;
var pc:array[0..255] of Char;
begin
 StrPCopy(pc,S);
 MessageBox(h,pc,'',mb_ok)
end;
{--------------------------------------------------------------}
procedure telli;
var ch : array[0..9] of char;
begin
 str(pc,ch);
 MessageBox(h,ch,'',mb_ok)
end;
{--------------------------------------------------------------}
procedure telle;
var ch : array[0..19] of char;
begin
 StrPCopy(ch,FloatToStrF(pc,ffexponent,10,5));
 MessageBox(h,ch,'',mb_ok)
end;
{--------------------------------------------------------------}
procedure tellia;
var ch : array[0..255] of char;
    ch1: array[0..9]   of char;
    i    : Integer;
begin
 StrCopy(ch,'');
 for i:=0 to n-1 do
 begin
  str(pc[i],ch1);
  strcat(ch,ch1);
 end;
 tell(h,ch)
end;
{--------------------------------------------------------------}
procedure tellea;
var ch : array[0..255] of char;
    ch1: array[0..9]   of char;
    i    : Integer;
begin
 StrCopy(ch,'');
 for i:=0 to n-1 do
 begin
  str(pc[i]:12:6,ch1);
  strcat(ch,ch1);
 end;
 tell(h,ch)
end;

{--------------------------------------------------------------------------
                   Процедуры удаления символа перед строкой и после строки
--------------------------------------------------------------------------}
function DelStrLeadSpaces(S:String;ch:Char):String;
var i,k : Integer;
begin
 Result:=S;
 i:=Length(S);
 if i = 0 then exit;
 k:=1;
 while (S[k] = ch)and(k < i) do Inc(k);
 Result:=Copy(S,k,i)
end;

function DelStrEndSpaces(S:String;ch:Char):String;
var i,k : Integer;
begin
 Result:=S;
 i:=Length(S);
 if i = 0 then exit;
 k:=i;
 while (S[k] = ch)and(k > 1) do Dec(k);
 Result:=Copy(S,1,k)
end;
{--------------------------------------------------------------------------
                   Процедуры сохранения-загрузки строк
--------------------------------------------------------------------------}
procedure DecodePChar(pc:PChar;k:integer);
var
  i : integer;
begin
  if k>0 then
  for i := 0 to k-1 do
      byte((pc+i)^) := byte((pc+i)^) xor $ff;
end;

{$IFDEF SDEMO}
procedure EncodePChar(pc:PChar;k:integer);
var
  i : integer;
begin
  if k>0 then
  for i := 0 to k-1 do
    byte((pc+i)^) := byte((pc+i)^) xor $ff;
end;
{$ENDIF}

procedure SaveString(var F:File;S:String);
var nw  : Integer;
    k   : Integer;
    ch  : array[0..255] of char;
begin
 k:=Length(S);
 StrPLCopy(ch,S,k);
  {$IFDEF DEMO}
  //EncodePChar(ch,k);
  {$ENDIF}
 BlockWrite(F,k,SOfI,nw);
 BlockWrite(F,ch,k,nw);
end;
{--------------------------------------------------------------------------}
procedure Load_String(var F:File;var S:String);
var nw     : Integer;
    k      : Integer;
    pc,ch  : array[0..255] of char;
begin
   BlockRead(F,k,SOfI,nw);
   if (k>255) then k:= 255 else if k<0 then k:=0;
   BlockRead(F,ch,k,nw);
   move( ch, pc, k );
   pc[k]:=#0;
{   StrLCopy(pc,ch,k);}
{$IFDEF DEMO}
   DecodePChar(pc,k);
{$ENDIF}
   S:=StrPas(pc);
end;
{--------------------------------------------------------------------------}
procedure SavePChar;
var nw  : Integer;
    k   : Integer;
begin
 k:=StrLen(pc);
  {$IFDEF DEMO}
  //EncodePChar(pc,k);
  {$ENDIF}
 BlockWrite(F,k,SOfI,nw);
 if k > 0 then BlockWrite(F,pc^,k+1,nw)
end;
{--------------------------------------------------------------------------}
procedure LoadPChar;
var nw     : Integer;
    k      : Integer;
begin
   BlockRead(F,k,SOfI,nw);
   FreeMem(pc,StrLen(pc)+1);
   GetMem(pc,k+1);
   if k > 0 then begin
    BlockRead(F,pc^,k+1,nw);
{$IFDEF DEMO}
    DecodePChar(pc,k)
{$ENDIF}
   end else StrCopy(pc,'');
end;
{--------------------------------------------------------------------------}
function Find_Error;
var i  : Integer;
    S  : String;
begin
  Result:=0;
  for i:=0 to Count-1 do begin
   case What[i] of
    er_NoDirExist :
    begin
     S:=Trim(ExtractFilePath(PString(Arg[i])^));
     if S <> '' then
      if not DirectoryExists(S)
       then Result:=what[i];
    end;
    er_NoFileExist : if not FileExists(PString(Arg[i])^) then Result:=what[i];
    er_parzero     : if PRealType(Arg[i])^ = 0 then Result:=what[i];
   end;
   if Result <> 0 then exit
  end
end;
{--------------------------------------------------------------------------}
function Str2Args(var S:String;Count:Integer;
                   const Arg : array of Pointer;
                   const What: array of TValueType;c:Char):Boolean;
var i,j    : Integer;
    S1     : String;
    err    : Integer;
begin
 err:=0;
 Result:=True;
 for i:=0 to Count-1 do begin
  S:=Trim(S);
  j:=Pos(c,S);
  if j = 0 then S1:=S else S1:=Copy(S,1,j-1);
  S1:=Trim(S1);

  if Arg[i] <> nil then begin
   case What[i] of
    TInt4  :val(S1,PInteger(Arg[i])^,err);
    TStr   :PString(Arg[i])^:=S1;
    TReal8 :val(S1,PRealType(Arg[i])^,err);
    TBool  :PBool(Arg[i])^:=UpperCase(S1) = 'TRUE';
    TOp    :if S1 = '=' then PopType(Arg[i])^:=opEQ
             else if S1 = '<>' then PopType(Arg[i])^:=opNE
              else if S1 = '>' then PopType(Arg[i])^:=opGT
               else if S1 = '>=' then PopType(Arg[i])^:=opGE
                else if S1 = '<' then PopType(Arg[i])^:=opLT
                 else if S1 = '<=' then PopType(Arg[i])^:=opLE
                   else begin Result:=False;PopType(Arg[i])^:=opUnkn end;
   end;

   if err <> 0 then begin
    case What[i] of
     TInt4   :PInteger(Arg[i])^:=0;
     TReal8  :PRealType(Arg[i])^:=0;
     TBool   :PBool(Arg[i])^:=false;
    end;
    Result:=False
   end;
  end;

  if j = 0 then S:='' else S:=Copy(S,j+1,Length(S));
 end;
end;
//------------------------------------------------------------------------------
function UpdateStack(Index : Integer;abc,ord:RealType;x,y:PExtArr;eps:RealType):Integer;
var
  k1,k2,k3   : Integer;
  x1,dx,
  dy31,dy21,
  dx31,dx21,
  yy1,yy2    : RealType;
begin
  if Index < 3 then begin
    x^[Index+1]:=Abc;
    y^[Index+1]:=Ord;
    Result:=Index+1
  end
  else begin
   k3:=Index+1;k2:=k3-1;k1:=k3-2;
   dy31:=Ord-y^[k1];
   dy21:=y^[k2]-y^[k1];
   dx31:=Abc-x^[k1];
   dx21:=x^[k2]-x^[k1];
   dx:=dx31/2;
   if (dx31 = 0)or(dx21=0)or((dx31-dx21)=0)then x1:=0
   else begin
    yy1:=y^[k1]+dy21*(dx/dx21)*(dx31-dx)/(dx31-dx21);
    yy1:=yy1+dy31*(dx/dx31)*(dx-dx21)/(dx31-dx21);
    yy2:=y^[k1]+0.5*dy31;
    X1:=abs(dy31);
    if X1 <> 0 then X1:=abs(yy1-yy2)/X1 else X1:=abs(yy1-yy2);
   end;
   if X1 < eps then begin
    x^[k2]:=Abc;
    y^[k2]:=Ord;
    Result:=Index
   end
   else begin
    x^[k3]:=Abc;
    y^[k3]:=Ord;
    Result:=Index+1
   end
  end
end;
//------------------------------------------------------------------------------
function StrLogSubExpr(sub,S : String):Boolean;
var n,m,k,j,i : Integer;
    S1,S2     : String;
begin
  Result:=False;
  sub:=Trim(sub);
  m:=Length(S);
  S1:=S;

  n:=0;
  j:=Pos('*',sub);
  if j = 0 then S2:=sub
   else if j = 1 then begin inc(n);S2:=Copy(sub,j+1,Length(sub)) end
    else begin inc(n,2);S2:=Copy(sub,1,j-1) end;

  j:=Pos('*',S2);
  if j <> 0 then begin inc(n,2);S2:=Copy(S2,1,j-1) end;
  S2:=Trim(S2);
  k:=Length(S2);

  if (n > 0) and (k = 0) then begin Result:=True;exit end;

  if (n = 0) and (k <> m) then exit;

  case n of
  0 : S1:=S2;
  1 : for i:=1 to m do if i <= m-k then S1[i]:='?' else S1[i]:=S2[k+i-m];
  2 : for i:=1 to m do if i > k then S1[i]:='?' else S1[i]:=S2[i];
  3 : begin
       j:=Pos(S2,S);
       if j > 0 then Result:=True;
       exit
      end;
  end;

  j:=0;for i:=1 to m do if (S1[i] = '?') or (S1[i] = S[i]) then inc(j);

  Result:= j >= m
end;
//------------------------------------------------------------------------------
function StrEvalLog(sub:String):String;
var i,k,m       : Integer;
    sub1,sub2   : String;
    oP          : TOpType;
    rez         : Boolean;
begin
 Result:=sub;
 m:=Length(sub);
 sub:=Trim(sub);
 oP:=opUnkn;
 k:=Pos('&',sub);
 if k <> 0 then oP:=opAND
  else begin
   k:=Pos(':',sub);
   if k <> 0 then oP:=opOR
    else begin
     k:=Pos('!',sub);
     if k <> 0 then oP:=opNot;
    end
  end;

 case oP of
   opAND : begin
            sub1:=Trim(Copy(sub,1,k-1));
            sub2:=Trim(Copy(sub,k+1,m));
            rez:=(sub1 = 'T') and (sub2 = 'T');
           end;
   opOR  : begin
            sub1:=Trim(Copy(sub,1,k-1));
            sub2:=Trim(Copy(sub,k+1,m));
            rez:=(sub1 = 'T') or (sub2 = 'T');
           end;
   opNot : begin
            sub2:=Trim(Copy(sub,k+1,m));
            rez:=not(sub2 = 'T');
           end;
   else    begin
            sub1:=Trim(sub);
            rez:=(sub1 = 'T');
           end;
 end;
 for i:=1 to m do Result[i]:=' ';
 if rez then Result[1]:='T' else Result[1]:='F'
end;
//------------------------------------------------------------------------------
function StrFiltr(Filtr,S:String):Boolean;
const Cnt = 50;
var i,j,k,m     : Integer;
    k1,k2       : Integer;
    sub,rez,
    S1,S2       : String;
    f1          : Boolean;
    ch          : Char;
    Pos1,Pos2   : array[1..Cnt] of Byte;

begin
 Result:=False;
 S:=Trim(S);
 S1:=Trim(Filtr);if S1 = '' then exit;
 S1:='('+S1+')';
 m:=Length(S1);

 f1:=false;S2:=S1;
 for i:=1 to m do begin
  if (not (S1[i] in ['(', ')', '&', ':', '!'])) then begin
   if not f1 then begin
    f1:=True;
    k1:=i
   end
  end else begin
   if f1 then begin
    k2:=i;
    sub:=Copy(S1,k1,k2-k1);
    if StrLogSubExpr(sub,S) then ch:='T' else ch:='F';
    S2:=StringReplace(S2,sub,ch,[]);
    f1:=False
   end
  end;

  if (i = m) and f1 then begin
   sub:=Copy(S1,k1,Length(S1));
   if StrLogSubExpr(sub,S) then ch:='T' else ch:='F';
   S2:=StringReplace(S2,sub,ch,[]);
  end
 end;

 S1:=S2;
 k1:=0;k2:=0;
 for i:=1 to Length(S1) do
  case S1[i] of
   '(' : begin inc(k1);Pos1[k1]:=i end;
   ')' : begin inc(k2);Pos2[k2]:=i end;
  end;

 if k1 <> k2 then begin
  tells(0,'Не совпадает число открывающих и закрывающих скобок');
  Result:=False;
  exit
 end;

 if k1 = 0 then begin
  sub:=S1;
  rez:=StrEvalLog(sub)
 end else
 for i:=1 to k1 do begin
  k:=Pos2[i];
  j:=k1;while (Pos1[j] > k) and (j > 0) do dec(j);
  k2:=Pos1[j];
  Pos1[j]:=m;
  sub:=Copy(S1,k2+1,k-k2-1);
  rez:=StrEvalLog(sub);
  S1:=StringReplace(S1,'('+sub+')',' '+rez+' ',[]);
 end;
 Result:=rez[1] = 'T'
end;
//------------------------------------------------------------------------------
function SecToDateStr(TimeInSec:RealType):String;
var day,hour,
    minute,sec : RealType;
begin
 Result:='';
 day:=int(TimeInSec/(24*60*60));
 hour:=int(TimeInSec/(60*60))-24*day;
 minute:=int(TimeInSec/60)-60*(24*day+hour);
 sec:=TimeInSec-60*(60*24*day+60*hour+minute);
 Result:=Result+FloatToStrF(day,fffixed,3,0)+':'+
 FloatToStrF(hour,fffixed,2,0)+':'+
 FloatToStrF(minute,fffixed,2,0)+':'+
 FloatToStrF(sec,fffixed,2,0);
end;
{--------------------------------------------------------------------------}
Function GetReal;
Var
  Code : Integer;
Begin
  Val( From, Dest, Code );
  GetReal := Code = 0;
End;

Function GetString;
Begin
  result := FloatToStrF( From, ffGeneral, 9, 0 )
End;

Procedure SetErrorState;
begin
  ErrorState := ErrorCode;
  ErrorStart := ErrorPoint;
  ErrorLength := ErrorDate;
end;

Procedure SetErrorInText;
begin
  ErrorState := ErrorCode;
  ErrorStart := ErrorPoint-TextBegin;
  ErrorLength := ErrorDate;
end;

Procedure ClearErrorState;
begin
  ErrorState := erNoError;
  ErrorStart := 0;
  ErrorLength := 0;
  ErrorVarName := '';
end;
//------------------------------------------------------------------------------
function Aperiodika(dt,Tau,Yn,U:RealType):RealType;
begin
 if dt <= 0 then Result:=Yn
  else if Tau <= 0 then Result:=U
   else Result:=(dt*U+Yn*Tau)/(Tau+dt);
end;

procedure LoadRstString(var F:File;var S:String);
var nw     : Integer;
    k      : Integer;
    pc,ch  : array[0..255] of char;
begin
   BlockRead(F,k,SOfI,nw);
   if (k>255) then k:= 255 else if k<0 then k:=0;
   BlockRead(F,ch,k,nw);
   move( ch, pc, k );
   pc[k]:=#0;
   S:=StrPas(pc);
end;

function ConvertVector(const S: string):string;
 var SL: TStringList;
     i:  integer;
begin
   SL:=TStringList.Create;
   //Парсим свойство заданное в одной строчке
   ExtractStrings([' ',';'],[' '],PChar(S),SL);
   Result:='[';
   if SL.Count > 0 then begin
     Result:='['+SL[0];
     for i:=1 to SL.Count - 1 do Result:=Result +',' + SL[i];
     Result:=Result + ']';
   end
   else
     Result:=Result + ']';
   SL.Free;
end;

function ConvertMatrix(S: string):string;
 var i:  integer;
 label Next;
begin
   S:=Trim(S);

Next:
   i:=Pos('  ',S);
   if i > 0 then begin
     Delete(S,i,1);
     goto Next;
   end;

   for i:=1 to Length(S) do
     if S[i] = ')' then S[i]:=']'
       else
     if S[i] = '(' then S[i]:='['
       else
     if S[i] = ' ' then S[i]:=',';

   for i:=1 to Length(S) do
     if Copy(S,i,2) = '][' then Insert(',',S,i + 1);

   Result:='[' + S + ']';
end;


BEGIN
    SetPrecisionMode(pmDouble); //Для программного комплекса и для
    DecimalSeparator := '.';    //библиотек точность вычисления по умолчанию должна быть 64 бита !!!
    MachEps := 1.00;
    repeat
      MachEps := MachEps/2.00;
    until 1.00 + MachEps <= 1.00;
END.