ab.com コミュニティ

コード: 全て選択

TypeDef PFunc_StrCalculationElementaryFuncReal = *Function( x As Double ) As Double
TypeDef PFunc_StrCalcElemR = PFunc_StrCalculationElementaryFuncReal


'その１：関数を考慮しないパタン
Function Calc_ReversePolish( pobjQueue As *StrQueue, ByRef xResult As Double ) As Char
	Dim ppszArray[1] As *BytePtr
	Dim pFuncArray[1] As PFunc_StrCalcElemR

	ppszArray[0] = NULL
	pFuncArray[0] = NULL

	Calc_ReversePolish = Calc_ReversePolishEx( pobjQueue, xResult, ppszArray, pFuncArray )
End Function
'その１：関数を考慮するパタン
Function Calc_ReversePolishEx( pobjQueue As *StrQueue, ByRef xResult As Double, ppszFuncArray As *BytePtr, pfuncArray As *PFunc_StrCalcElemR ) As Char
	Dim strBuf As String
	Dim pMark As BytePtr
	Dim objStk As StrStack
	Dim strR As String
	Dim strL As String
	Dim xTermR As Double
	Dim xTermL As Double
	Dim xRlt As Double

	Dim pFuncElemR As PFunc_StrCalcElemR
	Dim fError

	Dim i As Long

	While( pobjQueue->GetItemCount()>0 )
		strBuf = pobjQueue->GetOld()
'OutputDebugString( strBuf + ", " )
		If( 0<InStr( 1, strBuf, "(" ) or 0<InStr( 1, strBuf, ")" ) )Then
			'エラー：あるはずの無い括弧が含まれていた。＝未定義の関数が使われている。
			Calc_ReversePolishEx = FALSE

			'キューの内容を開放する
			While 0 < pobjQueue->GetItemCount()
				pobjQueue->Pop()
			Wend
			Exit Function
		End If
		pobjQueue->Pop()
		pMark = StrPtr( strBuf )

		'関数リストを考慮する：存在すれば、関数ポインタへ処理関数を格納する。
		pFuncElemR = NULL
		i = 0
		While( ppszFuncArray<>NULL )
			If 1 < lstrlen( pMark ) Then
				If 0=lstrcmp( pMark+1, ppszFuncArray ) Then
					pFuncElemR = pfuncArray
					Exit While
				End If
			End If
			i++
		Wend

		'演算子の処理と関数処理、定数（pi/e）を考慮した数値への変換。
		Select Case pMark[0]
			Case 43, 45, 42, 47, 94
				'演算子：処理すべき２項を数値へ変換する。
				strR = objStk.GetLast()
				objStk.Pop()
				xTermR = Calc_ReversePolish_ValEx( strR )

				strL = objStk.GetLast()
				objStk.Pop()
				xTermL = Calc_ReversePolish_ValEx( strL )

				If pFuncElemR<>NULL Then
					'関数ポインタが有効な場合は、処理する
					xTermR = pFuncElemR( xTermR )
'OutputDebugString( Ex"\r\n =" + Str$(xTermR) + Ex"\r\n" )
				Else If pMark[1]<>NULL Then
					'関数ポインタが無効 且つ 演算子の後ろにナニカある（＝未定義の関数）
					'→エラー。
					Calc_ReversePolishEx = FALSE

					'キューの内容を開放する
					While 0 < pobjQueue->GetItemCount()
						pobjQueue->Pop()
					Wend
					Exit Function
				End If

			Case Else
				'処理しない

		End Select
		'数値に変換した２項について計算する
		Select Case pMark[0]
			Case 43 '=[+]
				xRlt = xTermL + xTermR

			Case 45 '=[-]
				xRlt = xTermL - xTermR

			Case 42 '=[*]
				xRlt = xTermL * xTermR

			Case 47 '=[/]
				xRlt = xTermL / xTermR

			Case 94 '=[^]
				xRlt = xTermL^xTermR

		End Select
		Select Case pMark[0]
			Case 43, 45, 42, 47, 94
				'上記で処理がなされた場合
				strBuf = Calc_ReversePolish_StrDollerEx( xRlt )

			Case Else
				'処理しない

		End Select
		objStk.Push( strBuf )

'OutputDebugString( Ex"\r\n =" + strBuf + Ex"\r\n" )
	Wend
'OutputDebugString( strBuf + Ex"\r\n" )


	'計算成功
	xResult = Val( objStk.GetLast() )
	Calc_ReversePolishEx = TRUE
End Function
'Valの拡張版：いくつかの定数を置き換える。
Function Calc_ReversePolish_ValEx( strD As String ) As Double
	If strD="pi" Then
		Calc_ReversePolish_ValEx = 3.14159265358979 '15桁：倍精度浮動小数点型 
	Else If strD="e" Then
		Calc_ReversePolish_ValEx = 2.71828182845904 '15桁：倍精度浮動小数点型
	Else
		Calc_ReversePolish_ValEx = Val( strD )
	End If
End Function
'Str$の拡張版：[e-]付きの文字列は、範囲外として０として扱う。
Function Calc_ReversePolish_StrDollerEx( xD As Double ) As String
	Calc_ReversePolish_StrDollerEx = Str$( xD )
	If 0<>InStr( 1, Calc_ReversePolish_StrDollerEx, "e-" ) Then
		Calc_ReversePolish_StrDollerEx = "0"
	End If
End Function

コード: 全て選択

Dim strBuf As String '計算式を格納
Dim obj As StringCalc_ReversePolishNotation '逆ポーランド表記への変換クラス
Dim objQ As StrQueue '逆ポーランド表記の格納するキュー
Dim ppszList[3] As *BytePtr '対応関数リスト

Dim pFuncList[3] As PFunc_StrCalcElemR '対応関数の処理リスト

Dim x As Double '計算結果を格納


'認識する関数名を設定する。
ppszList[0] = "cos"
ppszList[1] = "sin"
ppszList[2] = NULL
obj.SetFunctionList( ppszList )

'認識する関数の処理を設定する。（※１）
pFuncList[0] = AddressOf( AddFuncCos )
pFuncList[1] = AddressOf( AddFuncSin )
pFuncList[2] = NULL

strBuf = "(5+7)*sin(pi*0.5)-4"

'逆ポーランド表記に変換
obj.SetNumericalFormula( strBuf )
obj.TraverseTreeToQueue( VarPtr(objQ) )

'逆ポーランド表記を元に計算を実行
Calc_ReversePolishEx( VarPtr(objQ), x, ppszList, pFuncList )
Print x


'終了を待機
Input strBuf


End


'関数の処理を定義
Function AddFuncCos( x As Double ) As Double
	AddFuncCos = Cos(x)
End Function
Function AddFuncSin( x As Double ) As Double
	AddFuncSin = Sin(x)
End Function

コード: 全て選択

Dim s[1024] As Byte
Dim s_end As Long
Dim s_i As Long
Dim c As Byte
Function read_s() As Byte
    If s_end <= s_i then
        read_s = 0
    Else
        read_s = s[s_i]
        s_i++
    End If
End Function

Sub MainWnd_CommandButton1_Click()
    Dim ans As Long
    Dim ansStr[100] As Byte
    s_end =  GetWindowText(GetDlgItem(hMainWnd,EditBox1),s,1024)
    s_i = 0
    c = read_s()

    ans = expr()
    lstrcpy(ansStr,Str$(ans))
    
    SetWindowText(GetDlgItem(hMainWnd,Static1),ansStr)
       
End Sub


Function expr() As Long
'    Dim d1 As Long
    Dim d3 As Long

'    d1 = term()
    expr = term()
    If c = Asc("+") Then
        c = read_s()
        d3 = expr()
'        Return (d1 + d3)
        expr += d3
    ElseIf c = Asc("-") Then
        c = read_s()
        d3 = expr()
'        Return (d1 - d3)
        expr -= d3
    Else
'        Return (d1)
    End If

End Function

Function term() As Long
    Dim d2 As Long
'    Dim d1 As Long
    Dim d3 As Long
    If c = Asc("(") Then
        c = read_s()
        d2 = expr()
        c = read_s()
        Return (d2)
    ElseIf Asc("1") <= c And c <= Asc("9") Then
'        d1  = num()
        term  = num()
        If c = Asc("*") Then
            c = read_s()
            d3 = term()
'            Return (d1 * d3)
            term *= d3
        ElseIf c = Asc("/") Then
            c = read_s()
            d3 = term()
'            Return (d1 / d3)
            term /= d3
        Else
'            Return (d1)
        End If     
    End If
End Function


Function num() As Long
'    Dim  v As Long
'    v  = 0
    num  = 0
    while Asc("0") <= c And c <= Asc("9")
'        v *= 10
        num *= 10
'        v += c- Asc("0")
        num += c- Asc("0")
        c = read_s()
    Wend
'    Return (v)
End Function