Вычисление определенного интеграла методом правых прямоугольников (на отрезке, с указаным шагом разбития)

unit NGFunc;
 
Interface
 
uses SysUtils, NGMath;
 
 
type
  TFunc=class(TObject)
    Tx, St: String;
    Arr: RealArray;
  public
    constructor Create(SF: String);
    function PointX(Arg:extended): Extended; virtual;
    function PointY(Arg:extended): Extended; virtual;
    procedure ChangeFunc(SF: String; var Chng: Boolean);virtual;
    function Eval(ArgX, ArgY: Extended): Extended;
  end;
 
implementation
 
constructor TFunc.Create(SF: String);
  var Err:Boolean;
begin
  Inherited Create;
  Tx:=SF;
  St:=UpperCase(Tx);
  Err:=False;
  Convertor(St,Arr,Err);
end;
 
function TFunc.PointX(Arg: Extended): Extended;
begin
  PointX:=Arg
end;
 
function TFunc.PointY(Arg: Extended): Extended;
begin
  PointY:=Eval(Arg,0)
end;
 
function TFunc.Eval(ArgX, ArgY: Extended): Extended;
  var stack:array[1..10] of extended;
      y,z,w:extended;
      i,j,top,xx,integ1,integ2:integer;
begin
  Top:=0;
  i:=1;
  try
  while i<=Length(St) do
    begin
      case St[i] of
       #0..chr(numofconst):begin
                             stack[top+1]:=Arr[Byte(St[i])];inc(top)
                           end;
       #30:begin
             stack[top+1]:=ArgX;inc(top)
           end;
       #29:begin
             stack[top+1]:=ArgY;inc(top)
           end;
      #255:begin
             y:=stack[top]; stack[top]:=stack[top-1]; stack[top-1]:=y
           end;
       '"':begin
             stack[top-1]:=stack[top-1]+stack[top];dec(top)
           end;
       '#':begin
             stack[top-1]:=stack[top-1]-stack[top];dec(top)
           end;
       '$':begin
             stack[top-1]:=stack[top-1]*stack[top];dec(top)
           end;
       '%':begin
             if stack[top]<>0 then stack[top-1]:=stack[top-1]/stack[top] else begin stack[top]:=AllErr; Break; end;
             dec(top)
           end;
       '&':begin
             if stack[top-1]=0 then
               dec(top)
             else
               begin
                 if stack[top]=0 then
                   begin
                     stack[top-1]:=1;
                     dec(top)
                   end
                 else
                   begin
                     y:=ln(abs(stack[top-1]))*stack[top];
                     if (stack[top]>0) and (stack[top]<MaxInt) and (int(stack[top])=stack[top]) then
                       begin
                         z:=1;integ1:=round(stack[top]);
                         while integ1>0 do
                           begin
                             integ2:=integ1 div 2;
                             if (integ2+integ2)<integ1 then z:=z*stack[top-1];
                             integ1:=integ2;
                             stack[top-1]:=stack[top-1]*stack[top-1];
                           end;
                         stack[top-1]:=z;
                         dec(top)
                       end
                     else
                       begin
                         y:=exp(y);
                         z:=abs(stack[top]);
                         xx:=0;
                         if (stack[top-1]<0) then
                         begin
                           if (z<=1) and (z>=(1/1e+3)) and (int(1/z)=1/z) and ((round(1/z) mod 2)=1) then
                           stack[top-1]:=sign(stack[top-1])*y
                           else
                           begin
                           if (z>=1) and (int(z)=z) then
                           begin
                             w:=1;integ1:=round(z);
                             while integ1>0 do
                             begin
                               integ2:=integ1 div 2;
                               if (integ2+integ2)<integ1 then w:=w*stack[top-1];
                               integ1:=integ2;
                               stack[top-1]:=stack[top-1]*stack[top-1];
                             end;
                             stack[top-1]:=1/w;
                           end
                           else
                           begin
                             stack[top]:=AllErr;
                             Break;
                           end
                           end
                         end
                         else
                           stack[top-1]:=y;
                         dec(top);
                       end;
                   end;
               end;
           end;
       'H':stack[top]:=arctan(stack[top]);
       'B':stack[top]:=cos(stack[top]);
       'J':stack[top]:=exp(stack[top]);
       'L':if stack[top]>0 then stack[top]:=ln(stack[top]) else begin stack[top]:=AllErr; Break; end;
       'K':if stack[top]>0 then stack[top]:=ln(stack[top])/Ln10 else begin stack[top]:=AllErr; Break; end;
       'M':stack[top]:=abs(stack[top]);
       'N':if stack[top]>=0 then stack[top]:=sqrt(stack[top]) else begin stack[top]:=AllErr; Break; end;
       'A':stack[top]:=sin(stack[top]);
       'C':stack[top]:=sin(stack[top])/cos(stack[top]);
       'D':stack[top]:=cos(stack[top])/sin(stack[top]);
       'F':if abs(stack[top])<1 then stack[top]:=arctan(stack[top]/sqrt(1-stack[top]*stack[top])) else begin stack[top]:=AllErr; Break; end;
       'G':if abs(stack[top])<1 then stack[top]:=pi/2-arctan(stack[top]/sqrt(1-stack[top]*stack[top])) else begin stack[top]:=AllErr; Break; end;
       'I':stack[top]:=pi/2-arctan(stack[top]);
       'R':if stack[top]>=0 then stack[top]:=int(stack[top]) else stack[top]:=int(stack[top])-1;
      end;
      i:=i+1;
    end;
  Eval:=stack[top];
  except
    Eval:=AllErr;
  end;
end;
 
 
procedure TFunc.ChangeFunc(SF: String; var Chng:Boolean);
  var
      Err:Boolean;
      NTx, NSt: String;
      NArr: RealArray;
begin
  Err:=False;
  NTx:=SF;
  NSt:=UpperCase(NTx);
  Convertor(NSt, NArr, Err);
  if Err then
      Chng:=False
  else
    begin
      Tx:=NTx; St:=NSt; Arr:=NArr;
      Chng:=True;
    end;
end;
 
end.

unit NGMath;
 
interface
 
uses SysUtils;
 
const
      NumOfConst  = 28;
      AllErr      = 1e+100;
      IlFfuncCall = 2e+202;
      Zero        = 1e+101;
      Overflow    = 3e+303;
type
     RealArray=array[0..numofconst] of Extended;
 
  var   Ln10       : Extended;
        izero : Extended=0.000000001;
 
function Minimum(A, B: Extended): Extended;
function Maximum(A, B: Extended): Extended;
function SValue(X: Extended; Exac : Integer=2): String;  //перевод числа в стринг
function equ(a,b,e:double) : boolean; //соотношение числа с точностью
procedure Convertor(var s:string;var consts:realarray;var error:boolean);
function Sign(x:extended):integer;
function TrueFormula(S: String): Boolean;
function TrueNumbers(S : String; zn : Char='.') : Boolean; //перевірка чи є рядок просто числом
 
implementation
 
function Minimum(A, B: Extended): Extended;
begin
  if A<B then Minimum:=A else Minimum:=B
end;
 
function Maximum(A, B: Extended): Extended;
begin
  if A<B then Maximum:=B else Maximum:=A
end;
 
function SValue(X: Extended; Exac : Integer=2): String;
Var n : Byte;
    Eps : Byte;
begin
  Eps:=Exac;
  If Equ(X,0,izero) Then X:=0;
  n:=Length(IntToStr(Trunc(Abs(X))));
  If Abs(X)<1 Then n:=n-1;
  If Eps<>0
   Then SValue:=FloatToStrF(X,ffGeneral,Eps+n,2)
   Else SValue:=IntToStr(Round(X));
end;
 
function equ(a,b,e:double):boolean;
begin
  Result:=Abs(a-b)<e;
end;
 
procedure convertor(var s:string;var consts:realarray;var error:boolean);
  var sl:string;
      op,countop:byte;
procedure coder;
  var i,clos,open,constcount:byte;
procedure fuin;
  const funames:string=
        'Y   T   X   F   SIN COS TG  CTG ASINACOSATG ACTGEXP LG  LN  ABS SQRTLOG PI  INT ';
        fucode:string=#29+#30+#30+#30'ABCDFGHIJKLMNOPR';
        {
        'Y   T   X   F   SIN COS ';
        fucode:string=#29+#30+#30+#30'AB';
        }
        
  var ss:string;
      n:byte;
begin
  ss:='';
  while (s[i] in ['A'..'Z']) and (i<=length(s)) do
    begin
      ss:=ss+s[i];
      inc(i)
    end;
  n:=pos(ss,funames);
  if (n>0) and ((n mod 4)=1) then
    begin
      sl:=sl+fucode[(n div 4)+1];
      dec(i);
      if sl[length(sl)]='P' then
        begin
          consts[constcount]:=Pi;
          inc(constcount);
          sl[length(sl)]:=chr(constcount-1);
        end;
    end
      else error:=true;
end;
procedure valuein;
  var ss:string[20];
      e:integer;
      d:extended;
procedure dit;
begin
  while  (s[i] in ['0'..'9','.']) and (i<=length(s)) do
    begin
      ss:=ss+s[i];
      inc(i)
    end
end;
begin
  ss:='';
  dit;
  if (i<=length(s)-2) and (s[i]='E') and (s[i+1] in ['-','+'])
    then
      begin
        ss:=ss+s[i]+s[i+1];
        i:=i+2;
        dit
      end;
  val(ss,d,e);
  if e>0 then error:=true else begin
  consts[constcount]:=abs(d);
  inc(constcount);
  sl:=sl+chr(constcount-1);
  dec(i); end
end;
 
function log(s:string):string;
  var s1:string;
      pn,pe,z,k:longint;
begin
  while pos('LOG',s)>0 do
    begin
      pn:=pos('LOG',s);
      if s[pn+3]<>'(' then
        begin
          error:=true;
          exit;
        end;
      k:=1;pe:=pn+3;
      repeat
        inc(pe);
        if s[pe]='(' then inc(k);
        if s[pe]=')' then dec(k);
      until (k=0) or (pe=length(s));
      if k<>0 then
        begin
          error:=true;
          exit;
        end;
      s1:=copy(s,pn+4,pe-pn-4);
      delete(s,pn,pe-pn+1);
      s1:=log(s1);
      z:=pos(',',s1);
      if z=0 then begin
                    error:=true;
                    exit;
                  end;
      s1:='LN('+copy(s1,z+1,length(s1)-z)+')/LN('+copy(s1,1,z-1)+')';
      insert(s1,s,pn);
    end;
  log:=s;
end;
 
begin
  constcount:=1;
  open:=0;
  clos:=0;
  sl:=#0+'"';
  consts[0]:=0;
  error:=false;
  s:=log(s);
  i:=1;
  while i<=length(s) do
    begin
      case s[i] of
      'A'..'Z':fuin;
      '0'..'9','.':valuein;
      '(':begin open:=open+1; sl:=sl+' ' end;
      ')':begin clos:=clos+1; sl:=sl+'!' end;
      '+':sl:=sl+'"';
      '-':sl:=sl+'#';
      '*':sl:=sl+'$';
      '/':sl:=sl+'%';
      '^':sl:=sl+'&'
    end;
    if clos>open then error:=true;
    if ConstCount>NumOfConst then error:=true;
    inc(i)
  end;
  if clos<>open then error:=true;
end;
procedure minus;
  var i:byte;
begin
  if sl[3]='#' then insert(#0,sl,3);
  for i:=1 to length(sl)-2 do
    if (sl[i]=' ') and (sl[i+1]='#')
      then
        insert(#0,sl,i+1)
end;
procedure anothererrors;
  var i,a:byte;
begin
  op:=0;
  for i:=1 to length(sl)-1 do
    begin
      a:=byte(sl[i]);
      if ((a<=Succ(NumOfConst+1)) and (sl[i+1]<'!'))         or
         ((a<=Succ(NumOfConst+1)) and (sl[i+1]>='A'))        or
         ((a=32) and (sl[i+1] in ['"'..'&']))                or
         ((sl[i] in ['"'..'&']) and (sl[i+1]='!'))           or
         ((a>64) and (sl[i+1]<>' '))                         or
         ((sl[i] in ['"'..'&']) and (sl[i+1] in ['"'..'&'])) or
         ((sl[i]=' ') and (sl[i+1]='!'))                     or
         (sl[length(sl)] in ['"'..'&','A'..'Z'])             or
         ((sl[i]='O') and (ord(sl[i+1])>NumOfConst))         or
         ((sl[i]='!') and (not (sl[i+1] in ['!','"'..'&'])))
         then error:=true;
      if a>=34 then op:=op+1
    end
end;
procedure analis;
  var open,l,r,lr:byte;
      tmpl,tmpr:char;
procedure searcho(a:byte;var b:byte);
begin
  b:=a+1;
  while (sl[b]<'"') and (b<length(sl)) do
    b:=b+1;
end;
function rang(a:byte):word;
  var i:byte;
begin
  open:=0;
  for i:=1 to a do
    begin
      if sl[i]=' ' then open:=open+1;
      if sl[i]='!' then open:=open-1;
    end;
  if a>=length(sl)
    then
      rang:=0
    else
      begin
        case sl[a] of
          '"','#':rang:=40*open+1;
          '$','%':rang:=40*open+2;
          '&':rang:=40*open+3;
          'A'..'Z':rang:=40*open+4
        end
      end
end;
procedure oper(var lr:byte);
  var l:byte;
begin
  searcho(0,l);
  repeat
    lr:=l;
    searcho(l,l)
  until rang(lr)>=rang(l)
end;
procedure searchl(lr:byte;var l:byte);
begin
  l:=lr-1;
  while sl[l]='!' do
    l:=l-1
end;
procedure searchr(lr:byte;var r:byte);
begin
  r:=lr+1;
  while sl[r]=' ' do
    r:=r+1
end;
begin
  oper(lr);
  case sl[lr] of
    '"'..'&':begin
               searchl(lr,l); tmpl:=#0;
               if sl[l]<>#31 then s:=s+sl[l] else tmpl:=#31;
               searchr(lr,r); tmpr:=#0;
               if sl[r]<>#31 then s:=s+sl[r] else tmpr:=#31;
               if (tmpl<>#31) and (tmpr=#31) then s:=s+#255;
               s:=s+sl[lr];
               delete(sl,2*l-lr+1,2*r-2*l-1);
               insert(#31,sl,2*l-lr+1)
             end;
    'A'..'T':begin
               searchr(lr,r);
               if sl[r]<>#31 then s:=s+sl[r];
               s:=s+sl[lr];
               delete(sl,lr,2*r-2*lr);
               insert(#31,sl,lr)
             end
  end;
  countop:=countop+1;
  if countop<op then analis
end;
begin
  countop:=0;
  coder;
  s:='';
  if not error then minus;
  if not error then anothererrors;
  if not error then analis
end;
 
function sign(x:extended):integer;
begin
  if Abs(x)>=AllErr then
    sign:=2
  else
    begin
      if x>0 then
        sign:=1
      else
        begin
          if x<0 then
            sign:=-1
          else
            sign:=0;
        end;
    end;
end;
 
function TrueFormula(S: String): Boolean;
  var St :  String;
      Arr:  RealArray;
      Err:  Boolean;
begin
  St:=UpperCase(S);
  Convertor(St, Arr, Err);
  TrueFormula:= not Err;
end;
 
function TrueNumbers(S : String; zn : Char='.') : Boolean; //перевірка чи є рядок просто числом
Var i : Integer;
    ch : Set Of Char;
begin
  s:=Trim(s);
  ch:=['-','0','1'..'9']+[zn];
  Result:=True;
  For i:=1 To Length(S) Do
   If Not (s[i] in ch) Then
    Begin
      Result:=False;
      Exit;
    End;
end;
 
initialization
  Ln10:=Ln(10);
end.