unit Numbers;

interface
uses
  sysutils,
  dialogs;

  Function  DecBin(x:word; size:integer=16):string;
  Function  BinDec(s: string):longint;
  Function  HexDec(s:string):word;
  Function  HexDecI(s:string):integer;

  Function  HexDecLong(s:string):longint;
  Function  DecHexB(w:Word):string;
  Function  DecHexW(w:Word):string;
  Function  DecHex(w:Word):string;
  Function  FloatStr(X:extended; width, decimals: integer):string;

  function  GetCRC8(buff: string): byte;
  function  GetLRC8(s: string): integer;
//  function getA100Crc(data: string): Byte;

  Function  StrInteger(s: string):integer;

  function GetStrDelimit(s: string; Delimit: char; var i: integer): string;
  function GetNumberStr(s: string; var i: integer): string;
  function GetInteger(s: string; var i: integer): integer;
  function GetSingle(s: string; var i: integer): single;

  function iif(Logic: boolean; ValA, ValB: string): string; overload;
  function iif(Logic: boolean; ValA, ValB: integer): integer; overload;

  function CheckFilter(src, flt: string): boolean;
  function CheckFilterA(src, flt: string): boolean;
  function CheckFilterOr(src, flt: string): boolean;
  function CheckFilterLogic(expr, values: string; UseAllValues: boolean): boolean;
  function rpCalcStr(Source:AnsiString):Double;
  procedure PrepIncludes(Dir, Src, Dst: string);

  function MaskString(mask, src: string): string;
  procedure rpReplaceS(var s: string; old, new: string);

  function rpGetStrTag(src, sbeg, send: string; var idx: integer; var taglen: integer): string;
  function get_substr_beg(c: char; var s: string): string;


var
  bJ,bI: boolean;

implementation
uses HyperStr;

Function DecBin(x:word; size:integer=16):string;
Var i: byte;
    s: string;
Begin
  s:='';
  For i:=1 to size Do Begin
    If x mod 2 = 1 then s:='1'+s
                   else s:='0'+s;
    x:=x div 2;
  End;
  DecBin:=s;
End;

Function  BinDec(s: string):longint;
Var i: byte;
    k,w: longint;
Begin
  w:=0;
  k:=1;
  for i:=length(s) downto 1 do begin
    if s[i] = '1' then w := w + k;
    k := k * 2;
  end;
  result:=w;
end;


Function HexDec(s:string):word;
Var
  i: integer;
  w,m: word;
  b: byte;
  c: char;
Begin
  b:=0;
  w:=0;
  m:=1;
  For i:=1 to Length(s) do
    Begin
       c:=s[length(s)-i+1];
       c:=UpCase(c);
       if c in ['0'..'9'] Then b:=ord(c)-48;
       if c in ['A'..'F'] Then b:=ord(c)-55;
       w:=w+m*b;
       m:=m*16;
    End;
  HexDec:=w;
End;

Function HexDecI(s:string):integer;
Var
  i: integer;
  w,m: integer;
  b: byte;
  c: char;
Begin
  b:=0;
  w:=0;
  m:=1;
  For i:=1 to Length(s) do
    Begin
       c:=s[length(s)-i+1];
       c:=UpCase(c);
       if c in ['0'..'9'] Then b:=ord(c)-48;
       if c in ['A'..'F'] Then b:=ord(c)-55;
       w:=w+m*b;
       m:=m*16;
    End;
  result:=w;
End;



Function HexDecLong(s:string):longint;
Var
  i: integer;
  w,m: longint;
  b: byte;
  c: char;
Begin
  b:=0;
  w:=0;
  m:=1;
  For i:=1 to Length(s) do
    Begin
       c:=s[length(s)-i+1];
       c:=UpCase(c);
       if c in ['0'..'9'] Then b:=ord(c)-48;
       if c in ['A'..'F'] Then b:=ord(c)-55;
       w:=w+m*b;
       m:=m*16;
    End;
  result := w;
End;


Function DecHexB(w:Word):string;
Var
  i: integer;
  m: word;
  b: byte;
  s: string;
Begin
  s:='';
  m:=16;
  For i:=1 to 2 do
    Begin
      b:= w div m;
      w:= w mod m;
      m:= m div 16;
      if b in [0..9] Then s:=s+chr(b+48);
      if b in [10..15] Then s:=s+chr(b+55);
    End;
  DecHexB:=s;
End;

Function DecHexW(w:Word):string;
Var
  i: integer;
  m: word;
  b: byte;
  s: string;
Begin
  s:='';
  m:=16*16*16;
  For i:=1 to 4 do
    Begin
      b:= w div m;
      w:= w mod m;
      m:= m div 16;
      if b in [0..9] Then s:=s+chr(b+48);
      if b in [10..15] Then s:=s+chr(b+55);
    End;
  DecHexW:=s;
End;


Function DecHex(w:Word):string;
Var
  s: string;
begin
  s:=DecHexW(w);
  while (copy(s,1,1)='0') and (length(s)>1) do
    s := copy(s, 2, length(s)-1);
  result:=s;
end;

Function DecHexA(w:Word):string;
Var
  s: string;
begin
  s:=DecHexW(w);
  while (copy(s,1,1)='0') and (length(s)>1) do
    s := copy(s, 2, length(s)-1);
  result:=s;
end;


Function  FloatStr(X:extended; width, decimals: integer):string;
var
  s: string;
begin
  str(X:width:decimals, s);
  result := trim(s);
end;


function GetCRC8(buff: string): byte;
var
  crc: byte;
  b: byte;
  flag: boolean;
  i,j: integer;
begin
  crc := 0;
  for i:=1 to length(buff) do begin
    b := ord(buff[i]);
    for j:=0 to 7 do begin
      flag := (b and 1)>0;
      b := (b shr 1);
      if flag then b := b or $80;
      flag := flag xor ((crc and 1)>0);
      if (flag) then crc := (crc xor $18) or 1;
      crc := (crc shr 1);
      if flag then crc := crc or $80;
    end;
  end;
  result := crc;
end;


function GetLRC8(s: string): integer;
var
  v,i: Integer;
begin
  v := 0;

  for i:=0 to Length(s) do
    v := v + ord(s[i]);


  v := $100 - (v and $FF);

  result := v;
end;



// !!! replaced to the unit A100 of the RpSvrTcp 
//
//function getA100Crc(data: string): Byte;
//var
//  crc,i,j: Integer;
//  b: Byte;
//begin
//  crc := 0;
//  for i:=1 to 11 do begin
//    b := Ord(data[i]);
//    for j:=0 to 7 do begin
//      crc := crc shl 1;
//
//      if (b and 1) > 0 then
//        crc := crc + 1;
//
//      if (crc and $80) > 0 then
//        crc := crc xor 9;
//
//      b := b shr 1;
//
//
//    end;
//  end;
//  crc := crc and $7F;
//  result := crc;
//end;


//Получение подстроки из строки, определенную указанным разделителем
function GetStrDelimit(s: string; Delimit: char; var i: integer): string;
var
  ss: string;
begin
  ss := '';
  if (s[i] = Delimit) and (i<length(s)) then inc(i);
  while (not(s[i] = Delimit)) and (i<=length(s)) do begin
    ss := ss + s[i];
    inc(i);
  end;
  result := ss;
end;


//Чтение значения типа числа из строки
function GetNumberStr(s: string; var i: integer): string;
var
  ss: string;
begin
  ss := '';
  while (not(s[i] in ['-','.','0'..'9'])) and (i<length(s)) do inc(i);
  while (s[i] in ['-','.','0'..'9']) and (i<=length(s)) do begin
    ss := ss + s[i];
    inc(i);
  end;
  result := ss;
end;

//Чтение значения типа Integer из строки
function GetInteger(s: string; var i: integer): integer;
var
  ss: string;
  v,j: integer;
begin
  ss := GetNumberStr(s,i);
  val(ss, v, j);
  result := v;
end;


//Чтение значения типа Singler из строки
function GetSingle(s: string; var i: integer): single;
var
  ss: string;
  j: integer;
  v: single;
begin
  ss := GetNumberStr(s,i);
  val(ss, v, j);
  result := v;
end;



function iif(Logic: boolean; ValA, ValB: string): string;
begin
  if Logic then
    result := ValA
  else
    result := ValB;
end;

function iif(Logic: boolean; ValA, ValB: integer): integer;
begin
  if Logic then
    result := ValA
  else
    result := ValB;
end;



////////////////////////////////////////////////////////////////////////////////
// ФИЛЬТРОВАНИЕ
////////////////////////////////////////////////////////////////////////////////
function CheckFilter(src, flt: string): boolean;
var
  i,j,k: integer;
  stmp, sflt: string;
  flag: boolean;
begin
  stmp := trim(flt);
  repeat
    k := pos(';', stmp);
    if k > 0 then begin
      sflt := copy(stmp, 1, k-1);
      delete(stmp, 1, k);
    end else begin
      sflt := stmp;
      stmp := '';
    end;

    if length(sflt) > 0 then begin
      i := 1;
      j := ScanW(src, sflt, i);
      if i=1 then
        if j=length(src) then flag := true
        else flag := sflt[length(sflt)] = '*'
      else
        flag := false;
    end else
      flag := true;

    if flag then break;
  until stmp = '';

  result := flag;
end;

////////////////////////////////////////////////////////////////////////////////
// ФИЛЬТРОВАНИЕ Вариант A
//   для фильтрования используются стандартные символы "*" и "?" (а-ля MSDOS)
//   несколько значений фильтров разделяются символом ";". Результат объеденяется по ИЛИ
//   символ "~" используется для исключения (фильтр наоборот)
////////////////////////////////////////////////////////////////////////////////
function CheckFilterA(src, flt: string): boolean;
var
  i,j,k: integer;
  stmp, sflt: string;
  flag, flag1: boolean;
begin
  flag := false;
  stmp := trim(flt);
  repeat
    k := pos(';', stmp);
    if k > 0 then begin
      sflt := copy(stmp, 1, k-1);
      delete(stmp, 1, k);
    end else begin
      sflt := stmp;
      stmp := '';
    end;



    if length(sflt) > 0 then begin

      if sflt[1]='~' then begin
        delete(sflt,1,1);
        i := 1;
        j := ScanW(src, sflt, i);
        if i=1 then begin
          if j=length(src) then
            flag1 := true
          else
            flag1 := sflt[length(sflt)] = '*';
        end else
          flag1 := false;

        if flag1 then begin
          flag := false;
          break;
        end;
      end else

      if not flag then begin
        i := 1;
        j := ScanW(src, sflt, i);
        if i=1 then begin
          if j=length(src) then
            flag := true
          else
            flag := sflt[length(sflt)] = '*';
        end else
          flag := false;
      end;

    end else
      flag := true;


//    if flag then break;
  until stmp = '';




  result := flag;
end;


function CheckFilterOr(src, flt: string): boolean;
var
  k: integer;
  stmp, ssrc: string;
  flag: boolean;
begin
  flag := false;
  stmp := trim(src);
  repeat
    k := pos(';', stmp);
    if k > 0 then begin
      ssrc := copy(stmp, 1, k-1);
      delete(stmp, 1, k);
    end else begin
      ssrc := stmp;
      stmp := '';
    end;

    if length(ssrc) > 0 then begin
      flag := flag or CheckFilter(ssrc, flt);
    end;

    if flag then break;
  until stmp = '';

  result := flag;
end;

function CheckFilterLogic(expr, values: string; UseAllValues: boolean): boolean;
var
  i: integer;
  s, scalc, sval, ssrc: string;
  flag: boolean;
begin
  // проверка на обязательное участие всех values в expr
  if UseAllValues then begin
    ssrc:=expr;
    Translate(ssrc,'|&)(!',';;;;;');

    i := 1;
    while i < length(ssrc) do
      if copy(ssrc, i, 2) = ';;' then
        delete(ssrc, i, 1)
      else
      if copy(ssrc, i, 2) = '; ' then
        delete(ssrc, i+1, 1)
      else
      if copy(ssrc, i, 2) = ' ;' then
        delete(ssrc, i, 1)
      else
        inc(i);

    ssrc := trim(ssrc);
    if copy(ssrc,1,1) = ';' then delete(ssrc, 1, 1);
    if copy(ssrc,length(ssrc),1) = ';' then delete(ssrc, length(ssrc), 1);
    ssrc := trim(ssrc);

    flag := true;

    i := 1;
    repeat
      s := Parse(values, ';', i);
      if s='' then break;
      flag := flag and CheckFilter(s, ssrc);
    until not flag;

    if not flag then begin
      result := false;
      exit;
    end;
  end;

  // обработка expr
  scalc:='';
  sval:='';
  for i:=1 to length(expr) do begin
    flag := expr[i] in [';','|','&','(',')','!'];

    if not flag then sval := sval + expr[i];

    if (flag) or (i=length(expr)) then
      if not(trim(sval)='') then begin
      
        if UpperCase(trim(sval)) = 'TRUE' then
          scalc := scalc + '1'
        else
        if UpperCase(trim(sval)) = 'FALSE' then
          scalc := scalc + '0'
        else
          scalc := scalc + iif(CheckFilterOr(values, trim(sval)),'1','0');

        sval := '';
      end;

    if flag then scalc := scalc + expr[i];
  end;
  if copy(scalc,1,1) = ';' then delete(scalc, 1, 1);
  if copy(scalc,length(scalc),1) = ';' then delete(scalc, length(scalc), 1);

  // расчет результата
  Translate(scalc, '|;&', '++*');

  ReplaceS(scalc, '!', 'NOT');

  try
    result := trunc(rpCalcStr(scalc)) > 0;
  except
    result := false;
  end;
end;



////////////////////////////////////////////////////////////////////////////////
// CALC STR
////////////////////////////////////////////////////////////////////////////////
function rpCalcStr(Source:AnsiString):Double;
  {Numeric evaluation of an algebraic string using a recursive approach.
   Supports the 4 basic math operators, negation, exponentiation, Ln(),
   Exp(),Abs() and trigonometric functions (MATH unit required, commented out in
   freeware version).  Other functions can be easily added. Exception is
   raised if the string cannot be evaluated for any reason.}
const
  MathDel:AnsiString = '+-/*^()';
var
  Term:AnsiString;
  Oper:Char;
  P:Integer;

  procedure GetOperTerm;
  begin
    Term:=Parse(Source,MathDel,P);
    if P<1 then Oper:=#0 else Oper:=Source[P-1];
  end;

  function DoAdd : Double; forward;

  function DoBracket : Double; //5
  begin
    Result := DoAdd;
    if Oper = ')' then GetOperTerm
    else raise Exception.Create ('Mismatched brackets')
  end;

  function DoSign : Double;    //4
  var
    I:Integer;
  begin
    Result:=0;
    bJ := False;  //global boolean
    GetOperTerm;
    if Length(Term)>0 then begin
      if IsFloat(Term) then begin
        Result := StrToFloat(Term)
      end else begin
        I:=Hash(UpperCase(Term));
        if Oper = '(' then begin
          //Function table - define new functional hash values as needed
          case I of
            1294:    Result:=LN(DoBracket);
            17779:   Result:=ABS(DoBracket);
            19152:   Result:=EXP(DoBracket);
            21316:   if DoBracket=0 then result:=1 else result:=0;
{            18499:   Result:=COS(DoBracket);
            22494:   Result:=SIN(DoBracket);
            22622:   Result:=TAN(DoBracket);
            296056:  Result:=COSH(DoBracket);
            332706:  Result:=LOG2(DoBracket);
            359976:  Result:=SINH(DoBracket);
            362024:  Result:=TANH(DoBracket);
            5323328: Result:=LOG10(DoBracket);
            73824323:Result:=ARCCOS(DoBracket);
            73828314:Result:=ARCSIN(DoBracket);
            73828442:Result:=ARCTAN(DoBracket);}
            else         bJ:=True;
          end;
        end else begin
          //Constants table
          case I of
            1353: Result:=PI;
            else      bJ:=True;
          end;
        end;
      end;
    end else begin
      case Oper of
        '+' : Result := DoSign;
        '-' : Result := -DoSign;
        '(' : Result := DoBracket;
        else      bJ := True
      end;
    end;
    if bJ then raise Exception.CreateFmt ('Syntax error at position %d', [P])
  end;

  function DoPwr : Double; //3
  begin
    Result := DoSign;
    if Oper='^' then Result := exp (ln (Result) * DoSign);
  end;

  function DoDiv : Double; //2
  begin
    Result := DoPwr;
    while True do begin
      case Oper of
        '*' : Result := Result * DoPwr;
        '/' : Result := Result / DoPwr;
        else break;
      end;
    end;
  end;

  function DoAdd : Double; //1
  begin
    Result := DoDiv;
    while True do begin
      case Oper of
        '+' : Result := Result + DoDiv;
        '-' : Result := Result - DoDiv;
        else break;
      end;
    end;
  end;

begin
  Result:=0;
  bI:=False;             //global boolean
  P := Compact(Source);
  if P>0 then begin
    SetLength(Source,P);
    P := 1;
    Result := DoAdd;
    bI:=(Oper=#0);
  end;
  if bI=False then Raise Exception.Create('Unexpected end of string');
end;



////////////////////////////////////////////////////////////////////////////////
// PREPROCESSING INCLUDES IN TEXTFILE
////////////////////////////////////////////////////////////////////////////////
procedure PrepIncludes(Dir, Src, Dst: string);

  procedure _PrepIncludes(Src: string; var Fd: TextFile; RepCnt: integer);
  var
    Fs: TextFile;
    s: string;
  begin
    AssignFile(Fs, Src);
    try
      reset(Fs);
      while not(eof(fs)) do begin
        readln(fs,s);
        s := trim(s);
        if copy(UpperCase(s),1,8)='#INCLUDE' then begin
          delete(s,1,8);
          s := trim(s);
          if RepCnt<32 then _PrepIncludes(s, Fd, RepCnt+1);
        end else
          writeln(fd, s);
      end;
      CloseFile(fs);
    except
      //
    end;
  end;

var
  F: TextFile;
  OldDir: string;
begin
  OldDir := GetCurrentDir;
  ChDir(Dir);

  AssignFile(F, Dst);
  try
    rewrite(F);
    _PrepIncludes(Src, F, 0);
  finally
    CloseFile(F);
  end;

  ChDir(OldDir);
end;


////////////////////////////////////////////////////////////////////////////////
// КОНВЕРТАЦИЯ СТРОКИ ПО МАСКЕ '__XXX__'
////////////////////////////////////////////////////////////////////////////////
function MaskString(mask, src: string): string;
var
  i: integer;
  s: string;
begin
  s := '';
  for i:=1 to length(mask) do begin
    if i>length(src) then break;
    if mask[i] in ['X','x'] then
      s := s + src[i]
    else
      s := s + mask[i];
  end;
  result := s;
end;




////////////////////////////////////////////////////////////////////////////////
// ЗАМЕНА В СТРОКЕ s ВСЕХ ПОДСТРОК old НА НОВЫЕ new
////////////////////////////////////////////////////////////////////////////////
procedure rpReplaceS(var s: string; old, new: string);
var
  l1,l2,i: integer;
begin
  l1:=length(old);
  l2:=length(new);
  i:=1;
  while (i>0) and (i<=length(s)) do begin
    if copy(s,i,l1)=old then begin
      delete(s,i,l1);
      insert(new,s,i);
      i := i + l2 - 1;
    end else begin
      inc(i);
    end;
  end;;
end;



function rpGetStrTag(src, sbeg, send: string; var idx: integer; var taglen: integer): string;
var
  k1,k2,l1,l2: integer;
begin
  result:='';
  taglen:=0;
  if idx>1 then delete(src, 1, idx-1);

  k1:=pos(sbeg, src);
  k2:=pos(send, src);
  if (k1=0) or (k2=0) then exit;;

  l1:=length(sbeg);
  l2:=length(send);

  taglen := k2-k1+l2;
  result:=copy(src, k1+l1, k2-k1-l1);
end;


Function  StrInteger(s: string):integer;
var
  i,j: integer;
begin
  val(s, i, j);
  result := i;
end;


function get_substr_beg(c: char; var s: string): string;
var
  k: integer;
begin
  k := pos(c, s);
  if k>0 then begin
    result := copy(s, 1, k-1);
    delete(s, 1, k);
  end else begin
    result := s;
    s := '';
  end;
end;

end.
