Tweet
' Further improved math expression evaluator for PBWin70.
'
' This version of the math parser or interpreter includes more functions
' and error checking.
' Using extended precision, 18 digits of precision is obtained. Factorials
' up to 1754! can be handled without overflow. A number of constants
' and conversions are available, making this math evaluator an advanced
' scientific calculator. You can easily add your own functions, constants
' and conversions to the source code. Input of angles can be in degrees and
' radians. However, trigonometric output using the ARC functions will
' always be in radians. You can transform angles to radians and vice versa
' using the built-in conversions. Input of your math expression can be done
' using the keyboard or by clicking the items in the list boxes.
' Expressions and functions should be entered strictly according to standard
' algebraic syntax rules. Operators and expressions which can be used are:
' + - * / \ ^ ! ( ) < = > <> >= <= in addition to those shown
' in the list box.
' The Operator Precedence follows as closely as possible that used by
' PowerBasic - see the section on "Operator Precedence" in the PowerBasic
' help file. The only exception is the unary negation operator which in this
' program does not have a special priority following exponentiation.
' However, operations inside parentheses always have the highest
' priority and are always evaluated first. Thus by using parentheses in the
' right places you can always obtain the operator precedence you need for
' your purpose.
' The following operator precedence is used in the program:
' 1. parentheses ( )
' 2. unary operators (Factorials (!) )
' 3. one argument functions
' 4. exponentiation (^) (power expressions)
' 5. multiplication (*) and floating-point division (/)
' 6. integer division (\)
' 7. modulo (MOD)
' 8. addition (+), subtraction (-)
' 9. relational operators (<, <=, =, >=, >, <> )
' 10. NOT, ISFALSE and ISTRUE
' 11. AND
' 12. OR and XOR (exclusive OR)
' 13. EQV (equivalence)
' 14. IMP (implication)
' Many thanks to Gafny Jacob, who provided the original code, which have
' been considerably changed and improved. Thanks to Achilles B. Mina
' for free to use code concerning conversions and constants. Thanks
' to Tony Burcham and Gunar Zagars for valuable contributions
' concerning error checking and overflow indication. Also many thanks to
' the whole PowerBasic forum for great inspiration.
'
' Good luck! -- August 17, 2003 -- Erik Christensen -- [email protected]
' NB: Important improvement made June 10 and June 29, 2005
[This message has been edited by Erik Christensen (edited June 29, 2005).]
'
' This version of the math parser or interpreter includes more functions
' and error checking.
' Using extended precision, 18 digits of precision is obtained. Factorials
' up to 1754! can be handled without overflow. A number of constants
' and conversions are available, making this math evaluator an advanced
' scientific calculator. You can easily add your own functions, constants
' and conversions to the source code. Input of angles can be in degrees and
' radians. However, trigonometric output using the ARC functions will
' always be in radians. You can transform angles to radians and vice versa
' using the built-in conversions. Input of your math expression can be done
' using the keyboard or by clicking the items in the list boxes.
' Expressions and functions should be entered strictly according to standard
' algebraic syntax rules. Operators and expressions which can be used are:
' + - * / \ ^ ! ( ) < = > <> >= <= in addition to those shown
' in the list box.
' The Operator Precedence follows as closely as possible that used by
' PowerBasic - see the section on "Operator Precedence" in the PowerBasic
' help file. The only exception is the unary negation operator which in this
' program does not have a special priority following exponentiation.
' However, operations inside parentheses always have the highest
' priority and are always evaluated first. Thus by using parentheses in the
' right places you can always obtain the operator precedence you need for
' your purpose.
' The following operator precedence is used in the program:
' 1. parentheses ( )
' 2. unary operators (Factorials (!) )
' 3. one argument functions
' 4. exponentiation (^) (power expressions)
' 5. multiplication (*) and floating-point division (/)
' 6. integer division (\)
' 7. modulo (MOD)
' 8. addition (+), subtraction (-)
' 9. relational operators (<, <=, =, >=, >, <> )
' 10. NOT, ISFALSE and ISTRUE
' 11. AND
' 12. OR and XOR (exclusive OR)
' 13. EQV (equivalence)
' 14. IMP (implication)
' Many thanks to Gafny Jacob, who provided the original code, which have
' been considerably changed and improved. Thanks to Achilles B. Mina
' for free to use code concerning conversions and constants. Thanks
' to Tony Burcham and Gunar Zagars for valuable contributions
' concerning error checking and overflow indication. Also many thanks to
' the whole PowerBasic forum for great inspiration.
'
' Good luck! -- August 17, 2003 -- Erik Christensen -- [email protected]
' NB: Important improvement made June 10 and June 29, 2005
Code:
#COMPILE EXE
#REGISTER NONE
#DIM ALL
'
%FORM1_CLEAREXPRESSION = 90
%FORM1_BUTTONDOANALYSIS = 100
%FORM1_BUTTONHELP = 103
%FORM1_BUTTONABOUT = 106
%FORM1_BUTTONEXIT = 110
%FORM1_TEXTRESULTS = 120
%FORM1_TEXTFORMULA = 130
%FORM1_LABEL = 140
%FORM1_LABEL2 = 150
%FORM1_LABEL3 = 155
%FORM1_LABEL4 = 157
%FORM1_DESCRIBE = 160
%FORM1_LISTBOX1 = 170
%FORM1_LISTBOX2 = 172
%LabelRadioButtonAction = 175
%RadioButtonRadians = 180
%RadioButtonDegrees = 185
%HelpText = 190
%HelpExitButton = 195
'
#INCLUDE "WIN32API.INC"
#INCLUDE "COMMCTRL.INC"
'
GLOBAL gOldSubClassEdit&
GLOBAL hForm1&, hHelpForm&,hList2&,hTxt1& ' handles
GLOBAL ListFlag AS LONG
GLOBAL Trig() AS STRING
GLOBAL CheckArr() AS STRING
GLOBAL FirstTime AS LONG
GLOBAL ErrorTxt AS STRING
GLOBAL ErrorMes AS STRING
GLOBAL Extra() AS STRING, NoEx AS LONG
GLOBAL CF AS SINGLE
'
FUNCTION FindMatch(InString AS STRING) AS LONG
LOCAL Cntr AS LONG
LOCAL Pl AS LONG
DO WHILE pl <= LEN(InString)
INCR Pl
IF (MID$(InString, Pl, 1) = ")") THEN DECR Cntr
IF (MID$(InString, Pl, 1) = "(") THEN INCR Cntr
IF (MID$(InString, Pl, 1) = ")") AND ISFALSE Cntr THEN
FUNCTION = pl
EXIT DO
END IF
LOOP
END FUNCTION
'
FUNCTION Factorial(InVal AS LONG) AS EXT
LOCAL i AS LONG
LOCAL r AS EXT
r = 1
FOR i = 2 TO InVal
r = r * i
NEXT
FUNCTION = r
END FUNCTION
'
FUNCTION Eval(Formula AS STRING) AS EXT
LOCAL InString AS STRING
LOCAL checkStr AS STRING
LOCAL EndPl AS LONG
LOCAL Tmp AS STRING
LOCAL Expr AS STRING
LOCAL SaveExpr AS STRING
LOCAL ExprVal AS EXT
LOCAL Owner AS STRING
LOCAL LastDigit AS LONG
LOCAL LastDigOld AS LONG
LOCAL Ex AS LONG
LOCAL Dp AS LONG
LOCAL RitWingLen AS LONG
LOCAL InStrLen AS LONG
LOCAL p AS LONG
LOCAL Plc AS LONG
LOCAL pp AS LONG
LOCAL Mp AS LONG
LOCAL Mm AS LONG
LOCAL PExp AS LONG
LOCAL MExp AS LONG
LOCAL Padd AS LONG
LOCAL Psub AS LONG
LOCAL BEGIN AS LONG
LOCAL Sign AS LONG
LOCAL pMod AS LONG
LOCAL RemoveFlag AS LONG
LOCAL ValidVal AS LONG
LOCAL LftWing AS STRING
LOCAL RitWing AS STRING
LOCAL RitWingval AS EXT
LOCAL X AS EXT
LOCAL LftWingval AS EXT
LOCAL Pl AS LONG
LOCAL Valid AS STRING
LOCAL digit AS STRING
LOCAL i AS LONG
LOCAL Result AS EXT
LOCAL Numeric AS STRING
LOCAL TicTac AS LONG
LOCAL l AS LONG
LOCAL De AS STRING
LOCAL Block AS STRING
LOCAL Mult AS LONG
LOCAL Div AS LONG
LOCAL IDiv AS LONG
LOCAL P1 AS LONG
LOCAL P2 AS LONG
LOCAL P3 AS LONG
LOCAL P4 AS LONG
LOCAL P5 AS LONG
LOCAL P6 AS LONG
'
Instring = Formula
'
IF ISTRUE FirstTime THEN ' Check and "re-shape" expression string to facilitate evaluation.
'
' Instring = UCASE$(Formula)
' Instring = REMOVE$(Instring," ")
IF Instring = "" THEN ErrorMes = "Empty expression! - You need to enter an expression." : GOTO ExitOnError
'
' 1. Check for unknown words in CheckStr (copy of InString)
CheckStr = InString
' remove known words
LOCAL ccc&, ttt$
FOR i = 1 TO UBOUND(CheckArr)
ttt$ = CheckArr(i)
ccc& = INSTR(ttt$,"()")
IF ccc& THEN ttt$ = LEFT$(ttt$,ccc&-1) : GOTO hop2
ccc& = INSTR(ttt$," ")
IF ccc& THEN ttt$ = LEFT$(ttt$,ccc&-1)
hop2:
CheckStr = REMOVE$(CheckStr,ttt$)
NEXT
LOCAL k1&,k2&
' locate unknown words or characters
FOR i = 1 TO LEN(CheckStr)
IF INSTR("0123456789ED.-+*/\^!()=<>", MID$(CheckStr,i,1)) = 0 THEN
IF k1&=0 THEN k1& = i : k2& = i
IF k1&>0 THEN k2& = i
END IF
NEXT
IF k1&>0 THEN ErrorMes = "Cannot understand this: " + MID$(CheckStr,k1&,k2&-k1&+1) + " Please correct. " : GOTO ExitOnError
'
' 2. Check syntax.
' This part is heavily inspired by a fine code by Tony Burcham. Thank you.
CheckStr = InString
REPLACE "PI#" WITH "1.1" IN CheckStr ' Temporary replacememt
REPLACE "E#" WITH "11" IN CheckStr ' Temporary replacememt
' Replace function name letters with F and logical functions with L
FOR i = 1 TO UBOUND(CheckArr)
ttt$ = CheckArr(i)
ccc& = INSTR(ttt$,"()")
IF ISTRUE ccc& THEN ttt$ = LEFT$(ttt$,ccc&-1)
IF INSTR(CheckStr,ttt$) THEN REPLACE ttt$ WITH STRING$(LEN(ttt$),"F") IN CheckStr
NEXT
FOR i = 1 TO UBOUND(CheckArr)
ttt$ = CheckArr(i)
ccc& = INSTR(ttt$," ")
IF ISTRUE ccc& THEN ttt$ = LEFT$(ttt$,ccc&-1)
IF INSTR(CheckStr,ttt$) THEN REPLACE ttt$ WITH STRING$(LEN(ttt$),"L") IN CheckStr
NEXT
' Make map string and detect any bad characters
REPLACE ANY "0123456789ED-/\^" WITH "##########EE+***" IN CheckStr
LOCAL posi&,Er&
i = VERIFY(CheckStr,"#.+*EFL()<>=!")
IF i THEN ErrorMes = "Illegal character: " + MID$(Instring,i,1) + " Please correct. " : GOTO ExitOnError
' Scan for illegal sequences
LOCAL bad AS STRING, pc&
'bad = " () (* )F )E )# +) +* +E *) ** *E F) F+ F* F. F# FE .( .. .F .E #( #F E( E) E* EF E. EE !# F! L) L+ L* L. LE .L EL L!"
bad = "()(*)F)E)#+)+*+E*)***EF)F+F*F.F#FE.(...F.E#(#FE(E)E*EFE.EE!#F!L)L+L*L.LE.LELL!" 'compressed version of above
FOR i = 1 TO LEN(bad) STEP 2
pc = INSTR(CheckStr, MID$(bad,i,2))
IF pc THEN ErrorMes = "Illegal character sequence: " + MID$(Instring,pc,2) + " Please correct. " : GOTO ExitOnError
NEXT
' check end of string
IF INSTR("+*FEL", RIGHT$(CheckStr, 1 )) THEN ErrorMes = "Illegal last character: " + RIGHT$(Instring,1) + " Please correct. " : GOTO ExitOnError
' since "*+" and "++" are allowed, we have
' to check for operator triplets
REPLACE "*" WITH "+" IN CheckStr
pc = INSTR(CheckStr, "+++")
IF pc THEN ErrorMes = "Illegal character sequence: " + MID$(Instring,pc,3) + " Please correct. " : GOTO ExitOnError
'
' checking OK, so continue to prepare expression for parsing
REPLACE "PI#" WITH "3.14159265358979324" IN Instring
REPLACE "E#" WITH "2.71828182845904524" IN Instring
'
REPLACE "LN" WITH "LOG" IN Instring ' LOG is used for LN in the parsing
'
REPLACE "LOG10" WITH "CLG" IN Instring ' to avoid confusing numbers
REPLACE "LOG2" WITH "TLG" IN Instring ' to avoid confusing numbers
REPLACE "EXP10" WITH "ETE" IN Instring ' to avoid confusing numbers
REPLACE "EXP2" WITH "ETO" IN Instring ' to avoid confusing numbers
REPLACE "MOD" WITH CHR$(254) IN InString
'
'if
'
REPLACE "XOR" WITH CHR$(222) IN Instring ' to avoid confusion with OR
REPLACE "OR" WITH CHR$(223) IN Instring ' to avoid confusion with XOR
REPLACE "NOT" WITH CHR$(247) IN Instring
REPLACE "ISTRUE" WITH CHR$(215) IN Instring
REPLACE "ISFALSE" WITH CHR$(182) IN Instring
'
REPLACE "<>" WITH CHR$(174) IN Instring ' one-character code for <>
REPLACE "><" WITH CHR$(174) IN Instring
REPLACE ">=" WITH CHR$(169) IN Instring ' one-character code for >=
REPLACE "=>" WITH CHR$(169) IN Instring
REPLACE "<=" WITH CHR$(167) IN Instring ' one-character code for <=
REPLACE "=<" WITH CHR$(167) IN Instring
'
FirstTime = %FALSE
END IF
'
' Check parentheses
IF TALLY(InString, "(") <> TALLY(InString, ")") THEN ErrorMes = "Parentheses mismatch" : GOTO ExitOnError
'
' Priority 1.
' Evaluate parentheses ( )
' Evaluate each parenthesis in turn.
DO
Plc = INSTR(1 + Plc, InString, "(") ' find left parenthesis
IF Plc THEN
EndPl = FindMatch(MID$(InString, Plc)) ' find matching right parenthesis
IF EndPl = 2 THEN ErrorMes = "Empty parenthesis" : GOTO ExitOnError
SaveExpr = MID$(InString, Plc + 1, EndPl - 2) ' Expression in between
Owner = LTRIM$(STR$(VAL(SaveExpr),18))
IF (SaveExpr = Owner) OR (SaveExpr = "+" & Owner) OR (SaveExpr = Owner + "!" ) THEN ' this part fully evaluated or just needs calculation of factorial
IF RIGHT$(SaveExpr,1) = "!" THEN Owner = Owner +"!" ' Keep any ! sign for proper evaluation of Factorial
InString = LEFT$(InString, Plc - 1) & Owner & MID$(InString, Plc + EndPl)
ELSE ' this part not fully evaluated
ExprVal = Eval(SaveExpr) ' evaluate expression - recursive call
' insert evaluated part in proper place
InString = LEFT$(InString, Plc - 1) & LTRIM$(STR$(ExprVal,18)) & MID$(InString, Plc + EndPl)
END IF
ELSE
EXIT DO
END IF
LOOP
'
' Remove multiple signs which may occur after evaluation of parentheses.
REPLACE "++" WITH "+" IN Instring
REPLACE "-+" WITH "-" IN Instring
REPLACE "+-" WITH "-" IN Instring
REPLACE "--" WITH "+" IN Instring
'
Tmp = LTRIM$(STR$(VAL(InString),18))
'
' Finished or not ?
IF (Tmp = InString) OR ("+" & Tmp = InsTring) GOTO ExitOk
'
' Priority 2.
' Evaluate UNARY operators
'
' calculate factorials
DO
Pl = INSTR(InString, "!")
IF Pl THEN
RitWing = MID$(InString, Pl + 1)
GOSUB GetLeftWing
IF LftWingVal <> FIX(LftWingVal) THEN ErrorMes = "Invalid factorial argument: Non integer." : GOTO ExitOnError
IF ABS(LftWingVal) > 1754 THEN ErrorMes = "Factorial argument too large." : GOTO ExitOnError
LOCAL flg3& : flg3 = 1
IF LftWingVal < 0 THEN LftWingVal = ABS(LftWingVal) : flg3 = -1
LOCAL FAC## : FAC## = Factorial##(CLNG(LftWingVal)) * flg3
InString = LftWing & LTRIM$(STR$(FAC##,18)) & RitWing
LftWing = "": RitWing = ""
ELSE
EXIT DO
END IF
LOOP
'
' Priority 3:
' Calculate built-in and some extra one argument functions:
'
' Angles measured in degrees ?
LOCAL res&
CONTROL SEND hForm1&,%RadioButtonDegrees,%BM_GETCHECK,0,0 TO res&
'
FOR i = 1 TO UBOUND(Trig)
DO
Pl = INSTR(InString, Trig(i))
IF Pl THEN
LftWing = LEFT$(InString, Pl - 1) ' string prior to function
Pl = Pl + LEN(Trig(i)) - 1 ' place at start of argument
'
GOSUB GetRightWing : X = RitWingVal ' Get argument
'
' If Angles measured in degrees - then transform to radians (only for non-inverse trig functions).
' Inverse trig-(ARC)functions will always be returned in radians.
IF res&=%BST_CHECKED AND i<= 22 AND i>=12 THEN X = X * 1.74532925199432958E-2
'
SELECT CASE i
CASE 1: Result = LOG(X + SQR(X * X + 1)) ' ARCSINH
CASE 2: IF X < 1 THEN ErrorMes = "Argument outside range for ARCCOSH" :GOTO ExitOnError
IF LOG(X)>5678 THEN ErrorMes = "Argument too large for ARCCOSH. Will give overflow" :GOTO ExitOnError
Result = LOG(X + SQR(X * X - 1)) ' ARCCOSH
CASE 3: IF ABS(X)>=1 THEN ErrorMes = "Argument outside range for ARCTANH" :GOTO ExitOnError
Result = LOG((1 + X) / (1 - X)) / 2 ' ARCTANH
CASE 4: IF (X<=0 OR X>1) THEN ErrorMes = "Argument outside range for ARCSECH" :GOTO ExitOnError
Result = LOG((SQR(-X * X + 1) + 1) / X) ' ARCSECH
CASE 5: IF LOG(X)>5678 THEN ErrorMes = "Argument too large for ARCCSCH. Will give overflow" :GOTO ExitOnError
Result = LOG((SGN(X) * SQR(X * X + 1) + 1) / X) ' ARCCSCH
CASE 6: IF ABS(X)<=1 THEN ErrorMes = "Argument outside range for ARCCOTH" :GOTO ExitOnError
Result = LOG((X + 1) / (X - 1)) / 2 ' ARCCOTH
CASE 7: IF ABS(X)>1 THEN ErrorMes = "Argument outside range for ARCSIN" :GOTO ExitOnError
Result = ATN(X / SQR(-X * X + 1)) ' ARCSIN
CASE 8: IF ABS(X)>1 THEN ErrorMes = "Argument outside range for ARCCOS" :GOTO ExitOnError
Result = -ATN(X / SQR(-X * X + 1)) + 1.57079632679489662 ' ARCCOS
CASE 9: IF ABS(X)<1 THEN ErrorMes = "Argument outside range for ARCSEC" :GOTO ExitOnError
IF LOG(X)>5678 THEN ErrorMes = "Argument too large for ARCSEC. Will give overflow" :GOTO ExitOnError
Result = ATN(X / SQR(X * X - 1)) + SGN(X - 1) * 1.57079632679489662 ' ARCSEC
CASE 10:IF ABS(X)<1 THEN ErrorMes = "Argument outside range for ARCCSC" :GOTO ExitOnError
IF LOG(X)>5678 THEN ErrorMes = "Argument too large for ARCCSC. Will give overflow" :GOTO ExitOnError
Result = ATN(X / SQR(X * X - 1)) + (SGN(X) - 1) * 1.57079632679489662 ' ARCCSC
CASE 11:Result = ATN(X) + 1.57079632679489662 ' ARCCOT
CASE 12:IF ABS(X)>11356 THEN ErrorMes = "Argument too large for SINH. Will give overflow. " :GOTO ExitOnError
Result = (EXP(X) - EXP(-X)) / 2 ' SINH
CASE 13:IF ABS(X)>11356 THEN Result = SGN(X) : EXIT SELECT
Result = (EXP(X) - EXP(-X)) / (EXP(X) + EXP(-X)) ' TANH
CASE 14:IF ABS(X)>11356 THEN Result = 0 : EXIT SELECT
Result = 2 / (EXP(X) + EXP(-X)) ' SECH
CASE 15:IF X=0 THEN ErrorMes = "Argument for CSCH is zero." :GOTO ExitOnError
Result = 2 / (EXP(X) - EXP(-X)) ' CSCH
CASE 16:IF X=0 THEN ErrorMes = "Argument for COTH is zero." :GOTO ExitOnError
IF ABS(X)>11356 THEN Result = SGN(X) : EXIT SELECT
Result = (EXP(X) + EXP(-X)) / (EXP(X) - EXP(-X)) ' COTH
CASE 17:IF COS(X)=0 THEN ErrorMes = "SEC is not defined for this argument." :GOTO ExitOnError
Result = 1 / COS(X) ' SEC
CASE 18:IF SIN(X)=0 THEN ErrorMes = "CSC is not defined for this argument." :GOTO ExitOnError
Result = 1 / SIN(X) ' CSC
CASE 19:IF TAN(X)=0 THEN ErrorMes = "COT is not defined for this argument." :GOTO ExitOnError
Result = 1 / TAN(X) ' COT
CASE 20:Result = SIN(X)
CASE 21:Result = COS(X)
CASE 22:Result = TAN(X)
CASE 23:Result = ATN(X)
CASE 24:IF X <= 0 THEN ErrorMes = "LN or LOG <= 0" : GOTO ExitOnError
Result = LOG(X)
CASE 25:IF ABS(X)>11356 THEN ErrorMes = "Argument too large for EXP. Will give overflow. " :GOTO ExitOnError
Result = EXP(X)
CASE 26:IF X < 0 THEN ErrorMes = "Square Root < 0" :GOTO ExitOnError
Result = SQR(X)
CASE 27:IF X <= 0 THEN ErrorMes = "LOG10 <= 0" :GOTO ExitOnError
Result = LOG10(X)
CASE 28:Result = ABS(X)
CASE 29:IF X <= 0 THEN ErrorMes = "LOG2 <= 0" :GOTO ExitOnError
Result = LOG2(X)
CASE 30:Result = CEIL(X)
CASE 31:Result = FIX(X)
CASE 32:Result = FRAC(X)
CASE 33:Result = SGN(X)
CASE 34:IF ABS(X)>16383 THEN ErrorMes = "Argument too large for EXP2. Will give overflow. " :GOTO ExitOnError
Result = EXP2(X)
CASE 35:IF ABS(X)>4932 THEN ErrorMes = "Argument too large for EXP10. Will give overflow. " :GOTO ExitOnError
Result = EXP10(X)
END SELECT
' Update InString with result and reset helper variables.
InString = LftWing + LTRIM$(STR$(Result,18)) + RitWing
GOSUB CleanUpVar
ELSE
EXIT DO
END IF
LOOP
NEXT
'
' Priority 4:
' calculate exponentiation (^) (power expressions)
DO
Pl = INSTR(InString, "^")
IF Pl = 1 THEN
ErrorMes = "Missing left argument in power espression" : GOTO ExitOnError
ELSEIF Pl > 1 THEN
GOSUB GetLeftWing : GOSUB GetRightWing
IF LftWingVal>1 AND ABS(RitWingVal*LOG(LftWingVal))>11356 THEN ErrorMes = "Arguments too large for exponentiation. Will give overflow." :GOTO ExitOnError
IF LftWingVal<0 AND FRAC(RitWingVal)<>0 THEN ErrorMes = "Exponentiation problem: Negative root is not allowed with a non-integer exponent." :GOTO ExitOnError
Block = LTRIM$(STR$(LftWingVal ^ RitWingVal,18))
InString = LftWing & Block & RitWing
IF Block = InString THEN GOSUB CleanUpVar : GOTO ExitOk ' fully evaluated
ELSE
EXIT DO
END IF
LOOP
'
' Priority 5:
' Perform multiplication (*) and floating-point division (/)
DO
InStrLen = LEN(InString)
Mult = INSTR(InString, "*") : IF ISFALSE Mult THEN Mult = InStrLen
Div = INSTR(InString, "/") : IF ISFALSE Div THEN Div = InStrLen
Pl = MIN(Mult, Div)
IF Pl = InstrLen THEN Pl = 0
IF Pl = 1 THEN
ErrorMes = "Missing left argument in multiplication (*) or floating-point division (/)" : GOTO ExitOnError
ELSEIF Pl > 1 THEN
GOSUB GetLeftWing : GOSUB GetRightWing
IF Pl = Mult THEN
IF LOG(ABS(LftWingVal)) + LOG(ABS(RitWingVal)) > 11356 THEN ErrorMes = "Arguments too large for multiplication. Will give overflow" :GOTO ExitOnError
result = LftWingVal * RitWingVal
ELSEIF Pl = Div THEN
IF RitWingVal = 0 THEN ErrorMes = "Division by zero" : GOTO ExitOnError
result = LftWingVal / RitWingVal
END IF
Block = LTRIM$(STR$(result,18))
InString = LftWing & Block & RitWing
IF Block = InString THEN GOSUB CleanUpVar : GOTO ExitOk
ELSE
EXIT DO
END IF
LOOP
'
' Priority 6:
' Perform integer division (\)
DO
InStrLen = LEN(InString)
Pl = INSTR(InString, "\")
IF Pl = InstrLen THEN Pl = 0
IF Pl = 1 THEN
ErrorMes = "Missing left argument in integer division (\)" : GOTO ExitOnError
ELSEIF Pl > 1 THEN
GOSUB GetLeftWing : GOSUB GetRightWing
IF RitWingVal = 0 THEN ErrorMes = "Integer Division by zero" : GOTO ExitOnError
result = LftWingVal \ RitWingVal
Block = LTRIM$(STR$(result,18))
InString = LftWing & Block & RitWing
IF Block = InString THEN GOSUB CleanUpVar : GOTO ExitOk
ELSE
EXIT DO
END IF
LOOP
'
' Priority 7:
' Perform modulo (MOD) operation
DO
InStrLen = LEN(InString)
Pl = INSTR(InString, CHR$(254))
IF Pl = InstrLen THEN Pl = 0
IF Pl = 1 THEN
ErrorMes = "Missing left argument in MOD expression" : GOTO ExitOnError
ELSEIF Pl > 1 THEN
GOSUB GetLeftWing : GOSUB GetRightWing
IF RitWingVal = 0 THEN ErrorMes = "Division by zero in MOD expression" : GOTO ExitOnError
result = LftWingVal MOD RitWingVal
Block = LTRIM$(STR$(result,18))
InString = LftWing & Block & RitWing
IF Block = InString THEN GOSUB CleanUpVar : GOTO ExitOk
ELSE
EXIT DO
END IF
LOOP
'
' Priority 8:
' Perform addition (+) and subtraction (-)
'
DO
PExp = 2: MExp = 1: InstrLen = LEN(InString)
PlusFind:
PAdd = INSTR(PExp, InString, "+")
IF Padd THEN
De = MID$(InString, PAdd - 1, 1)
IF (De = "D") OR (De = "E") THEN
PExp = Padd + 1
GOTO PlusFind
END IF
ELSE
PAdd = InstrLen
END IF
'
MinusFind:
INCR TicTac
IF TicTac = InstrLen + 1 GOTO RelationalOp
PSub = INSTR(MExp, InString, "-")
IF Psub = 1 THEN
IF LEN(STR$(VAL(InString),18)) = InstrLen GOTO ExitOk
MExp = 2
GOTO MinusFind
END IF
IF PSub THEN
De = MID$(InString, PSub - 1, 1)
IF De < "0" OR De > "9" THEN
MExp = PSub + 1
GOTO MinusFind
END IF
ELSE
Psub = InstrLen
END IF
Pl = MIN(PAdd, PSub)
IF Pl = InstrLen THEN Pl = 0
IF Pl THEN
GOSUB GetLeftWing : GOSUB GetRightWing
IF Pl = PAdd THEN
Result = LftWingVal + RitWingVal
ELSEIF Pl = PSub THEN
result = LftWingVal - RitWingVal
END IF
TicTac = 0
Block = LTRIM$(STR$(Result,18))
InString = LftWing & Block & RitWing
IF Block = InString OR InString = "-1=-1" THEN GOSUB CleanUpVar : GOTO ExitOk
ELSE
EXIT DO
END IF
LOOP
'
' Priority 9:
' Evaluate relational operators (<, <=, =, >=, >, <> )
'
RelationalOp:
DO
InStrLen = LEN(InString)
P1 = INSTR(InString, "=") : IF P1 = 0 THEN P1 = InStrLen
P2 = INSTR(InString, ">") : IF P2 = 0 THEN P2 = InStrLen
P3 = INSTR(InString, "<") : IF P3 = 0 THEN P3 = InStrLen
'
P4 = INSTR(InString, CHR$(174)) : IF P4 = 0 THEN P4 = InStrLen ' <>
P5 = INSTR(InString, CHR$(169)) : IF P5 = 0 THEN P5 = InStrLen ' >=
P6 = INSTR(InString, CHR$(167)) : IF P6 = 0 THEN P6 = InStrLen ' <=
'
Pl = MIN(P1, P2, P3, P4, P5, P6)
IF Pl = InStrLen THEN EXIT DO
IF Pl = 1 THEN
ErrorMes = "No left argument in relational expression" : GOTO ExitOnError
ELSEIF Pl > 1 THEN
GOSUB GetLeftWing : GOSUB GetRightWing
SELECT CASE Pl
CASE P1 : Result = LftWingVal = RitWingVal
CASE P2 : Result = LftWingVal > RitWingVal
CASE P3 : Result = LftWingVal < RitWingVal
CASE P4 : Result = LftWingVal <> RitWingVal
CASE P5 : Result = LftWingVal >= RitWingVal
CASE P6 : Result = LftWingVal <= RitWingVal
END SELECT
Block = LTRIM$(STR$(Result,18))
InString = LftWing & Block & RitWing
IF Block = InString THEN GOSUB CleanUpVar : GOTO ExitOk
ELSE
EXIT DO
END IF
LOOP
'
' Priority 10:
' Evaluate NOT, ISFALSE and ISTRUE
LOCAL Pnot&,Pisfalse&,Pistrue&
DO
InStrLen = LEN(InString)
Pnot = INSTR(InString, CHR$(247)) : IF Pnot = 0 THEN Pnot = InStrLen
Pisfalse = INSTR(InString, CHR$(182)) : IF Pisfalse = 0 THEN Pisfalse = InStrLen
Pistrue = INSTR(InString, CHR$(215)) : IF Pistrue = 0 THEN Pistrue = InStrLen
Pl = MIN(Pnot, Pisfalse, Pistrue)
IF Pl = InStrLen THEN EXIT DO
IF Pl THEN
GOSUB GetRightWing
IF Pl = Pnot THEN
result = NOT RitWingVal
ELSEIF Pl = Pisfalse THEN
result = ISFALSE RitWingVal
ELSEIF Pl = Pistrue THEN
result = ISTRUE RitWingVal
END IF
InString = LftWing & LTRIM$(STR$(Result,18)) & RitWing
LftWing = "": Numeric = "": RitWing = ""
ELSE
EXIT DO
END IF
LOOP
' Priority 11:
' Evaluate AND
DO
Pl = INSTR(InString, "AND")
IF Pl = 1 THEN
ErrorMes = "No left argument in AND expression" : GOTO ExitOnError
ELSEIF Pl > 1 THEN
GOSUB GetLeftWing
Pl = Pl + 2
GOSUB GetRightWing
Result = LftWingVal AND RitWingVal
InString = LftWing & LTRIM$(STR$(Result,18)) & RitWing
LftWing = "": Numeric = "": RitWing = ""
ELSE
EXIT DO
END IF
LOOP
' '
' Priority 12:
' Evaluate OR and XOR (exclusive OR)
LOCAL Por&,Pxor&
DO
InStrLen = LEN(InString)
Por = INSTR(InString, CHR$(223)) : IF Por = 0 THEN Por = InStrLen
Pxor = INSTR(InString, CHR$(222)) : IF Pxor = 0 THEN Pxor = InStrLen
Pl = MIN(Por, Pxor)
IF Pl = InStrLen THEN EXIT DO
IF Pl = 1 THEN
ErrorMes = "No left argument in OR or XOR expression" : GOTO ExitOnError
ELSEIF Pl > 1 THEN
GOSUB GetLeftWing : GOSUB GetRightWing
IF Pl = Por THEN
result = LftWingVal OR RitWingVal
ELSEIF Pl = Pxor THEN
result = LftWingVal XOR RitWingVal
END IF
InString = LftWing & LTRIM$(STR$(Result,18)) & RitWing
LftWing = "": Numeric = "": RitWing = ""
ELSE
EXIT DO
END IF
LOOP
'
' Priority 13:
' Evaluate EQV (equivalence)
DO
Pl = INSTR(InString, "EQV")
IF Pl = 1 THEN
ErrorMes = "No left argument in EQV expression" : GOTO ExitOnError
ELSEIF Pl > 1 THEN
GOSUB GetLeftWing
Pl = Pl + 2
GOSUB GetRightWing
Result = LftWingVal EQV RitWingVal
InString = LftWing & LTRIM$(STR$(Result,18)) & RitWing
LftWing = "": Numeric = "": RitWing = ""
ELSE
EXIT DO
END IF
LOOP
'
' Priority 14:
' Evaluate IMP (implication)
DO
Pl = INSTR(InString, "IMP")
IF Pl = 1 THEN
ErrorMes = "No left argument in IMP expression" : GOTO ExitOnError
ELSEIF Pl > 1 THEN
GOSUB GetLeftWing
Pl = Pl + 2
GOSUB GetRightWing
Result = LftWingVal IMP RitWingVal
InString = LftWing & LTRIM$(STR$(Result,18)) & RitWing
LftWing = "": Numeric = "": RitWing = ""
ELSE
EXIT DO
END IF
LOOP
'
'
ExitOk:
FUNCTION = VAL(InString)
ErrorTxt = ""
EXIT FUNCTION
'
ExitOnError:
ErrorTxt = " Error in Expression: " + ErrorMes
FUNCTION = 0
EXIT FUNCTION
'
'
GetLeftWing:
' Get left wing and left argument
Valid = "1234567890.-+DE"
BEGIN = Pl
DO
ValidVal = 1
DECR BEGIN
P = INSTR(Valid, MID$(InString, BEGIN, 1))
IF P THEN
IF ((P = 12) _ ' -
OR (P = 13)) _ ' +
AND (Sign = 0) _ ' no sign yet
AND (BEGIN > 1) _
THEN
IF INSTR("1234567890.", MID$(InString, BEGIN - 1, 1)) THEN ' ~ if not D or E
ValidVal = 0: INCR BEGIN
END IF
Sign = -1 ' Sign flag true
ELSEIF (P = 14) _ ' D
OR (P = 15) _ ' E
THEN
Sign = 0: Valid = "1234567890.-+" ' D and E no more valid
ELSEIF P > 11 THEN
ValidVal = 0
IF Sign THEN INCR BEGIN
END IF
ELSE
ValidVal = 0: INCR BEGIN
END IF
LOOP WHILE (ValidVal = 1) AND (BEGIN > 1)
LftWing = LEFT$(InString, BEGIN - 1) ' left wing prior to LftWingVal
LftWingVal = VAL(MID$(InString, BEGIN, Pl - BEGIN)) ' left wing value
IF Pl = BEGIN THEN ErrorMes = "Invalid left argument" : GOTO ExitOnError
RETURN
'
'
GetRightWing:
' Get right wing and right argument
RitWing = MID$(InString, Pl + 1) ' right wing
IF LEN(RitWing) <= 0 THEN ErrorMes = "No right argument" : GOTO ExitOnError
RitWingVal = VAL(RitWing) ' Value of (first part of) right wing
IF RitWing = LTRIM$(STR$(RitWingVal,18)) THEN ' fully evaluated
RitWing = ""
GOTO FinishRightBlock
END IF
LastDigit = 1: LastDigOld = 0: EX = 0: DP = 0
RitWingLen = LEN(RitWing)
DO WHILE LastDigit <= RitWingLen
Digit = MID$(RitWing, LastDigit, 1)
IF LastDigit = 1 THEN ' sign position
IF INSTR("+-", Digit) THEN
IF (SGN(RitWingVal) = 1) AND (Digit = "+") THEN
INCR LastDigit
ELSEIF (SGN(RitWingVal) = -1) AND (Digit = "-") THEN
INCR LastDigit
ELSE
EXIT DO
END IF
END IF
END IF
' Get valid number
IF INSTR("1234567890", Digit) THEN
INCR LastDigit
ELSEIF Digit = "." THEN
IF Dp = 0 THEN INCR LastDigit: Dp = 1
ELSEIF INSTR("DE", Digit) THEN
IF Ex = 0 THEN INCR LastDigit: Ex = 1
ELSEIF (INSTR("+-", Digit) <> 0) AND (INSTR("DE", MID$(RitWing, MAX(1, LastDigit - 1), 1)) <> 0) THEN
INCR LastDigit
END IF
IF LastDigit = LastDigOld THEN EXIT DO
LastDigOld = LastDigit
LOOP
RitWing = MID$(RitWing, LastDigit)
'
FinishRightBlock:
P = 0
BEGIN = P
Sign = P
LastDigit = P
LastDigOld = P
RitWingLen = P
Ex = P
Dp = P
Valid = ""
Digit = ""
RETURN
'
CleanUpVar:
LftWing = "": Numeric$ = "": RitWing = ""
RitWingVal = 0: Result = 0 : X = 0
LftWingVal = 0
Block = "" : De = ""
RETURN
END FUNCTION ' Eval
'
CALLBACK FUNCTION CBF_HelpExit
DIALOG END hHelpForm&
END FUNCTION
' ------------------------------------------------
SUB ShowHelpText(BYVAL hForm1&) ' make and display help form
LOCAL tt AS STRING
tt="This latest improved version of the math parser or interpreter includes a better interphase, more facilities, and more functions "+ _
"as well as error checking. "+$CRLF+$CRLF+ _
"By performing the calculations using extended-precision floating-point numbers, 18 digits of precision is obtained. Factorials "+ _
"up to 1754! can now be handled without overflow. "+$CRLF+$CRLF+ _
"A number of constants "+ _
"and conversions are available, making this math evaluator an advanced "+ _
"scientific calculator. Constants can stand alone, but conversions should always be preceeded by a number or numerical expression to work correctly."+$CRLF+$CRLF+ _
"You can easily add your own functions, constants "+ _
"and conversions to the source code."+$CRLF+$CRLF+ _
"Input of angles can be in degrees and "+ _
"radians. However, trigonometric output using the ARC functions will "+ _
"always be in radians, but you can always transform angles to radians and vice versa "+ _
"using the built-in conversions."+$CRLF+$CRLF+ _
"Input of your math expression can be done "+ _
"using the keyboard or by clicking the items in the list boxes. "+$CRLF+$CRLF+ _
"Expressions and functions should be entered strictly according to standard "+ _
"algebraic syntax rules. Operators and expressions which can be used are: "+ _
"+ - * / \ ^ ! ( ) < = > <> >= <= in addition to those shown "+ _
"in the large list box. "+$CRLF+$CRLF+ _
"The Operator Precedence follows as closely as possible that used by PowerBasic - see the section on ""Operator Precedence"" in the PowerBasic help file. "+ _
"The only exception is the unary negation operator which in this program does not have a special priority following exponentiation. "+ _
"However, operations inside parentheses always have the highest priority and are always evaluated first. "+ _
"Thus by using parentheses in the right places you can always obtain the operator precedence you need for your purpose. "+$CRLF+$CRLF+ _
"The following operator precedence is used: "+$CRLF+ _
"1. parentheses ( )"+$CRLF+ _
"2. unary operators (factorials (!) )"+$CRLF+ _
"3. one argument functions"+$CRLF + _
"4. exponentiation (^) (power expressions)"+$CRLF + _
"5. multiplication (*) and floating-point division (/)"+$CRLF + _
"6. integer division (\)"+$CRLF + _
"7. modulo (MOD)"+$CRLF + _
"8. addition (+), subtraction (-)"+$CRLF + _
"9. relational operators (<, <=, =, >=, >, <> )"+$CRLF + _
"10. NOT, ISFALSE and ISTRUE"+$CRLF + _
"11. AND"+$CRLF + _
"12. OR and XOR (exclusive OR)"+$CRLF+ _
"13. EQV (equivalence)"+$CRLF + _
"14. IMP (implication)"+$CRLF+$CRLF+ _
"Many thanks to Gafny Jacob, who provided the original code, which has "+ _
"been considerably changed and improved. Thanks to Achilles B. Mina "+ _
"for free to use code concerning conversions and constants. Thanks "+ _
"to Tony Burcham and Gunar Zagars for valuable contributions "+ _
"concerning error checking and overflow indication. Also many thanks to "+ _
"the whole PowerBasic forum for great inspiration. "+$CRLF+$CRLF+ _
"Good luck! -- June 29, 2005 -- Erik Christensen -- [email protected]"
LOCAL Style&
Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_SYSMENU OR %DS_CENTER
DIALOG NEW hForm1&, "Math Evaluator Help", , , 300*CF, 200*CF, Style&, TO hHelpForm&
CONTROL ADD BUTTON, hHelpForm&, %HelpExitButton, "E&xit", 260*CF, 184*CF, 37*CF, 12*CF, _
%WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_HelpExit
CONTROL ADD TEXTBOX, hHelpForm&, %HelpText,tt, 3*CF, 3*CF, 294*CF,176*CF, _
%WS_CHILD OR %WS_VISIBLE OR %ES_MULTILINE OR %WS_VSCROLL OR %ES_READONLY OR %ES_LEFT OR %WS_TABSTOP, %WS_EX_CLIENTEDGE
CONTROL SET COLOR hHelpForm&,%HelpText, RGB(0,0,255), RGB(255,255,255)
CONTROL SEND hHelpForm&,%HelpText,%WM_SETFONT,GetStockObject(%SYSTEM_FONT),%TRUE
DIALOG SHOW MODAL hHelpForm&
END SUB
' ------------------------------------------------
CALLBACK FUNCTION CBF_FORM1_BUTTONHELP
CALL ShowHelpText(hForm1&)
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
END FUNCTION
' ------------------------------------------------
CALLBACK FUNCTION CBF_FORM1_BUTTONABOUT
LOCAL St AS STRING
St="Math expression evaluator with built-in constants and conversions for PBWin70. Program version 1.41 - June 29, 2005"+$CRLF+$CRLF+ _
"By Erik Christensen, Copenhagen, Denmark [email protected]"+$CRLF+$CRLF+ _
"The use of this Public Domain program and its consequences are your own responsibility. However, any comment you may have is welcome."+$CRLF+$CRLF+ _
"Good Luck!"
MSGBOX St,%MB_ICONINFORMATION,"About this program"
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
END FUNCTION
'
CALLBACK FUNCTION SubClassEditKeys
' Subclass callback function for processing key messages in edit control (textbox).
SELECT CASE CBMSG
CASE %WM_GETDLGCODE
FUNCTION = %DLGC_WANTALLKEYS: EXIT FUNCTION
CASE %WM_CHAR ' Any character key at time of pressing
SELECT CASE CBWPARAM ' Holds the code of the key.
' Specify what action should be taken for each key code.
CASE 65 TO 90, 97 TO 122 ' character signs A-Z and a-z
LOCAL txt$,Res&
txt$ = UCASE$(CHR$(CBWPARAM))
IF ISTRUE(LOWRD(GetKeyState(%VK_SHIFT)) AND &H8000) THEN
' If SHIFT is pressed while character key is
' pressed, then scroll listbox to show items
' beginning with that character.
' (This is better than using "GetAsyncKeyState")
LOCAL flag& : flag = 0
DO ' This loop serves to scroll to item just above any
' missing first letter in the list box, e.g. J at present.
CONTROL SEND hForm1&,%FORM1_LISTBOX1,%LB_SELECTSTRING,-1, STRPTR(txt$) TO Res&
IF Res& = %LB_ERR THEN txt$ = CHR$(ASC(txt$)+1) : flag = 1 ' First letter missing - move on to next letter
LOOP UNTIL Res&<>%LB_ERR OR txt$ >= "Z"
IF Res&<>%LB_ERR THEN CONTROL SEND hForm1&,%FORM1_LISTBOX1,%LB_SETTOPINDEX,Res& - flag,0
CONTROL SEND hForm1&,%FORM1_LISTBOX1,%LB_SETCURSEL,-1,0 ' deselect any item
ListFlag = 1 ' set flag for removing this character from expression textbox.
END IF
CASE %VK_RETURN ' 13 ' ENTER pressed
ListFlag = 0
CALL analysis
EXIT FUNCTION
CASE ELSE ' No action to be taken here for the other keys.
ListFlag = 0
END SELECT
CASE ELSE
ListFlag = 0
END SELECT
' Pass the message on to the original window procedure... the DDT engine!
FUNCTION = CallWindowProc(gOldSubClassEdit&, CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
END FUNCTION
'
CALLBACK FUNCTION CBF_FORM1_CLEAREXPRESSION
CONTROL SET TEXT hForm1&,%FORM1_TEXTFORMULA, ""
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
FUNCTION = %TRUE
END FUNCTION
'
CALLBACK FUNCTION CBF_FORM1_BUTTONDOANALYSIS
CALL analysis
FUNCTION = %TRUE
END FUNCTION
'
CALLBACK FUNCTION CBF_FORM1_BUTTONEXIT
LOCAL res&
res&=MSGBOX ("Are you sure?",%MB_YESNO OR %MB_ICONQUESTION ,"End?")
IF res&=%IDYES THEN DIALOG END hForm1&
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
END FUNCTION
'
SUB analysis
STATIC t AS STRING,t1 AS SINGLE,t2 AS SINGLE
LOCAL hCtl&,t3$,ii&, i&, k&
LOCAL Test$,LineCount&,FirstVisLine&,Res&,NN AS EXT
STATIC Number&, NotFirst&
'
' Added June 10, 2005
DIM OpLog(1 TO 8) AS STATIC STRING
IF ISFALSE NotFirst THEN
DATA "NOT","ISFALSE","ISTRUE","AND","OR","XOR","EQV","IMP"
FOR i = 1 TO 8
OpLog(i) = READ$(i)
NEXT
NotFirst& = %TRUE
END IF
'
FirstTime = %TRUE
CONTROL SEND hForm1&, %FORM1_TEXTFORMULA,%EM_SETSEL,0,-1 ' select all text
CONTROL GET TEXT hForm1&, %FORM1_TEXTFORMULA TO Test$
' CONTROL SEND hForm1&, %FORM1_TEXTFORMULA,%EM_SETSEL,0,-1
' CONTROL SEND hForm1&, %FORM1_TEXTFORMULA,%EM_SETSEL,-1,0 ' deselect all text. Put caret at the end
INCR Number&
t = t + "Evaluation "+STR$(Number&)+$CRLF
' t1 = TIMER ' START TIME
t = t + "Expression: " + Test$
'
' Replace text with numeric expressions for conversions or constants
FOR ii& = 0 TO NoEx
IF INSTR(Test$,Extra(0,ii&)) THEN
REPLACE Extra(0,ii&) WITH Extra(1,ii&) IN Test$
Test$ = REMOVE$(Test$," ")
REPLACE "**" WITH "*" IN Test$
END IF
NEXT
'
' insert extra parentheses to ensure correct evaluation of logical expressions (June 10, 2005)
Test$ = UCASE$(Test$)
Test$ = REMOVE$(Test$," ")
Test$ = "(" + Test$ + ")"
FOR i = 1 TO 8
k = 1
DO
k = INSTR(k, Test$, OpLog(i))
IF ISTRUE k THEN Test$ = STRINSERT$(Test$, "(", k + LEN(OpLog(i))) : Test$ = STRINSERT$(Test$, ")", k) : k = k + 3
LOOP UNTIL ISFALSE k
NEXT
'
Test$ = REMOVE$(Test$, "()") ' added June 29, 2005
t3$ = STR$(Eval(Test$),18)
t = t + ErrorTxt + $CRLF
IF ErrorTxt ="" THEN
t = t + "Result: " + t3$ + $CRLF + $CRLF
ELSE
t = t + $CRLF + $CRLF
END IF
' t2 = TIMER ' END TIME
' t = t + "Evaluation time in ms: "+FORMAT$(1000 * (t2 - t1),"####")+$CRLF
' t = t + $CRLF
t = RIGHT$(t, 65535) ' To avoid exceding the capacity limit of the multiline textbox
CONTROL SET TEXT hForm1&,%FORM1_TEXTRESULTS,t
CONTROL HANDLE hForm1&, %FORM1_TEXTRESULTS TO hCtl&
LineCount&=Edit_GetLineCount(hCtl&)
FirstVisLine&=Edit_GetFirstVisibleLine(hCtl&)
' scroll down to last evaluation
Res&=Edit_LineScroll(hCtl&,0,LineCount&-FirstVisLine&-5)
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
END SUB
'
CALLBACK FUNCTION CallbackListbox
LOCAL CVal&, text$ ,text2$
LOCAL hEdit AS LONG
LOCAL lpStart AS LONG, lpEnd AS LONG
IF CBCTLMSG=%LBN_SELCHANGE THEN
' Get first and last position of the selection if any
CONTROL SEND hForm1&,%FORM1_TEXTFORMULA, %EM_GETSEL, VARPTR(lpStart), VARPTR(lpEnd)
CONTROL GET TEXT hForm1&,%FORM1_TEXTFORMULA TO text$
' Return Current Selection in CVal&
CVal&=-1
CONTROL SEND CBHNDL , CBCTL, %LB_GETCURSEL, 0,0 TO CVal&
IF CVal& > -1 THEN ' valid selection
LISTBOX GET TEXT CBHNDL , CBCTL TO text2$
LOCAL cc&
cc& = INSTR(text2$," ")
IF cc& THEN text2$=LEFT$(text2$,cc&-1)
cc&=0
IF INSTR(text2$,"()") THEN cc&=1
CONTROL SEND CBHNDL, CBCTL,%LB_SETCURSEL,-1,0
text$=LEFT$(text$,lpStart)+text2$+MID$(text$,lpStart+1)
CONTROL SET TEXT hForm1&,%FORM1_TEXTFORMULA, text$
CONTROL SEND hForm1&,%FORM1_TEXTFORMULA,%EM_SETSEL,0,lpStart+LEN(text2$)-cc&
CONTROL SEND hForm1&,%FORM1_TEXTFORMULA,%EM_SETSEL,-1,0
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
FUNCTION = %TRUE
END IF
END IF
END FUNCTION
'
CALLBACK FUNCTION CallbackListbox2
LOCAL CVal&, text$ ,text2$
LOCAL hEdit AS LONG, le&
LOCAL lpStart AS LONG, lpEnd AS LONG
IF CBCTLMSG=%LBN_SELCHANGE THEN
' Get first and last position of the selection if any
CONTROL SEND hForm1&,%FORM1_TEXTFORMULA, %EM_GETSEL, VARPTR(lpStart), VARPTR(lpEnd)
CONTROL GET TEXT hForm1&,%FORM1_TEXTFORMULA TO text$
' Return Current Selection in CVal&
CVal&=-1
CONTROL SEND CBHNDL , CBCTL, %LB_GETCURSEL, 0,0 TO CVal&
IF CVal& > -1 THEN ' valid selection
LISTBOX GET TEXT CBHNDL, CBCTL TO text2$
text2$ = TRIM$(text2$)
CONTROL SEND CBHNDL, CBCTL,%LB_SETCURSEL,-1,0
text$=LEFT$(text$,lpStart)+text2$+MID$(text$,lpStart+1)
CONTROL SET TEXT hForm1&,%FORM1_TEXTFORMULA, text$
CONTROL SEND hForm1&,%FORM1_TEXTFORMULA,%EM_SETSEL,0,lpStart+LEN(text2$)
CONTROL SEND hForm1&,%FORM1_TEXTFORMULA,%EM_SETSEL,-1,0
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
FUNCTION = %TRUE
END IF
END IF
END FUNCTION
' ------------------------------------------------
SUB SizeListbox(BYVAL hDlg&,BYVAL id&,BYVAL Xp&,BYVAL Yp&,BYVAL W&,BYVAL H&,BYVAL UNflag&)
' Resize LISTBOX while maintaining integral line height.
' The built-in behavior of listbox is not satisfactory
' when switching to and from horizontal scroll bar. Therefore,
' the %LBS_NOINTEGRALHEIGHT style should be applied, so we
' can control the whole process. The %WS_HSCROLL and %WS_VSCROLL
' styles are also necessary.
STATIC t$
LOCAL I&,j&,TotalWidth&,Temp$,nResult&,nCount&,hDC&
LOCAL TotalHeight&,hCtr&,VS&,HS&
LOCAL rc AS RECT
LOCAL Si AS APISIZE
LOCAL hFont AS LONG
LOCAL VScrollBarWidth&,HScrollBarHeight&,ListboxItemHeight&
IF UNflag& THEN ' convert dialog units to pixels
DIALOG UNITS hDlg&, Xp&, Yp& TO PIXELS Xp&, Yp&
DIALOG UNITS hDlg&, W&, H& TO PIXELS W&, H&
END IF
CONTROL HANDLE hDlg&, id& TO hCtr&
ListboxItemHeight& = SendMessage(hCtr&,%LB_GETITEMHEIGHT,0,0)
VScrollBarWidth& = GetSystemMetrics(%SM_CXVSCROLL)
HScrollBarHeight& = GetSystemMetrics(%SM_CYHSCROLL)
'
' Find maximum width string to determine if a horizontal scroll bar is needed.
' Lance Edmonds is thanked for his example in the source code forum.
nCount = 1
hDC = GetDC(hCtr&)
hFont = SendMessage(hCtr&, %WM_GETFONT, 0, 0)
IF hFont THEN hFont = SelectObject(hDC, hFont)
j = SendMessage(hCtr&, %LB_GETCOUNT, 0, 0)
TotalHeight& = j * ListboxItemHeight& ' Total height of listbox content.
' Enumerate the strings in the LISTBOX
FOR i = 0 TO j - 1
nResult = SendMessage(hCtr&,%LB_GETTEXTLEN, i, 0)
IF nResult THEN
Temp = SPACE$(nResult)
SendMessage hCtr&, %LB_GETTEXT, i, STRPTR(Temp)
' Get the width of the string. Addition of "N" provides a safety margin.
GetTextExtentPoint32 hDC, BYCOPY Temp + "N", nResult + 1, Si
' Get the maximum width.
nCount = MAX&(nCount, Si.cx)
END IF
NEXT i
' Set horizontal extent of the listbox. If this is larger than
' listbox's physical width, a horizontal scroll bar is sutomatically added.
SendMessage hCtr&, %LB_SETHORIZONTALEXTENT, nCount, 0
' Clean up
IF hFont THEN SelectObject hDC, hFont
ReleaseDC hCtr&, hDC
'
TotalWidth& = nCount
'
' Assess if scrollbars will be displayed and make proper adjustments:
IF H& < TotalHeight& + HScrollBarHeight& THEN VS& = 1 ' Vertical scroll bar dependent on horizontal scroll bar
IF H& < TotalHeight& THEN VS& = VScrollBarWidth& ' Vertical scroll bar certain
IF W& - 2 * GetSystemMetrics(%SM_CXEDGE)< TotalWidth& + VScrollBarWidth& THEN HS& = 1 ' Horizontal scroll bar dependent on vertical scroll bar
IF W& - 2 * GetSystemMetrics(%SM_CXEDGE)< TotalWidth& THEN HS& = HScrollBarHeight& ' Horizontal scroll bar certain
IF HS& = HScrollBarHeight& AND VS& = 1 THEN VS& = VScrollBarWidth&
IF VS& = VScrollBarWidth& AND HS& = 1 THEN HS& = HScrollBarHeight&
IF VS& <= 1 AND HS& <= 1 THEN HS& = 0 AND VS& = 0
H& = H& - HS&
'
H& = INT(H&/ListboxItemHeight&) * ListboxItemHeight& _ ' Get integral lines height
+ 2 * GetSystemMetrics(%SM_CYEDGE) + 1 _ ' Add edge height (may be improved)
+ HS& ' Add horizontal scroll factor
' Set new position and size of listbox
' The following approach always going from larger to smaller width gives
' the best results.
MoveWindow hCtr&,Xp&,Yp&,W&+VScrollBarWidth&,H&,%TRUE
MoveWindow hCtr&,Xp&,Yp&,W&,H&,%TRUE
END SUB
'
CALLBACK FUNCTION EditFormulaProc
LOCAL hCtl&,j&,Result&
SELECT CASE CBMSG
CASE %WM_INITDIALOG
' Resize LISTBOX while maintaining integral line height.
CALL SizeListbox(hForm1&,%FORM1_LISTBOX1,140*CF,10*CF,248*CF,164*CF,1)
InvalidateRect hForm1&, BYVAL %NULL , %TRUE
UpdateWindow hForm1&
CONTROL HANDLE hForm1&, %FORM1_TEXTFORMULA TO hCtl&
gOldSubClassEdit& = SetWindowLong(hCtl&, %GWL_WNDPROC, CODEPTR(SubClassEditKeys))
CASE %WM_DESTROY
' Important! Remove the subclassing
SetWindowLong hCtl&, %GWL_WNDPROC, gOldSubClassEdit&
CASE ELSE
END SELECT
END FUNCTION
'
CALLBACK FUNCTION CallbackTextFormula
LOCAL text$
LOCAL lpStart AS LONG, lpEnd AS LONG
' If pressed keyboard character was meant to scroll listbox, then remove it from the expression.
IF CBCTLMSG = %EN_CHANGE AND ListFlag = 1 THEN
' Get first and last position of the selection if any
CONTROL SEND CBHNDL,CBCTL, %EM_GETSEL, VARPTR(lpStart), VARPTR(lpEnd)
CONTROL GET TEXT CBHNDL, CBCTL TO text$
' Delete character just prior to caret.
text$=LEFT$(text$,lpStart-1)+MID$(text$,lpStart+1)
CONTROL SET TEXT CBHNDL, CBCTL, text$
CONTROL SEND CBHNDL, CBCTL,%EM_SETSEL,lpStart-1,lpStart-1
CONTROL SEND CBHNDL, CBCTL,%EM_SETSEL,-1,0 ' de-select text.
ListFlag = 0
END IF
FUNCTION = %TRUE
END FUNCTION
' ------------------------------------------------
CALLBACK FUNCTION CBF_RadioButtonRadians
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
FUNCTION = %TRUE
END FUNCTION
' ------------------------------------------------
CALLBACK FUNCTION CBF_RadioButtonDegrees
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
FUNCTION = %TRUE
END FUNCTION
' ----------------------------------------------------------------
FUNCTION PBMAIN()
LOCAL tt$,ni&,t$,LogPixelsY&
LOCAL hDC AS LONG
LOCAL CC1 AS INIT_COMMON_CONTROLSEX
CC1.dwSize=SIZEOF(CC1)
CC1.dwICC=%ICC_WIN95_CLASSES
InitCommonControlsEX CC1
'Retrieves a handle of a display device context (DC) for the
'client area of the specified window (here the desktop).
hDC = GetDC(%HWND_DESKTOP)
'
'Retrieves device-specific information about the number
'of pixels per logical inch along the screen height
'(depends on screen resolution setting).
'This is important to define appropriate font sizes.
'LogPixelsY = 120 for large fonts and 96 for small fonts setting of Windows
LogPixelsY = GetDeviceCaps(hDC, %LOGPIXELSY)
CF = 1 ' dialog conversion factor for large fonts setting
IF LogPixelsY = 96 THEN CF = 1.25 ' dialog conversion factor for small fonts setting
LOCAL Style&,Exstyle&,LabelStyle&,DWstyle&,ListStyle&
Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER' OR %WS_CLIPCHILDREN
ExStyle& = 0
LabelStyle& = %WS_CHILD OR %WS_VISIBLE OR %SS_LEFT
DIALOG NEW 0, "Math expression evaluator with built-in constants and conversions for PBWin70", 0, 0, 392*CF, 260*CF, Style&, ExStyle& TO hForm1&
CONTROL ADD LABEL, hForm1&, %FORM1_LABEL, "Enter expression using standard syntax:", 5*CF,168*CF,140*CF,12*CF, LabelStyle&
CONTROL ADD LABEL, hForm1&, %FORM1_LABEL2, "Result of expression evaluation:", 5*CF,191*CF,159*CF,12*CF, LabelStyle&
LOCAL tx$
tx$ = "Easy Find: SHIFT + First Letter - Then click to select:"
CONTROL ADD LABEL, hForm1&, %FORM1_LABEL3, tx$, 142*CF,2*CF,248*CF,12*CF, LabelStyle&
CONTROL ADD LABEL, hForm1&, %FORM1_LABEL4, "Click to select:", 5*CF,117*CF,134*CF,12*CF, LabelStyle&
ListStyle&=%WS_CHILD OR %WS_VISIBLE OR %WS_VSCROLL OR %WS_TABSTOP OR %LBS_SORT
CONTROL ADD LISTBOX, hForm1&, %FORM1_LISTBOX1, , 140*CF,10*CF,248*CF,164*CF,ListStyle& OR %WS_HSCROLL OR %LBS_NOINTEGRALHEIGHT ,%WS_EX_CLIENTEDGE CALL CallbackListbox
CONTROL SET COLOR hForm1&,%FORM1_LISTBOX1, RGB(0,0,225), RGB(255,255,230)
CONTROL SEND hForm1&,%FORM1_LISTBOX1,%WM_SETFONT,GetStockObject(%ANSI_FIXED_FONT),%TRUE
ListStyle& = ListStyle& - %LBS_SORT
CONTROL ADD LISTBOX, hForm1&, %FORM1_LISTBOX2, , 3*CF,125*CF,134*CF,40,ListStyle& OR %LBS_MULTICOLUMN ,%WS_EX_CLIENTEDGE CALL CallbackListbox2
LOCAL cv&: cv=22: IF CF>1 THEN cv=21
CONTROL SEND hForm1&, %FORM1_LISTBOX2, %LB_SETCOLUMNWIDTH, cv,0
CONTROL SET COLOR hForm1&,%FORM1_LISTBOX2, RGB(0,0,225), RGB(255,255,230)
CONTROL SEND hForm1&,%FORM1_LISTBOX2,%WM_SETFONT,GetStockObject(%SYSTEM_FONT),%TRUE
DWstyle& = %WS_CHILD OR %WS_VISIBLE OR %ES_MULTILINE OR %WS_VSCROLL OR %ES_READONLY OR %ES_LEFT OR %WS_TABSTOP
CONTROL ADD TEXTBOX, hForm1&,%FORM1_DESCRIBE,"",3*CF,10*CF,134*CF,104*CF,DWstyle&,%WS_EX_CLIENTEDGE
CONTROL SET COLOR hForm1&,%FORM1_DESCRIBE, RGB(230,0,0), RGB(255,240,255)
CONTROL SEND hForm1&,%FORM1_DESCRIBE,%WM_SETFONT,GetStockObject(%SYSTEM_FIXED_FONT),%TRUE
CONTROL ADD TEXTBOX, hForm1&, %FORM1_TEXTFORMULA, "", 3*CF, 176*CF, 386*CF, 12*SQR(CF), _
%ES_AUTOHSCROLL OR %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %ES_UPPERCASE ,%WS_EX_CLIENTEDGE CALL CallbackTextFormula
CONTROL SET COLOR hForm1&,%FORM1_TEXTFORMULA, RGB(0,0,225), RGB(255,255,255)
CONTROL SEND hForm1&,%FORM1_TEXTFORMULA,%WM_SETFONT,GetStockObject(%ANSI_FIXED_FONT),%TRUE
CONTROL ADD TEXTBOX, hForm1&, %FORM1_TEXTRESULTS, "", 3*CF, 199*CF, 386*CF, 40*CF, _
%WS_CHILD OR %WS_VISIBLE OR %ES_MULTILINE OR %ES_WANTRETURN OR _
%ES_LEFT OR %WS_VSCROLL OR %ES_NOHIDESEL OR %ES_AUTOVSCROLL OR %WS_TABSTOP, _
%WS_EX_CLIENTEDGE
CONTROL SET COLOR hForm1&,%FORM1_TEXTRESULTS, RGB(0,0,225), RGB(235,255,255)
CONTROL SEND hForm1&,%FORM1_TEXTRESULTS,%WM_SETFONT,GetStockObject(%ANSI_FIXED_FONT),%TRUE
'
CONTROL ADD LABEL, hForm1&, %LabelRadioButtonAction, "Input Angles in:",5*CF,155*CF,48*CF,10*CF
CONTROL ADD OPTION, hForm1&, %RadioButtonRadians, "Radians", 56*CF,154*CF,38*CF, 10*CF, _
%WS_CHILD OR %WS_VISIBLE OR %BS_AUTORADIOBUTTON OR %WS_GROUP OR %WS_TABSTOP CALL CBF_RadioButtonRadians
CONTROL ADD OPTION, hForm1&, %RadioButtonDegrees, "Degrees", 96*CF,154*CF,38*CF, 10*CF CALL CBF_RadioButtonDegrees
CONTROL SEND hForm1&,%RadioButtonRadians,%BM_SETCHECK,%BST_CHECKED,0
'
CONTROL ADD BUTTON, hForm1&, %FORM1_CLEAREXPRESSION, "&Clear expression", 3*CF, 244*CF, 70*CF, 12*CF, _
%WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_CLEAREXPRESSION
CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTONDOANALYSIS, "&Evaluate expression", 78*CF, 244*CF, 180*CF, 12*CF, _
%WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTONDOANALYSIS
CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTONHELP, "&Help", 264*CF, 244*CF, 34*CF, 12*CF, _
%WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTONHELP
CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTONABOUT, "&About", 304*CF, 244*CF, 34*CF, 12*CF, _
%WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTONABOUT
CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTONEXIT, "E&xit", 344*CF, 244*CF, 45*CF, 12*CF, _
%WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_FORM1_BUTTONEXIT
'
tt="Expressions and functions should be entered strictly according to standard "+ _
"algebraic syntax rules. GIGO you know."+$CRLF+$CRLF+"Type or build expression by selecting its components in "+ _
"the list boxes. "+ $CRLF+$CRLF+ "Good Luck!"+$CRLF+"Erik Christensen"+$CRLF+"[email protected]"
CONTROL SET TEXT hForm1&,%FORM1_DESCRIBE,tt
CONTROL SET FOCUS hForm1&,%FORM1_TEXTFORMULA
'
DATA "ARCSINH() - Arc (Inverse) Hyperbolic Sine","ARCCOSH() - Arc (Inverse) Hyperbolic Cosine","ARCTANH() - Arc (Inverse) Hyperbolic Tangent","ARCSECH() - Arc (Inverse) Hyperbolic Secant"
DATA "ARCCSCH() - Arc (Inverse) Hyperbolic Cosecant","ARCCOTH() - Arc (Inverse) Hyperbolic Cotangent","ARCSIN() - Arc (Inverse) Sine","ARCCOS() - Arc (Inverse) Cosine"
DATA "ARCSEC() - Arc (Inverse) Secant","ARCCSC() - Arc (Inverse) Cosecant","ARCCOT() - Arc (Inverse) Cotangent","SINH() - Hyperbolic Sine","TANH() - Hyperbolic Tangent"
DATA "SECH() - Hyperbolic Secant","CSCH() - Hyperbolic Cosecant","COTH() - Hyperbolic Cotangent","SEC() - Secant","CSC() - Cosecant"
DATA "COT() - Cotangent","SIN() - Sine","COS() - Cosine","TAN() - Tangent","ATN() - Arc (Inverse) Tangent","LN() - Natural Log (base E)"
DATA "EXP2() - Exponentiation of 2 or Antilog 2","EXP10() - Exponentiation of 10 or Antilog 10"
DATA "EXP() - Exponentiation of E or Antilog E","SQR() - Square Root","LOG10() - Common Log (base 10)","ABS() - Absolute Value","LOG2() - Log (base 2)","LOG() - Natural Log (base E)"
DATA "AND - Logical AND","XOR - Logical XOR (Exclusive OR)","OR - Logical OR","MOD - MOD (Modulo)","IMP - Logical IMP (Implication)"
DATA "EQV - Logical EQV (Equivalence)","NOT - NOT","ISTRUE - Logical Truth","ISFALSE - Logical Falsity","CEIL() - Ceiling"
DATA "FRAC() - Fractional Part","FIX() - Truncate To Integer","SGN() - Sign","PI# - Constant (3.14159..)","E# - Constant (2.71828..)","**1**"
' EXP must come after EXP2 and EXP10
' LOG must come after LOG2 and LOG10
ni = 1
LOCAL kk&
DO WHILE READ$(ni) <> "**1**"
t = READ$(ni)
IF INSTR(t,"()") THEN
t = t + " Function"
ELSE
IF INSTR(t,"#") THEN EXIT IF
t = t + " Operator"
END IF
LISTBOX ADD hForm1&, %FORM1_LISTBOX1, t
REDIM PRESERVE CheckArr(ni)
kk& = INSTR(t,"()")
IF kk& THEN t = LEFT$(t,kk&-1)
CheckArr(ni) = t
INCR ni
LOOP
'
DATA "1","+","2","-","3","*","4","/","5","\","6","^","7","("
DATA "8",")","9","=","0","<",".",">","E","!","**2**"
INCR ni
DO WHILE READ$(ni) <> "**2**"
t = READ$(ni)
LISTBOX ADD hForm1&, %FORM1_LISTBOX2, " "+t
INCR ni
LOOP
'
REDIM Extra(1,0)
INCR ni
NoEx=-1
' Read conversions
DO WHILE READ$(ni) <> "**3**"
INCR NoEx
REDIM PRESERVE Extra(1,NoEx)
t = UCASE$(READ$(ni))
LISTBOX ADD hForm1&, %FORM1_LISTBOX1, t + " - Conversion"
Extra(0,NoEx) = t
INCR ni
Extra(1,NoEx) = READ$(ni)
INCR ni
LOOP
'
DATA "Foot_TO_meter" , "*1/ 3.28084"
DATA "Meter_TO_foot" , "* 3.28084"
DATA "Inch_TO_centimeter" , "* 2.54"
DATA "Centimeter_TO_inch" , "*1 / 2.54"
DATA "Kilometer_TO_mile" , "*1 / 1.609344"
DATA "Mile_TO_kilometer" , "* 1.609344"
DATA "Inch_TO_foot" , "*1 / 12"
DATA "Foot_TO_inch" , "* 12"
DATA "Yard_TO_meter" , "*1 / 1.093613"
DATA "Meter_TO_yard" , "* 1.093613"
DATA "Fathom_TO_meter" , "* 1.8288"
DATA "Meter_TO_fathom" , "*1 / 1.8288"
DATA "Mile_TO_light-year" , "*1 / 5880000000000"
DATA "Light-year_TO_mile" , "* 5880000000000"
DATA "Parsec_TO_light-year" , "* 3.261643"
DATA "Light-year_TO_parsec" , "*1 / 3.261643"
DATA "Square_ft_TO_square_m" , "*1 / 10.76391"
DATA "Square_m_TO_square_ft" , "* 10.76391"
DATA "Square_in_TO_square_cm" , "* 6.4516"
DATA "Square_cm_TO_square_in" , "*1 / 6.4516"
DATA "Hectare_TO_acre" , "* 2.471054"
DATA "Acre_TO_hectare" , "*1 / 2.471054"
DATA "Pound_TO_kilogram" , "*1 / 2.204623"
DATA "Kilogram_TO_pound" , "* 2.204623"
DATA "Ton_(metric)_TO_Kilogram" , "* 1000"
DATA "Kilogram_TO_ton_(metric)" , "*1 / 1000"
DATA "Ton_(US)_TO_Kilogram" , "* 907.18474"
DATA "Kilogram_TO_ton_(US)" , "*1 / 907.18474"
DATA "Ton_(UK)_TO_Kilogram" , "* 1016.046909"
DATA "Kilogram_TO_ton_(UK)" , "*1 / 1016.046909"
DATA "Ounce_(avoirdupois)_TO_gram" , "* 28.349551"
DATA "Gram_TO_ounce_(avoirdupois)" , "*1 / 28.349551"
DATA "Ounce_(troy)_TO_gram" , "* 31.103508"
DATA "Gram_TO_ounce_(troy)" , "*1 / 31.103508"
DATA "Fahrenheit_TO_Celsius" , "*1 / 1.8 - 32 / 1.8"
DATA "Celsius_TO_Fahrenheit" , "* 1.8 + 32"
DATA "Celsius_TO_Kelvin" , "*1 + 273.16"
DATA "Kelvin_TO_Celsius" , "*1 - 273.16"
DATA "Gallon_(US_dry)_TO_liter" , "* 4.404884"
DATA "Liter_TO_gallon_(US_dry)" , "*1 / 4.404884"
DATA "Gallon_(US_liquid)_TO_liter" , "* 3.785412"
DATA "Liter_TO_gallon_(US_liquid)" , "*1 / 3.785412"
DATA "Quart_(US_dry)_TO_gallon_(US_dry)" , "*1 / 4"
DATA "Gallon_(US_dry)_TO_quart_(US_dry)" , "* 4"
DATA "Pint_TO_liter_(US_dry)" , "* 0.55061"
DATA "Liter_TO_pint_(US_dry)" , "*1 / 0.55061"
DATA "Pint_TO_liter_(US_liquid)" , "* 0.473176"
DATA "Liter_TO_pint_(US_liquid)" , "*1 / 0.473176"
DATA "Cubic_ft_TO_cubic_m" , "*1 / 35.314667"
DATA "Cubic_m_TO_cubic_ft" , "* 35.314667"
DATA "Horsepower_(elec.)_TO_watt" , "* 745.7"
DATA "Watt_TO_horsepower_(elec.)" , "*1 / 745.7"
DATA "Horsepower_(metric)_TO_watt" , "* 735.499"
DATA "Watt_TO_horsepower_(metric)" , "*1 / 735.499"
DATA "BTU/hour_TO_watt" , "* 0.293071"
DATA "Watt_TO_BTU/hour" , "*1 / 0.293071"
DATA "Kilowatt_TO_watt" , "* 1000"
DATA "Watt_TO_kilowatt" , "*1 / 1000"
DATA "Kph_TO_mph" , "*1 / 1.609344"
DATA "Mph_TO_kph" , "* 1.609344"
DATA "Knot_TO_mph" , "* 1.150778"
DATA "Mph_TO_knot" , "*1 / 1.150778"
DATA "Meter/sec_TO_ft/sec" , "* 3.28084"
DATA "Ft/sec_TO_meter/sec" , "*1 / 3.28084"
DATA "Second_TO_minute" , "*1 / 60"
DATA "Minute_TO_second" , "* 60"
DATA "Minute_TO_hour" , "*1 / 60"
DATA "Hour_TO_minute" , "* 60"
DATA "Minute_TO_day" , "*1 / 1440"
DATA "Day_TO_minute" , "* 1440"
DATA "Day_TO_hour" , "* 24"
DATA "Hour_TO_day" , "*1 / 24"
DATA "Psi_TO_pascal" , "* 6894.757"
DATA "Pascal_TO_psi" , "*1 / 6894.757"
DATA "Psi_TO_atmosphere" , "* 0.068046"
DATA "Atmosphere_TO_psi" , "*1 / 0.068046"
DATA "Psi_TO_kg/sqcm" , "* 0.070307"
DATA "Kg/sqcm_TO_psi" , "*1 / 0.070307"
DATA "Degrees_TO_radians" , "* 1.74532925199432958E-2
DATA "Radians_TO_degrees" , "*1 / 1.74532925199432958E-2
' **************************************
' You may insert other conversions here.
' **************************************
DATA "**3**"
'
' Read constants
INCR ni
DO WHILE READ$(ni) <> "**4**"
INCR NoEx
REDIM PRESERVE Extra(1,NoEx)
t = UCASE$(READ$(ni))
LISTBOX ADD hForm1&, %FORM1_LISTBOX1, t + " - Constant"
Extra(0,NoEx) = t
INCR ni
Extra(1,NoEx) = READ$(ni)
INCR ni
LOOP
'
DATA "Acceleration_of_gravity_(m/sec²)" , "9.80665"
DATA "Dry_air_density_at_STP_(kg/m³)" , "1.293"
DATA "Light_speed_in_a_vacuum_(m/sec)" , "299792458"
DATA "Solar_constant_(watts/m²)" , "1340"
DATA "Sound_speed_at_STP_(m/sec)" , "331.4"
DATA "Standard_atmosphere_(nt/m²)" , "101300"
DATA "Earth_equatorial_radius_(m)" , "6378000"
DATA "Earth_escape_velcity_(m/sec)" , "11186"
DATA "Earth_magnetic_dipole_moment_(amp-m²)" , "6.400E21"
DATA "Earth_mass_(kg)" , "5.983E24"
DATA "Earth_mean_angular_rotational_speed_(rads/sec)" , ".0000729"
DATA "Earth_mean_density_(kg/m³)" , "5522"
DATA "Earth_mean_orbital_speed_(m/sec)" , "29770"
DATA "Earth_polar_radius_(m)" , "6357000"
DATA "Earth_volume_(m³)" , "1.087E21"
DATA "Alpha_particle_mass_(kg)" , "6.64465598E-27"
DATA "Electron_charge-mass_ratio_(coul/kg)" , "175881961000"
DATA "Electron_rest_mass_(kg)" , "9.10938188E-31"
DATA "Muon_rest_mass_(kg)" , "1.88353109E-28"
DATA "Neutron_rest_mass_(kg)" , "1.67492716E-27"
DATA "Proton_rest_mass_(kg)" , "1.67262158E-27"
DATA "Atomic_mass_constant_(kg)" , "1.66053873E-27"
DATA "Avogadro_constant_(1/mole)" , "6.02214199E23"
DATA "Boltzmann_constant_(joule/K)" , "1.3806503E-23"
DATA "Elementary_charge_(coul)" , "1.602176462E-19"
DATA "Faraday_constant_(coul/mole)" , "96485.3415"
DATA "Gravitational_constant_(nt-m²/kg²)" , ".000000000066726"
DATA "Permeability_constant_(henry/m)" , "1.25663706143E-6"
DATA "Permittivity_constant_(farad/m)" , "8.85418781762E-12"
DATA "Planck_constant_(joule-sec)" , "6.62606876E-34"
DATA "Rydberg_constant_(1/m)" , "10973731.568549"
DATA "Stefan-Boltzmann_constant_(watt/m²K4)" , ".000000056704"
DATA "Universal_gas_constant_(joule/K-mole)" , "8.314472"
DATA "Wien_displacement_constant_(m-K)" , ".00290"
' ************************************
' You may insert other constants here.
' ************************************
DATA "**4**"
'
REDIM Trig(35)
Trig(1) = "ARCSINH"
Trig(2) = "ARCCOSH"
Trig(3) = "ARCTANH"
Trig(4) = "ARCSECH"
Trig(5) = "ARCCSCH"
Trig(6) = "ARCCOTH"
Trig(7) = "ARCSIN"
Trig(8) = "ARCCOS"
Trig(9) = "ARCSEC"
Trig(10) = "ARCCSC"
Trig(11) = "ARCCOT"
Trig(12) = "SINH"
Trig(13) = "TANH"
Trig(14) = "SECH"
Trig(15) = "CSCH"
Trig(16) = "COTH"
Trig(17) = "SEC"
Trig(18) = "CSC"
Trig(19) = "COT"
Trig(20) = "SIN"
Trig(21) = "COS"
Trig(22) = "TAN"
Trig(23) = "ATN"
Trig(24) = "LOG" ' natural log or ln (logE)
Trig(25) = "EXP"
Trig(26) = "SQR"
Trig(27) = "CLG" ' log10
Trig(28) = "ABS"
Trig(29) = "TLG" ' log2
Trig(30) = "CEIL"
Trig(31) = "FIX"
Trig(32) = "FRAC"
Trig(33) = "SGN"
Trig(34) = "ETO" ' EXP2
Trig(35) = "ETE" ' EXP10
DIALOG SHOW MODAL hForm1& , CALL EditFormulaProc
END FUNCTION
' ------------------------------------------------
[This message has been edited by Erik Christensen (edited June 29, 2005).]
Comment