'=========================================================================== ' Subject: ALGEBRAIC FUNCTION SOLVER Date: 09-27-99 (22:37) ' Author: Quinn Tyler Jackson Code: PBDLL ' Origin: qjackson@wave.home.com Packet: PBDLL.ABC '=========================================================================== ' ' THE * ARDAF300.BAS ' AMAZING * ' RECURSIVE * *** * * ' DESCENT * * * * ' ALGEBRAIC ****** * * * * ' FORMULA * `****' * * ' AND ** *************************************** ' DEFINABLE * * ' FUNCTIONS * * ' ENGINE *****' * * * ' * * * ' * * * * ' * * * * 5(100-x+2b) * * * ' * * * * * * * ' * * * ************* * * * ' * * * * `****** ' * * * 10+35i * * ' * * * * * ' * * * * `****' ' v3.0 * * * ' ' PUBLIC DOMAIN CODE ' ' author: Quinn Tyler Jackson, Ph.D. ' email: quinn@qtj.net ' url: http://www.qtj.net/~quinn/ ' ' ' Version 3.0 Notes (27 September 1999): ' -------------------------------------- ' ' ARDAF has gone through many version changes since I first released ' it back in January 1993. (It has even been ported to C++.) ' ' One of the reasons I've maintained this code for so long is that ' I believe a recursive descent function evaluator serves the BASIC ' programming community both by providing a practical, useful tool ' and by providing a tutorial in the design and implementation of ' what a lot of programmers may still consider some of the most ' obscure code to follow - a parser and interpreter. Perhaps one of ' the handiest ways to get to know a programming language intimately ' is to implement a parser in that language. (Well, that's how I ' learned to program in C++ after years of BASIC dialects, anyway.) ' ' With v3.0, I have ported the engine to PowerBASIC/DLL 6.0 compatible ' code, but I have not added any functionality to the engine. My ' coding style has differed over the years, so I have also attempted ' to bring this code more to my present style, although I haven't ' been entirely successful in this regard. ' ' This code is intended to be compiled as a DLL, but if you compile as ' an EXE, you can modify PBMAIN at the end of the file for testing. The ' DLL version exports only two functions: ' ' FUNCTION SolveExpression(_ ' expr AS STRING,_ ' ImagPart AS EXT,_ ' ErrorCode AS INTEGER) AS EXT ' ' FUNCTION ArdafErrorMessage(ErrorCode AS INTEGER) AS STRING ' ' SolveExpression is called as follows: ' ' DIM result AS EXT ' DIM ImagPart AS EXT ' DIM ErrorCode AS INTEGER ' DIM expr AS STRING ' ' expr = "a[10]:=5; b:=100+10*2+a[2+8]; b*2+cos(b)" ' ' result = SolveExpression(expr, ImagPart, ErrorCode) ' ' If, upon returning, ErrorCode is 0, then result will contain the ' numeric result of having solved the expression in expr. If the function ' solves to a complex number, ImagPart will contain the imaginary part ' of the result. If ErrorCode is less than zero -- you have been warned ' that some default has been used, some undefined array element accessed, ' or something else that defaults, but does not cause a termination. ' If ErrorCode is greater than zero, the error was fatal. ' ' You can get an English description of the error or warning by calling ' the function ArdafErrorMessage and passing the code as the parameter. ' ' The expressions that ARDAF can deal with can be quite opaque, and ' need not be in the familiar "programmer-ese" format. Consider the ' following: ' ' a(x) := 2x; b(x) := a(4x+i); b(2) ' ' The above expression would be solved in three steps. First, the ' function a(x) would be defined as returning 2 times x. Then, the ' function b(x) would be defined as returning a(4x+i), and finally, ' b(2) would be invoked. Taken as a whole, the above would return ' a result with a real and imaginary part, 16 + 8i. When multiple ' subexpressions are separated by semicolons, SolveExpression returns ' the result of the rightmost expression. ' ' ARDAF can accept expressions in a more algebraic format than a ' compiler would, so that: ' ' a:=5; b:=9; (5a + 1)(7b + 9a + i) ' ' solves to 2808 + 26i. Internally, this is actually expanded to: ' ' a:=5; b:=9; (5*a + 1)*(7*b + 9*a + i) ' ' It's important to note that 5a expands to 5*a, but a5 is a variable ' name. Also, a(5) is a function call, whereas (5)a is 5*a. ' ' Because ARDAF can deal with complex math in standard format, it ' may be possible to solve expressions that you weren't anticipating ' having been solved. Consider this: ' ' f(x) := square_root(100 - 5x); f(25) ' ' This solves to square_root(-25), or 5i, but long-time BASIC ' programmers might expect otherwise on values of x greater than 20. ' ' -------------------------------------- ' COMPILER DIRECTIVES: #COMPILE EXE'DLL ' change to EXE for debugging #DIM ALL #REGISTER NONE ' EQUATES: %RDF_TRUE = -1 %RDF_FALSE = NOT %RDF_TRUE %RDF_SYMBOL_VARIABLE = 0 %RDF_SYMBOL_FUNCTION = 1 %RDF_SYMBOL_ARRAY = 2 %RDF_CLASS_OPERATOR = 1 %RDF_CLASS_DIGIT = 2 %RDF_CLASS_COMPLEX = 3 %RDF_CLASS_FUNCTION = 4 %RDF_CLASS_ASSIGNMENT= 5 %RDF_CLASS_ARRAY = 6 ' Operator classes PRECEDENCE '--------------------------------------------- $RDF_OPS_POWER = "^?>><==>`" ' FOURTH $RDF_OPS_UNARY = "!" ' UNARY operators ' The following %MAX_xxxxxx constants can be modified to account for ' how you intend on using ARDAF. %RDF_MAX_LEVELS = 100 ' Numbers of levels of nesting allowed %RDF_MAX_COMMANDS = 10 ' Number of commands per statement %RDF_MAX_PARAMS = 10 ' Number of parameters in a function allowed %RDF_MAX_WORDOPS = 10 ' Number of WORD --> OPERATOR conversions %RDF_MAX_VARS = 1024 ' Total number of variables allowed %RDF_MAX_FUNCS = 1024 ' Total number of definable functions allowed %RDF_MAX_SYMBOLS = %RDF_MAX_VARS + %RDF_MAX_FUNCS ' Total symbols allowed %RDF_PROTECTED = -1 %RDF_UNPROTECTED = 0 ' Error code constants %RDF_ERROR_Success = 0 %RDF_ERROR_DivisionByZero = 1 %RDF_ERROR_ProtectedFunction = 2 %RDF_ERROR_ProtectedVariable = 3 %RDF_ERROR_SymbolTableFull = 4 %RDF_ERROR_VariableTableFull = 5 %RDF_ERROR_FunctionTableFull = 6 %RDF_ERROR_MismatchedParenthesis= 7 %RDF_ERROR_UndefinedVariable = 8 %RDF_ERROR_NestedTooDeep = 9 %RDF_ERROR_ComplexNumberSystem = 10 %RDF_ERROR_ProtectedKeyword = 11 %RDF_ERROR_Overflow = 12 %RDF_ERROR_UsingEnvironmentVar = -1 %RDF_ERROR_UndefinedArray = -2 %RDF_ERROR_UndefinedArrayElem = -3 %RDF_ERROR_FunctionDefaultUsed = -4 ' TYPE DECLARATIONS: TYPE ArrayDataType Index AS INTEGER TheVal AS EXT Imag AS EXT END TYPE TYPE SymbolTableType SymLvl AS INTEGER ' Level that it was assigned SymType AS INTEGER ' Whether it is a variable or function TblPtr AS INTEGER ' Pointer to data tables END TYPE TYPE RDF_GLOBAL_DATA ErrorCode AS INTEGER ' An error will stop things but WarningCode AS INTEGER ' A warning isn't fatal.... SymPtr AS INTEGER ' Points to highest symbol in table VariPtr AS INTEGER ' Points to highest variable in table FunPtr AS INTEGER ' Points to highest function in table WordOps AS INTEGER ' Number of word operators OPERATOR AS STRING * 256 END TYPE ' The two exported functions - if this is compiled as a DLL DECLARE FUNCTION SolveExpression (BYVAL InText AS STRING, ImagPart AS EXT, ErrorCode AS INTEGER) AS EXT DECLARE FUNCTION ArdafErrorMessage (TheCode AS INTEGER) AS STRING DECLARE FUNCTION NormalAlgebra (BYVAL InText AS STRING) AS STRING DECLARE FUNCTION WordOpsToCharOps (BYVAL InText AS STRING) AS STRING DECLARE FUNCTION Eval (InText AS STRING, ImagPart AS EXT, LvlPtr AS INTEGER) AS EXT DECLARE FUNCTION InList (OpType AS STRING, Op AS STRING) AS INTEGER DECLARE FUNCTION Evaluate (InText AS STRING, ImagPart AS EXT, LvlPtr AS INTEGER) AS EXT DECLARE FUNCTION FetchVar (VarName AS STRING, ImagPart AS EXT) AS EXT DECLARE FUNCTION SolveFormula (InToken AS STRING, ImagPart AS EXT, LvlPtr AS INTEGER) AS EXT DECLARE FUNCTION FetchArray (InToken AS STRING, ImagPart AS EXT, LvlPtr AS INTEGER) AS EXT DECLARE FUNCTION cosh (x AS EXT) AS EXT DECLARE FUNCTION cot (x AS EXT) AS EXT DECLARE FUNCTION coth (x AS EXT) AS EXT DECLARE FUNCTION pow (x AS EXT, y AS EXT) AS EXT DECLARE FUNCTION sinh (x AS EXT) AS EXT DECLARE FUNCTION tanh (x AS EXT) AS EXT DECLARE FUNCTION CompPower (LeftArg AS EXT, RightArg AS EXT, LeftI AS EXT, RightI AS EXT) AS EXT DECLARE FUNCTION CompLog (Arg AS EXT, ImagPart AS EXT) AS EXT DECLARE FUNCTION CompExp (Arg AS EXT, ImagPart AS EXT) AS EXT DECLARE FUNCTION CompAbs (Arg AS EXT, ImagPart AS EXT) AS EXT DECLARE SUB ApplyOp (Op AS STRING, LeftArg AS EXT, RightArg AS EXT, LeftI AS EXT, RightI AS EXT) DECLARE SUB ApplyRealOp (Op AS STRING, LeftArg AS EXT, RightArg AS EXT, LeftI AS EXT) DECLARE SUB ApplyComplexOp (Op AS STRING, LeftArg AS EXT, RightArg AS EXT, LeftI AS EXT, RightI AS EXT) DECLARE SUB AssignFun (FunctName AS STRING, Formula AS STRING, Protection AS INTEGER) DECLARE SUB AssignVar (VarName AS STRING, VarValue AS EXT, ImagPart AS EXT, LvlPtr AS INTEGER, Protection AS INTEGER) DECLARE SUB GetToken (Token AS STRING, TypeToken AS INTEGER, Expression AS STRING, ExPtr AS INTEGER) DECLARE SUB ParseIntoArray (TheArray() AS STRING, BYVAL InText AS STRING, Delim AS STRING, NumElems AS INTEGER) DECLARE SUB AssignArray (ArrayName AS STRING, Valu AS EXT, ImagPart AS EXT, LvlPtr AS INTEGER, ExPtr AS INTEGER) ' GLOBAL VARIABLE DEFINITIONS: GLOBAL RDF_GD AS RDF_GLOBAL_DATA GLOBAL RDF_GD_IdTable () AS STRING GLOBAL RDF_GD_SymTable() AS SymbolTableType GLOBAL RDF_GD_VarTable() AS EXT ' Table holds variable data GLOBAL RDF_GD_ImgTable() AS EXT ' Table holds imaginary part GLOBAL RDF_GD_ParTable() AS STRING ' Table holds function params GLOBAL RDF_GD_ForTable() AS STRING ' Table holds formulas GLOBAL RDF_GD_WordOp() AS STRING GLOBAL RDF_GD_CharOp() AS STRING '=====PUBLIC FUNCTIONS===== SUB InitializeGlobals () DIM RDF_GD_SymTable (%RDF_MAX_SYMBOLS) DIM RDF_GD_IdTable (%RDF_MAX_SYMBOLS) DIM RDF_GD_VarTable (%RDF_MAX_VARS) DIM RDF_GD_ImgTable (%RDF_MAX_VARS) DIM RDF_GD_ParTable (%RDF_MAX_FUNCS) DIM RDF_GD_ForTable (%RDF_MAX_FUNCS) DIM RDF_GD_WordOp (1:%RDF_MAX_WORDOPS) DIM RDF_GD_CharOp (1:%RDF_MAX_WORDOPS) END SUB SUB InitializePresets() DIM ni AS INTEGER ni = 1 DIM FunctionName AS STRING DIM FunctionDef AS STRING DO WHILE READ$(ni) <> "*END*" FunctionName = READ$(ni) FunctionDef = READ$(ni + 1) AssignFun FunctionName, FunctionDef, %RDF_PROTECTED ni = ni + 2 LOOP DIM SysVarName AS STRING DO WHILE READ$(ni) <> "*END*" SysVarName = READ$(ni) AssignVar SysVarName, 0, 0, 1, %RDF_PROTECTED INCR ni LOOP DO WHILE READ$(ni) <> "*END*" INCR RDF_GD.WordOps RDF_GD_WordOp(RDF_GD.WordOps) = READ$(ni) RDF_GD_CharOp(RDF_GD.WordOps) = READ$(ni + 1) ni = ni + 2 LOOP DECR RDF_GD.WordOps RDF_GD.OPERATOR = $RDF_OPS_ADDSUB + $RDF_OPS_MULTDIV + $RDF_OPS_POWER + $RDF_OPS_LOGICAL EXIT SUB ' DATA STATMENTS: ' Note that these are %RDF_PROTECTED. That is to say, they cannot be redefined ' by the user. Add any to this list any functions that would suit your ' needs. DATA "square_root(x)", "2}x" DATA "cube_root(x)","3}x" DATA "rand(high:100,seed:timer)","high?seed" DATA "binomial(x,n,p)","(n!/(x!*(n-x)!))*(p^x*(1-p)^(n-x))" ' The following are internal, hard-coded functions and the following ' list serves as a template for their syntax, and reserves a place for ' them in the symbol table, so that the user doesn't try to define his ' own COS(), for instance. DATA "abs(arg)", "" DATA "int(arg)", "" DATA "frac(arg)", "" DATA "cos(arg)", "" DATA "cosh(arg)", "" DATA "sin(arg)", "" DATA "sinh(arg)","" DATA "tan(arg)", "" DATA "tanh(arg)", "" DATA "cot(arg)", "" DATA "coth(arg)", "" DATA "sec(arg)", "" DATA "sech(arg)", "" DATA "csc(arg)", "" DATA "csch(arg)", "" DATA "atn(arg)", "" DATA "log(arg,base:1)", "" DATA "sgn(arg)", "" DATA "sqr(arg)", "" DATA "sigma(x,y,e,n:0)","" DATA "stddev()", "" DATA "mean()", "" DATA "*END*" , "" ' The following are system variables. They cannot be redefined, since they ' return system information. When you add a system variable to this ' list, you must also add it to the SELECT CASE VarName$ structure in ' the FUNCTION FetchVar. SystemVariableData: DATA "timer" DATA "rnd" DATA "pi" DATA "e" DATA "i" ' do NOT remove this or you'll lose complex math handling DATA "*END*" WordOperatorData: DATA " MOD ", "" DATA " AND ", "@" DATA " NOT ", " 0`" DATA "*END*", "" END SUB FUNCTION SolveExpression (BYVAL InText AS STRING, ImagPart AS EXT, ErrorCode AS INTEGER) EXPORT AS EXT STATIC Initialized AS INTEGER IF NOT Initialized THEN InitializeGlobals InitializePresets Initialized = %RDF_TRUE END IF DIM LvlPtr AS INTEGER RDF_GD.ErrorCode = 0 RDF_GD.WarningCode = 0 LvlPtr = 0 ImagPart = 0 IF INSTR(LTRIM$(UCASE$(InText)), ANY (RDF_GD.OPERATOR + "ABCDEFGHIJKLMNOPQRSTUVWXYZ()'")) THEN InText = NormalAlgebra(InText) FUNCTION = Evaluate(InText, ImagPart, LvlPtr) ELSE ' just pass back the value FUNCTION = VAL(InText) END IF ErrorCode = MAX(RDF_GD.WarningCode, RDF_GD.ErrorCode) END FUNCTION FUNCTION ArdafErrorMessage (TheCode AS INTEGER) EXPORT AS STRING SELECT CASE TheCode CASE 0 FUNCTION = "" CASE %RDF_ERROR_DivisionByZero FUNCTION = "Division by zero" CASE %RDF_ERROR_ProtectedVariable FUNCTION = "Attempt to overwrite protected variable" CASE %RDF_ERROR_ProtectedFunction FUNCTION = "Attempt to redefine protected function" CASE %RDF_ERROR_ProtectedKeyword FUNCTION = "Attempt to redefine protected keyword" CASE %RDF_ERROR_SymbolTableFull FUNCTION = "Symbol table full" CASE %RDF_ERROR_VariableTableFull FUNCTION = "Variable table full" CASE %RDF_ERROR_FunctionTableFull FUNCTION = "Function table full" CASE %RDF_ERROR_MismatchedParenthesis FUNCTION = "Mismatched parenthesis encountered" CASE %RDF_ERROR_UndefinedVariable FUNCTION = "Undefined variable referenced -- assuming 0" CASE %RDF_ERROR_UndefinedArray FUNCTION = "Undefined array referenced -- assuming 0" CASE %RDF_ERROR_UndefinedArrayElem FUNCTION = "Undefined array index referenced -- assuming 0" CASE %RDF_ERROR_FunctionDefaultUsed FUNCTION = "Function parameter not supplied -- default assumed" CASE %RDF_ERROR_ComplexNumberSystem FUNCTION = "Complex numbers not supported" CASE %RDF_ERROR_NestedTooDeep FUNCTION = "Unbounded nesting" CASE %RDF_ERROR_Overflow FUNCTION = "Overflow" CASE %RDF_ERROR_UsingEnvironmentVar FUNCTION = "DOS environment variable used" CASE ELSE FUNCTION = "General syntax error" END SELECT END FUNCTION '=====PRIVATE ROUTINES===== SUB DescentParse (Phase AS INTEGER, Arg AS EXT, ImagPart AS EXT, Token AS STRING, TypeToken AS INTEGER, Expression AS STRING, ExPtr AS INTEGER) ' This is the central cortex of this module. ON Phase GOSUB Level1, Level2, Level3, Level4, Level5, Level6 DIM Oper AS STRING DIM y AS EXT DIM ImagY AS EXT DIM CommaPtr AS INTEGER EXIT SUB Level1: ' See if something of a higher precedence should be done first. DescentParse 2, Arg, ImagPart, Token, TypeToken, Expression, ExPtr Oper = Token ' The lowest level of precedence is handled by this Level. DO WHILE InList($RDF_OPS_LOGICAL, Oper) GetToken Token, TypeToken, Expression, ExPtr DescentParse 2, y, ImagY, Token, TypeToken, Expression, ExPtr ApplyOp Oper, Arg, y, ImagPart, ImagY Oper = Token LOOP RETURN Level2: ' See if something of a higher precedence should be done first. DescentParse 3, Arg, ImagPart, Token, TypeToken, Expression, ExPtr Oper = Token DO WHILE InList($RDF_OPS_ADDSUB, Oper) GetToken Token, TypeToken, Expression, ExPtr DescentParse 3, y, ImagY, Token, TypeToken, Expression, ExPtr ApplyOp Oper, Arg, y, ImagPart, ImagY Oper = Token LOOP RETURN Level3: ' See if something of a higher precedence should be done first. DescentParse 4, Arg, ImagPart, Token, TypeToken, Expression, ExPtr Oper = Token DO WHILE InList($RDF_OPS_MULTDIV, Oper) GetToken Token, TypeToken, Expression, ExPtr DescentParse 4, y, ImagY, Token, TypeToken, Expression, ExPtr ApplyOp Oper, Arg, y, ImagPart, ImagY Oper = Token LOOP RETURN Level4: ' See if something of a higher precedence should be done first. DescentParse 5, Arg, ImagPart, Token, TypeToken , Expression, ExPtr Oper = Token IF InList($RDF_OPS_POWER, Oper) THEN GetToken Token, TypeToken, Expression, ExPtr DescentParse 5, y, ImagY, Token, TypeToken, Expression, ExPtr ApplyOp Oper, Arg, y, ImagPart, ImagY END IF RETURN Level5: Oper = "" IF TypeToken = %RDF_CLASS_OPERATOR AND (InList($RDF_OPS_ADDSUB, Token)) THEN Oper = Token GetToken Token, TypeToken, Expression, ExPtr END IF DescentParse 6, Arg, ImagPart, Token, TypeToken, Expression, ExPtr ' This handles negative prefixes SELECT CASE Oper CASE "-" Arg = -Arg END SELECT RETURN Level6: ' This level handles parentheses IF Token = "(" AND TypeToken = %RDF_CLASS_OPERATOR THEN GetToken Token, TypeToken, Expression, ExPtr DescentParse 1, Arg, ImagPart, Token, TypeToken, Expression, ExPtr IF Token <> ")" THEN RDF_GD.ErrorCode = %RDF_ERROR_MismatchedParenthesis END IF GetToken Token, TypeToken, Expression, ExPtr ELSE SELECT CASE TypeToken CASE %RDF_CLASS_DIGIT Arg = VAL(Token) GetToken Token, TypeToken, Expression, ExPtr CASE %RDF_CLASS_FUNCTION Arg = SolveFormula(Token, ImagPart, 0) TypeToken = %RDF_CLASS_DIGIT GetToken Token, TypeToken, Expression, ExPtr CASE %RDF_CLASS_ARRAY Arg = FetchArray(Token, ImagPart, 0) TypeToken = %RDF_CLASS_DIGIT GetToken Token, TypeToken, Expression, ExPtr CASE %RDF_CLASS_COMPLEX Arg = VAL(Token) CommaPtr = INSTR(Token, "'") ImagPart = VAL(MID$(Token, CommaPtr + 1)) GetToken Token, TypeToken, Expression, ExPtr END SELECT END IF RETURN END SUB FUNCTION NormalAlgebra (BYVAL InText AS STRING) AS STRING InText = UCASE$(InText) + ")" ' The extra close paren keeps ARDAF from choking on statements that ' have no closing parenthesis, such as "sqr(4" IF INSTR(InText, ANY "ABCDEFGHIJKLMNOPQRSTUVWXYZ") THEN InText = WordOpsToCharOps(InText) END IF InText = " " + REMOVE$(InText, ANY CHR$(9, 10, 13, 32, 255)) ' The following code inserts *'s between literal numbers and ' variables or open parentheses, as in: ' ' 5x + 2 --> 5*x+2 ' 5(3+1) --> 5*(3+1) ' (1+1)(2+2) --> (1+1)*(2+2) ' ' This makes the expression more like algebra. ' ' NOTE: ' ' To accommodate hexidecimal numbers, the variable name cannot begin ' with A, B, C, D, E, or F.... If it does, an explicit "*" is ' required. DIM Pointer AS INTEGER Pointer = INSTR(InText, ANY "GHIJKLMNOPQRSTUVWXYZ(") DO WHILE Pointer SELECT CASE MID$(InText, Pointer - 1, 1) CASE "0" TO "9", ")" InText = LEFT$(InText, Pointer - 1) + "*" + MID$(InText, Pointer) END SELECT Pointer = INSTR(Pointer + 1, InText, ANY "ABCDEFGHIJKLMNOPQRSTUVWXYZ(") LOOP IF INSTR(InText, ANY "²³½¼÷µ×") THEN REPLACE "²" WITH "^2" IN InText REPLACE "³" WITH "^3" IN InText REPLACE "÷" WITH "/" IN InText REPLACE "×" WITH "*" IN InText REPLACE "µ" WITH "MEAN" IN InText REPLACE "½" WITH ".5" IN InText REPLACE "¼" WITH ".25" IN InText END IF ' Expand unary suffixes for easier parsing IF INSTR(InText, ANY $RDF_OPS_UNARY) THEN DIM UnaryChar AS STRING DIM i AS INTEGER FOR i = 1 TO LEN($RDF_OPS_UNARY) UnaryChar = MID$($RDF_OPS_UNARY, i, 1) REPLACE UnaryChar WITH UnaryChar + "0" IN InText NEXT i END IF FUNCTION = LTRIM$(InText) END FUNCTION FUNCTION WordOpsToCharOps (BYVAL InText AS STRING) AS STRING InText = " " + InText DIM i AS INTEGER FOR i = 1 TO RDF_GD.WordOps REPLACE RDF_GD_WordOp(i) WITH RDF_GD_CharOp(i) IN InText NEXT i FUNCTION = InText END FUNCTION FUNCTION Evaluate (InText AS STRING, ImagPart AS EXT, LvlPtr AS INTEGER) AS EXT IF LvlPtr < %RDF_MAX_LEVELS THEN INCR LvlPtr DIM CommandArray(%RDF_MAX_COMMANDS) AS STRING ' separate statement by semicolons DIM NumCommands AS INTEGER ParseIntoArray CommandArray(), InText, ";", NumCommands DIM i AS INTEGER FOR i = 1 TO NumCommands FUNCTION = Eval(CommandArray(i), ImagPart, LvlPtr) IF RDF_GD.ErrorCode THEN FUNCTION = 0 EXIT FUNCTION END IF NEXT i DECR LvlPtr ELSE RDF_GD.ErrorCode = %RDF_ERROR_NestedTooDeep END IF END FUNCTION FUNCTION Eval (InText AS STRING, ImagPart AS EXT, LvlPtr AS INTEGER) AS EXT DIM Expression AS STRING DIM ExPtr AS INTEGER Expression = InText ExPtr = 1 DIM AssignmentPtr AS INTEGER DIM ParenPtr AS INTEGER AssignmentPtr = INSTR(Expression, ":=") ParenPtr = INSTR(Expression, "(") IF AssignmentPtr = 0 THEN ' just do a simple evaluation DIM Token AS STRING DIM TypeToken AS INTEGER DIM x AS EXT GetToken Token, TypeToken, Expression, ExPtr DescentParse 1, x, ImagPart, Token, TypeToken, Expression, ExPtr FUNCTION = x ELSE ' assign a variable or function DIM VariableName AS STRING VariableName = LTRIM$(RTRIM$(LEFT$(Expression, AssignmentPtr - 1))) SELECT CASE (ParenPtr > 0) AND (ParenPtr < AssignmentPtr) CASE 0 DIM BracketPtr AS INTEGER BracketPtr = INSTR(Expression, "[") DIM Valu AS EXT IF (BracketPtr > 0) AND (BracketPtr < AssignmentPtr) THEN Valu = Eval(MID$(Expression, AssignmentPtr + 2), ImagPart, ExPtr) AssignArray VariableName, Valu, ImagPart, LvlPtr, ExPtr FUNCTION = Valu ELSE Valu = Eval(MID$(Expression, AssignmentPtr + 2), ImagPart, ExPtr) AssignVar VariableName, Valu, ImagPart, LvlPtr, ExPtr FUNCTION = Valu END IF CASE ELSE DIM Formula AS STRING Formula = LTRIM$(MID$(Expression, AssignmentPtr + 2)) AssignFun VariableName, Formula, %RDF_UNPROTECTED END SELECT END IF END FUNCTION FUNCTION FetchVar (VarName AS STRING, ImagPart AS EXT) AS EXT ' Internal functions that are added to this list must be ' added to the DATA list in InitializePresets FUNCTION. ImagPart = 0 SELECT CASE VarName CASE "TIMER" FUNCTION = TIMER CASE "RND" FUNCTION = RND CASE "PI" FUNCTION = ATN(1) * 4 CASE "E" FUNCTION = 2.71828182845904## + 5.24D-15 CASE "I" FUNCTION = 0 ImagPart = 1 CASE ELSE DIM i AS INTEGER FOR i = RDF_GD.SymPtr TO 1 STEP -1 IF RDF_GD_SymTable(i).SymType = %RDF_SYMBOL_VARIABLE THEN IF RDF_GD_IdTable(i) = VarName THEN FUNCTION = RDF_GD_VarTable(RDF_GD_SymTable(i).TblPtr) ImagPart = RDF_GD_ImgTable(RDF_GD_SymTable(i).TblPtr) EXIT FUNCTION END IF END IF NEXT i DIM tempVarName AS STRING tempVarName = ENVIRON$(VarName) IF LEN(tempVarName) THEN FUNCTION = SolveExpression(tempVarName, ImagPart, RDF_GD.ErrorCode) ImagPart = RDF_GD_ImgTable(RDF_GD_SymTable(i).TblPtr) RDF_GD.WarningCode = %RDF_ERROR_UsingEnvironmentVar ELSE RDF_GD.WarningCode = %RDF_ERROR_UndefinedVariable END IF END SELECT END FUNCTION FUNCTION InList (OpType AS STRING, Op AS STRING) AS INTEGER IF LEN(Op) THEN IF INSTR(OpType, Op) > 0 THEN FUNCTION = %RDF_TRUE END IF END IF END FUNCTION FUNCTION SolveFormula (InToken AS STRING, ImagPart AS EXT, LvlPtr AS INTEGER) AS EXT DIM Param(%RDF_MAX_PARAMS) AS STRING DIM theDefaults(%RDF_MAX_PARAMS) AS EXT DIM ParmValueString(%RDF_MAX_PARAMS) AS STRING DIM ParmValue(%RDF_MAX_PARAMS) AS EXT DIM ParPtr AS INTEGER DIM FunctName AS STRING DIM Par AS STRING ParPtr = INSTR(InToken, "(") FunctName = LTRIM$(RTRIM$(LEFT$(InToken, ParPtr - 1))) Par = MID$(InToken, ParPtr + 1, LEN(InToken) - ParPtr - 1) DIM i AS INTEGER FOR i = 1 TO RDF_GD.SymPtr IF RDF_GD_SymTable(i).SymType = %RDF_SYMBOL_FUNCTION THEN IF RDF_GD_IdTable(i) = FunctName THEN DIM Formula AS STRING DIM Parm AS STRING DIM Tot AS INTEGER Formula = RDF_GD_ForTable(RDF_GD_SymTable(i).TblPtr) Parm = RDF_GD_ParTable(RDF_GD_SymTable(i).TblPtr) ParseIntoArray Param(), Parm, ",", Tot DIM a AS INTEGER FOR a = 1 TO Tot DIM tempParm AS STRING tempParm = Param(a) DIM parmPtr AS INTEGER parmPtr = INSTR(tempParm, ":") SELECT CASE parmPtr CASE 0 ' Do nothing theDefaults(a) = 0 CASE ELSE Param(a) = LEFT$(tempParm, parmPtr - 1) theDefaults(a) = Evaluate(MID$(tempParm, parmPtr + 1), ImagPart, LvlPtr) END SELECT NEXT a EXIT FOR END IF END IF NEXT i DIM Tot2 AS INTEGER ParseIntoArray ParmValueString(), Par, ",", Tot2 FOR i = 1 TO Tot IF ParmValueString(i) = "" THEN ParmValue(i) = theDefaults(i) RDF_GD.WarningCode = %RDF_ERROR_FunctionDefaultUsed ELSE ParmValue(i) = Evaluate(ParmValueString(i), ImagPart, LvlPtr) END IF ' Push the parameters to the variable stack temporarily IF RDF_GD.SymPtr < %RDF_MAX_SYMBOLS THEN ' put it there IF RDF_GD.VariPtr < %RDF_MAX_VARS THEN INCR RDF_GD.VariPtr INCR RDF_GD.SymPtr RDF_GD_IdTable(RDF_GD.SymPtr) = Param(i) RDF_GD_SymTable(RDF_GD.SymPtr).SymType = %RDF_SYMBOL_VARIABLE RDF_GD_SymTable(RDF_GD.SymPtr).TblPtr = RDF_GD.VariPtr RDF_GD_SymTable(RDF_GD.SymPtr).SymLvl = LvlPtr + 1 RDF_GD_VarTable(RDF_GD.VariPtr) = ParmValue(i) ELSE RDF_GD.ErrorCode = %RDF_ERROR_VariableTableFull END IF ELSE RDF_GD.ErrorCode = %RDF_ERROR_SymbolTableFull END IF NEXT i SELECT CASE FunctName ' First, we have the built in functions CASE "ABS" FUNCTION = ABS(ParmValue(1)) CASE "INT" FUNCTION = INT(ParmValue(1)) CASE "FRAC" FUNCTION = FRAC(ParmValue(1)) CASE "ATN" FUNCTION = ATN(ParmValue(1)) CASE "LOG" SELECT CASE ParmValue(2) CASE 1' base e FUNCTION = LOG(ParmValue(1)) CASE 2 FUNCTION = LOG2(ParmValue(1)) CASE 10 FUNCTION = LOG10(ParmValue(1)) END SELECT CASE "SQR" FUNCTION = SQR(ParmValue(1)) CASE "COS" FUNCTION = COS(ParmValue(1)) CASE "COSH" FUNCTION = COSH(ParmValue(1)) CASE "SIN" FUNCTION = SIN(ParmValue(1)) CASE "SINH" FUNCTION = SINH(ParmValue(1)) CASE "TAN" FUNCTION = TAN(ParmValue(1)) CASE "TANH" FUNCTION = TANH(ParmValue(1)) CASE "COT" FUNCTION = COT(ParmValue(1)) CASE "COTH" FUNCTION = COTH(ParmValue(1)) CASE "SEC" FUNCTION = 1/COS(ParmValue(1)) CASE "SECH" FUNCTION = 1/COS(ParmValue(1)) CASE "CSC" FUNCTION = 1/SIN(ParmValue(1)) CASE "CSCH" FUNCTION = 1/SINH(ParmValue(1)) CASE "SGN" FUNCTION = SGN(ParmValue(1)) CASE "SIGMA" DIM SumReal AS EXT DIM SumI AS EXT DIM Expression AS STRING SumReal = 0 SumI = 0 Expression = ParmValueString(3) FOR i = ParmValue(1) TO ParmValue(2) RDF_GD_VarTable(RDF_GD.VariPtr) = i SumReal = SumReal + Eval(Expression, ImagPart, 0) SumI = SumI + ImagPart IF RDF_GD.ErrorCode THEN EXIT FUNCTION END IF NEXT i FUNCTION = SumReal ImagPart = ImagPart + SumI CASE "STDDEV" DIM SumArray(%RDF_MAX_PARAMS) AS EXT DIM Sum AS EXT Sum = 0 FOR i = 1 TO Tot2 SumArray(i) = Evaluate(ParmValueString(i), ImagPart, 0) Sum = Sum + SumArray(i) NEXT i DIM Mean AS EXT Mean = Sum / Tot2 DIM DevSum AS EXT DevSum = 0 FOR i = 1 TO Tot2 DevSum = DevSum + (SumArray(i)-Mean)^2 NEXT i FUNCTION = SQR(DevSum / Tot2) CASE "MEAN" Sum = 0 FOR i = 1 TO Tot2 Sum = Sum + Evaluate(ParmValueString(i), ImagPart, 0) NEXT i FUNCTION = Sum / Tot2 CASE ELSE FUNCTION = Evaluate(Formula, ImagPart, LvlPtr) END SELECT RDF_GD.VariPtr = RDF_GD.VariPtr - Tot ' Clear the variable stack of RDF_GD.SymPtr = RDF_GD.SymPtr - Tot ' variables used in parameter END FUNCTION SUB AssignArray (ArrayName AS STRING, Valu AS EXT, ImagPart AS EXT, LvlPtr AS INTEGER, ExPtr AS INTEGER) DIM ArrayData AS ArrayDataType PTR DIM ParPtr AS INTEGER DIM TheName AS STRING DIM Index AS STRING ParPtr = INSTR(ArrayName, "[") TheName = LTRIM$(RTRIM$(LEFT$(ArrayName, ParPtr - 1))) Index = MID$(ArrayName, ParPtr + 1, LEN(ArrayName) - ParPtr - 1) ArrayName = UCASE$(TheName) DIM TrueIndex AS INTEGER TrueIndex = INT(Evaluate(Index, ImagPart, 0)) DIM Pointer AS INTEGER ARRAY SCAN RDF_GD_WordOp() FOR RDF_GD.WordOps, = " " + ArrayName + " ", TO Pointer IF Pointer THEN RDF_GD.ErrorCode = %RDF_ERROR_ProtectedKeyword EXIT SUB END IF ' First we see if this variable is already in the list DIM i AS INTEGER FOR i = 1 TO RDF_GD.SymPtr IF RDF_GD_SymTable(i).SymType = %RDF_SYMBOL_ARRAY THEN IF RDF_GD_IdTable(i) = ArrayName THEN IF RDF_GD_SymTable(i).SymLvl = LvlPtr THEN ' just change its value DIM TheData AS STRING TheData = RDF_GD_ForTable(RDF_GD_SymTable(i).TblPtr) DIM j AS INTEGER FOR j = 1 TO LEN(TheData) STEP LEN(ArrayDataType) ArrayData = STRPTR(TheData) + j - 1 IF @ArrayData.Index = TrueIndex THEN @ArrayData.TheVal = Valu @ArrayData.Imag = ImagPart RDF_GD_ForTable(RDF_GD_SymTable(i).TblPtr) = TheData EXIT SUB END IF NEXT j ' Tack the new element on to the end DIM NewElem AS STRING NewElem = SPACE$(LEN(ArrayDataType)) ArrayData = STRPTR(NewElem) @ArrayData.Index = TrueIndex @ArrayData.TheVal= Valu @ArrayData.Imag = ImagPart RDF_GD_ForTable(RDF_GD_SymTable(i).TblPtr) = RDF_GD_ForTable(RDF_GD_SymTable(i).TblPtr) + NewElem EXIT SUB END IF END IF END IF NEXT i IF RDF_GD.SymPtr < %RDF_MAX_SYMBOLS THEN ' put it there IF RDF_GD.FunPtr < %RDF_MAX_VARS THEN INCR RDF_GD.FunPtr INCR RDF_GD.SymPtr RDF_GD_IdTable (RDF_GD.SymPtr) = ArrayName RDF_GD_SymTable(RDF_GD.SymPtr).SymType = %RDF_SYMBOL_ARRAY RDF_GD_SymTable(RDF_GD.SymPtr).TblPtr = RDF_GD.FunPtr RDF_GD_SymTable(RDF_GD.SymPtr).SymLvl = LvlPtr ' Tack the new element on to the end NewElem = SPACE$(LEN(ArrayDataType)) ArrayData = STRPTR(NewElem) @ArrayData.Index = TrueIndex @ArrayData.TheVal= Valu @ArrayData.Imag = ImagPart RDF_GD_ForTable(RDF_GD_SymTable(i).TblPtr) = NewElem ELSE RDF_GD.ErrorCode = %RDF_ERROR_FunctionTableFull END IF ELSE RDF_GD.ErrorCode = %RDF_ERROR_SymbolTableFull END IF END SUB FUNCTION FetchArray (InToken AS STRING, ImagPart AS EXT, LvlPtr AS INTEGER) AS EXT DIM ParPtr AS INTEGER DIM ArrayName AS STRING DIM Index AS STRING ImagPart = 0 ParPtr = INSTR(InToken, "[") ArrayName = LTRIM$(RTRIM$(LEFT$(InToken, ParPtr - 1))) Index = MID$(InToken, ParPtr + 1, LEN(InToken) - ParPtr - 1) DIM ArrayData AS ArrayDataType PTR DIM i AS INTEGER FOR i = 1 TO RDF_GD.SymPtr IF RDF_GD_SymTable(i).SymType = %RDF_SYMBOL_ARRAY THEN IF RDF_GD_IdTable(i) = ArrayName THEN DIM TrueIndex AS INTEGER DIM TheData AS STRING TrueIndex = INT(Evaluate(Index, ImagPart, 0)) TheData = RDF_GD_ForTable(RDF_GD_SymTable(i).TblPtr) DIM j AS INTEGER FOR j = 1 TO LEN(TheData) STEP LEN(ArrayDataType) ArrayData = STRPTR(TheData) + j - 1 IF @ArrayData.Index = TrueIndex THEN FUNCTION = @ArrayData.TheVal ImagPart = @ArrayData.Imag EXIT FUNCTION END IF NEXT j RDF_GD.WarningCode = %RDF_ERROR_UndefinedArrayElem EXIT FUNCTION END IF END IF NEXT i RDF_GD.WarningCode = %RDF_ERROR_UndefinedArray END FUNCTION SUB ParseIntoArray (TheArray() AS STRING, BYVAL InText AS STRING, Delim AS STRING, NumElems AS INTEGER) NumElems = 0 IF INSTR(InText, "(") THEN DIM Char AS STRING PTR * 1 Char = STRPTR(InText) DIM i AS INTEGER DIM InParen AS INTEGER DIM Elem AS STRING FOR i = 1 TO LEN(InText) IF InParen > 0 THEN IF @Char = ")" THEN DECR InParen END IF Elem = Elem + @Char ELSE IF @Char = Delim THEN INCR NumElems TheArray(NumElems) = Elem Elem = "" ELSE IF @Char = "(" THEN INCR InParen END IF Elem = Elem + @Char END IF END IF INCR Char NEXT i INCR NumElems TheArray(NumElems) = Elem ELSE DIM DelimLen AS INTEGER DelimLen = LEN(Delim) DO INCR NumElems DIM EndWord AS INTEGER EndWord = INSTR(InText, Delim) IF EndWord THEN TheArray(NumElems) = LEFT$(InText, EndWord - 1) InText = MID$(InText, EndWord + DelimLen) ELSE TheArray(NumElems) = InText EXIT DO END IF LOOP END IF END SUB SUB ApplyOp (Op AS STRING, LeftArg AS EXT, RightArg AS EXT, LeftI AS EXT, RightI AS EXT) IF LeftI OR RightI THEN ApplyComplexOp Op, LeftArg, RightArg, LeftI, RightI ELSE ApplyRealOp Op, LeftArg, RightArg, LeftI END IF END SUB SUB ApplyRealOp (Op AS STRING, LeftArg AS EXT, RightArg AS EXT, LeftI AS EXT) ' This is the meat of the operator section, and can be modified to ' includ ANY symbol as an operator, or any two byte symbol combination. ' Any symbol added must be added to the $RDF_OPS_????? constant that ' sets its level of precedence. SELECT CASE Op CASE "+" ' addition LeftArg = LeftArg + RightArg CASE "-" ' subtraction LeftArg = LeftArg - RightArg CASE "*" ' multiplication LeftArg = LeftArg * RightArg CASE "/" ' division IF RightArg <> 0 THEN LeftArg = LeftArg / RightArg ELSE RDF_GD.ErrorCode = %RDF_ERROR_DivisionByZero END IF CASE "\" ' integer division IF RightArg <> 0 THEN LeftArg = LeftArg \ RightArg ELSE RDF_GD.ErrorCode = %RDF_ERROR_DivisionByZero END IF CASE "%" ' modulo division IF RightArg <> 0 THEN LeftArg = LeftArg MOD RightArg ELSE RDF_GD.ErrorCode = %RDF_ERROR_DivisionByZero END IF CASE "^" ' exponentation LeftArg = LeftArg ^ RightArg CASE "}" ' the rth root of RightArg SELECT CASE RightArg CASE 0 RDF_GD.ErrorCode = %RDF_ERROR_DivisionByZero CASE < 0 SELECT CASE LeftArg MOD 2 CASE 0 LeftI = ABS(RightArg) ^ (1 / LeftArg) LeftArg = 0 CASE 1 LeftArg = -(ABS(RightArg) ^ (1 / LeftArg)) END SELECT CASE ELSE LeftArg = RightArg ^ (1 / LeftArg) END SELECT CASE "?" ' random number from 0 toLeftArg, seed RightArg RANDOMIZE RightArg LeftArg = RND * LeftArg CASE "<<" ' bitshift left RightArg by LeftArg bits DIM ShiftVal AS INTEGER DIM Arg AS INTEGER ShiftVal = RightArg Arg = LeftArg SHIFT LEFT Arg, ShiftVal LeftArg = Arg CASE ">>" ' bitshift right RightArg byLeftArg bits ShiftVal = RightArg Arg = LeftArg SHIFT RIGHT Arg, ShiftVal LeftArg = Arg CASE "!" ' factorial DIM temp AS INTEGER Temp = 1 DIM i AS INTEGER FOR i = 1 TO LeftArg Temp = Temp * i NEXT i LeftArg = Temp CASE "<" ' logical less than than LeftArg = LeftArg < RightArg CASE "<=", "=<" ' logical less than or equal to LeftArg = LeftArg <= RightArg CASE ">" ' logical greater than LeftArg = LeftArg > RightArg CASE ">=", "=>" ' logical greater than or equal to LeftArg = LeftArg >= RightArg CASE "==" ' logical equality LeftArg = (LeftArg = RightArg) CASE "<>" ' logical inequality LeftArg = LeftArg <> RightArg CASE "|=", "=|" ' logical implication LeftArg = LeftArg IMP RightArg CASE "&=", "=&" ' logical equivlance LeftArg = LeftArg EQV RightArg CASE "@" ' bitwise AND LeftArg = LeftArg AND RightArg CASE "|" ' bitwise OR LeftArg = LeftArg OR RightArg CASE "~" ' bitwise XOR LeftArg = LeftArg XOR RightArg CASE "`" ' LOGICAL NOT LeftArg = NOT RightArg END SELECT END SUB SUB ApplyComplexOp (Op AS STRING, LeftArg AS EXT, RightArg AS EXT, LeftI AS EXT, RightI AS EXT) SELECT CASE Op CASE "+" ' addition LeftArg = LeftArg + RightArg LeftI = LeftI + RightI CASE "-" ' subtraction LeftArg = LeftArg - RightArg LeftI = LeftI - RightI CASE "*" ' multiplication '(x+yi)(a+bi) = (xa+ayi+xbi+(-yb)) DIM x AS EXT DIM a AS EXT DIM y AS EXT DIM b AS EXT x = LeftArg a = RightArg y = LeftI b = RightI LeftArg = (x*a)-(y*b) LeftI = (y*a)+(x*b) CASE "/" ' division ' These formulas provided by Nick Sawadsky.... x = LeftArg a = RightArg y = LeftI b = RightI LeftArg = (x*a + y*b)/(a^2 + b^2) LeftI = (y*a - x*b)/(a^2 + b^2) CASE "^" LeftArg = CompPower(LeftArg, RightArg, LeftI, RightI) CASE ELSE RDF_GD.ErrorCode = %RDF_ERROR_ComplexNumberSystem END SELECT END SUB SUB AssignFun (FunctName AS STRING, Formula AS STRING, Protection AS INTEGER) FunctName = UCASE$(FunctName) Formula = NormalAlgebra(Formula) DIM ParPtr AS INTEGER DIM NamePart AS STRING DIM ParamPart AS STRING ParPtr = INSTR(FunctName, "(") NamePart = LEFT$(FunctName, ParPtr - 1) ParamPart = MID$(FunctName, ParPtr + 1, LEN(FunctName) - ParPtr - 1) ' First we see if this function is already in the list DIM i AS INTEGER FOR i = 1 TO RDF_GD.SymPtr IF RDF_GD_SymTable(i).SymType = %RDF_SYMBOL_FUNCTION THEN IF RDF_GD_IdTable(i) = NamePart THEN IF RDF_GD_SymTable(i).SymLvl <> %RDF_PROTECTED THEN ' just change its formula IF LEN(ParamPart) THEN ' Make sure it just isn't a formula that ' uses empty parentheses for the params. RDF_GD_ParTable(RDF_GD_SymTable(i).TblPtr) = ParamPart END IF ELSE RDF_GD.ErrorCode = %RDF_ERROR_ProtectedFunction END IF RDF_GD_ForTable(RDF_GD_SymTable(i).TblPtr) = Formula EXIT SUB END IF END IF NEXT i IF RDF_GD.SymPtr < %RDF_MAX_SYMBOLS THEN ' put it there IF RDF_GD.FunPtr < %RDF_MAX_FUNCS THEN INCR RDF_GD.FunPtr INCR RDF_GD.SymPtr RDF_GD_IdTable(RDF_GD.SymPtr) = NamePart RDF_GD_SymTable(RDF_GD.SymPtr).SymType = %RDF_SYMBOL_FUNCTION RDF_GD_SymTable(RDF_GD.SymPtr).SymLvl = Protection RDF_GD_SymTable(RDF_GD.SymPtr).TblPtr = RDF_GD.FunPtr RDF_GD_ParTable(RDF_GD.FunPtr) = ParamPart RDF_GD_ForTable(RDF_GD.FunPtr) = Formula ELSE RDF_GD.ErrorCode = %RDF_ERROR_FunctionTableFull END IF ELSE RDF_GD.ErrorCode = %RDF_ERROR_SymbolTableFull END IF END SUB SUB AssignVar (VarName AS STRING, VarValue AS EXT, ImagPart AS EXT, LvlPtr AS INTEGER, Protection AS INTEGER) VarName = UCASE$(VarName) DIM Pointer AS INTEGER ARRAY SCAN RDF_GD_WordOp() FOR RDF_GD.WordOps, = " " + VarName + " ", TO Pointer IF Pointer THEN RDF_GD.ErrorCode = %RDF_ERROR_ProtectedKeyword EXIT SUB END IF ' First we see if this variable is already in the list DIM i AS INTEGER FOR i = 1 TO RDF_GD.SymPtr IF RDF_GD_SymTable(i).SymType = %RDF_SYMBOL_VARIABLE THEN IF RDF_GD_IdTable(i) = VarName THEN IF RDF_GD_SymTable(i).SymLvl <> %RDF_PROTECTED THEN IF RDF_GD_SymTable(i).SymLvl = LvlPtr THEN ' just change its value RDF_GD_VarTable(RDF_GD_SymTable(i).TblPtr) = VarValue RDF_GD_ImgTable(RDF_GD_SymTable(i).TblPtr) = ImagPart EXIT SUB END IF ELSE RDF_GD.ErrorCode = %RDF_ERROR_ProtectedVariable EXIT SUB END IF END IF END IF NEXT i IF RDF_GD.SymPtr < %RDF_MAX_SYMBOLS THEN ' put it there IF RDF_GD.VariPtr < %RDF_MAX_VARS THEN INCR RDF_GD.VariPtr INCR RDF_GD.SymPtr RDF_GD_IdTable (RDF_GD.SymPtr) = VarName RDF_GD_SymTable(RDF_GD.SymPtr).SymType = %RDF_SYMBOL_VARIABLE RDF_GD_SymTable(RDF_GD.SymPtr).TblPtr = RDF_GD.VariPtr RDF_GD_SymTable(RDF_GD.SymPtr).SymLvl = Protection RDF_GD_VarTable(RDF_GD.VariPtr) = VarValue RDF_GD_ImgTable(RDF_GD.VariPtr) = ImagPart ELSE RDF_GD.ErrorCode = %RDF_ERROR_VariableTableFull END IF ELSE RDF_GD.ErrorCode = %RDF_ERROR_SymbolTableFull END IF END SUB SUB GetToken (Token AS STRING, TypeToken AS INTEGER, Expression AS STRING, ExPtr AS INTEGER) DIM Char AS STRING PTR * 1 DIM LenExpression AS INTEGER LenExpression = LEN(Expression) IF ExPtr > LenExpression THEN EXIT SUB END IF Char = STRPTR(Expression) + ExPtr - 1 Token = "" SELECT CASE @Char CASE "0" TO "9", ".", "'" DIM LegalDigitChar AS STRING LegalDigitChar = "0123456789.'E" TypeToken = %RDF_CLASS_DIGIT DO Token = Token + @Char IF @Char = "'" THEN IF Token = "'" THEN Token = "0'" END IF TypeToken = %RDF_CLASS_COMPLEX INCR Char IF @Char = "-" THEN INCR ExPtr Token = Token + @Char ELSE DECR Char END IF ELSE IF @Char = "E" THEN INCR Char IF INSTR("-+", @Char) THEN INCR ExPtr Token = Token + @Char ELSE DECR Char END IF ELSE END IF END IF INCR Char INCR ExPtr LOOP WHILE INSTR(@Char, ANY LegalDigitChar) CASE "&" LegalDigitChar = "0123456789ABCDEF&HO" DO Token = Token + @Char INCR Char INCR ExPtr LOOP WHILE INSTR(@Char, ANY LegalDigitChar) TypeToken = %RDF_CLASS_DIGIT Token = STR$(VAL(Token)) CASE ELSE IF INSTR(RDF_GD.OPERATOR, @Char) THEN TypeToken = %RDF_CLASS_OPERATOR Token = @Char INCR ExPtr INCR Char IF INSTR(RDF_GD.OPERATOR, @Char) THEN IF @Char <> "-" THEN Token = Token + @Char INCR ExPtr INCR Char END IF END IF IF Token = ":=" THEN TypeToken = %RDF_CLASS_ASSIGNMENT END IF ELSE IF @Char >= "A" AND @Char <= "Z" THEN ' build up a name based upon letters DO Token = Token + @Char IF INSTR("([", @Char) = 0 THEN INCR Char INCR ExPtr ELSE IF @Char = "(" THEN TypeToken = %RDF_CLASS_FUNCTION ELSE TypeToken = %RDF_CLASS_ARRAY END IF DIM SepPtr AS INTEGER DO UNTIL SepPtr = - 1 INCR ExPtr INCR Char SELECT CASE @Char CASE "(", "[" INCR SepPtr CASE ")", "]" DECR SepPtr END SELECT Token = Token + @Char LOOP INCR ExPtr EXIT SUB END IF LOOP UNTIL INSTR(RDF_GD.OPERATOR, @Char) OR (ExPtr >= LenExpression) IF RIGHT$(Token, 1) = ")" THEN Token = REMOVE$(Token, ")") DECR ExPtr DECR Char END IF DIM ImagPart AS EXT Token = STR$(FetchVar(Token, ImagPart)) IF ImagPart THEN Token = RTRIM$(Token) +"'"+ LTRIM$(STR$(ImagPart)) TypeToken = %RDF_CLASS_COMPLEX ELSE TypeToken = %RDF_CLASS_DIGIT END IF ELSE IF INSTR("()", @Char) THEN ' just ignore it Token = @Char TypeToken = %RDF_CLASS_OPERATOR INCR ExPtr END IF END IF END IF END SELECT END SUB FUNCTION cosh (x AS EXT) AS EXT FUNCTION = (EXP(x) + EXP(-x)) / 2 END FUNCTION FUNCTION cot (x AS EXT) AS EXT FUNCTION = COS(x) / SIN(x) END FUNCTION FUNCTION coth (x AS EXT) AS EXT FUNCTION = cosh(x) / sinh(x) END FUNCTION FUNCTION pow (x AS EXT, y AS EXT) AS EXT FUNCTION = EXP(y * LOG(x)) END FUNCTION FUNCTION sinh (x AS EXT) AS EXT FUNCTION = (EXP(x) - EXP(-x)) / 2 END FUNCTION FUNCTION tanh (x AS EXT) AS EXT FUNCTION = sinh(x) / cosh(x) END FUNCTION FUNCTION CompPower (LeftArg AS EXT, RightArg AS EXT, LeftI AS EXT, RightI AS EXT) AS EXT 'pow(base, expon) = exp(expon log(base)) IF RightI = 0 THEN RDF_GD.ErrorCode = %RDF_ERROR_ComplexNumberSystem EXIT FUNCTION END IF 'A. log(base) DIM LogBaseImag AS EXT DIM LogBaseReal AS EXT LogBaseImag = LeftI LogBaseReal = CompLog(LeftArg, LogBaseImag) 'B. expon*B DIM x AS EXT DIM y AS EXT DIM a AS EXT DIM b AS EXT x = LogBaseReal y = LogBaseImag a = RightArg b = RightI DIM RealPart AS EXT DIM ImagPart AS EXT RealPart = (x*a)-(y*b) ImagPart = (y*a)+(x*b) 'C. exp(B) LeftArg = CompExp(RealPart, ImagPart) FUNCTION = LeftArg LeftI = ImagPart END FUNCTION FUNCTION CompLog (Arg AS EXT, ImagPart AS EXT) AS EXT 'log(z) = log(abs(z)) + i arg(z) DIM RealPart AS EXT RealPart = LOG(CompAbs(Arg, ImagPart)) IF Arg <> 0 THEN ImagPart = ATN(ImagPart / Arg) ELSE ImagPart = 0 END IF FUNCTION = RealPart END FUNCTION FUNCTION CompExp (Arg AS EXT, ImagPart AS EXT) AS EXT 'exp(x + iy) = exp(x) * (cos(y) + i sin(y)) 'exp(x)*(x+yi)(a+bi) = exp(x)*(xa + xbi + ayi - yb) DIM a AS EXT DIM b AS EXT DIM x AS EXT DIM y AS EXT a = COS(ImagPart) b = SIN(ImagPart) x = EXP(Arg) y = 0 FUNCTION = (x*a)-(y*b) ImagPart = (y*a)+(x*b) END FUNCTION FUNCTION CompAbs (Arg AS EXT, ImagPart AS EXT) AS EXT FUNCTION = SQR(Arg * Arg + ImagPart * ImagPart) END FUNCTION ' --------------------- ' If this code is compiled as an EXE, then you can test and debug ' in PBMAIN below. ' --------------------- #IF %DEF(%PB_EXE) #IF 0 FUNCTION PBMAIN () AS LONG DIM RealPart AS EXT DIM ImagPart AS EXT DIM ErrorCode AS INTEGER DIM expr AS STRING DIM di AS INTEGER DIM dn AS INTEGER dn = DATACOUNT FOR di = 1 TO dn STEP 2 expr = READ$(di) RealPart = SolveExpression(expr, ImagPart, ErrorCode) DIM result AS STRING result = FORMAT$(RealPart, "0000.00") + " + " + FORMAT$(ImagPart, "0000.00i") IF result <> READ$(di + 1) THEN ' error ELSE DIM msg AS STRING msg = "The expression:" + $CRLF + $TAB + expr + $CRLF + "solves to:" + $CRLF + $TAB msg = msg + result MSGBOX msg, , "ARDAF for PB/DLL 6.0" END IF NEXT di EXIT FUNCTION DATA "a(x):=2x;b(x):=a(4x+i);b(2)", "0016.00 + 0008.00i" DATA "a:=5;b:=9;(5a+1)(7b+9a+i)", "2808.00 + 0026.00i" DATA "f(x):=square_root(100-5x);f(25)", "0000.00 + 0005.00i" END FUNCTION #ENDIF #INCLUDE "win32api.inc" FUNCTION WINMAIN (BYVAL hInstance AS LONG, BYVAL hPrevInstance AS LONG, lpCmdLine AS ASCIIZ PTR, BYVAL iCmdShow AS LONG) AS LONG DIM Msg AS tagMsg DIM wndclass AS WndClassEx DIM szClassName AS ASCIIZ * 80 DIM hWnd AS LONG szClassName = "ArdafGraph" wndclass.cbSize = SIZEOF(WndClass) wndclass.style = %CS_HREDRAW OR %CS_VREDRAW wndclass.lpfnWndProc = CODEPTR( WndProc ) wndclass.cbClsExtra = 0 wndclass.cbWndExtra = 0 wndclass.hInstance = hInstance wndclass.hIcon = %NULL wndclass.hCursor = LoadCursor( %NULL, BYVAL %IDC_ARROW ) wndclass.hbrBackground = GetStockObject( %BLACK_BRUSH ) wndclass.lpszMenuName = %NULL wndclass.lpszClassName = VARPTR(szClassName) wndclass.hIconSm = LoadIcon( hInstance, BYVAL %IDI_APPLICATION ) RegisterClassEx wndclass ' Create a window using the registered class hWnd = CreateWindowEx(0, _ ' extended Window style "ArdafGraph", _ ' window class name "ARDAF Demo", _ ' window caption %WS_OVERLAPPEDWINDOW, _ ' window style %CW_USEDEFAULT, _ ' initial x position %CW_USEDEFAULT, _ ' initial y position %CW_USEDEFAULT, _ ' initial x size %CW_USEDEFAULT, _ ' initial y size %HWND_DESKTOP, _ ' parent window handle BYVAL 0, _ ' window menu handle hInstance, _ ' program instance handle BYVAL %NULL) ' creation parameters ShowWindow hWnd, iCmdShow UpdateWindow hWnd WHILE GetMessage(Msg, %NULL, 0, 0) TranslateMessage Msg DispatchMessage Msg WEND FUNCTION = msg.wParam END FUNCTION FUNCTION WndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG DIM Rct AS RECT DIM PS AS PAINTSTRUCT DIM hDC AS LONG SELECT CASE wMsg CASE %WM_CREATE GetClientRect hWnd, Rct EXIT FUNCTION CASE %WM_SIZE InvalidateRect hWnd, BYVAL %NULL, %TRUE EXIT FUNCTION CASE %WM_SYSCOMMAND IF wParam = %SC_CLOSE THEN DestroyWindow hWnd EXIT FUNCTION END IF CASE %WM_PAINT DIM h AS LONG DIM w AS LONG GetClientRect hWnd, Rct hDC = BeginPaint(hWnd, PS) h = Rct.nBottom - Rct.nTop w = Rct.nRight - Rct.nLeft DIM x AS EXT DIM y AS EXT DIM i AS EXT DIM xS AS STRING DIM expr AS STRING DIM ErrorCode AS INTEGER DIM cr AS LONG FOR x = 0 TO w STEP .1 expr = "f(x):=" + STR$(Rct.nBottom-Rct.nTop) + "sin(x);x:=" + STR$(x) + ";f(x)" cr = RGB(50 + (x MOD 205), 50 + (y MOD 205), 255) y = SolveExpression(expr, i, ErrorCode) y = h*SIN(x) SetPixel hDC, x, y, cr NEXT y EndPaint hWnd, PS EXIT FUNCTION CASE %WM_DESTROY PostQuitMessage 0 EXIT FUNCTION END SELECT FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam) END FUNCTION #ENDIF