Mega Code Archive
Your own evaluator
<![CDATA[
Title: Your own evaluator
Question: Having a string logic that does your checking or setting of your component propertys
Answer:
// Please vote or leafe messages so we all learn from eachother :)
The example is a project that i reused
http://www.xs4all.nl/~suusie/Pieter/Programs/MapingComponentsToGui.zip
I modified it so you can check and set some propertys in the object.
the source i posted is pure the object so if you dont want to type or
want to see it all work just check out the component attachment .
Ok heres the deal you have validations on your object that are user controleble.
You can store them like strings and do checking like this
I made a simple example that explains the use of the object.
If you want to do more validationm you wil have to write a mechanism that wil allow more statements to be saved and executed.
Ik my self used a Collection Class for this ..
Not included in the example .
procedure TForm1.ButtonSetAndCheckClick(Sender: TObject);
var
LogicParcer: TLogicParcer;
aVariant,BVariant,CVariant: Variant;
begin
LogicParcer := TLogicParcer.Create;
try
// set the logic parcers eval object to be able to have acces to
// those propertys
LogicParcer.EvalObject := ExampleComponent;
aVariant := LogicParcer.CalcValue('5 if Vartype(aVariant) varBoolean then
raise Exception.Create('Invalid if statement');
BVariant := LogicParcer.CalcValue('4 * 5');
if Vartype(BVariant) = varEmpty then
raise Exception.Create('Not a value assigned');
CVariant := LogicParcer.CalcValue('True');
if Vartype(CVariant) varBoolean then
raise Exception.Create('Invalid if check statement');
// this is how you cold parce the logic
if aVariant then
LogicParcer.SetPersistentProp('AFloat',
ExampleComponent,BVariant);
if CVariant then
raise Exception.Create('Error text here ');
finally
LogicParcer.free;
end;
end;
unit LogicParcer;
interface
uses
Classes, Sysutils; // Graphics, Controls, Forms, Dialogs,
// StdCtrls;
const
TokenSet: set of char = ['+', '-', '*', '/', '^', '|', '=', '!', '&', ''];
type
TLogixType = (ltToken, tlValue, ltRecurse, ltObject, ltFunction);
TLogixNode = class(TObject)
LogixType: TLogixType;
Value: Variant;
end;
TLogicParcer = class
private
FEvalObject: TPersistent;
function EvalMax(AString: string): string;
procedure FindBeginAndEndPosOfBracets(const AValue: string; var Abeginpos, AEndPos: Integer);
function GetObjectValue(AObject: string): Variant;
function CalcValueFromlist(Alist: Tlist): Variant;
function Evalmin(AString: string): string;
Function EvalToDate(aString : String ) : String ;
procedure SetEvalObject(const Value: TPersistent);
{ Private declarations }
public
// Easy acces to objects bij string
function GetPersistentProp(AName: string; aPersistent: TPersistent): Variant;
procedure SetPersistentProp(AName: string; aPersistent: TPersistent; Value: Variant);
function CalcValue(AValue: string): Variant;
// USed in evaluating Object propertys defined lik [SomeProp] including
// nestled operations like [somePersistendprop.SomeProp
property EvalObject: TPersistent read FEvalObject write SetEvalObject;
{ Public declarations }
end;
implementation
uses math, contnrs, TypInfo;
function TLogicParcer.CalcValue(AValue: string): Variant;
var
AList: Tobjectlist;
i, y, EndPos: Integer;
ALogicNode: TLogixNode;
TempStr: string;
begin
try
// spaties strippen
for i := Length(AValue) downto 1 do
begin
if AValue[i] = ' ' then
delete(AValue, i, 1);
end;
AList := Tobjectlist.Create;
AList.OwnsObjects := False;
try
// function Search
// min
while Pos('Min', AValue) 0 do
begin
i := Pos('min', AValue) + 3;
FindBeginAndEndPosOfBracets(AValue, i, EndPos);
TempStr := copy(AValue, i + 1, EndPos - i);
TempStr := Evalmin(TempStr);
delete(AValue, i - 3, (EndPos - i) + 5);
insert(TempStr, AValue, i);
end;
// max
while Pos('Max', AValue) 0 do
begin
i := Pos('max', AValue) + 3;
FindBeginAndEndPosOfBracets(AValue, i, EndPos);
TempStr := copy(AValue, i + 1, EndPos - i);
TempStr := Evalmax(TempStr);
delete(AValue, i - 3, (EndPos - i) + 5);
insert(TempStr, AValue, i);
end;
// ToDate
while Pos('ToDate', AValue) 0 do
begin
i := Pos('ToDate', AValue) + 6;
FindBeginAndEndPosOfBracets(AValue, i, EndPos);
TempStr := copy(AValue, i + 1, EndPos - i);
TempStr := EvalToDate(TempStr);
delete(AValue, i - 6, (EndPos - i) + 8);
insert(TempStr, AValue, i-6);
end;
i := 1;
while i begin
// Brackets Value
if AValue[i] = '(' then
begin
FindBeginAndEndPosOfBracets(AValue, i, EndPos);
ALogicNode := TLogixNode.Create;
AList.Add(ALogicNode);
ALogicNode.LogixType := ltRecurse;
ALogicNode.Value := copy(AValue, i + 1, EndPos - i);
ALogicNode.Value := CalcValue(VarToStr(ALogicNode.Value));
i := EndPos + 2;
end
else
if AValue[i] in TokenSet then // Token value
begin
ALogicNode := TLogixNode.Create;
AList.Add(ALogicNode);
ALogicNode.LogixType := ltToken;
TempStr := copy(AValue, i, 1);
ALogicNode.Value := TempStr;
Inc(i);
end
else
// object of nummer of boolean
begin
TempStr := '';
while not (AValue[i] in TokenSet + ['(', #0]) do
begin
TempStr := TempStr + AValue[i];
inc(i);
end;
ALogicNode := TLogixNode.Create;
AList.Add(ALogicNode);
ALogicNode.LogixType := tlValue;
ALogicNode.Value := '';
if (UpperCase(tempstr) = 'FALSE') or
(UpperCase(tempstr) = 'TRUE') then
begin
ALogicNode.LogixType := tlValue;
ALogicNode.Value := (UpperCase(tempstr) = 'TRUE');
end
else
begin
for y := 1 to Length(tempstr) do
begin
// is het een nummer ??
if not (TempStr[y] in ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '.', 'E']) then
begin
ALogicNode.Value := GetObjectValue(tempstr);
ALogicNode.LogixType := ltObject;
end;
end;
// is de waarde gevult ?? zo niet dan is het een Nummer
if VarToStr(ALogicNode.Value) = '' then
ALogicNode.Value := StrToFloat(tempstr);
end;
end;
end;
Result := CalcValueFromlist(AList);
// end while i finally
for i := 0 to AList.Count - 1 do
begin
TObject(AList[i]).free;
end;
AList.free;
end;
except
on e: Exception do
begin
Result := E.Message;
end;
end;
end;
procedure TLogicParcer.FindBeginAndEndPosOfBracets(const AValue: string; var Abeginpos,
AEndPos: Integer);
var
i, BracetsCount: Integer;
begin
BracetsCount := 0;
for i := Abeginpos to length(AValue) do
begin
if AValue[i] = '(' then
inc(BracetsCount)
else if AValue[i] = ')' then
Dec(BracetsCount);
if BracetsCount = 0 then
begin
AEndPos := i - 1;
exit;
end;
end;
raise EMathError.Create(Format('bracets not closed in %s', [AValue]));
end;
function TLogicParcer.GetObjectValue(AObject: string): Variant;
var
i: Integer;
Day, Jear, Month: Word;
TempStr, TempMonth: string;
begin
// nul datum 30#12#1899
if (AObject = '') or (AObject[1] '[') or (AObject[Length(AObject)] ']') then
exit;
if POS('#', AObject) 0 then
begin
AObject[Length(AObject)] := ' ';
AObject[1] := ' ';
for i := 1 to Length(AObject) do
begin
if AObject[i] = '#' then AObject[i] := '-';
end;
AObject := Trim(AObject);
if StrToInt(AObject[1] + AObject[2]) = 0 then
begin
i := Length(AObject);
// jaren
while (AObject[i] in ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']) do
begin
TempStr := AObject[i] + TempStr;
dec(i);
end;
dec(i);
// maanden
while (AObject[i] in ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']) do
begin
TempMonth := AObject[i] + TempMonth;
dec(i);
end;
Jear := 1899;
Month := 12;
Day := 30;
Jear := Jear + StrToInt(TempStr);
Result := EncodeDate(jear, month, day);
end
else
Result := StrToDate(AObject);
end
else if AObject = '[TODAY]' then
result := Date
else
begin
AObject[Length(AObject)] := ' ';
AObject[1] := ' ';
AObject := Trim(AObject);
Result := GetPersistentProp(AObject, FEvalObject);
end;
if TVarData(result).VType = varEmpty then
Result := AObject ;
end;
function TLogicParcer.CalcValueFromlist(Alist: Tlist): Variant;
var
i: Integer;
begin
Result := 0;
// Check
if Alist.Count = 1 then
begin
result := TlogixNode(Alist[0]).Value;
exit;
end;
if VarToStr(TlogixNode(AList[0]).Value) '!' then
begin
if Alist.Count if (TLogixNode(Alist[0]).LogixType = lttoken)
or (TlogixNode(Alist[Alist.Count - 1]).LogixType = lttoken) then
raise EMathError.Create('Error in Expression Token found at begin or end of list');
end;
// berekening
// '^'
// '*',
// '/',
// '+','-',
// ,'|','=','!','&',''
// meneer = machtsVerheffen
i := Alist.Count - 1;
while i = 0 do
begin
if TLogixNode(AList[i]).LogixType = ltToken then
begin
if TLogixNode(AList[i]).Value = '^' then
begin
TLogixNode(AList[i]).Value := Power(TLogixNode(AList[i - 1]).Value, TLogixNode(AList[i + 1]).Value);
TLogixNode(AList[i]).LogixType := tlValue;
TLogixNode(alist[i + 1]).free;
Alist.Delete(i + i);
TLogixNode(alist[i - 1]).free;
Alist.Delete(i - i);
dec(i, 2);
end
else
dec(i);
end
else
dec(i);
end;
// van = vermenigvuldigen
i := Alist.Count - 1;
while i = 0 do
begin
if TLogixNode(AList[i]).LogixType = ltToken then
begin
if TLogixNode(AList[i]).Value = '*' then
begin
TLogixNode(AList[i]).Value := TLogixNode(AList[i - 1]).Value * TLogixNode(AList[i + 1]).Value;
TLogixNode(AList[i]).LogixType := tlValue;
TLogixNode(alist[i + 1]).free;
Alist.Delete(i + 1);
TLogixNode(alist[i - 1]).free;
Alist.Delete(i - 1);
dec(i, 2);
end
else
dec(i);
end
else
dec(i);
end;
// dalen = Delen
i := 0;
while i begin
if TLogixNode(AList[i]).LogixType = ltToken then
begin
if TLogixNode(AList[i]).Value = '/' then
begin
TLogixNode(AList[i]).Value := TLogixNode(AList[i - 1]).Value / TLogixNode(AList[i + 1]).Value;
TLogixNode(AList[i]).LogixType := tlValue;
TLogixNode(alist[i + 1]).free;
Alist.Delete(i + 1);
TLogixNode(alist[i - 1]).free;
Alist.Delete(i - 1);
end
else
inc(i);
end
else
inc(i);
end;
// Wacht doen weniet
// Op = Optellen
i := Alist.Count - 1;
while i = 0 do
begin
if TLogixNode(AList[i]).LogixType = ltToken then
begin
if TLogixNode(AList[i]).Value = '+' then
begin
TLogixNode(AList[i]).Value := TLogixNode(AList[i - 1]).Value + TLogixNode(AList[i + 1]).Value;
TLogixNode(AList[i]).LogixType := tlValue;
TLogixNode(alist[i + 1]).free;
Alist.Delete(i + 1);
TLogixNode(alist[i - 1]).free;
Alist.Delete(i - 1);
dec(i, 2);
end
else
dec(i);
end
else
dec(i);
end;
// Antwoord = aftrekken
i := Alist.Count - 1;
while i = 0 do
begin
if TLogixNode(AList[i]).LogixType = ltToken then
begin
if TLogixNode(AList[i]).Value = '-' then
begin
TLogixNode(AList[i]).Value := TLogixNode(AList[i - 1]).Value - TLogixNode(AList[i + 1]).Value;
TLogixNode(AList[i]).LogixType := tlValue;
TLogixNode(alist[i + 1]).free;
Alist.Delete(i + 1);
TLogixNode(alist[i - 1]).free;
Alist.Delete(i - 1);
dec(i, 2);
end
else
dec(i);
end
else
dec(i);
end;
// Booleanse vergelijking
i := Alist.Count - 1;
while i = 0 do
begin
if TLogixNode(AList[i]).LogixType = ltToken then
begin
if (TLogixNode(AList[i]).Value = '=') or
(TLogixNode(AList[i]).Value = ' (TLogixNode(AList[i]).Value = '') then
begin
if TLogixNode(AList[i - 1]).LogixType = ltToken then
begin
if (TLogixNode(AList[i - 1]).Value = ' or (TLogixNode(AList[i - 1]).Value = '') then
begin
TLogixNode(AList[i]).Value := TLogixNode(AList[i - 1]).Value + TLogixNode(AList[i]).Value;
TLogixNode(AList[i - 1]).free;
alist.Delete(i - 1);
dec(i);
end
else
raise EMathError.Create('Not a valid equasion');
end;
if TLogixNode(AList[i]).Value = '=' then
TLogixNode(AList[i]).Value := (TLogixNode(AList[i - 1]).Value = TLogixNode(AList[i + 1]).Value)
else if TLogixNode(AList[i]).Value = ' TLogixNode(AList[i]).Value := (TLogixNode(AList[i - 1]).Value else if TLogixNode(AList[i]).Value = '' then
TLogixNode(AList[i]).Value := (TLogixNode(AList[i - 1]).Value TLogixNode(AList[i + 1]).Value)
else if TLogixNode(AList[i]).Value = ' TLogixNode(AList[i]).Value := (TLogixNode(AList[i - 1]).Value else if TLogixNode(AList[i]).Value = '=' then
TLogixNode(AList[i]).Value := (TLogixNode(AList[i - 1]).Value = TLogixNode(AList[i + 1]).Value)
else if TLogixNode(AList[i]).Value = '' then
TLogixNode(AList[i]).Value := (TLogixNode(AList[i - 1]).Value TLogixNode(AList[i + 1]).Value);
TLogixNode(AList[i]).LogixType := tlValue;
TLogixNode(alist[i + 1]).free;
Alist.Delete(i + 1);
TLogixNode(alist[i - 1]).free;
Alist.Delete(i - 1);
dec(i, 2);
end
else
dec(i);
end
else
dec(i);
end;
// booleanse operatoren
// and
i := Alist.Count - 1;
while i = 0 do
begin
if TLogixNode(AList[i]).LogixType = ltToken then
begin
if TLogixNode(AList[i]).Value = '&' then
begin
TLogixNode(AList[i]).Value := TLogixNode(AList[i - 1]).Value and TLogixNode(AList[i + 1]).Value;
TLogixNode(AList[i]).LogixType := tlValue;
TLogixNode(alist[i + 1]).free;
Alist.Delete(i + 1);
TLogixNode(alist[i - 1]).free;
Alist.Delete(i - 1);
dec(i, 2);
end
else
dec(i);
end
else
dec(i);
end;
// or
i := Alist.Count - 1;
while i = 0 do
begin
if TLogixNode(AList[i]).LogixType = ltToken then
begin
if TLogixNode(AList[i]).Value = '|' then
begin
TLogixNode(AList[i]).Value := TLogixNode(AList[i - 1]).Value or TLogixNode(AList[i + 1]).Value;
TLogixNode(AList[i]).LogixType := tlValue;
TLogixNode(alist[i + 1]).free;
Alist.Delete(i + 1);
TLogixNode(alist[i - 1]).free;
Alist.Delete(i - 1);
dec(i, 2);
end
else
dec(i);
end
else
dec(i);
end;
// not
i := Alist.Count - 1;
while i = 0 do
begin
if TLogixNode(AList[i]).LogixType = ltToken then
begin
if TLogixNode(AList[i]).Value = '!' then
begin
TLogixNode(AList[i]).Value := not TLogixNode(AList[i + 1]).Value;
TLogixNode(AList[i]).LogixType := tlValue;
TLogixNode(alist[i + 1]).free;
Alist.Delete(i + 1);
dec(i);
end
else
dec(i);
end
else
dec(i);
end;
if Alist.Count 1 then raise EMathError.Create('Error After calc list count 1');
Result := TLogixNode(Alist[0]).Value;
end;
function TLogicParcer.EvalMax(AString: string): string;
var
i: Integer;
a, b: Extended;
sa, sb: string;
begin
i := length(AString);
while not (AString[i] = ',') do
begin
sb := AString[i] + sb;
dec(i);
if i = 1 then exit;
end;
dec(i);
while not (AString[i] = #0) do
begin
sa := AString[i] + sa;
dec(i);
end;
a := StrToFloat(VarToStr(CalcValue(sa)));
b := StrToFloat(VarToStr(CalcValue(sb)));
result := FloatToStr(max(a, b));
end;
function TLogicParcer.Evalmin(AString: string): string;
var
i: Integer;
a, b: Extended;
sa, sb: string;
begin
i := length(AString);
while not (AString[i] = ',') do
begin
sb := AString[i] + sb;
dec(i);
if i = 1 then exit;
end;
dec(i);
while not (AString[i] = #0) do
begin
sa := AString[i] + sa;
dec(i);
end;
a := StrToFloat(VarToStr(CalcValue(sa)));
b := StrToFloat(VarToStr(CalcValue(sb)));
result := FloatToStr(Min(a, b));
end;
procedure TLogicParcer.SetEvalObject(const Value: TPersistent);
begin
FEvalObject := Value;
end;
procedure TLogicParcer.SetPersistentProp(AName: string; APersistent: TPersistent; Value: Variant);
var
PropList: PPropList;
PropCount: Integer;
ClassTypeInfo: PTypeInfo;
ClassTypeData: PTypeData;
i: integer;
Propname, NextName: string;
begin
if APersistent = nil then exit;
ClassTypeInfo := APersistent.ClassInfo;
ClassTypeData := GetTypeData(ClassTypeInfo);
PropCount := ClassTypeData.PropCount - 1;
if pos('.', AName) 0 then
begin
Propname := copy(AName, 1, pos('.', AName) - 1);
NextName := copy(AName, pos('.', AName) + 1, Length(AName) - pos('.', AName) + 1);
end
else
Propname := AName;
// reserveer geheugen
GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
// Error trap
try
// Vul de prop list
GetPropInfos(APersistent.ClassInfo, PropList);
for i := 0 to PropCount do
begin
if (PropList[i]^.Name = Propname) and (NextName = '') then
case PropList[i]^.PropType^.Kind of
tkString, tkLString,
tkWString, tkWChar,
tkChar:
begin
SetStrProp(APersistent, PropList[i], VarToStr(Value));
end;
tkInteger,
tkEnumeration:
begin
if VarToStr(Value) '' then
SetOrdProp(APersistent, PropList[i], StrToInt(VarToStr(Value)));
end;
tkFloat:
begin
if (PropList[i]^.PropType^.Name = 'TDateTime') then
SetFloatProp(APersistent, PropList[i], VarToDateTime(Value))
else
SetFloatProp(APersistent, PropList[i], StrToFloat(VarToStr(Value)));
end;
end; // end case
// recursion logic
if PropList[i]^.PropType^.Kind = tkClass then
if GetObjectProp(APersistent, PropList[i]) is TPersistent then
begin
if (PropList[i]^.Name = Propname) and (NextName '') then
SetPersistentProp(NextName, TPersistent(GetObjectProp(APersistent, PropList[i])), Value);
end;
end; // end i
finally
FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
end;
end;
function TLogicParcer.GetPersistentProp(AName: string; APersistent: TPersistent): Variant;
var
PropList: PPropList;
PropCount: Integer;
ClassTypeInfo: PTypeInfo;
ClassTypeData: PTypeData;
i: integer;
Propname, NextName: string;
begin
if APersistent = nil then exit;
ClassTypeInfo := APersistent.ClassInfo;
ClassTypeData := GetTypeData(ClassTypeInfo);
PropCount := ClassTypeData.PropCount - 1;
if pos('.', AName) 0 then
begin
Propname := copy(AName, 1, pos('.', AName) - 1);
NextName := copy(AName, pos('.', AName) + 1, Length(AName) - pos('.', AName) + 1);
end
else
Propname := AName;
// reserveer geheugen
GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
// Error trap
try
// Vul de prop list
GetPropInfos(APersistent.ClassInfo, PropList);
for i := 0 to PropCount do
begin
if (PropList[i]^.Name = Propname) and (NextName = '') then
case PropList[i]^.PropType^.Kind of
tkString, tkLString,
tkWString, tkWChar,
tkChar:
begin
Result := GetStrProp(APersistent, PropList[i]);
end;
tkInteger,
tkEnumeration:
begin
Result := GetOrdProp(APersistent, PropList[i]);
end;
tkFloat:
begin
if (PropList[i]^.PropType^.Name = 'TDateTime') then
Result := VarFromDateTime(GetFloatProp(APersistent, PropList[i]))
else
Result := GetFloatProp(APersistent, PropList[i]);
end;
end; // end case
// recursion logic
if PropList[i]^.PropType^.Kind = tkClass then
if GetObjectProp(APersistent, PropList[i]) is TPersistent then
begin
If (GetObjectProp(APersistent, PropList[i]) is TCollection) and
(NextName ='Count') then Result := TCollection (GetObjectProp(APersistent, PropList[i])).Count
else
if (PropList[i]^.Name = Propname) and (NextName '') then
Result := GetPersistentProp(NextName, TPersistent(GetObjectProp(APersistent, PropList[i])));
end;
end; // end i
finally
FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
end;
end;
function TLogicParcer.EvalToDate(aString: String): String;
var
i : Integer ;
begin
Result := VarToStr(CalcValue(aString));
for i := 1 to length(Result) do
if result[i] = '-' then result[i] := '#' ;
Result := '[' + result + ']' ;
end;
end.
]]>