Delphi Programmer's Power Pack/Delphi Volume 1.iso/e_to_l/fbuilder/delphi/demos/hlpxampl.pas

Pascal/Delphi Source File | 1996-09-15 | 9.2 KB | 298 lines

{*                                 *}
{*  FormulaBuilder 1.0             *}
{*  YGB Software, Inc.             *}
{*  Copyright 1995 Clayton Collie  *}
{*                                 *}

 {*                                                                     *}
 {* This unit implements the functions discussed in the online help     *}
 {* To use these functions, simply include this unit in the USES        *}
 {* statement of any unit in your project (they register and unregister *}
 {* automatically                                                       *}
 {*                                                                     *}

Unit HlpXampl;
INTERFACE
uses FBCALC;


IMPLEMENTATION
Uses SYSUTILS,FBMISC,FBCOMP;
var
 CompInterestFnId,
 RomanFnId,
 SumSqFnId,
 ParamInfoFnId,
 AtSumFnId,
 WhoCalledFNId : Integer;


{*
 *  Example 2
 *
 *  Consider the Compound Interest Formula
 *
 *  A =  P * (1 + i)^n
 *
 *  where A is the accumulated value, P is the principal,
 *  I is the rate of interest and n is the number of periods
 *  Here is how the function could be implemented :
 *
 *}

Procedure CompoundInterestProc(paramcount     : byte;
                               const params   : TActParamList;
                               var   Retvalue : TValueRec ;
                               var   errcode  : integer;
                                     ExprData : longint); export;
var p, I , n : double;
      A    : extended;
begin
    p := params[0].vFloat;
    I := params[1].vFloat;
    N := params[2].vFloat;
    A := P * power(1 + i,n); { power is defined in FBMISC}
    retvalue.vFloat  := A;
end;



{*
 * Callback Error Reporting Example
 *
 * Suppose we want to limit the range of values the user can enter
 * as arguments to the ROMAN function from Example 1. The ROMAN function,
 * takes an integer value and returns a Roman Numeral string.
 *
 * The Roman Function does not accept negative numbers. Also remember from
 * our discussion that FormulaBuilder does automatic type conversions
 * between compatible types to ensure that the correct parameter type is
 * passed to a function. This would allow the user of the ROMAN function
 * to type 'ROMAN(15.43)', which would be evaluated as ''ROMAN(15)'. We
 * will disallow the of floating point numbers in our function .
 *
 * If a negative or floating point value were passed into the function
 *  (for example Expression1.formula = 'Roman(-1)' ) then evaluation of
 * the expression would terminate with the Status Property of the
 * TExpression being set to EXPR_DOMAIN_ERROR.
 *}

{ RomanFunc with range checking }
Procedure RomanProc( paramcount     : byte;
                     const params   : TActParamList;
                     var   retvalue : TValueRec;
                     var   errcode  : integer;
                           Exprdata : longint); export;
var number : longint;
    roman  : string[40];
begin
  { complain if there is a fractional part }
  if (Frac(params[0].vFloat) - 1E6) > 0 then
     Errcode := EXPR_TYPE_MISMATCH
 else
  if number < 0 then
     errcode := EXPR_DOMAIN_ERROR { param is out of domain of function }
 else                              { definition   }
  begin
    number := Trunc(params[0].vFloat);
    roman  := Romanize(number)+#0;
    retvalue.vpString := FBCreateString(@Roman[1]);
  end;
end;



{*
 * Variable Parameter List Example 2
 *
 * The SUMSQ function returns the sum of the squares of its
 * arguments. We can have as few as 1 and as many as 16 parameters
 * of type float.
 *
 *}

Procedure SumSqProc(     paramcount  : byte;
                      const params   : TActParamList;
                      var   retvalue : TValueRec;
                      var   errcode  : integer;
                            Exprdata : longint); export;
var i   : integer;
    sum    : extended;
    number : extended;
    sqr    : Extended;

begin
  sum := 0;
  for i := 0 to pred(paramcount) do
  begin
    number := params[i].vFloat;
    sum    := sum + (number * number);
  end;
  retvalue.vFloat := sum;
end;


{*
 * The vtANY Type : Example 2
 *
 * It is not immediately obvious from the IIFProc example that the
 * arguments can be of different types. To demonstrate this, we will
 * implement a function PARMINFO which returns a string describing the
 * parameters passed to it
 *
 *}

 Procedure ParamInfoProc( paramcount     : byte;
                          const params   :  TActParamList;
                          var   retvalue : TValueRec;
                          var   errcode  : integer;
                                exprdata : longint); export;
 var i      : integer;
     tmpstr : string[255];
     anycount,intcount,stringcount,
     floatcount, boolcount, datecount : integer;

 begin
   intcount    := 0;
   floatcount  := 0;
   boolcount   := 0;
   datecount   := 0;
   anycount    := 0;
   stringcount := 0;
   if paramcount = 0 then
   begin
     tmpstr  := ' No parameters '+#0;
     retvalue.vpString := FBCreateString(@Tmpstr[1]);
     exit;
   end;
   for i := 0 to pred(paramcount) do
   with params[i] do
   begin
     case vtype of
        vtInteger : inc(intCount);
        vtstring  : inc(stringcount);
        vtFloat   : inc(floatcount);
        vtboolean : inc(boolCount);
        vtdate    : inc(datecount);
        vtany     : inc(AnyCount); { should NEVER get here }
     end;
   end;
   tmpstr := ' %d Params : %d Ints, %d Strings,%d Booleans, %d Floats, '
            +'%d Dates , %d variants ';

   tmpstr := format(tmpstr,[paramcount,intcount,stringcount,
                            boolcount,floatcount,datecount,AnyCount]) + #0;

   retvalue.vpString := FBCreateString(@tmpstr[1]);
 end;


{*
 * The vtANY Type : Example 3
 *
 * The built in SUM function takes only numeric values, and will
 * raise an error if other types are entered as parameters. It is
 * sometimes useful, however, to permit other types of arguments,
 * whether or not the function uses them. Spreadsheets for example have
 * functions such as @SUM and @AVG which work on ranges which may
 * contain non-numeric data. In such cases those cells with non-numeric
 * data are ignored.
 *
 * We will implement a sum function which works along the lines of a
 * spreadsheet summation function, in other words, we will simply ignore
 * non-numeric values rather than raise an error.
 *
 *}
 Procedure AtSumProc( paramcount     : byte;
                      const params   :  TActParamList;
                      var   retvalue : TValueRec;
                      var   errcode  : integer;
                            exprdata : longint); export;
 var i   : integer;
     sum : extended;

 begin
   sum := 0;
   for i := 0 to pred(paramcount) do
   with params[i] do
   begin
     case vtype of
        vtInteger : sum := sum + vInteger;
        vtFloat   : sum := sum + vFloat;
     end;
   end;
   retvalue.vFloat := sum;
 end;


{*
 * ExprData Data Passing Example
 *
 * Observe the following code which implements the function WHOCALLED.
 * The implicit typecast works only if WHOCALLED is called from a TExpression
 * or descendant class:
 *
 * This can be especially useful for subclasses of TExpression which
 * add additional methods and properties. Using this method, we have access
 * to the public and published methods and properties of the TExpression
 * instance.
 *}

 Procedure ReturnCallerProc( paramcount     : byte;
                             const params   :  TActParamList;
                             var   retvalue : TValueRec;
                             var   errcode  : integer;
                                   exprdata : longint); export;
 var i      : integer;
     expr   : TExpression absolute exprdata;   {implicit typecast}
     tmpstr : string;

 begin
   try  {verify we are indeed being called from a TExpression }
    tmpstr := 'Called from a '+Expr.ClassName+'. Formula  = '+
              Expr.Formula + #0;
   Except
     on EGPFault do tmpstr := 'NOT called from a TExpression !'#0;
   end;
   retvalue.vpString := FBCreateString(@tmpstr[1]);
 end;


Procedure RegisterFunctions;
begin
  InitFbuilder;
  if not FBLoaded then exit;
  CompInterestFnId := FBRegisterFunction('CompInterest',vtFLOAT,
                                          'fff',3,CompoundInterestProc);

  RomanFnId := FBRegisterFunction('ROMAN',vtSTRING,'f',1,RomanProc);

  SumSqFnId := FBRegisterFunction('SUMSQ',vtFLOAT,
          'ffffffffffffffff',1,SumSqProc);

  ParamInfoFnId := FBRegisterFunction('PARMINFO',vtSTRING,'aaaaaaaaaaaaaaaa',1,ParamInfoProc);

  AtSumFnId     := FBRegisterFunction('AtSum',vtFLOAT,'aaaaaaaaaaaaaaaa',1,AtSumProc);

  WhoCalledFNId := FBRegisterFunction('WHOCALLED',vtSTRING,NIL,0,ReturnCallerProc);
end;


Procedure UnRegisterFunctions; Far;
begin
  If not FBLoaded then exit;
  FBUnRegisterFunction(CompInterestFnId);
  FBUnRegisterFunction(RomanFnId);
  FBUnRegisterFunction(SumSqFnId);
  FBUnRegisterFunction(ParamInfoFnId);
  FBUnRegisterFunction(AtSumFnId);
  FBUnRegisterFunction(WhoCalledFNId);
  FreeFBuilder;
end;


INITIALIZATION
  RegisterFunctions;
  AddExitProc(UnRegisterFunctions);
END.