formulan.pas

来自「ArtFormula package contains two nonvisua」· PAS 代码 · 共 966 行 · 第 1/2 页

   result := byte(F_LE);
   exit;
  end;
  if input[pos] = '>' then
  begin
   inc(pos);
   result := byte(F_NE);
   exit;
  end;
  result := byte(c);
  exit;
 end;


 ferror := ER_ILLEGAL;
 result := 0;
 exit;
end;

const err_strings : array [TFormulaError] of string =
('Ok', 'Illegal character', 'Unknown identifier', '")" expected', '"(" expected',
  'Syntax error', 'Variable not used','Not enough parameters');

function TArtFormulaN.ErrString : string;
begin
 result := err_strings[ferror];
end;

function TArtFormulaN.Compile(instr : string; num : byte; vars : PStringArray) : string;
var c: char;
begin
 c := decimalseparator;
 decimalseparator := '.';
 fcompiled := '';
 if not Test(instr, num, vars) then
 begin
  result := '';
  exit;
 end;
 fcompiled := temp;
 result := temp;
 decimalseparator := c;
end;


function TArtFormulaN.ComputeStr(instr : string; num : byte; vars : PStringArray; vals : pdoublearray) : double;
var tmp : string;
begin
 tmp := Compile(instr, num, vars);
 if(tmp = '') then raise FormulaException.Create(ErrString);
 result := Compute(vals);
end;

function TArtFormulaN.Test(instr : string; num : byte; vars : PStringArray) : boolean;
var i:integer;
begin
  if num > 0 then
  begin
   setlength(usedvars,num);
   for i:=0 to num-1 do usedvars[i] := false;
  end;
  input := instr+#0;
  pos := 1;
  numofvar := num;
  varnames := vars;
  temp := '';
 if Form <> F_EOS then
 begin
  if ferror = ER_Ok then ferror := ER_SYNTAX;
  result := false;
  exit;
 end;

 while S.Top <> #0 do
 begin
  temp := temp + S.Popex;
 end;

 if ftestused then
 for i:=0 to num-1 do
  if usedvars[i] = false then
  begin
   ferror := ER_VARS;
   result := false;
   exit;
  end;

 if length(temp) = 0 then
  result := false
 else
  result := true;
end;

function TArtFormulaN.Form:integer;
var p : integer;
    u : ^double;
    i,cnt:integer;
begin
  p := Parser;
  if p = F_EOS then
  begin
   result := 0;
   exit;
  end;

   if chr(p) = '+' then p := Parser;

   if chr(p) = '-' then
   begin
     S.Push(F_UMINUS);
     p := Form;
   end
   else
   if chr(p) = '!' then
   begin
     S.Push('!');
     p := Form;
   end
   else
   if(chr(p) = '(') then
   begin
     S.Push('(');
     p := Form();
     if p = 0 then
     begin
      result := 0;
      exit;
     end;
     if(chr(p) <> ')') then
     begin
      ferror := ER_RIGHT;
      result := 0;
      exit;
     end;

     while(S.Top()<>'(') do
     begin
      temp := temp + S.Popex;
     end;

     S.Pop;
     if isfun(S.Top) then
     begin
      temp := temp + S.Top;
      temp := temp + chr(table[byte(S.Pop)].paramcount)
     end;

     p := Parser;
    end
   else
   if isfun(chr(p)) then
    begin
     S.Push(chr(p));
     cnt := table[p].paramcount;
     if(chr(Parser) <> '(') then
     begin
      ferror := ER_LEFT;
      result := 0;
      exit;
     end;
     S.Push('(');
     if cnt > 0 then
     for i := 1 to cnt do
     begin
      S.Push(',');
      p := Form;
      if p = 0 then
      begin
       result := 0;
       exit;
      end;

      while(S.Top <> ',') do
      begin
       temp := temp + S.Popex;
      end;
      if (chr(p) <> ',') and (i<cnt) then
      begin
       ferror := ER_NOTENOUGH;
       result := 0;
       exit;
      end;
      S.Pop;
     end
     else if cnt = -1 then
     begin
      p := Parser(true);
      cnt := 0;
      while chr(p) <> ')' do
      begin
       inc(cnt);
       S.Push(',');
       p := Form;
       if p = 0 then
       begin
        result := 0;
        exit;
       end;

       while(S.Top <> ',') do
       begin
        temp := temp + S.Popex;
       end;
       S.Pop;
      end;
      temp := temp + chr(F_DATA);
      temp := temp + stringofchar(#0,sizeof(double));
      u := @(temp[length(temp)-sizeof(double)+1]);
      u^ := cnt;
     end
     else p := Parser;
     if chr(p) <> ')' then
     begin
      ferror := ER_RIGHT;
      result := 0;
      exit;
     end;
     while(S.Top <> '(') do
     begin
      temp := temp + S.Popex;
     end;
     S.Pop;
     temp := temp + S.PopEx;
     p := Parser;
    end

   else
   if chr(p) = F_USERF then
    begin
     S.Push(char(trunc(data)));
     S.Push(chr(p));
     p := trunc(data);
     cnt := userfunc[p].paramcount;
     if(chr(Parser) <> '(') then
     begin
      ferror := ER_LEFT;
      result := 0;
      exit;
     end;
     S.Push('(');
     if cnt > 0 then
     for i := 1 to cnt do
     begin
      S.Push(',');
      p := Form;
      if p = 0 then
      begin
       result := 0;
       exit;
      end;

      while(S.Top <> ',') do
      begin
       temp := temp + S.Popex;
      end;
      if (chr(p) <> ',') and (i<cnt) then
      begin
       ferror := ER_NOTENOUGH;
       result := 0;
       exit;
      end;
      S.Pop;
     end
     else p := Parser;

     if chr(p) <> ')' then
     begin
      ferror := ER_RIGHT;
      result := 0;
      exit;
     end;
     while(S.Top <> '(') do
     begin
      temp := temp + S.Popex;
     end;
     S.Pop;
     temp := temp + S.PopEx;
     p := Parser;
    end

   else if p = F_VAR then
    begin
     temp := temp + chr(p);
     temp := temp + chr(trunc(data));
     p := Parser;
    end
   else if p = F_DATA then
    begin
     temp := temp + chr(p);
     temp := temp + stringofchar(#0,sizeof(double));
     u := @(temp[length(temp)-sizeof(double)+1]);
     u^ := data;
     p := Parser;
    end
   else
   begin
    result := 0;
    exit;
   end;


     if p = F_EOS then
     begin
      result :=  F_EOS;
      exit;
     end;
     if not isznak(chr(p)) then
     begin
       result := p;
       exit;
     end;

     while prior(chr(p),S.Top) do temp := temp + S.Popex;
     S.Push(chr(p));
     p := Form;
     if p = 0 then
     begin
       result := 0;
       exit;
     end
     else
     begin
      result := p;
      exit;
     end;
end;

function TArtFormulaN.Compute(vals : pDoubleArray) : double;
var i,idx,l,cnt:integer;
begin
 i := 1;
 l := length(compiled);
 cpos := 0;
 ferror := ER_Ok;

 while(i<=l) do
 begin
   case compiled[i] of
      '+':
      begin
       dec(cpos);
       cdata[cpos-1] := cdata[cpos] + cdata[cpos-1];
      end;
      '-':
      begin
       dec(cpos);
       cdata[cpos-1] := cdata[cpos-1] - cdata[cpos];
      end;
      '*':
      begin
       dec(cpos);
       cdata[cpos-1] := cdata[cpos-1] * cdata[cpos];
      end;
      '/':
      begin
       dec(cpos);
       cdata[cpos-1] := cdata[cpos-1] / cdata[cpos];
      end;
      '%':
      begin
       dec(cpos);
       cdata[cpos-1] := trunc(cdata[cpos-1]) mod trunc(cdata[cpos]);
      end;
      '^':
      begin
       dec(cpos);
       cdata[cpos-1] := power(cdata[cpos-1], cdata[cpos]);
      end;
      F_NE :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]<>cdata[cpos],1,0);
      end;
      '=' :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]=cdata[cpos],1,0);
      end;
      '<' :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]<cdata[cpos],1,0);
      end;
      F_LE :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]<=cdata[cpos],1,0);
      end;
      '>' :
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]>cdata[cpos],1,0);
      end;
      F_GE:
      begin
       dec(cpos);
       cdata[cpos-1] := ifthen(cdata[cpos-1]>=cdata[cpos],1,0);
      end;
      F_UMINUS:
      begin
       cdata[cpos-1] := -cdata[cpos-1];
      end;
      '!':
      begin
       cdata[cpos-1] := ifthen(cdata[cpos-1]<>0,1,0);
      end;
      #1 .. chr(NUMFUN-1):
        begin
         idx := byte(compiled[i]);
         inc(i);
         cnt := byte(compiled[i]);
         if cnt = 255 then cnt := trunc(cdata[cpos-1]+1)
         else if cnt = 0 then
         begin
          if cpos = max then
          begin
           inc(max,128);
           setlength(cdata,max);
          end;
          cdata[cpos] := 0;
          inc(cpos);
          cnt := 1;
         end;
         cdata[cpos-cnt] := table[idx].fun(cpos-1, cdata);
         dec(cpos,cnt-1);
        end;
      F_USERF:
        begin
         inc(i);
         idx := byte(compiled[i]);
         inc(i);
         cnt := byte(compiled[i]);
         if cnt = 255 then cnt := trunc(cdata[cpos-1]+1)
         else if (cnt = 0) then
         begin
          if cpos = max then
          begin
           inc(max,128);
           setlength(cdata,max);
          end;
          cdata[cpos] := 0;
          inc(cpos);
          cnt := 1;
         end;
         cdata[cpos-cnt] := userfunc[idx].fun(cpos-1, cdata);
         dec(cpos,cnt-1);
        end;
     chr(F_VAR):
       begin
        inc(i);
        if cpos = max then
        begin
         inc(max,256);
         setlength(cdata,max);
        end;
        cdata[cpos] := vals^[byte(compiled[i])];
        inc(cpos);
       end;
     chr(F_DATA):
       begin
        if cpos = max then
        begin
         inc(max,256);
         setlength(cdata,max);
        end;
        cdata[cpos] := (pdouble(@(compiled[i+1])))^;
        inc(cpos);
        inc(i,sizeof(double));
       end;
     end;
  inc(i);
 end;
 result := cdata[cpos-1];
end;

procedure Register;
begin
  RegisterComponents('Art', [TArtFormulaN]);
end;


end.