Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Formel-Parser
| Uploader: |  nemored |
| Datum/Zeit: | 19.11.2014 23:00:52 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts Formel-Parser und Termberechnung, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
/'
Copyright (c) 2014 by nemored
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated
documentation files (the "Software"), to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and
to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all copies or substantial portions of
the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO
THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
Version 2014-11-24
'/
#ifndef CALCULATE_DATATYPE
#define CALCULATE_DATATYPE double
#endif
namespace Calculate
enum Errors
NoError = 0
ErrorNoValue
ErrorMissingBracket
ErrorMissingValue
ErrorWrongDecimalPoint
ErrorWrongExponent
ErrorIllegalSymbol
ErrorNotANumber
ErrorUndefinedFunction
ErrorUndefinedVariable
ErrorOverwriteFunction
ErrorIllegalValue
end enum
enum Tokens
Nil = 0
Number
Plus
Minus
Asterisk
Slash
Backslash
Exponent
Equal
BracketLeft
BracketRight
OpMod
OpShl
OpShr
OpAnd
OpOr
OpXor
OpEqv
OpImp
OpNot
Variable
Func
Seperator
end enum
type TVariable
as string id
as CALCULATE_DATATYPE value
declare constructor
declare constructor(i as string, v as CALCULATE_DATATYPE)
end type
constructor TVariable
end constructor
constructor TVariable(i as string = "", v as CALCULATE_DATATYPE = 0)
this.id = i
this.value = v
end constructor
type TToken
as TToken ptr prev, nxt
as Tokens token
as string value
declare property size(last as TToken ptr) as integer
declare constructor
declare sub add(t as Tokens, v as string)
declare function del as TToken ptr
declare sub delAll
declare sub delFromCurrent
declare sub replace(last as TToken ptr, t as Tokens, v as string)
end type
constructor TToken
end constructor
property TToken.size(last as TToken ptr) as integer
dim cur as TToken ptr = @this, ret as integer = 0
do while cur
if cur = last then exit do
cur = cur->nxt
if cur andalso cur->token <> Tokens.Nil then ret += 1
loop
return ret
end property
sub TToken.add(t as Tokens, v as string)
dim as TToken ptr newToken = new TToken
newToken->nxt = this.nxt
newToken->prev = @this
newToken->token = t
newToken->value = v
this.nxt = newToken
if newToken->nxt then newToken->nxt->prev = newToken
end sub
function TToken.del as TToken ptr
dim as TToken ptr cur = this.nxt
if cur then this.nxt->prev = this.prev
if this.prev then this.prev->nxt = cur
this.token = 0
this.value = ""
this.prev = 0
this.nxt = 0
delete @this
return cur
end function
sub TToken.delAll
dim as TToken ptr current = @this
do while current->prev
current = current->prev
loop
current->delFromCurrent
end sub
sub TToken.delFromCurrent
dim as TToken ptr current = @this
do
current = current->del
loop until current = 0
end sub
sub TToken.replace(last as TToken ptr, t as Tokens, v as string)
if last <> @this then
dim as TToken ptr cur = this.nxt
do while cur <> 0 and cur <> last
cur = this.nxt->del
loop
if cur then cur->del
end if
this.token = t
this.value = v
end sub
dim shared as TVariable globalVar(), localVar()
dim shared as Errors CalcError
dim shared as string CalcErrorTerm
const NaN = -sqr(-1)
declare sub debug(debugString as string)
declare function debugCalcString(first as TToken ptr, last as TToken ptr = 0) as string
declare function eval overload(t as string) as CALCULATE_DATATYPE
declare function eval(byval first as TToken ptr, byval last as TToken ptr = 0) as CALCULATE_DATATYPE
declare function evalSearch(token as integer, first as TToken ptr, last as TToken ptr) as TToken ptr
declare function getVar overload(variable as string) as CALCULATE_DATATYPE
declare function getVar(tok as TToken ptr) as CALCULATE_DATATYPE
declare sub setVar(variable as string, value as CALCULATE_DATATYPE, scop as integer = 0)
end namespace
' pre-defined constants
Calculate.setVar "e", 2.718281828459045
Calculate.setVar "pi", 3.141592653589793
sub Calculate.debug(debugString as string)
#ifdef CALCULATE_DEBUG
print debugstring
#endif
end sub
function Calculate.debugCalcString(first as Calculate.TToken ptr, last as Calculate.TToken ptr) as string
#ifdef CALCULATE_DEBUG
dim as Calculate.TToken ptr cur = first
dim as string debugString = "eval "
do while cur
if cur->Token <> Calculate.Tokens.Nil then debugString &= " " & cur->value
if cur = last then exit do
cur = cur->nxt
loop
return debugString
#else
return ""
#endif
end function
function Calculate.eval(t as string) as CALCULATE_DATATYPE
dim as integer position = 0, char, lastToken = Calculate.Tokens.Nil, numberPos = 0, skipping = 0
dim as Calculate.TToken ptr listStart = new Calculate.TToken, listCurrent = listStart
dim as string numberString
Calculate.CalcError = Calculate.NoError
do while position < len(t)
char = t[position]
' skip space
if char = 9 or char = 32 then
position += 1
skipping = -1
continue do
else
skipping = 0
if numberPos > 0 and (char = 69 or char = 101) then
lastToken = Calculate.Tokens.Number
listCurrent->add(Calculate.Tokens.Number, numberString)
listCurrent = listCurrent->nxt
numberPos = 0
end if
end if
' continue number
if numberPos then
select case char
case 48 to 57 ' number
numberString += chr(char)
case 46 ' decimal point
if numberPos = 1 then
numberString += "."
numberPos = 2
else
Calculate.CalcError = Calculate.ErrorWrongDecimalPoint
exit do
end if
case 69, 101 ' e, E
if numberPos > 2 then
Calculate.CalcError = Calculate.ErrorWrongDecimalPoint
exit do
end if
if position = len(t)-1 orelse _
t[position+1] <> 43 and t[position+1] <> 45 and t[position+1] < 48 and t[position+1] > 57 then
Calculate.CalcError = Calculate.ErrorWrongExponent
exit do
end if
if t[position+1] = 43 or t[position+1] = 45 then
if position = len(t)-2 orelse t[position+2] < 48 and t[position+2] > 57 then
Calculate.CalcError = Calculate.ErrorWrongExponent
exit do
end if
numberString += "e" + chr(t[position+1], t[position+2])
position += 2
else
numberString += "e+" + chr(t[position+1])
position += 1
end if
numberPos = 3
case else
lastToken = Calculate.Tokens.Number
listCurrent->add(Calculate.Tokens.Number, numberString)
listCurrent = listCurrent->nxt
numberPos = 0
end select
' start number?
else
select case char
case 48 to 57 ' number
numberPos = 1
numberString = chr(char)
case 46 ' decimal point
numberPos = 2
numberString = "."
case 43, 45 ' sign +, -
if lastToken <> Calculate.Tokens.Number _
and lastToken <> Calculate.Tokens.BracketLeft _
and lastToken <> Calculate.Tokens.BracketRight _
and lastToken <> Calculate.Tokens.Equal _
and lastToken <> Calculate.Tokens.Variable _
and lastToken <> Calculate.Tokens.Func _
and lastToken <> Calculate.Tokens.Seperator then
numberPos = 1
numberString = chr(char)
end if
end select
end if
' no number
if numberPos = 0 then
numberString = ""
select case char
case 40 : lastToken = Calculate.Tokens.BracketLeft ' (
case 41 : lastToken = Calculate.Tokens.BracketRight ' )
case 42 : lastToken = Calculate.Tokens.Asterisk ' *
case 43 : lastToken = Calculate.Tokens.Plus ' +
case 45 : lastToken = Calculate.Tokens.Minus ' -
case 47 : lastToken = Calculate.Tokens.Slash ' /
case 59 : lastToken = Calculate.Tokens.Seperator ' ;
case 61 : lastToken = Calculate.Tokens.Equal ' =
case 92 : lastToken = Calculate.Tokens.Backslash ' \
case 94 : lastToken = Calculate.Tokens.Exponent ' ^
case 65 to 90, 95, 97 to 122
' search end of word
dim as integer p = position + 1
do while p < len(t)
if t[p]<>95 and not(t[p]>47 and t[p]<58) and not(t[p]>64 and t[p]<91) and not(t[p]>96 and t[p]<123) then exit do
p += 1
loop
numberString = mid(t, position+1, p-position)
select case lcase(mid(t, position+1, p-position))
case "mod" : lastToken = Calculate.OpMod
case "shl" : lastToken = Calculate.OpShl
case "shr" : lastToken = Calculate.OpShr
case "not" : lastToken = Calculate.OpNot
case "and" : lastToken = Calculate.OpAnd
case "or" : lastToken = Calculate.OpOr
case "xor" : lastToken = Calculate.OpXor
case "eqv" : lastToken = Calculate.OpEqv
case "imp" : lastToken = Calculate.OpImp
case "sin", "cos", "tan", "asin", "acos", "atan", "atn", "abs", "sgn", "sqr", _
"exp", "log", "ln", "int", "cint", "fix", "frac"
lastToken = Calculate.Tokens.Func
case else
lastToken = Calculate.Tokens.Variable
end select
position = p - 1
case else
Calculate.CalcError = Calculate.ErrorIllegalSymbol
exit do
end select
#ifdef CALCULATE_DEBUG
if numberString = "" then numberString = chr(t[position])
#endif
listCurrent->add(lastToken, numberString)
listCurrent = listCurrent->nxt
end if
position += 1
loop
if numberPos then
listCurrent->add(Calculate.Tokens.Number, numberString)
listCurrent = listCurrent->nxt
end if
dim as CALCULATE_DATATYPE ret = iif(Calculate.CalcError, 0, Calculate.eval(listStart->nxt))
listStart->delAll
erase Calculate.localVar
return iif(Calculate.CalcError, 0, ret)
end function
function Calculate.eval(byval first as Calculate.TToken ptr, byval last as Calculate.TToken ptr = 0) as CALCULATE_DATATYPE
dim as CALCULATE_DATATYPE value
dim as string calcString = Calculate.debugCalcString(first, last)
if first andalso first->token = Calculate.Tokens.Nil then first = first->nxt
' no token (error)
if first = 0 then
Calculate.CalcError = ErrorMissingValue
return 0
end if
Calculate.debug calcString
dim as Calculate.TToken ptr listCurrent = first, firstBracket
dim as integer depth = 0
' search brackets and seperators
do while listCurrent
if listCurrent->token = Calculate.Tokens.Nil then
if listCurrent = last then exit do
if listCurrent->nxt = 0 then last = listCurrent
listCurrent = listCurrent->nxt
continue do
end if
if listCurrent->token = Calculate.Seperator then
if depth then
Calculate.CalcError = ErrorMissingBracket
return 0
else
dim as CALCULATE_DATATYPE dummy = Calculate.eval(first, listCurrent->prev)
value = Calculate.eval(listCurrent->nxt, last)
Calculate.debug "() returns " & value
return value
end if
end if
if listCurrent->token = Calculate.BracketLeft then
if depth = 0 then firstBracket = listCurrent
depth += 1
elseif listCurrent->token = Calculate.BracketRight then
if depth = 0 then
Calculate.CalcError = ErrorMissingBracket
return 0
end if
depth -= 1
if depth = 0 then
firstBracket->replace(listCurrent->prev, Calculate.Tokens.Number, _
str(Calculate.eval(firstBracket->nxt, listCurrent->prev)))
listCurrent->token = Calculate.Tokens.Nil
end if
end if
if listCurrent = last then exit do
if listCurrent->nxt = 0 then last = listCurrent
listCurrent = listCurrent->nxt
loop
' single token (must be a number or variable)
if first->size(last) = 0 then
if first->token = Calculate.Tokens.Number then
Calculate.debug "return single value " & first->value
return val(first->value)
elseif first->token = Calculate.Tokens.Variable then
Calculate.debug "return var value " & Calculate.getVar(first)
return Calculate.getVar(first)
else
Calculate.CalcError = ErrorMissingValue
return 0
end if
end if
' definition
if first->nxt->token = Calculate.Tokens.Equal then
if first->Token = Calculate.Tokens.Variable then
dim as CALCULATE_DATATYPE ret = Calculate.eval(first->nxt->nxt, last)
Calculate.setVar(first->value, ret, -1)
if Calculate.CalcError then
return 0
else
Calculate.debug "define " & first->value & " = " & ret
return ret
end if
else
Calculate.CalcError = ErrorIllegalSymbol
return 0
end if
end if
' function
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.Func, first, last)
if listCurrent then
value = Calculate.getVar(listCurrent)
if Calculate.CalcError then return 0
if last = listCurrent->nxt then last = listCurrent
listCurrent->token = Calculate.Tokens.Number
listCurrent->value = str(value)
listCurrent->nxt->token = Calculate.Tokens.Nil
value = Calculate.eval(first, last)
Calculate.debug "function " & listCurrent->value & " returns " & value
return value
end if
' xor, imp, eqv
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.OpXor + 2^Calculate.Tokens.OpImp _
+ 2^Calculate.Tokens.OpEqv, first, last)
if listCurrent then
dim as CALCULATE_DATATYPE l = Calculate.eval(first, listCurrent->prev), r = Calculate.eval(listCurrent->nxt, last)
Calculate.debug "xor,imp,eqv values " & l & " , " & r
select case listCurrent->token
case Calculate.Tokens.OpXor : return l xor r
case Calculate.Tokens.OpImp : return l imp r
case Calculate.Tokens.OpEqv : return l eqv r
end select
end if
' or
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.OpOr, first, last)
if listCurrent then
dim as CALCULATE_DATATYPE l = Calculate.eval(first, listCurrent->prev), r = Calculate.eval(listCurrent->nxt, last)
Calculate.debug "or values " & l & " , " & r
return l or r
end if
' and
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.OpAnd, first, last)
if listCurrent then
dim as CALCULATE_DATATYPE l = Calculate.eval(first, listCurrent->prev)
dim as CALCULATE_DATATYPE r = Calculate.eval(listCurrent->nxt, last)
Calculate.debug "and values " & l & " , " & r
return l and r
end if
' not
listCurrent = first
do while listCurrent
if listCurrent->token = Calculate.Tokens.OpNot then
value = Calculate.eval(listCurrent->nxt, last)
if Calculate.CalcError then
return 0
else
listCurrent->replace(last->prev, Calculate.Tokens.Number, str(not value))
last->token = Calculate.Tokens.Nil
Calculate.debug "not returns " & not value
return Calculate.eval(first, last)
end if
end if
if listCurrent = last then exit do
listCurrent = listCurrent->nxt
loop
' +, -
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.Plus + 2^Calculate.Tokens.Minus, first, last)
if listCurrent andalso listCurrent <> first then
dim as CALCULATE_DATATYPE l = Calculate.eval(first, listCurrent->prev), r = Calculate.eval(listCurrent->nxt, last)
Calculate.debug "+,- values " & l & " , " & r
select case listCurrent->token
case Calculate.Tokens.Plus : return l + r
case Calculate.Tokens.Minus : return l - r
end select
end if
' shr, shl
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.OpShr + 2^Calculate.Tokens.OpShl, first, last)
if listCurrent then
dim as CALCULATE_DATATYPE l = Calculate.eval(first, listCurrent->prev), r = Calculate.eval(listCurrent->nxt, last)
Calculate.debug "shr,shl values " & l & " , " & r
select case listCurrent->token
case Calculate.Tokens.OpShr : return l shr r
case Calculate.Tokens.OpShl : return l shl r
end select
end if
' mod
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.OpMod, first, last)
if listCurrent then
value = Calculate.eval(first, listCurrent->prev) mod Calculate.eval(listCurrent->nxt, last)
Calculate.debug "mod returns " & value
return value
end if
' \
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.Backslash, first, last)
if listCurrent then
value = Calculate.eval(first, listCurrent->prev) \ Calculate.eval(listCurrent->nxt, last)
Calculate.debug "\ returns " & value
return value
end if
' /, *
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.Slash + 2^Calculate.Tokens.Asterisk, first, last)
if listCurrent then
dim as CALCULATE_DATATYPE l = Calculate.eval(first, listCurrent->prev), r = Calculate.eval(listCurrent->nxt, last)
Calculate.debug "/,* values " & l & " , " & r
select case listCurrent->token
case Calculate.Tokens.Slash : return l / r
case Calculate.Tokens.Asterisk : return l * r
end select
end if
' sign
if first->token = Calculate.Tokens.Plus then
value = Calculate.eval(first->nxt, last)
Calculate.debug "+ returns " & value
return value
end if
if first->token = Calculate.Tokens.Minus then
value = -Calculate.eval(first->nxt, last)
Calculate.debug "- returns " & value
return value
end if
' ^
listCurrent = Calculate.evalSearch(2^Calculate.Tokens.Exponent, first, last)
if listCurrent then
value = Calculate.eval(first, listCurrent->prev) ^ Calculate.eval(listCurrent->nxt, last)
Calculate.debug "^ returns " & value
return value
end if
' nothing found
Calculate.CalcError = Calculate.Errors.ErrorIllegalValue
return 0
end function
function Calculate.evalSearch(token as integer, first as Calculate.TToken ptr, last as Calculate.TToken ptr) _
as Calculate.TToken ptr
dim as Calculate.TToken ptr listCurrent = last
do while listCurrent
if bit(token, listCurrent->token) then return listCurrent
if listCurrent = first then return 0
listCurrent = listCurrent->prev
loop
return 0
end function
function Calculate.getVar(variable as string) as CALCULATE_DATATYPE
for i as integer = 0 to ubound(Calculate.localVar)
if Calculate.localVar(i).id = variable then return Calculate.localVar(i).value
next
for i as integer = 0 to ubound(Calculate.globalVar)
if Calculate.globalVar(i).id = variable then return Calculate.globalVar(i).value
next
Calculate.CalcError = Calculate.ErrorUndefinedVariable
Calculate.CalcErrorTerm = variable
return Calculate.NaN
return 0
end function
function Calculate.getVar(tok as Calculate.TToken ptr) as CALCULATE_DATATYPE
dim as CALCULATE_DATATYPE v
if Calculate.CalcError then return 0
if tok = 0 then
Calculate.CalcError = Calculate.ErrorIllegalSymbol
return 0
end if
' check if it's a function
if tok->token = Calculate.Tokens.Func then
if tok->nxt = 0 orelse _
tok->nxt->token <> Calculate.Tokens.Number _
and tok->nxt->token <> Calculate.Tokens.Variable _
and tok->nxt->token <> Calculate.Tokens.Func then
Calculate.CalcError = Calculate.ErrorMissingValue
return 0
else
if tok->nxt->token = Calculate.Tokens.Number then
v = val(tok->nxt->value)
else
v = Calculate.getVar(tok->nxt)
if Calculate.CalcError then return 0
end if
end if
else
' check if it's a defined variable
return Calculate.getVar(tok->value)
end if
select case tok->value
case "sin"
return sin(v)
case "cos"
return cos(v)
case "tan"
return tan(v)
case "asin"
if v < -1 or v > 1 then
Calculate.CalcError = Calculate.ErrorIllegalValue
Calculate.CalcErrorTerm = "asin(" & v & ")"
return Calculate.NaN
end if
return asin(v)
case "acos"
if v < -1 or v > 1 then
Calculate.CalcError = Calculate.ErrorIllegalValue
Calculate.CalcErrorTerm = "acos(" & v & ")"
return Calculate.NaN
end if
return acos(v)
case "atan", "atn"
return atn(v)
case "abs"
return abs(v)
case "sgn"
return sgn(v)
case "sqr"
if v < 0 then
Calculate.CalcError = Calculate.ErrorIllegalValue
Calculate.CalcErrorTerm = "sqr(" & v & ")"
return Calculate.NaN
end if
return sqr(v)
case "exp"
return exp(v)
case "log", "ln"
if v <= 0 then
Calculate.CalcError = Calculate.ErrorIllegalValue
Calculate.CalcErrorTerm = tok->value & "(" & v & ")"
return Calculate.NaN
end if
return log(v)
case "int"
return int(v)
case "cint"
return cint(v)
case "fix"
return fix(v)
case "frac"
return frac(v)
end select
Calculate.CalcError = Calculate.ErrorUndefinedVariable
Calculate.CalcErrorTerm = tok->value
return 0
end function
sub Calculate.setVar(variable as string, value as CALCULATE_DATATYPE, scop as integer = 0)
select case variable
case "sin", "cos", "tan", "asin", "acos", "atan", "atn", "abs", "sgn", "sqr", _
"exp", "log", "ln", "int", "cint", "fix", "frac"
Calculate.CalcError = Calculate.ErrorOverwriteFunction
Calculate.CalcErrorTerm = variable
exit sub
end select
if scop then
' set local variable
if ubound(Calculate.localVar) < 0 then
redim Calculate.localVar(0)
Calculate.localVar(0) = Calculate.TVariable(variable, value)
else
for i as integer = 0 to ubound(Calculate.localVar)
if Calculate.localVar(i).id = variable then Calculate.localVar(i).value = value : exit sub
next
redim preserve Calculate.localVar(ubound(Calculate.localVar)+1)
Calculate.localVar(ubound(Calculate.localVar)) = Calculate.TVariable(variable, value)
end if
else
' set global variable
if ubound(Calculate.globalVar) < 0 then
redim Calculate.globalVar(0)
Calculate.globalVar(0) = Calculate.TVariable(variable, value)
else
for i as integer = 0 to ubound(Calculate.globalVar)
if Calculate.globalVar(i).id = variable then Calculate.globalVar(i).value = value : exit sub
next
redim preserve Calculate.globalVar(ubound(Calculate.globalVar)+1)
Calculate.globalVar(ubound(Calculate.globalVar)) = Calculate.TVariable(variable, value)
end if
end if
end sub