PureBasic

Forums PureBasic - Français
http://forums.purebasic.com/french/

Calcul littéral

http://forums.purebasic.com/french/viewtopic.php?t=10021

Page 1 sur 1

Calcul littéral

Publié : mer. 16/déc./2009 23:22
par Le Soldat Inconnu
J'ai vu passé un code de calcul littéral sur le forum

Code intéressant, mais travaillant en 32 bit et avec quelque soucis (par rapport à mon code de calcul littéral de ma calculatrice)

Par contre, le code est relativement simple. Donc j'ai modifié pour pouvoir l'utiliser.

- Ajout du support 64bits
- Nettoyage du code (j'ai supprimé des procédures inutiles)
- Ajout de la fonction factorielle " ! "
- Ajout de la fonction %
- Ajout des fonctions = > < >= <= <>
- Ajout d'une erreur pour les calculs impossible, exemple : Sqr(-1) log(-10) 0.8! etc...
- Ajout du mode Degrés ou Radian
- Ajout du support de l'unicode

Code : Tout sélectionner

; Operanten-Codes
Enumeration -1
	#OP_UNKNOWN
	#OP_NONE
	#OP_PLUS
	#OP_MINUS
	#OP_MULT
	#OP_DIV
	#OP_POT
	#OP_FACT
	#OP_PERCENT
	#OP_EQUAL
	#OP_SUP
	#OP_INF
	#OP_SUPEQUAL
	#OP_INFEQUAL
	#OP_NOTEQUAL
	#OP_FUNC
EndEnumeration

; Funktions-Codes
Enumeration 1
	#FUNC_SQR
	#FUNC_SIN
	#FUNC_ASIN
	#FUNC_COS
	#FUNC_ACOS
	#FUNC_TAN
	#FUNC_ATAN
	#FUNC_INT
	#FUNC_ABS
	#FUNC_LOG10
	#FUNC_LOG
EndEnumeration

; Constant
#CONST_PI = "3.1415926535897932" ; PI
#CONST_E = "2.7182818284590451" ; Eulersche Zahl

; Mode
#CALC_MODE_RAD = 1
#CALC_MODE_DEG = 2

; Error-Codes
#CALC_ERR_NONE = 0 ; No error
#CALC_ERR_SYNTAX = 1 ; Syntax error
#CALC_ERR_DIVNULL = 2 ; Division / 0
#CALC_ERR_OPNOTFOUND = 3 ; Operand not found
#CALC_ERR_FUNCNOTFOUND = 4 ; Function not found
#CALC_ERR_WRONGINPUT = 5 ; Wrong input parameter in function

#PRIORITY_STEP = 6 ; entspricht der hchsten Priorittsstufe der Operanten
#MAX_TREENODES = 256 ; Maximale Anzahl an SyntaxBaum-Knoten

#OPERAND = 1
#VALUE = 2

Structure SyntaxTreeNode
	*parent.SyntaxTreeNode
	*child.SyntaxTreeNode[2]
	operand.i
	prior.i
	Value.d
EndStructure

Structure SyntaxTree
	*root.SyntaxTreeNode
	node.SyntaxTreeNode[#MAX_TREENODES]
	remark$ ; frei verwendbar
EndStructure

;{ Declarations
Declare.i GetCalculationError()
Declare SetRadCalculatation()
Declare SetDegCalculatation()
Declare.d CalculateD(expression$)
Declare.f CalculateF(expression$)
Declare.q CalculateQ(expression$)
Declare.i CalculateI(expression$)
Declare.l CalculateL(expression$)
Declare.q CalculateSyntaxTreeL(*tree.SyntaxTree)
Declare.d CalculateSyntaxTreeF(*tree.SyntaxTree)
Declare CreateSyntaxTree(*tree.SyntaxTree, expression$)
Declare.d Calc_GetNodeValue(*node.SyntaxTreeNode)
Declare Calc_InsertNodeAsChild(*nodeTarget.SyntaxTreeNode, child.i, *nodeInsert.SyntaxTreeNode)
Declare Calc_InsertNodeAsParent(*nodeTarget.SyntaxTreeNode, *nodeInsert.SyntaxTreeNode)
Declare.s Calc_GetContent(expression.s, type.i, *pos.Integer)
Declare Calc_SetOperand(operand$, *node.SyntaxTreeNode)
;}

Global Radian.i

Procedure Calc_SetOperand(operand$, *node.SyntaxTreeNode)
	Shared priorMod.q
	
	While Left(operand$, 1) = ")"
    operand$ = Mid(operand$, 2, Len(operand$) - 1)
    priorMod - #PRIORITY_STEP
	Wend
	
  While Right(operand$, 1) = "("
    operand$ = Left(operand$, Len(operand$) - 1)
    changePrior.q + #PRIORITY_STEP
	Wend
	
	Select operand$
		Case "+"
			*node\operand = #OP_PLUS
			*node\prior = priorMod + 1
		Case "-"
			*node\operand = #OP_MINUS
			*node\prior = priorMod + 1
		Case "*"
			*node\operand = #OP_MULT
			*node\prior = priorMod + 2
		Case "/"
			*node\operand = #OP_DIV
			*node\prior = priorMod + 2
		Case "^"
			*node\operand = #OP_POT
			*node\prior = priorMod + 3
		Case "!"
			*node\operand = #OP_FACT
			*node\prior = priorMod + 4
		Case "%"
			*node\operand = #OP_PERCENT
			*node\prior = priorMod + 4
		Case "="
			*node\operand = #OP_EQUAL
			*node\prior = priorMod + 5
		Case ">"
			*node\operand = #OP_SUP
			*node\prior = priorMod + 5
		Case "<"
			*node\operand = #OP_INF
			*node\prior = priorMod + 5
		Case ">="
			*node\operand = #OP_SUPEQUAL
			*node\prior = priorMod + 5
		Case "<="
			*node\operand = #OP_INFEQUAL
			*node\prior = priorMod + 5
		Case "<>"
			*node\operand = #OP_NOTEQUAL
			*node\prior = priorMod + 5
		Case "~"
			*node\operand = #OP_FUNC
			; ACHTUNG: Funktionen mssen IMMMER die hchste Prioritt besitzen
			*node\prior = priorMod + 6
		Default
			*node\operand = #OP_UNKNOWN
	EndSelect
	
	priorMod + changePrior
EndProcedure
Procedure.s Calc_GetContent(expression.s, type.i, *pos.Integer)
	Memoire = *pos\i
	
	Index = *pos\i + 1
	If type = #VALUE
		; (-x) Ausrdrcke zulassen
		Char.i = Asc(Mid(expression, Index, 1))
		If Char = '-'
			; Debug Chr(Char)
			Index + 1
			Char.i = Asc(Mid(expression, Index, 1))
		EndIf
		
		; ) + - * / ^ ~ ! % \0
		; Ascii-Wert eines neuen Operators hier mit einfgen
		; Debug Chr(Char)
		While (Char < 'a' Or Char > 'z') And Char <> ')' And Char <> '*' And Char <> '+' And Char <> '-' And Char <> '/' And Char <> '^' And Char <> '!' And Char <> '%' And Char <> '~' And Char <> '>' And Char <> '<' And Char <> '=' And Char <> 0
			Index + 1
			Char.i = Asc(Mid(expression, Index, 1))
			; Debug Chr(Char)
		Wend
	Else
		; 0-9 .
		Char.i = Asc(Mid(expression, Index, 1))
		; Debug Chr(Char)
		While (Char < '0' Or Char > '9') And Char <> '.' And Char <> 0
			Index + 1
			Char.i = Asc(Mid(expression, Index, 1))
			; Debug Chr(Char)
		Wend
		; (-x) Ausrdrcke zulassen
		Char1.i = Asc(Mid(expression, Index - 1, 1))
		Char2.i = Asc(Mid(expression, Index - 2, 1))
		If Char1 = '-' And (Char2 = '(' Or Char2 = '*' Or Char2 = '+' Or Char2 = '/' Or Char2 = '^' Or Char2 = '-' Or Char2 = '>' Or Char2 = '<' Or Char2 = '=' Or Char2 = '!' Or Char2 = '%') ; '(-' '*-' '+-' '/-' '^-' '--'
			Index - 1
		EndIf
	EndIf
	
	Index - 1
	a_RET$ = Mid(expression, *pos\i + 1, Index - *pos\i)
	If Char
		*pos\i = Index
	Else
		*pos\i = -1
	EndIf
	
	; Debug ""
	; Debug *pos\i
	; Debug a_RET$
	; Debug "-------------------"
	
	; *pos\i = Memoire
	; 
	; *pointer.Byte = @expression + *pos\i
	; 
	; If type = #VALUE
	; ; (-x) Ausrdrcke zulassen
	; If PeekB(*pointer) = '-'
	; Debug Chr(PeekB(*pointer))
	; *pointer + 1
	; EndIf
	; 
	; ; ) + - * / ^ ~ ! % \0
	; ; Ascii-Wert eines neuen Operators hier mit einfgen
	; Debug Chr(PeekB(*pointer))
	; While (*pointer\b < 'a' Or *pointer\b > 'z') And *pointer\b <> ')' And *pointer\b <> '*' And *pointer\b <> '+' And *pointer\b <> '-' And *pointer\b <> '/' And *pointer\b <> '^' And *pointer\b <> '!' And *pointer\b <> '%' And *pointer\b <> '~' And *pointer\b <> 0
	; *pointer + 1
	; Debug Chr(PeekB(*pointer))
	; Wend
	; Else
	; ; 0-9 .
	; Debug Chr(PeekB(*pointer))
	; While (*pointer\b < '0' Or *pointer\b > '9') And *pointer\b <> '.' And *pointer\b <> 0
	; *pointer + 1
	; Debug Chr(PeekB(*pointer))
	; Wend
	; ; (-x) Ausrdrcke zulassen
	; If PeekB(*pointer - 1) = '-' And (PeekB(*pointer - 2) = '(' Or PeekB(*pointer - 2) = '*' Or PeekB(*pointer - 2) = '+' Or PeekB(*pointer - 2) = '/' Or PeekB(*pointer - 2) = '^' Or PeekB(*pointer - 2) = '-') ; '(-' '*-' '+-' '/-' '^-' '--'
	; *pointer - 1
	; EndIf
	; EndIf
	; 
	; a_RET$ = PeekS(@expression + *pos\i,(*pointer - @expression) - *pos\i)
	; 
	; If *pointer\b
	; *pos\i = *pointer - @expression
	; Else
	; *pos\i = -1
	; EndIf
	; 
	; Debug ""
	; Debug *pos\i
	; Debug a_RET$
	; Debug "________________"
	
	ProcedureReturn a_RET$
EndProcedure
Procedure Calc_InsertNodeAsParent(*nodeTarget.SyntaxTreeNode, *nodeInsert.SyntaxTreeNode)
	Protected child.i
	
	If *nodeTarget\parent
		If *nodeTarget\parent\child[0] = *nodeTarget
			child = 0
		ElseIf *nodeTarget\parent\child[1] = *nodeTarget
			child = 1
		EndIf
		*nodeTarget\parent\child[child] = *nodeInsert
		*nodeInsert\parent = *nodeTarget\parent
	EndIf
	*nodeTarget\parent = *nodeInsert
	*nodeInsert\child[0] = *nodeTarget
EndProcedure
Procedure Calc_InsertNodeAsChild(*nodeTarget.SyntaxTreeNode, child.i, *nodeInsert.SyntaxTreeNode)
	If *nodeTarget\child[child]
		*nodeChild.SyntaxTreeNode = *nodeTarget\child[child]
		*nodeChild\parent = *nodeInsert
		*nodeInsert\child[0] = *nodeTarget\child[child]
	EndIf
	
	*nodeTarget\child[child] = *nodeInsert
	*nodeInsert\parent = *nodeTarget
EndProcedure
Procedure.d Calc_GetNodeValue(*node.SyntaxTreeNode)
	Shared calculationErrorOccured.b
	Result.d
	
	If *node
		If *node\operand
			valueOne.d = Calc_GetNodeValue(*node\child[0])
			valueTwo.d = Calc_GetNodeValue(*node\child[1])
			Select *node\operand
				Case #OP_PLUS
					Result = valueOne + valueTwo
				Case #OP_MINUS
					Result = valueOne - valueTwo
				Case #OP_MULT
					Result = valueOne * valueTwo
				Case #OP_DIV
					Result = valueOne / valueTwo
					If valueTwo = 0 And calculationErrorOccured = 0
						calculationErrorOccured = #CALC_ERR_DIVNULL
					EndIf
				Case #OP_POT
					Result = Pow(valueOne, valueTwo)
				Case #OP_FACT
					If IntQ(valueOne) <> valueOne Or valueOne <= 0
						calculationErrorOccured = #CALC_ERR_WRONGINPUT
					EndIf
					Result = 1
					For x = 2 To valueOne
						Result * x
					Next
				Case #OP_PERCENT
					Result = valueOne / 100
				Case #OP_EQUAL
					If valueOne = valueTwo
						Result = 1
					Else
						Result = 0
					EndIf
				Case #OP_SUP
					If valueOne > valueTwo
						Result = 1
					Else
						Result = 0
					EndIf
				Case #OP_INF
					If valueOne < valueTwo
						Result = 1
					Else
						Result = 0
					EndIf
				Case #OP_SUPEQUAL
					If valueOne => valueTwo
						Result = 1
					Else
						Result = 0
					EndIf
				Case #OP_INFEQUAL
					If valueOne <= valueTwo
						Result = 1
					Else
						Result = 0
					EndIf
				Case #OP_NOTEQUAL
					If valueOne <> valueTwo
						Result = 1
					Else
						Result = 0
					EndIf
					
				Case #OP_FUNC
					Select valueOne ; steht fr den Funktionstyp
						Case #FUNC_SQR
							If valueTwo <= 0
								calculationErrorOccured = #CALC_ERR_WRONGINPUT
							EndIf
							Result = Sqr(valueTwo)
						Case #FUNC_SIN
							If Radian = 0
								valueTwo * #PI / 180
							EndIf
							Result = Sin(valueTwo)
						Case #FUNC_ASIN
							If valueTwo < - 1 Or valueTwo > 1
								calculationErrorOccured = #CALC_ERR_WRONGINPUT
							EndIf
							Result = ASin(valueTwo)
							If Radian = 0
								Result * 180 / #PI
							EndIf
						Case #FUNC_COS
							If Radian = 0
								valueTwo * #PI / 180
							EndIf
							Result = Cos(valueTwo)
						Case #FUNC_ACOS
							If valueTwo < - 1 Or valueTwo > 1
								calculationErrorOccured = #CALC_ERR_WRONGINPUT
							EndIf
							Result = ACos(valueTwo)
							If Radian = 0
								Result * 180 / #PI
							EndIf
						Case #FUNC_TAN
							If Radian = 0
								valueTwo * #PI / 180
							EndIf
							Result = Tan(valueTwo)
							If Radian = 0
								Result * 180 / #PI
							EndIf
						Case #FUNC_ATAN
							Result = ATan(valueTwo)
							If Radian = 0
								Result * 180 / #PI
							EndIf
						Case #FUNC_INT
							Result = IntQ(valueTwo)
						Case #FUNC_ABS
							Result = Abs(valueTwo)
						Case #FUNC_LOG10
							If valueTwo < 0
								calculationErrorOccured = #CALC_ERR_WRONGINPUT
							EndIf
							Result = Log10(valueTwo)
						Case #FUNC_LOG
							If valueTwo < 0
								calculationErrorOccured = #CALC_ERR_WRONGINPUT
							EndIf
							Result = Log(valueTwo)
						Default
							calculationErrorOccured = #CALC_ERR_FUNCNOTFOUND
					EndSelect
					
				Case #OP_UNKNOWN
					calculationErrorOccured = #CALC_ERR_OPNOTFOUND
			EndSelect
			ProcedureReturn Result
		Else
			ProcedureReturn *node\Value
		EndIf
	Else
		calculationErrorOccured = 1
	EndIf
EndProcedure

Procedure CreateSyntaxTree(*tree.SyntaxTree, expression$)
	Shared priorMod.q, functionCalculationEnabled.b, constantCalculationEnabled.b
	
	priorMod = 0
	nodeCount.i = 0
	Position.i = 0
	
	*nodeLastValue.SyntaxTreeNode
	*nodeCurrentValue.SyntaxTreeNode
	*nodeLastOperand.SyntaxTreeNode
	*nodeCurrentOperand.SyntaxTreeNode
	
	expression$ = LCase(ReplaceString(expression$, " ", ""))
	
	While Left(expression$, 1) = "("
		expression$ = Mid(expression$, 2, Len(expression$) - 1)
		priorMod + #PRIORITY_STEP
	Wend
	While Right(expression$, 1) = ")"
		expression$ = Left(expression$, Len(expression$) - 1)
	Wend
	
	expression$ = ReplaceString(expression$, "sqr", Str(#FUNC_SQR) + "~")
	expression$ = ReplaceString(expression$, "asin", Str(#FUNC_ASIN) + "~")
	expression$ = ReplaceString(expression$, "sin", Str(#FUNC_SIN) + "~")
	expression$ = ReplaceString(expression$, "acos", Str(#FUNC_ACOS) + "~")
	expression$ = ReplaceString(expression$, "cos", Str(#FUNC_COS) + "~")
	expression$ = ReplaceString(expression$, "atan", Str(#FUNC_ATAN) + "~")
	expression$ = ReplaceString(expression$, "tan", Str(#FUNC_TAN) + "~")
	expression$ = ReplaceString(expression$, "int", Str(#FUNC_INT) + "~")
	expression$ = ReplaceString(expression$, "abs", Str(#FUNC_ABS) + "~")
	expression$ = ReplaceString(expression$, "log", Str(#FUNC_LOG10) + "~")
	expression$ = ReplaceString(expression$, "ln", Str(#FUNC_LOG) + "~")
	expression$ = ReplaceString(expression$, "!", "!0")
	expression$ = ReplaceString(expression$, "%", "%0")
	
	expression$ = ReplaceString(expression$, "pi", #CONST_PI)
	expression$ = ReplaceString(expression$, "e^", #CONST_E + "^")
	
	Repeat
		nodeCount + 1
		
		If nodeCount & %1 = 1
			node$ = Calc_GetContent(expression$, #VALUE, @Position)
			*tree\node[nodeCount]\Value = ValD(node$)
			*nodeCurrentValue = *tree\node[nodeCount]
			; Debug node$
			
			If nodeCount > 1
				Calc_InsertNodeAsChild(*nodeLastOperand, 1, *nodeCurrentValue)
			EndIf
			
			*nodeLastValue = *nodeCurrentValue
		Else ; Operator
			node$ = Calc_GetContent(expression$, #OPERAND, @Position)
			Calc_SetOperand(node$, *tree\node[nodeCount])
			
			*nodeCurrentOperand = *tree\node[nodeCount]
			; Debug node$ + " :: " + Str(*nodeCurrentOperand\prior)
			
			If *nodeLastOperand
				If *nodeCurrentOperand\prior > *nodeLastOperand\prior
					Calc_InsertNodeAsChild(*nodeLastOperand, 1, *nodeCurrentOperand)
				ElseIf *nodeCurrentOperand\prior = *nodeLastOperand\prior
					Calc_InsertNodeAsParent(*nodeLastOperand, *nodeCurrentOperand)
				Else
					*node.SyntaxTreeNode = *nodeLastOperand
					While *node\parent And *node\prior > *nodeCurrentOperand\prior
						*node = *node\parent
					Wend
					
					If *node\prior = *nodeCurrentOperand\prior
						Calc_InsertNodeAsParent(*node, *nodeCurrentOperand)
					ElseIf *node\prior < *nodeCurrentOperand\prior
						Calc_InsertNodeAsChild(*node, 1, *nodeCurrentOperand)
					Else
						Calc_InsertNodeAsParent(*node, *nodeCurrentOperand)
					EndIf
				EndIf
			Else
				Calc_InsertNodeAsParent(*nodeLastValue, *nodeCurrentOperand)
			EndIf
			
			*nodeLastOperand = *nodeCurrentOperand
		EndIf
		
	Until Position = -1
	
	If *nodeLastOperand
		While *nodeLastOperand\parent
			*nodeLastOperand = *nodeLastOperand\parent
		Wend
		*tree\root = *nodeLastOperand
	ElseIf nodeCount = 1
		*tree\root = *nodeLastValue
	Else
		*tree\root = 0
	EndIf
	
EndProcedure
Procedure.d CalculateSyntaxTreeF(*tree.SyntaxTree)
	Shared calculationErrorOccured.b
	calculationErrorOccured = 0
	
	If *tree\root
		Result.d = Calc_GetNodeValue(*tree\root)
	Else
		; Fehler auslsen
		calculationErrorOccured = 1
		Result.d = 0 / Result
	EndIf
	
	ProcedureReturn Result
EndProcedure
Procedure.q CalculateSyntaxTreeL(*tree.SyntaxTree)
	Shared calculationErrorOccured.b
	calculationErrorOccured = 0
	
	If *tree\root
		Result.q = Calc_GetNodeValue(*tree\root)
	Else
		; Fehler auslsen
		calculationErrorOccured = 1
	EndIf
	
	ProcedureReturn Result
EndProcedure

Procedure SetCalculatationMode(Mode.i)
	Select Mode
		Case #CALC_MODE_RAD
			Radian = 1
		Case #CALC_MODE_DEG
			Radian = 0
	EndSelect
EndProcedure

Procedure.l CalculateL(expression$)
	Shared calculationErrorOccured.b
	calculationErrorOccured = 0
	
	tree.SyntaxTree
	CreateSyntaxTree(@tree, expression$)
	
	If tree\root
		Result.l = Calc_GetNodeValue(tree\root)
	Else
		; Fehler auslsen
		calculationErrorOccured = 1
	EndIf
	
	ProcedureReturn Result
EndProcedure
Procedure.i CalculateI(expression$)
	Shared calculationErrorOccured.b
	calculationErrorOccured = 0
	
	tree.SyntaxTree
	CreateSyntaxTree(@tree, expression$)
	
	If tree\root
		Result.i = Calc_GetNodeValue(tree\root)
	Else
		; Fehler auslsen
		calculationErrorOccured = 1
	EndIf
	
	ProcedureReturn Result
EndProcedure
Procedure.q CalculateQ(expression$)
	Shared calculationErrorOccured.b
	calculationErrorOccured = 0
	
	tree.SyntaxTree
	CreateSyntaxTree(@tree, expression$)
	
	If tree\root
		Result.q = Calc_GetNodeValue(tree\root)
	Else
		; Fehler auslsen
		calculationErrorOccured = 1
	EndIf
	
	ProcedureReturn Result
EndProcedure
Procedure.f CalculateF(expression$)
	Shared calculationErrorOccured.b
	calculationErrorOccured = 0
	
	tree.SyntaxTree
	CreateSyntaxTree(tree, expression$)
	
	If tree\root
		Result.f = Calc_GetNodeValue(tree\root)
	Else
		; Fehler auslsen
		calculationErrorOccured = 1
		Result.f = 0 / Result
	EndIf
	
	ProcedureReturn Result
EndProcedure
Procedure.d CalculateD(expression$)
	Shared calculationErrorOccured.b
	calculationErrorOccured = 0
	
	tree.SyntaxTree
	CreateSyntaxTree(tree, expression$)
	
	If tree\root
		Result.d = Calc_GetNodeValue(tree\root)
	Else
		; Fehler auslsen
		calculationErrorOccured = 1
		Result.d = 0 / Result
	EndIf
	
	ProcedureReturn Result
EndProcedure

Procedure.i GetCalculationError()
	Shared calculationErrorOccured.b
	ProcedureReturn calculationErrorOccured
EndProcedure


SetCalculatationMode(#CALC_MODE_DEG)
Debug CalculateD("acos(0)")
Debug GetCalculationError()

Re: Calcul littéral

Publié : ven. 18/déc./2009 17:34
par Thyphoon
c'est du caviar !!! Merci !! :)

Re: Calcul littéral

Publié : mer. 28/avr./2010 22:22
par Le Soldat Inconnu
Correction du code pour le support de l'Unicode :)

je ferais une mise à jour avec 4.50 et les nouvelles fonctions mathématique plus tard

Re: Calcul littéral

Publié : jeu. 29/avr./2010 8:29
par Le Soldat Inconnu
Encore une mise à jour pour l'unicode qui ne marchait pas encore au top et ajout des fonctions = > < >= <= <>
Fuseau horaire sur UTC+01:00
Page 1 sur 1

Développé par phpBB® Forum Software © phpBB Limited

Traduction française officielle © Qiaeru