БланкСШаблоном "Библиотека процедур контроля межформенных соотношений";

var expression	   :String;
var expression_    :String;
var vars[]	   :Integer;
var signs[]	   :Numeric;
var oper_ind[]	   :Integer;
var oper_code[]    :Integer;
var counter	   :Integer;
var op_count	   :Integer;
var args[]	   :Numeric;
var values[]	   :Numeric;
var level[]	   :String;
var LEVELS	   :Integer=4;
var correct_synt   :logical;
var ПН		   :String='{';
var ПК		   :String='}';
var REP 	   :String='#';
var КП[]	   :String;
var ЗП[]	   :Numeric;
var ВидПред	   :String;

var ТАБЛ_ВИД[]	   :String;
var ТАБЛ_ОТЧ[]	   :String;
----------------------------------------------------------------------------

proc Clear;
  ClearVariable(Библио.Контроль.vars);
  ClearVariable(Библио.Контроль.signs);
  ClearVariable(Библио.Контроль.oper_ind);
  ClearVariable(Библио.Контроль.oper_code);
  ClearVariable(Библио.Контроль.counter);
  ClearVariable(Библио.Контроль.op_count);
  ClearVariable(Библио.Контроль.args);
  ClearVariable(Библио.Контроль.values);
  ClearVariable(Библио.Контроль.level);
  ClearVariable(Библио.Контроль.КП);
  ClearVariable(Библио.Контроль.ЗП);
end;

proc Init;
  Clear;
--  level[1]='*/';	  *=&
--  level[2]='+-';	  /=not
--  level[3]=')(';	  +=|
  level[1]='><=';	-- -=~
  level[2]='&~';
  level[3]='|';
  level[4]=')(';
  counter=0;
  op_count=0;
end;

----------------------------------------------------------------------------

proc set_value (var_pos :integer; value :numeric);
  counter=counter+1;
  vars[counter]=var_pos;
  signs[counter]=value;
end;

proc ch_sign (position :integer);
  signs[position]=-signs[position];
end;

proc set_value_op (count :integer; code :integer);
  op_count=op_count+1;
  oper_ind[op_count]=count;
  oper_code[op_count]=code;
end;

func IEvaluate :numeric;
  var i,k,len,count,code :integer;

  ClearVariable(Библио.Контроль.values);
  len=counter;
  for i = 1 .. counter do
    if vars[i]<>-1:
      values[i]=signs[i]*args[vars[i]];
    else
      values[i]=signs[i];
    fi;
  od;
  for i = 1 .. op_count do
    count=oper_ind[i];
    code=oper_code[i];
    if code=0: values[count]=if(values[count]>values[count+1],1,0);-- >
     | code=1: values[count]=if(values[count]<values[count+1],1,0);-- <
     | code=2: values[count]=if(values[count]=values[count+1],1,0);-- =
     | code=3: values[count]=values[count]*values[count+1];	   -- &
     | code=4: values[count]=values[count]*if(values[count+1]=1,0,1);-- ~
     | code=5: values[count]=if((values[count]+values[count+1])>0,1,0);-- |	 |
    fi;
    if code<6:
      for k = count+1 .. len do
	values[k]=values[k+1];
      od;
      len=len-1;
    fi;
  od;
  return values[1];
end;

----------------------------------------------------------------------------

func expr_symb (index :integer) :string;
  return Substr(expression,index,1);
end;

func expr_write (index :integer; char :String) :string;
  var s1,s2,result :String;
  s1=Substr(expression,1,index-1);
  s2=Substr(expression,index+1,length(expression));
  result=s1+char+s2;
  return result;
end;

func is_digit (char :string) :logical;
  if char='0' or char='.': return true; fi;
  return (int(char)>0);
end;

func is_symbol (char :string) :logical;
  var code :integer;
  code=Ascii(char);
  return ((code>=Ascii('a') and code<=Ascii('z')) or
	  (code>=Ascii('A') and code<=Ascii('Z')));
end;

func get_num_len (index :integer) :integer;
  var l :integer;
  while is_digit(expr_symb(index)) do index=index+1; l=l+1; od;
  return l;
end;

proc replace_number (index :integer; len :integer);
  var num :numeric;
  var s1,s2 :String;
  s1=Substr(expression,1,index-1);
  s2=Substr(expression,index+len,length(expression));
  num=StringToNumeric(Substr(expression,index,len));
  expression=s1+REP+s2;
  set_value(-1,num);
end;

proc replace_letters;
  var i,count,n_len,k :integer;
  i=1;
  while i<=length(expression) do
    if is_digit(expr_symb(i)):
      n_len=get_num_len(i);
      replace_number(i,n_len);
    fi;
    if is_symbol(expr_symb(i)):
      correct_synt=false;
      break;
    fi;
    i=i+1;
  od;
end;

proc remove_min_plus;
  var i,y,len,count :integer;
  var flag :logical;
  len=length(expression);
  for i = 1 .. len do
    if expr_symb(i)=REP: count=count+1; fi;
    if count>0:
      if i=2 and (expr_symb(i-1)='-' or expr_symb(i-1)='+'): flag=true; fi;
      if i>2 and (expr_symb(i-1)='-' or expr_symb(i-1)='+') and expr_symb(i-2)='(': flag=true; fi;
      if flag:
	if expr_symb(i-1)='-': ch_sign(count); fi;
	for y = i-1 .. len-1 do expression=expr_write(y,expr_symb(y+1)); od;
	expression=Delete(expression,len,1);
	len=length(expression);
	flag=false;
      fi;
    fi;
  od;
end;

----------------------------------------------------------------------------

func find_next_let (since :integer) :integer;
  var i,num,len :integer;
  len=length(expression);
  for i = since .. len do
    if expr_symb(i)=REP: num=num+1; fi;
    if num=2: break; fi;
  od;
  return i;
end;

func chek_operation (lft_op :string; rght_op :string) :integer;
  var ret_code,l_op,r_op,lev,oper :integer;
  l_op=-1; r_op=-1;
  for lev=1 .. LEVELS do
    for oper = 1 .. length(level[lev]) do
      if l_op=-1: if lft_op=Substr(level[lev],oper,1): l_op=lev; fi; fi;
      if r_op=-1: if rght_op=Substr(level[lev],oper,1): r_op=lev; fi; fi;
      if r_op<>-1 and l_op<>-1: break; fi;
    od;
  od;
  if l_op>r_op: ret_code=-1; fi;
  if l_op<r_op: ret_code=+1; fi;
  return ret_code;
end;

func check_operat (indx :integer) :integer;
  var len :integer;
  len=length(expression);
  if indx=1 or indx=len: return 0; fi;
  return chek_operation(expr_symb(indx-1),expr_symb(indx+1));
end;

proc remeber_operation (indx :integer);
  var i,n,len,count :integer;
  var new_val :numeric;
  var op :string;
  len=length(expression);
  if indx>0:
    for n = 1 .. indx do if expr_symb(n)=REP: count=count+1; fi; od;
  fi;
  op=expr_symb(indx+1);
  if op='>': set_value_op(count,0);
   | op='<': set_value_op(count,1);
   | op='=': set_value_op(count,2);
   | op='&': set_value_op(count,3);
   | op='~': set_value_op(count,4);
   | op='|': set_value_op(count,5);
  fi;
  for i = indx .. len-2 do
    expression=expr_write(i,expr_symb(i+2));
  od;
  expression=Delete(expression,len-1,length(expression));
end;

func remove_brackets :logical;
  var n,k,i,len :integer;
  var flag :logical;

  len=length(expression);
  for k = 1 .. len do
    if expr_symb(k)='(' and expr_symb(k+2)=')':
      if k>0 and is_symbol(expr_symb(k-1)):
	correct_synt=false;
	flag=true;
	break;
      else
	expression=expr_write(k,REP);
	for i = k+1 .. len-2 do
	  expression=expr_write(i,expr_symb(i+2));
	od;
	expression=Delete(expression,len-1,length(expression));
	flag=true;
	break;
      fi;
    fi;
  od;
  return flag;
end;

func EEvaluate :Numeric;
  var len,i1,i2,since,count :integer;
  len=length(expression);

  correct_synt=true;
  replace_letters;
  remove_min_plus;
  since=1;
  while remove_brackets do od;
  if not correct_synt: return -1; fi;
  while len>1 do
    i1=find_next_let(since);
    i2=i1-2;
    if expr_symb(i2)=REP:
      if check_operat(i1)>=0 and check_operat(i2)<=0:
	remeber_operation(i2);
	remove_brackets;
	since=1;
      else
	remove_brackets;
	since=i1;
      fi;
    else
      since=i1;
      remove_brackets;
    fi;
    if not correct_synt: return -1; fi;
    len=length(expression);
  od;
  return IEvaluate;
end;

Func PosEx (Подстрока :String; Строка :String; НачПоз :Integer) :Integer;
  var fs :String;
  var p :Integer;
  fs=Substr(Строка,НачПоз,length(Строка));
  p=Pos(Подстрока,fs);
  return (if(p>0,НачПоз+p-1,0));
end;

Proc ПоискПодстановок;
  var p,pb,pe,n :Integer;
  var err :Logical;
  var c :String;
  p=1;
  while true do
    pb=PosEx(ПН,expression,p);
    if pb>0:
      pe=PosEx(ПК,expression,pb);
      if pe>0:
	c=Substr(expression,pb,pe-pb+1);
	if SearchInArray(КП,c)=-1:
	  n=n+1;
	  КП[n]=Substr(expression,pb,pe-pb+1);
	fi;
	p=pe+1;
      else
	err=true;
	break;
      fi;
    else
      break;
    fi;
  od;
end;

----------------------------------------------------------------------------

Func ЗначениеПодстановки (Поле :String; Вид :String) :Numeric;
  var Карт,Отч,Ф,Ф2 :String;
  var Знач :Numeric;
  var f,РО,РО2 :Integer;

  --Карт=Библио.БД.ПолеСтрПоКоду(Константы.Общ.картВидыОтчетов,Вид,'Картотека');
  f=SearchInArray(ТАБЛ_ВИД,Вид);
  if f>0: 
    Отч=ТАБЛ_ОТЧ[f];
    Ф='Код="'+Отч+'"';
    РО=OpenWorkArea(Карт,'Код',Ф);
    try
      if Records(РО)>0:
	Ф2='ИмяПоля="'+Поле+'"';
	РО2=OpenArray(РО,1,'ПозицииОтчета','ИмяПоля',Ф2);
	try
	  if Records(РО2)>0:
	    Знач=GetFieldN(РО2,1,'ЗначениеЧисло');
	  fi;
	finally
	  CloseWorkArea(РО2);
	end;

      fi;
    finally
      CloseWorkArea(РО);
    end;
  fi;
  return Знач;
end;

Proc ВычислитьПодтановки;
  var i,n :integer;
  var c :string;
  var Поле,Вид :String;

  n=LengthOfArray(КП);
  for i = 1 .. n do
    c=Substr(КП[i],2,Length(КП[i])-2);
    Поле=ExtractWord(1,c,'|');
    Вид=ExtractWord(2,c,'|');
    if Вид='': Вид=ВидПред; else ВидПред=Вид; fi;
    ЗП[i]=ЗначениеПодстановки(Поле,Вид);
  od;
end;

Proc ЗаменаПодтановок;
  var i,n,p,p1 :integer;
  var s1,s2 :string;

  n=LengthOfArray(КП);
  for i = 1 .. n do
    p=Pos(КП[i],expression);
    while p>0 do
      s1=Substr(expression,1,p-1);
      s2=Substr(expression,p+length(КП[i]),length(expression));
      expression=s1+'('+Str(ЗП[i],2)+')'+s2;
      p=Pos(КП[i],expression);
    od;
  od;
end;

Func ВычислитьВыражение (Выражение :String) :Numeric;
  Init;
  expression=Выражение;
  ПоискПодстановок;
  ВычислитьПодтановки;
  ЗаменаПодтановок;
  return EEvaluate;
end;

Proc Button1_OnClick(Sender: String);
  Init;
  expression=expression_;
  Message(Str(EEvaluate,2));
end;


Конец