この発言に対し以下のコメントが寄せられています

#00562　熊谷秀武        さん　RE:eval:関数電卓つきグリッド(３００行)

#00566　熊谷秀武        さん　RE:eval:関数電卓つきグリッド(３００行)






　Eval 〜　関数電卓付きグリッド

　

　比較的コンパクトな eval （数式の文字列を計算して数値を返す関数）が出
来たので公開します。

　累乗(^)・四則演算、カッコ、数学関数（int,sin、log など）、変数
（A..Z）
が使えます。 演算子の優先順位は、「^」累乗＞「*,/,%」＞「+,-」＞ 「=」
です。

　空文字列を与えると０を返します。カッコの中が空の場合にも０を返す。

　−−

　静的項目を作って、OnSetText イベントに次のように記述すると関数電卓付
きのＤＢグリッドやＤＢエディットになります。

procedure TForm1.Table1MIN_SALARYSetText(Sender: TField;
  const Text: String);
begin
  TField(Sender).asInteger := round(eval(text));
end;

　−−

　制限：

　変数は A から Z の半角１文字だけです。Eval_Variables[ 'X'  ]で他から
でも参照できます。

　関数の引数の数は１つか０だけです。２個以上の引数のある関数は定義でき
ません。

　デルファイ１な人間なのでデルファイ２以降への対応と、バグ情報をお願い
します。

　−−

const
  Eval_VarNames = ['A'..'Z'] ;
var
  Eval_Variables : array[ 'A'..'Z' ] of extended;

function Eval( const S:string ):extended;
type
  TFnc = (  fncNul  , fncATan , fncAbs , fncCos
        ,   fncExp  , fncFrac , fncInt , fncLn
        ,   fncLog  , fncPi   , fncSin , fncTan  );
var
  p:integer;

  function getVal:extended;forward;

  procedure EvalError( const msg:string );
  begin
    raise exception.create( copy(s,1,p)+' <-err:'+Msg+'
'+copy(S,p+1,255) );
  end;

function Power( v1,v2:extended ):extended;
var
  a1:extended;
begin
  if v1 = 0 then begin result := 0 ; exit ; end;    { 93-03-25 }
  if v2 = 0 then begin result := 1 ; exit ; end;    { 93-03-25 }
  a1 := Ln(abs(v1)) * v2;       (* a1:は答えのｌｏｇ        *)
  if  ( v1 < 0 )                (* 被累乗数がマイナスのとき *)
  and ( trunc(v2) <> v2 )       (* 整数でないときは         *)
    then EvalError('マイナスの非整数乗');
  a1 := Exp(a1);                (* a1:は答えの絶対値        *)
  if  (   v1 < 0          )     (* 被累乗数がマイナスで     *)
  and (  odd(trunc(v2))   )     (* 奇数乗なら               *)
      then a1 := -a1;           (* 答えはマイナス           *)
  result := a1;
end;

  function calc( val1:extended ; op:char ; val2:extended ):extended;
  begin
    case op of
    '+' :   result := val1  +  val2;
    '-' :   result := val1  -  val2;
    '*' :   result := val1  *  val2;
    '/' :   if val2 = 0
              then EvalError('割る数が０')
              else result := val1  /  val2;
    '%' :   result := trunc(val1)  mod  trunc(val2);
    '^' :   result := power( val1 , val2 );
    else    EvalError('知らない演算子');
    end; { case }
  end;

  procedure skipSpace;
  begin
    while ( p <= length(S) ) and ( s[p] <= ' ' ) do inc(p);
  end;

  function OpPriority( op:char ):integer;
  begin
                        {00  1   112223334}
    result := pos( op , 'xx'+#0+')=+--*/%^' ) div 3;
  end;

  function isOP( op:char ):boolean;
  begin
    result := ( OpPriority( op ) > 0 );
  end;

  function getOP:char;
  begin
    skipSpace;
    if p > length(S)
      then result := #0
      else result := s[p];
    if not isOP( result ) then EvalError('演算子でない');
    if not ( result in [ #0 , ')' ] ) then inc(p);
  end;

  function isFunc( var fnc:TFnc ):boolean;
  const
    MaxNameLen = length('ARCTAN')+1;
  var
    tmp:string;
    kakko:integer;
  begin
    result := false;
    tmp := UpperCase(copy(s,p, MaxNameLen ));
    kakko := pos( '(' , tmp );
    if ( kakko = 0 ) then exit;
    tmp := upperCase(copy(tmp,1,kakko-1));
    if tmp = ''       then fnc := fncNul    else
    if tmp = 'INT'    then fnc := fncInt    else
    if tmp = 'SIN'    then fnc := fncSin    else
    if tmp = 'COS'    then fnc := fncCos    else
    if tmp = 'TAN'    then fnc := fncTan    else
    if tmp = 'ARCTAN' then fnc := fncATan   else
    if tmp = 'EXP'    then fnc := fncExp    else
    if tmp = 'LN'     then fnc := fncLn     else
    if tmp = 'LOG'    then fnc := fncLog    else
    if tmp = 'ABS'    then fnc := fncAbs    else
    if tmp = 'FRAC'   then fnc := fncFrac   else
    if tmp = 'PI'     then fnc := fncPi     else
      exit; { else exit now }
    inc(p,length(tmp)+1);
    result := true;
  end;

  function isVar( var index:char ):boolean;
  var
    c:char;
  begin
    result := true;
    c := upCase(s[p]);
    if  ( c in Eval_VarNames )
    and ( ( p >= length(s) )
      or  ( not ( upcase(s[p+1]) in Eval_VarNames ))
        )
      then index  := c
      else result := false;
  end;

  function getNum:extended;
  var
    Minus:boolean;
    Start:integer;
    tmp:string;
    func:tFnc;
    tmpVar:char;
  begin
    Minus := false;
    skipSpace;
    if ( p > length(s)) or ( s[p] = ')' ) then begin
      result := 0 ;
      exit;
    end;
    if    ( p <= length(s)) and ( s[p] in [ '-','+' ] ) then begin
      if  ( s[p] in [ '-' ] ) then Minus := true;
      inc(p);
      skipSpace;
    end;
    if isVar( tmpVar ) then begin
        inc(p);
        result := Eval_Variables[ tmpVar ] ;
    end else
    if isFunc( func ) then begin
      result := getVal;
      if getOP <> ')'
        then EvalError('終わりのカッコがない')
        else inc(p);
      case func of
      fncNul    :   ;                           {　'(' }
      fncInt    :   result := int(result);
      fncSin    :   result := sin(result);
      fnccos    :   result := cos(result);
      fncTan    :   if ( abs(cos(result)) < 0.000000001 )
                      then EvalError('無限大になる')
                      else result := sin(result) / cos(result);
      fncAtan   :   result := arcTan(result);
      fncExp    :   result := Exp(result);
      fncLn     :   result := ln(result);
      fncLog    :   result := ln(result) / ln(10);
      fncAbs    :   result := abs(result);
      fncFrac   :   result := frac(result);
      fncPi     :   result := pi;
      else  EvalError('知らない関数');
      end;
    end else
    begin
      Start := p;
      if    ( p <= length(s)) and ( s[p] in [ '$'] )      then inc(p);
      while ( p <= length(s)) and ( s[p] in [ '0'..'9' , '.' ] )  do
inc(p);
      if ( p=Start ) then EvalError('数？');
      tmp := copy( s , start , p-Start );
      if ( pos( '$' , tmp ) <> 0 )
        then result := StrToInt( tmp )
        else result := StrToFloat( tmp );
    end;
    if Minus then result := -result;
  end;

  function getVal:extended;
  label
    getVal2,getOp2,testOp2,GetOP3,setVar;
  var
    val1,val2,val3,val4:extended;
    op1,op2,op3:char;
    dstVar,tmpVar:char;
  begin
    result := 0;
    dstVar := #0;
    tmpVar := #0;
      isVar( tmpVar );
      val1 := getNum;
      op1 := getOP;
      if op1 = '=' then begin
        dstVar := tmpVar;
        if dstVar = #0 then EvalError('左辺に変数がない');
        val1 := getNum;
        op1 := getOP;
      end;
      if op1 in [ #0,')' ] then begin
        result := val1;
        goto setVar;
      end;
getVal2:
      val2 := getNum;
getOp2:
      op2 := getOP;
testOp2:
      if op2 in [ #0,')' ] then begin
        result := calc( val1 , op1 , val2 );
        goto setVar;
      end;
        { v1 o1 v2 o2 v3 o3 v4 }    { v1 o1 v2 o2 v3 o3 v4 }
        { 1  +  2  +  3  *  4  }    { 3  +  3  *  4 }
        { 1  *  2  +  3  +  4  }    { 2  +  3  +  4 }
      if ( opPriority(op1) >= opPriority(op2) ) then begin
        val1 := calc( val1 , op1 , val2 );
        op1 := op2;
        goto getVal2;
      end;
      val3 := getNum;
getOP3:
      op3 := getOP;
        { v1 o1 v2 o2 v3 o3 v4 }    { v1 o1 v2 o2 v3 o3 v4 }
        { 1  +  2  ^  3  *  4  }    { 1  +  8  *  4 }
        { 1  *  2  ^  3  +  4  }    { 1  *  8  +  4 }
      if ( opPriority(op2) >= opPriority(op3) ) then begin
        val2 := calc( val2 , op2 , val3 );
        op2 := op3;
        goto testOp2;
      end;
        { v1 o1 v2 o2 v3 o3 v4 }
        { 1  +  2  *  3  ^  4  * 5 }
      val4 := getNum;
      val3 := calc( val3 , op3 , val4 );
      goto getop3;
setVar:
    if dstVar in Eval_VarNames
      then Eval_Variables[ dstVar ] := result;
  end;

begin       {  Evel 関数の本体　}
  p := 1;
  result := getVal;
  if getOP <> #0 then EvalError('カッコが多すぎる');
end;


                              98/6/11(Thu) GGB03124 熊谷秀武

Original document by 熊谷秀武        氏 ID:(GGB03124)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。