source upload

contrib/ParseExpression/__history/ParseClass.pas.~1~

@@ -0,0 +1,719 @@
+unit ParseClass;
+
+interface
+
+uses OObjects, SysUtils;
+
+const
+  MaxArg = 6;
+
+const
+  Nan: Double = 0 / 0;
+function isNan(const d: Double): boolean;
+
+type
+  TVarType = (vtDouble, vtBoolean, vtString, vtLeftBracket,
+    vtRightBracket, vtComma);
+  PDouble = ^Double;
+  EParserException = class(Exception);
+  PExpressionRec = ^TExpressionRec;
+
+  TExprWord = class;
+
+  TArgsArray = record
+    Res: Double;
+    Args: array [0 .. MaxArg - 1] of PDouble;
+    ExprWord: TExprWord; // can be used to notify the object to update
+  end;
+
+  TDoubleFunc = procedure(Expr: PExpressionRec);
+
+  TStringFunc = function(s1, s2: string): Double;
+
+  TExpressionRec = record
+    // used both as linked tree and linked list for maximum evaluation efficiency
+    Oper: TDoubleFunc;
+    Next: PExpressionRec;
+    Res: Double;
+    ExprWord: TExprWord;
+    case Byte of
+      0:
+        (Args: array [0 .. MaxArg - 1] of PDouble;
+          // can be used to notify the object to update
+        );
+      1:
+        (ArgList: array [0 .. MaxArg - 1] of PExpressionRec);
+  end;
+
+  TExprCollection = class(TNoOwnerCollection)
+  public
+    function NextOper(IStart: Integer): Integer;
+    procedure Check;
+    procedure EraseExtraBrackets;
+  end;
+
+  TExprWord = class
+  private
+    FName: string;
+    FDoubleFunc: TDoubleFunc;
+  protected
+    function GetIsOper: boolean; virtual;
+    function GetAsString: string; virtual;
+    function GetIsVariable: boolean;
+    function GetCanVary: boolean; virtual;
+    function GetVarType: TVarType; virtual;
+    function GetNFunctionArg: Integer; virtual;
+    function GetDescription: string; virtual;
+  public
+    constructor Create(AName: string; ADoubleFunc: TDoubleFunc);
+    function AsPointer: PDouble; virtual;
+    property AsString: string read GetAsString;
+    property DoubleFunc: TDoubleFunc read FDoubleFunc;
+    property IsOper: boolean read GetIsOper;
+    property CanVary: boolean read GetCanVary;
+    property isVariable: boolean read GetIsVariable;
+    property VarType: TVarType read GetVarType;
+    property NFunctionArg: Integer read GetNFunctionArg;
+    property Name: string read FName;
+    property Description: string read GetDescription;
+  end;
+
+  TExpressList = class(TSortedCollection)
+  public
+    function KeyOf(Item: Pointer): Pointer; override;
+    function Compare(Key1, Key2: Pointer): Integer; override;
+  end;
+
+  TDoubleConstant = class(TExprWord)
+  private
+    FValue: Double;
+  public
+    function AsPointer: PDouble; override;
+    constructor Create(AName: string; AValue: string);
+    constructor CreateAsDouble(AName: string; AValue: Double);
+    // not overloaded to support older Delphi versions
+    property Value: Double read FValue write FValue;
+  end;
+
+  TConstant = class(TDoubleConstant)
+  private
+    FDescription: string;
+  protected
+    function GetDescription: string; override;
+  public
+    constructor CreateAsDouble(AName, Descr: string; AValue: Double);
+  end;
+
+  TBooleanConstant = class(TDoubleConstant)
+  protected
+    function GetVarType: TVarType; override;
+  end;
+
+  TGeneratedVariable = class(TDoubleConstant)
+  private
+    FAsString: string;
+    FVarType: TVarType;
+  protected
+    function GetVarType: TVarType; override;
+    function GetAsString: string; override;
+    function GetCanVary: boolean; override;
+  public
+    constructor Create(AName: string);
+    property VarType read GetVarType write FVarType;
+    property AsString: string read GetAsString write FAsString;
+  end;
+
+  TDoubleVariable = class(TExprWord)
+  private
+    FValue: PDouble;
+  protected
+    function GetCanVary: boolean; override;
+  public
+    function AsPointer: PDouble; override;
+    constructor Create(AName: string; AValue: PDouble);
+  end;
+
+  TStringConstant = class(TExprWord)
+  private
+    FValue: string;
+  protected
+    function GetVarType: TVarType; override;
+    function GetAsString: string; override;
+  public
+    constructor Create(AValue: string);
+  end;
+
+  TLeftBracket = class(TExprWord)
+    function GetVarType: TVarType; override;
+  end;
+
+  TRightBracket = class(TExprWord)
+  protected
+    function GetVarType: TVarType; override;
+  end;
+
+  TComma = class(TExprWord)
+  protected
+    function GetVarType: TVarType; override;
+  end;
+
+  PString = ^string;
+
+  TStringVariable = class(TExprWord)
+  private
+    FValue: PString;
+  protected
+    function GetVarType: TVarType; override;
+    function GetAsString: string; override;
+    function GetCanVary: boolean; override;
+  public
+    constructor Create(AName: string; AValue: PString);
+  end;
+
+  TFunction = class(TExprWord)
+  private
+    FIsOper: boolean;
+    FOperPrec: Integer;
+    FNFunctionArg: Integer;
+    FDescription: string;
+  protected
+    function GetDescription: string; override;
+    function GetIsOper: boolean; override;
+    function GetNFunctionArg: Integer; override;
+  public
+    constructor Create(AName, Descr: string; ADoubleFunc: TDoubleFunc;
+      ANFunctionArg: Integer);
+    constructor CreateOper(AName: string; ADoubleFunc: TDoubleFunc;
+      ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer);
+    property OperPrec: Integer read FOperPrec;
+  end;
+
+  TVaryingFunction = class(TFunction)
+    // Functions that can vary for ex. random generators
+    // should be TVaryingFunction to be sure that they are
+    // always evaluated
+  protected
+    function GetCanVary: boolean; override;
+  end;
+
+  TBooleanFunction = class(TFunction)
+  protected
+    function GetVarType: TVarType; override;
+  end;
+
+  TOper = (op_eq, op_gt, op_lt, op_ge, op_le, op_in);
+
+const
+  ListChar = ','; { the delimiter used with the 'in' operator: e.g.,
+    ('a' in 'a,b') =True
+    ('c' in 'a,b') =False }
+
+type
+  TSimpleStringFunction = class(TFunction)
+  private
+    FStringFunc: TStringFunc;
+    FLeftArg: TExprWord;
+    FRightArg: TExprWord;
+  protected
+    function GetCanVary: boolean; override;
+  public
+    constructor Create(AName, Descr: string; AStringFunc: TStringFunc;
+      ALeftArg, ARightArg: TExprWord);
+    function Evaluate: Double;
+    property StringFunc: TStringFunc read FStringFunc;
+  end;
+
+  TVaryingStringFunction = class(TSimpleStringFunction)
+  protected
+    function GetCanVary: boolean; override;
+  end;
+
+  TLogicalStringOper = class(TSimpleStringFunction)
+  protected
+    function GetVarType: TVarType; override;
+  public
+    constructor Create(AOper: string; ALeftArg: TExprWord;
+      ARightArg: TExprWord);
+  end;
+
+procedure _Variable(Param: PExpressionRec);
+
+// procedure _StringFunc(Param: PExpressionRec);
+
+implementation
+
+// function _StrIn(sLookfor, sData: string): Double;
+
+// function _StrInt(a, b: string): Double;
+
+function isNan(const d: Double): boolean;
+begin
+  Result := comp(d) = comp(Nan);
+  // slower alternative: CompareMem(@d, @Nan, SizeOf(Double))
+end;
+
+procedure _Variable(Param: PExpressionRec);
+begin
+  with Param^ do
+    Res := Args[0]^;
+end;
+
+procedure _StringFunc(Param: PExpressionRec);
+begin
+  with Param^ do
+    Res := TSimpleStringFunction(ExprWord).Evaluate;
+end;
+
+function _StrInt(a, b: string): Double;
+begin
+  Result := StrToInt(a);
+end;
+
+function _StrEq(s1, s2: string): Double;
+begin
+  Result := Byte(s1 = s2);
+end;
+
+function _StrGt(s1, s2: string): Double;
+begin
+  Result := Byte(s1 > s2);
+end;
+
+function _Strlt(s1, s2: string): Double;
+begin
+  Result := Byte(s1 < s2);
+end;
+
+function _StrGe(s1, s2: string): Double;
+begin
+  Result := Byte(s1 >= s2);
+end;
+
+function _Strle(s1, s2: string): Double;
+begin
+  Result := Byte(s1 <= s2);
+end;
+
+function _Strne(s1, s2: string): Double;
+begin
+  Result := Byte(s1 <> s2);
+end;
+
+function _StrIn(sLookfor, sData: string): Double;
+var
+  loop: Integer;
+  subString: string;
+begin
+  Result := 0;
+  loop := pos(ListChar, sData);
+  while loop > 0 do
+  begin
+    subString := Copy(sData, 1, loop - 1);
+    sData := Copy(sData, loop + 1, Length(sData));
+    if subString = sLookfor then
+    begin
+      Result := 1;
+      break;
+    end;
+    loop := pos(ListChar, sData);
+  end;
+  if sLookfor = sData then
+    Result := 1;
+end;
+
+{ TExpressionWord }
+
+function TExprWord.AsPointer: PDouble;
+begin
+  Result := nil;
+end;
+
+constructor TExprWord.Create(AName: string; ADoubleFunc: TDoubleFunc);
+begin
+  FName := LowerCase(AName);
+  FDoubleFunc := ADoubleFunc;
+end;
+
+function TExprWord.GetAsString: string;
+begin
+  Result := '';
+end;
+
+function TExprWord.GetCanVary: boolean;
+begin
+  Result := False;
+end;
+
+function TExprWord.GetDescription: string;
+begin
+  Result := '';
+end;
+
+function TExprWord.GetIsOper: boolean;
+begin
+  Result := False;
+end;
+
+function TExprWord.GetIsVariable: boolean;
+begin
+  Result := @FDoubleFunc = @_Variable
+end;
+
+function TExprWord.GetNFunctionArg: Integer;
+begin
+  Result := 0;
+end;
+
+function TExprWord.GetVarType: TVarType;
+begin
+  Result := vtDouble;
+end;
+
+{ TDoubleConstant }
+
+function TDoubleConstant.AsPointer: PDouble;
+begin
+  Result := @FValue;
+end;
+
+constructor TDoubleConstant.Create(AName, AValue: string);
+begin
+  inherited Create(AName, _Variable);
+  if AValue <> '' then
+    FValue := StrToFloat(AValue)
+  else
+    FValue := Nan;
+end;
+
+constructor TDoubleConstant.CreateAsDouble(AName: string; AValue: Double);
+begin
+  inherited Create(AName, _Variable);
+  FValue := AValue;
+end;
+
+{ TStringConstant }
+
+function TStringConstant.GetAsString: string;
+begin
+  Result := FValue;
+end;
+
+constructor TStringConstant.Create(AValue: string);
+begin
+  inherited Create(AValue, _Variable);
+  if (AValue[1] = '''') and (AValue[Length(AValue)] = '''') then
+    FValue := Copy(AValue, 2, Length(AValue) - 2)
+  else
+    FValue := AValue;
+end;
+
+function TStringConstant.GetVarType: TVarType;
+begin
+  Result := vtString;
+end;
+
+{ TDoubleVariable }
+
+function TDoubleVariable.AsPointer: PDouble;
+begin
+  Result := FValue;
+end;
+
+constructor TDoubleVariable.Create(AName: string; AValue: PDouble);
+begin
+  inherited Create(AName, _Variable);
+  FValue := AValue;
+end;
+
+function TDoubleVariable.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+{ TFunction }
+
+constructor TFunction.Create(AName, Descr: string; ADoubleFunc: TDoubleFunc;
+  ANFunctionArg: Integer);
+begin
+  FDescription := Descr;
+  CreateOper(AName, ADoubleFunc, ANFunctionArg, False, 0);
+  // to increase compatibility don't use default parameters
+end;
+
+constructor TFunction.CreateOper(AName: string; ADoubleFunc: TDoubleFunc;
+  ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer);
+begin
+  inherited Create(AName, ADoubleFunc);
+  FNFunctionArg := ANFunctionArg;
+  if FNFunctionArg > MaxArg then
+    raise EParserException.Create('Too many arguments');
+  FIsOper := AIsOper;
+  FOperPrec := AOperPrec;
+end;
+
+function TFunction.GetDescription: string;
+begin
+  Result := FDescription;
+end;
+
+function TFunction.GetIsOper: boolean;
+begin
+  Result := FIsOper;
+end;
+
+function TFunction.GetNFunctionArg: Integer;
+begin
+  Result := FNFunctionArg;
+end;
+
+{ TLeftBracket }
+
+function TLeftBracket.GetVarType: TVarType;
+begin
+  Result := vtLeftBracket;
+end;
+
+{ TExpressList }
+
+function TExpressList.Compare(Key1, Key2: Pointer): Integer;
+begin
+  Result := StrIComp(Pchar(Key1), Pchar(Key2));
+end;
+
+function TExpressList.KeyOf(Item: Pointer): Pointer;
+begin
+  Result := Pchar(TExprWord(Item).Name);
+end;
+
+{ TRightBracket }
+
+function TRightBracket.GetVarType: TVarType;
+begin
+  Result := vtRightBracket;
+end;
+
+{ TComma }
+
+function TComma.GetVarType: TVarType;
+begin
+  Result := vtComma;
+end;
+
+{ TExprCollection }
+
+procedure TExprCollection.Check;
+var
+  brCount, I: Integer;
+begin
+  brCount := 0;
+  for I := 0 to Count - 1 do
+  begin
+    case TExprWord(Items[I]).VarType of
+      vtLeftBracket:
+        Inc(brCount);
+      vtRightBracket:
+        Dec(brCount);
+    end;
+  end;
+  if brCount <> 0 then
+    raise EParserException.Create('Unequal brackets');
+end;
+
+procedure TExprCollection.EraseExtraBrackets;
+var
+  I: Integer;
+  brCount: Integer;
+begin
+  if (TExprWord(Items[0]).VarType = vtLeftBracket) then
+  begin
+    brCount := 1;
+    I := 1;
+    while (I < Count) and (brCount > 0) do
+    begin
+      case TExprWord(Items[I]).VarType of
+        vtLeftBracket:
+          Inc(brCount);
+        vtRightBracket:
+          Dec(brCount);
+      end;
+      Inc(I);
+    end;
+    if (brCount = 0) and (I = Count) and
+      (TExprWord(Items[I - 1]).VarType = vtRightBracket) then
+    begin
+      for I := 0 to Count - 3 do
+        Items[I] := Items[I + 1];
+      Count := Count - 2;
+      EraseExtraBrackets; // Check if there are still too many brackets
+    end;
+  end;
+end;
+
+function TExprCollection.NextOper(IStart: Integer): Integer;
+var
+  brCount: Integer;
+begin
+  brCount := 0;
+  Result := IStart;
+  while (Result < Count) and
+    ((brCount > 0) or (TExprWord(Items[Result]).NFunctionArg <= 0)) do
+  begin
+    case TExprWord(Items[Result]).VarType of
+      vtLeftBracket:
+        Inc(brCount);
+      vtRightBracket:
+        Dec(brCount);
+    end;
+    Inc(Result);
+  end;
+end;
+
+{ TStringVariable }
+
+function TStringVariable.GetAsString: string;
+begin
+  if (FValue^[1] = '''') and (FValue^[Length(FValue^)] = '''') then
+    Result := Copy(FValue^, 2, Length(FValue^) - 2)
+  else
+    Result := FValue^
+end;
+
+constructor TStringVariable.Create(AName: string; AValue: PString);
+begin
+  inherited Create(AName, _Variable);
+  FValue := AValue;
+end;
+
+function TStringVariable.GetVarType: TVarType;
+begin
+  Result := vtString;
+end;
+
+function TStringVariable.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+{ TLogicalStringOper }
+
+constructor TLogicalStringOper.Create(AOper: string;
+  ALeftArg, ARightArg: TExprWord);
+begin
+  if AOper = '=' then
+    FStringFunc := @_StrEq
+  else if AOper = '>' then
+    FStringFunc := @_StrGt
+  else if AOper = '<' then
+    FStringFunc := @_Strlt
+  else if AOper = '>=' then
+    FStringFunc := @_StrGe
+  else if AOper = '<=' then
+    FStringFunc := @_Strle
+  else if AOper = '<>' then
+    FStringFunc := @_Strne
+  else if AOper = 'in' then
+    FStringFunc := @_StrIn
+  else
+    raise EParserException.Create(AOper + ' is not a valid string operand');
+  inherited Create(AOper, '', StringFunc, ALeftArg, ARightArg);
+end;
+
+function TLogicalStringOper.GetVarType: TVarType;
+begin
+  Result := vtBoolean;
+end;
+
+{ TBooleanFunction }
+
+function TBooleanFunction.GetVarType: TVarType;
+begin
+  Result := vtBoolean;
+end;
+
+{ TGeneratedVariable }
+
+constructor TGeneratedVariable.Create(AName: string);
+begin
+  inherited Create(AName, '');
+  FAsString := '';
+  FVarType := vtDouble;
+end;
+
+function TGeneratedVariable.GetAsString: string;
+begin
+  Result := FAsString;
+end;
+
+function TGeneratedVariable.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+function TGeneratedVariable.GetVarType: TVarType;
+begin
+  Result := FVarType;
+end;
+
+{ TVaryingFunction }
+
+function TVaryingFunction.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+{ TBooleanConstant }
+
+function TBooleanConstant.GetVarType: TVarType;
+begin
+  Result := vtBoolean;
+end;
+
+{ TConstant }
+
+constructor TConstant.CreateAsDouble(AName, Descr: string; AValue: Double);
+begin
+  FDescription := Descr;
+  inherited CreateAsDouble(AName, AValue);
+end;
+
+function TConstant.GetDescription: string;
+begin
+  Result := FDescription;
+end;
+
+{ TSimpleStringFunction }
+
+constructor TSimpleStringFunction.Create(AName, Descr: string;
+  AStringFunc: TStringFunc; ALeftArg, ARightArg: TExprWord);
+begin
+  FStringFunc := @AStringFunc;
+  FLeftArg := ALeftArg;
+  FRightArg := ARightArg;
+  inherited Create(AName, Descr, _StringFunc, 0)
+end;
+
+function TSimpleStringFunction.Evaluate: Double;
+var
+  s1, s2: string;
+begin
+  s1 := FLeftArg.AsString;
+  if FRightArg <> nil then
+    s2 := FRightArg.AsString
+  else
+    s2 := '';
+  Result := StringFunc(s1, s2);
+end;
+
+function TSimpleStringFunction.GetCanVary: boolean;
+begin
+  Result := ((FLeftArg <> nil) and FLeftArg.CanVary) or
+    ((FRightArg <> nil) and FRightArg.CanVary);
+end;
+{ TVaryingStringFunction }
+
+function TVaryingStringFunction.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+end.

contrib/ParseExpression/__history/ParseClass.pas.~2~

@@ -0,0 +1,719 @@
+unit ParseClass;
+
+interface
+
+uses OObjects, SysUtils;
+
+const
+  MaxArg = 1000;
+
+const
+  Nan: Double = 0 / 0;
+function isNan(const d: Double): boolean;
+
+type
+  TVarType = (vtDouble, vtBoolean, vtString, vtLeftBracket,
+    vtRightBracket, vtComma);
+  PDouble = ^Double;
+  EParserException = class(Exception);
+  PExpressionRec = ^TExpressionRec;
+
+  TExprWord = class;
+
+  TArgsArray = record
+    Res: Double;
+    Args: array [0 .. MaxArg - 1] of PDouble;
+    ExprWord: TExprWord; // can be used to notify the object to update
+  end;
+
+  TDoubleFunc = procedure(Expr: PExpressionRec);
+
+  TStringFunc = function(s1, s2: string): Double;
+
+  TExpressionRec = record
+    // used both as linked tree and linked list for maximum evaluation efficiency
+    Oper: TDoubleFunc;
+    Next: PExpressionRec;
+    Res: Double;
+    ExprWord: TExprWord;
+    case Byte of
+      0:
+        (Args: array [0 .. MaxArg - 1] of PDouble;
+          // can be used to notify the object to update
+        );
+      1:
+        (ArgList: array [0 .. MaxArg - 1] of PExpressionRec);
+  end;
+
+  TExprCollection = class(TNoOwnerCollection)
+  public
+    function NextOper(IStart: Integer): Integer;
+    procedure Check;
+    procedure EraseExtraBrackets;
+  end;
+
+  TExprWord = class
+  private
+    FName: string;
+    FDoubleFunc: TDoubleFunc;
+  protected
+    function GetIsOper: boolean; virtual;
+    function GetAsString: string; virtual;
+    function GetIsVariable: boolean;
+    function GetCanVary: boolean; virtual;
+    function GetVarType: TVarType; virtual;
+    function GetNFunctionArg: Integer; virtual;
+    function GetDescription: string; virtual;
+  public
+    constructor Create(AName: string; ADoubleFunc: TDoubleFunc);
+    function AsPointer: PDouble; virtual;
+    property AsString: string read GetAsString;
+    property DoubleFunc: TDoubleFunc read FDoubleFunc;
+    property IsOper: boolean read GetIsOper;
+    property CanVary: boolean read GetCanVary;
+    property isVariable: boolean read GetIsVariable;
+    property VarType: TVarType read GetVarType;
+    property NFunctionArg: Integer read GetNFunctionArg;
+    property Name: string read FName;
+    property Description: string read GetDescription;
+  end;
+
+  TExpressList = class(TSortedCollection)
+  public
+    function KeyOf(Item: Pointer): Pointer; override;
+    function Compare(Key1, Key2: Pointer): Integer; override;
+  end;
+
+  TDoubleConstant = class(TExprWord)
+  private
+    FValue: Double;
+  public
+    function AsPointer: PDouble; override;
+    constructor Create(AName: string; AValue: string);
+    constructor CreateAsDouble(AName: string; AValue: Double);
+    // not overloaded to support older Delphi versions
+    property Value: Double read FValue write FValue;
+  end;
+
+  TConstant = class(TDoubleConstant)
+  private
+    FDescription: string;
+  protected
+    function GetDescription: string; override;
+  public
+    constructor CreateAsDouble(AName, Descr: string; AValue: Double);
+  end;
+
+  TBooleanConstant = class(TDoubleConstant)
+  protected
+    function GetVarType: TVarType; override;
+  end;
+
+  TGeneratedVariable = class(TDoubleConstant)
+  private
+    FAsString: string;
+    FVarType: TVarType;
+  protected
+    function GetVarType: TVarType; override;
+    function GetAsString: string; override;
+    function GetCanVary: boolean; override;
+  public
+    constructor Create(AName: string);
+    property VarType read GetVarType write FVarType;
+    property AsString: string read GetAsString write FAsString;
+  end;
+
+  TDoubleVariable = class(TExprWord)
+  private
+    FValue: PDouble;
+  protected
+    function GetCanVary: boolean; override;
+  public
+    function AsPointer: PDouble; override;
+    constructor Create(AName: string; AValue: PDouble);
+  end;
+
+  TStringConstant = class(TExprWord)
+  private
+    FValue: string;
+  protected
+    function GetVarType: TVarType; override;
+    function GetAsString: string; override;
+  public
+    constructor Create(AValue: string);
+  end;
+
+  TLeftBracket = class(TExprWord)
+    function GetVarType: TVarType; override;
+  end;
+
+  TRightBracket = class(TExprWord)
+  protected
+    function GetVarType: TVarType; override;
+  end;
+
+  TComma = class(TExprWord)
+  protected
+    function GetVarType: TVarType; override;
+  end;
+
+  PString = ^string;
+
+  TStringVariable = class(TExprWord)
+  private
+    FValue: PString;
+  protected
+    function GetVarType: TVarType; override;
+    function GetAsString: string; override;
+    function GetCanVary: boolean; override;
+  public
+    constructor Create(AName: string; AValue: PString);
+  end;
+
+  TFunction = class(TExprWord)
+  private
+    FIsOper: boolean;
+    FOperPrec: Integer;
+    FNFunctionArg: Integer;
+    FDescription: string;
+  protected
+    function GetDescription: string; override;
+    function GetIsOper: boolean; override;
+    function GetNFunctionArg: Integer; override;
+  public
+    constructor Create(AName, Descr: string; ADoubleFunc: TDoubleFunc;
+      ANFunctionArg: Integer);
+    constructor CreateOper(AName: string; ADoubleFunc: TDoubleFunc;
+      ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer);
+    property OperPrec: Integer read FOperPrec;
+  end;
+
+  TVaryingFunction = class(TFunction)
+    // Functions that can vary for ex. random generators
+    // should be TVaryingFunction to be sure that they are
+    // always evaluated
+  protected
+    function GetCanVary: boolean; override;
+  end;
+
+  TBooleanFunction = class(TFunction)
+  protected
+    function GetVarType: TVarType; override;
+  end;
+
+  TOper = (op_eq, op_gt, op_lt, op_ge, op_le, op_in);
+
+const
+  ListChar = ','; { the delimiter used with the 'in' operator: e.g.,
+    ('a' in 'a,b') =True
+    ('c' in 'a,b') =False }
+
+type
+  TSimpleStringFunction = class(TFunction)
+  private
+    FStringFunc: TStringFunc;
+    FLeftArg: TExprWord;
+    FRightArg: TExprWord;
+  protected
+    function GetCanVary: boolean; override;
+  public
+    constructor Create(AName, Descr: string; AStringFunc: TStringFunc;
+      ALeftArg, ARightArg: TExprWord);
+    function Evaluate: Double;
+    property StringFunc: TStringFunc read FStringFunc;
+  end;
+
+  TVaryingStringFunction = class(TSimpleStringFunction)
+  protected
+    function GetCanVary: boolean; override;
+  end;
+
+  TLogicalStringOper = class(TSimpleStringFunction)
+  protected
+    function GetVarType: TVarType; override;
+  public
+    constructor Create(AOper: string; ALeftArg: TExprWord;
+      ARightArg: TExprWord);
+  end;
+
+procedure _Variable(Param: PExpressionRec);
+
+// procedure _StringFunc(Param: PExpressionRec);
+
+implementation
+
+// function _StrIn(sLookfor, sData: string): Double;
+
+// function _StrInt(a, b: string): Double;
+
+function isNan(const d: Double): boolean;
+begin
+  Result := comp(d) = comp(Nan);
+  // slower alternative: CompareMem(@d, @Nan, SizeOf(Double))
+end;
+
+procedure _Variable(Param: PExpressionRec);
+begin
+  with Param^ do
+    Res := Args[0]^;
+end;
+
+procedure _StringFunc(Param: PExpressionRec);
+begin
+  with Param^ do
+    Res := TSimpleStringFunction(ExprWord).Evaluate;
+end;
+
+function _StrInt(a, b: string): Double;
+begin
+  Result := StrToInt(a);
+end;
+
+function _StrEq(s1, s2: string): Double;
+begin
+  Result := Byte(s1 = s2);
+end;
+
+function _StrGt(s1, s2: string): Double;
+begin
+  Result := Byte(s1 > s2);
+end;
+
+function _Strlt(s1, s2: string): Double;
+begin
+  Result := Byte(s1 < s2);
+end;
+
+function _StrGe(s1, s2: string): Double;
+begin
+  Result := Byte(s1 >= s2);
+end;
+
+function _Strle(s1, s2: string): Double;
+begin
+  Result := Byte(s1 <= s2);
+end;
+
+function _Strne(s1, s2: string): Double;
+begin
+  Result := Byte(s1 <> s2);
+end;
+
+function _StrIn(sLookfor, sData: string): Double;
+var
+  loop: Integer;
+  subString: string;
+begin
+  Result := 0;
+  loop := pos(ListChar, sData);
+  while loop > 0 do
+  begin
+    subString := Copy(sData, 1, loop - 1);
+    sData := Copy(sData, loop + 1, Length(sData));
+    if subString = sLookfor then
+    begin
+      Result := 1;
+      break;
+    end;
+    loop := pos(ListChar, sData);
+  end;
+  if sLookfor = sData then
+    Result := 1;
+end;
+
+{ TExpressionWord }
+
+function TExprWord.AsPointer: PDouble;
+begin
+  Result := nil;
+end;
+
+constructor TExprWord.Create(AName: string; ADoubleFunc: TDoubleFunc);
+begin
+  FName := LowerCase(AName);
+  FDoubleFunc := ADoubleFunc;
+end;
+
+function TExprWord.GetAsString: string;
+begin
+  Result := '';
+end;
+
+function TExprWord.GetCanVary: boolean;
+begin
+  Result := False;
+end;
+
+function TExprWord.GetDescription: string;
+begin
+  Result := '';
+end;
+
+function TExprWord.GetIsOper: boolean;
+begin
+  Result := False;
+end;
+
+function TExprWord.GetIsVariable: boolean;
+begin
+  Result := @FDoubleFunc = @_Variable
+end;
+
+function TExprWord.GetNFunctionArg: Integer;
+begin
+  Result := 0;
+end;
+
+function TExprWord.GetVarType: TVarType;
+begin
+  Result := vtDouble;
+end;
+
+{ TDoubleConstant }
+
+function TDoubleConstant.AsPointer: PDouble;
+begin
+  Result := @FValue;
+end;
+
+constructor TDoubleConstant.Create(AName, AValue: string);
+begin
+  inherited Create(AName, _Variable);
+  if AValue <> '' then
+    FValue := StrToFloat(AValue)
+  else
+    FValue := Nan;
+end;
+
+constructor TDoubleConstant.CreateAsDouble(AName: string; AValue: Double);
+begin
+  inherited Create(AName, _Variable);
+  FValue := AValue;
+end;
+
+{ TStringConstant }
+
+function TStringConstant.GetAsString: string;
+begin
+  Result := FValue;
+end;
+
+constructor TStringConstant.Create(AValue: string);
+begin
+  inherited Create(AValue, _Variable);
+  if (AValue[1] = '''') and (AValue[Length(AValue)] = '''') then
+    FValue := Copy(AValue, 2, Length(AValue) - 2)
+  else
+    FValue := AValue;
+end;
+
+function TStringConstant.GetVarType: TVarType;
+begin
+  Result := vtString;
+end;
+
+{ TDoubleVariable }
+
+function TDoubleVariable.AsPointer: PDouble;
+begin
+  Result := FValue;
+end;
+
+constructor TDoubleVariable.Create(AName: string; AValue: PDouble);
+begin
+  inherited Create(AName, _Variable);
+  FValue := AValue;
+end;
+
+function TDoubleVariable.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+{ TFunction }
+
+constructor TFunction.Create(AName, Descr: string; ADoubleFunc: TDoubleFunc;
+  ANFunctionArg: Integer);
+begin
+  FDescription := Descr;
+  CreateOper(AName, ADoubleFunc, ANFunctionArg, False, 0);
+  // to increase compatibility don't use default parameters
+end;
+
+constructor TFunction.CreateOper(AName: string; ADoubleFunc: TDoubleFunc;
+  ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer);
+begin
+  inherited Create(AName, ADoubleFunc);
+  FNFunctionArg := ANFunctionArg;
+  if FNFunctionArg > MaxArg then
+    raise EParserException.Create('Too many arguments');
+  FIsOper := AIsOper;
+  FOperPrec := AOperPrec;
+end;
+
+function TFunction.GetDescription: string;
+begin
+  Result := FDescription;
+end;
+
+function TFunction.GetIsOper: boolean;
+begin
+  Result := FIsOper;
+end;
+
+function TFunction.GetNFunctionArg: Integer;
+begin
+  Result := FNFunctionArg;
+end;
+
+{ TLeftBracket }
+
+function TLeftBracket.GetVarType: TVarType;
+begin
+  Result := vtLeftBracket;
+end;
+
+{ TExpressList }
+
+function TExpressList.Compare(Key1, Key2: Pointer): Integer;
+begin
+  Result := StrIComp(Pchar(Key1), Pchar(Key2));
+end;
+
+function TExpressList.KeyOf(Item: Pointer): Pointer;
+begin
+  Result := Pchar(TExprWord(Item).Name);
+end;
+
+{ TRightBracket }
+
+function TRightBracket.GetVarType: TVarType;
+begin
+  Result := vtRightBracket;
+end;
+
+{ TComma }
+
+function TComma.GetVarType: TVarType;
+begin
+  Result := vtComma;
+end;
+
+{ TExprCollection }
+
+procedure TExprCollection.Check;
+var
+  brCount, I: Integer;
+begin
+  brCount := 0;
+  for I := 0 to Count - 1 do
+  begin
+    case TExprWord(Items[I]).VarType of
+      vtLeftBracket:
+        Inc(brCount);
+      vtRightBracket:
+        Dec(brCount);
+    end;
+  end;
+  if brCount <> 0 then
+    raise EParserException.Create('Unequal brackets');
+end;
+
+procedure TExprCollection.EraseExtraBrackets;
+var
+  I: Integer;
+  brCount: Integer;
+begin
+  if (TExprWord(Items[0]).VarType = vtLeftBracket) then
+  begin
+    brCount := 1;
+    I := 1;
+    while (I < Count) and (brCount > 0) do
+    begin
+      case TExprWord(Items[I]).VarType of
+        vtLeftBracket:
+          Inc(brCount);
+        vtRightBracket:
+          Dec(brCount);
+      end;
+      Inc(I);
+    end;
+    if (brCount = 0) and (I = Count) and
+      (TExprWord(Items[I - 1]).VarType = vtRightBracket) then
+    begin
+      for I := 0 to Count - 3 do
+        Items[I] := Items[I + 1];
+      Count := Count - 2;
+      EraseExtraBrackets; // Check if there are still too many brackets
+    end;
+  end;
+end;
+
+function TExprCollection.NextOper(IStart: Integer): Integer;
+var
+  brCount: Integer;
+begin
+  brCount := 0;
+  Result := IStart;
+  while (Result < Count) and
+    ((brCount > 0) or (TExprWord(Items[Result]).NFunctionArg <= 0)) do
+  begin
+    case TExprWord(Items[Result]).VarType of
+      vtLeftBracket:
+        Inc(brCount);
+      vtRightBracket:
+        Dec(brCount);
+    end;
+    Inc(Result);
+  end;
+end;
+
+{ TStringVariable }
+
+function TStringVariable.GetAsString: string;
+begin
+  if (FValue^[1] = '''') and (FValue^[Length(FValue^)] = '''') then
+    Result := Copy(FValue^, 2, Length(FValue^) - 2)
+  else
+    Result := FValue^
+end;
+
+constructor TStringVariable.Create(AName: string; AValue: PString);
+begin
+  inherited Create(AName, _Variable);
+  FValue := AValue;
+end;
+
+function TStringVariable.GetVarType: TVarType;
+begin
+  Result := vtString;
+end;
+
+function TStringVariable.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+{ TLogicalStringOper }
+
+constructor TLogicalStringOper.Create(AOper: string;
+  ALeftArg, ARightArg: TExprWord);
+begin
+  if AOper = '=' then
+    FStringFunc := @_StrEq
+  else if AOper = '>' then
+    FStringFunc := @_StrGt
+  else if AOper = '<' then
+    FStringFunc := @_Strlt
+  else if AOper = '>=' then
+    FStringFunc := @_StrGe
+  else if AOper = '<=' then
+    FStringFunc := @_Strle
+  else if AOper = '<>' then
+    FStringFunc := @_Strne
+  else if AOper = 'in' then
+    FStringFunc := @_StrIn
+  else
+    raise EParserException.Create(AOper + ' is not a valid string operand');
+  inherited Create(AOper, '', StringFunc, ALeftArg, ARightArg);
+end;
+
+function TLogicalStringOper.GetVarType: TVarType;
+begin
+  Result := vtBoolean;
+end;
+
+{ TBooleanFunction }
+
+function TBooleanFunction.GetVarType: TVarType;
+begin
+  Result := vtBoolean;
+end;
+
+{ TGeneratedVariable }
+
+constructor TGeneratedVariable.Create(AName: string);
+begin
+  inherited Create(AName, '');
+  FAsString := '';
+  FVarType := vtDouble;
+end;
+
+function TGeneratedVariable.GetAsString: string;
+begin
+  Result := FAsString;
+end;
+
+function TGeneratedVariable.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+function TGeneratedVariable.GetVarType: TVarType;
+begin
+  Result := FVarType;
+end;
+
+{ TVaryingFunction }
+
+function TVaryingFunction.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+{ TBooleanConstant }
+
+function TBooleanConstant.GetVarType: TVarType;
+begin
+  Result := vtBoolean;
+end;
+
+{ TConstant }
+
+constructor TConstant.CreateAsDouble(AName, Descr: string; AValue: Double);
+begin
+  FDescription := Descr;
+  inherited CreateAsDouble(AName, AValue);
+end;
+
+function TConstant.GetDescription: string;
+begin
+  Result := FDescription;
+end;
+
+{ TSimpleStringFunction }
+
+constructor TSimpleStringFunction.Create(AName, Descr: string;
+  AStringFunc: TStringFunc; ALeftArg, ARightArg: TExprWord);
+begin
+  FStringFunc := @AStringFunc;
+  FLeftArg := ALeftArg;
+  FRightArg := ARightArg;
+  inherited Create(AName, Descr, _StringFunc, 0)
+end;
+
+function TSimpleStringFunction.Evaluate: Double;
+var
+  s1, s2: string;
+begin
+  s1 := FLeftArg.AsString;
+  if FRightArg <> nil then
+    s2 := FRightArg.AsString
+  else
+    s2 := '';
+  Result := StringFunc(s1, s2);
+end;
+
+function TSimpleStringFunction.GetCanVary: boolean;
+begin
+  Result := ((FLeftArg <> nil) and FLeftArg.CanVary) or
+    ((FRightArg <> nil) and FRightArg.CanVary);
+end;
+{ TVaryingStringFunction }
+
+function TVaryingStringFunction.GetCanVary: boolean;
+begin
+  Result := True;
+end;
+
+end.

contrib/ParseExpression/__history/oObjects.pas.~1~

@@ -0,0 +1,203 @@
+unit OObjects;
+
+interface
+
+uses Classes;
+
+const
+
+  { TOCollection interfaces between OWL TCollection and VCL TList }
+  MaxCollectionSize = Maxint div (SizeOf(Integer) * 2);
+
+type
+  TOCollection = class(TList)
+  public
+    constructor Create(ACapacity: Integer);
+    procedure AtFree(Index: Integer);
+    procedure FreeAll;
+    procedure DoFree(Item: Pointer);
+    procedure FreeItem(Item: Pointer); virtual;
+    destructor Destroy; override;
+  end;
+
+  TNoOwnerCollection = class(TOCollection)
+  public
+    procedure FreeItem(Item: Pointer); override;
+  end;
+
+  { TSortedCollection object }
+
+  TSortedCollection = class(TOCollection)
+  public
+    Duplicates: Boolean;
+    constructor Create(ACapacity: Integer);
+    function Compare(Key1, Key2: Pointer): Integer; virtual; abstract;
+    function IndexOf(Item: Pointer): Integer; virtual;
+    procedure Add(Item: Pointer); virtual;
+    procedure AddReplace(Item: Pointer); virtual;
+    { if duplicate then replace the duplicate else add }
+    function KeyOf(Item: Pointer): Pointer; virtual;
+    function Search(Key: Pointer; var Index: Integer): Boolean; virtual;
+  end;
+
+  { TStrCollection object }
+
+  TStrCollection = class(TSortedCollection)
+  public
+    function Compare(Key1, Key2: Pointer): Integer; override;
+    procedure FreeItem(Item: Pointer); override;
+  end;
+
+implementation
+
+uses SysUtils;
+
+constructor TOCollection.Create(ACapacity: Integer);
+begin
+  inherited Create;
+  SetCapacity(ACapacity);
+  { Delta is automatic in TList }
+end;
+
+destructor TOCollection.Destroy;
+begin
+  FreeAll;
+  inherited Destroy;
+end;
+
+procedure TOCollection.AtFree(Index: Integer);
+var
+  Item: Pointer;
+begin
+  Item := Items[Index];
+  Delete(Index);
+  FreeItem(Item);
+end;
+
+procedure TOCollection.FreeAll;
+var
+  I: Integer;
+begin
+  try
+    for I := 0 to Count - 1 do
+      FreeItem(Items[I]);
+  finally
+    Count := 0;
+  end;
+end;
+
+procedure TOCollection.DoFree(Item: Pointer);
+begin
+  AtFree(IndexOf(Item));
+end;
+
+procedure TOCollection.FreeItem(Item: Pointer);
+begin
+  if (Item <> nil) then
+    with TObject(Item) as TObject do
+      Free;
+end;
+
+{ ----------------------------------------------------------------virtual;
+  Implementing TNoOwnerCollection
+  ----------------------------------------------------------------- }
+
+procedure TNoOwnerCollection.FreeItem(Item: Pointer);
+begin
+end;
+
+{ TSortedCollection }
+
+{$IFDEF maxComp}
+
+constructor TSortedCollection.Create(ACapacity, ADelta: Integer);
+begin
+  inherited Create(ACapacity, ADelta);
+  Duplicates := False;
+end;
+{$ELSE}
+
+constructor TSortedCollection.Create(ACapacity: Integer);
+begin
+  inherited Create(ACapacity);
+  Duplicates := False;
+end;
+{$ENDIF}
+
+function TSortedCollection.IndexOf(Item: Pointer): Integer;
+var
+  I: Integer;
+begin
+  IndexOf := -1;
+  if Search(KeyOf(Item), I) then
+  begin
+    if Duplicates then
+      while (I < Count) and (Item <> Items[I]) do
+        Inc(I);
+    if I < Count then
+      IndexOf := I;
+  end;
+end;
+
+procedure TSortedCollection.AddReplace(Item: Pointer);
+var
+  Index: Integer;
+begin
+  if Search(KeyOf(Item), Index) then
+    Delete(Index);
+  Add(Item);
+end;
+
+procedure TSortedCollection.Add(Item: Pointer);
+var
+  I: Integer;
+begin
+  if not Search(KeyOf(Item), I) or Duplicates then
+    Insert(I, Item);
+end;
+
+function TSortedCollection.KeyOf(Item: Pointer): Pointer;
+begin
+  KeyOf := Item;
+end;
+
+function TSortedCollection.Search(Key: Pointer; var Index: Integer): Boolean;
+var
+  L, H, I, C: Integer;
+begin
+  Search := False;
+  L := 0;
+  H := Count - 1;
+  while L <= H do
+  begin
+    I := (L + H) shr 1;
+    C := Compare(KeyOf(Items[I]), Key);
+    if C < 0 then
+      L := I + 1
+    else
+    begin
+      H := I - 1;
+      if C = 0 then
+      begin
+        Search := True;
+        if not Duplicates then
+          L := I;
+      end;
+    end;
+  end;
+  Index := L;
+end;
+
+{ TStrCollection }
+
+function TStrCollection.Compare(Key1, Key2: Pointer): Integer;
+begin
+  Compare := StrComp(PAnsiChar(Key1), PAnsiChar(Key2));
+end;
+
+procedure TStrCollection.FreeItem(Item: Pointer);
+begin
+  StrDispose(PAnsiChar(Item));
+end;
+
+end.