ab.com コミュニティ

コード: 全て選択

Sub MainWnd_CommandButton1_Click()
	Dim str	 As String
	Dim buf[50] As Byte
	Dim pra[50] As Byte
	Dim ans[50] As Double
	Dim operand[50]  As String
	Dim operator[30] As String
	Dim odc As Byte
	Dim orc As Byte
	Dim orn As Byte
	Dim ac	As Byte
	Dim f1	As Byte
	Dim f2	As Byte
	Dim f3	As Byte
	Dim i	As Byte
	Dim p	As Byte
	Dim a	As Long
	Dim b	As Long
	Dim c	As Long
	Dim d	As String
	Dim e	As String

	GetDlgItemText(hMainWnd, EditBox1, buf, 50)

'	If CHK_Parenthesis() Then Exit Sub	'Syntax Error

	i=InStr(1, buf, "="): str=Left$(buf, i)

	While buf
		p=i
		a=InStr(1, "SinsinCoscosTantan", Chr$(buf)+Chr$(buf[i+1])+Chr$(buf[i+2]))
		If a Then
			i=i+3
			p=i
			While InStr(1, "0123456789.", Chr$(buf)): i=i+1: f1=odc+1: WEnd
			If f1=0 Then Exit Sub	'Syntax Error
			operand[odc]=Mid$(buf, p+1, i-p)
			d=operand[f1-1]
			Select Case a\6
				Case 0
					ans[ac]=Sin(Val(d))
				Case 1
					ans[ac]=Cos(Val(d))
				Case 2
					ans[ac]=Tan(Val(d))
			End Select
			ans[ac]=Sin(Val(d))
			ac=ac+1: odc=odc+1
		Else
			p=i
			While InStr(1, "0123456789.", Chr$(buf)): i=i+1: f1=odc+1: WEnd
			If f1 Then operand[odc]=Mid$(buf, p+1, i-p): odc=odc+1

			p=i
			While ((buf>&H40 And buf<&H5b) Or (buf>&H60 And buf<&H7b)): i=i+1: f2=1: WEnd
			If f2 Then
				While InStr(1, "0123456789", Chr$(buf)): i=i+1: WEnd
				operand[odc]=Mid$(buf, p+1, i-p)
				GetDlgItemText(hMainWnd, EditBox2, pra, 50)
				lstrcat(pra, Ex"\r\n")
				a=1: b=0: c=0
				While InStr(a, pra, "=")
					b=InStr(a, pra, "="): a=InStr(b, pra, Ex"\r\n")
					If lstrcmp(Mid$(pra, c+1, b-c-1), operand[odc])=0 Then operand[odc]=Mid$(pra, b+1, a-b-1)
					c=a+1
				WEnd
				If b=0 Then Beep	'Error

				d=operand[f1-1]: e=operand[odc]
				If f1>0 Then ans[ac]=Val(d)*Val(e) Else ans[ac]=Val(e)
				ac=ac+1
				odc=odc+1
			Else
				If f1 Then d=operand[f1-1]: ans[ac]=Val(d): ac=ac+1
			End If
		End If

		Select Case orn 
				Case 1
					ans[orc]=ans[orc-1] + ans[orc]
				Case 2
					ans[orc]=ans[orc-1] - ans[orc]
				Case 3
					ans[orc]=ans[orc-1] * ans[orc]
				Case 4
					ans[orc]=ans[orc-1] / ans[orc]
				Case 5
					ans[orc]=ans[orc-1] \ ans[orc]
				Case 6
					ans[orc]=ans[orc-1] ^ ans[orc]
		End Select
		orn=0

		p=i
		orn=InStr(1, "+-*/\^", Chr$(buf))
		If orn Then
			f3=1: i=i+1
			operator[orc]=Mid$(buf, p+1, i-p): orc=orc+1
		End If

		If f1 Or f2 Or f3 Then f1=0: f2=0: f3=0 Else i=i+1
	WEnd

	SetDlgItemText(hMainWnd, EditBox3, str+Str$(ans[orc]))
End Sub

コード: 全て選択

Sub MainWnd_CommandButton1_Click()
	Dim ln As Long
	ln = GetWindowText(GetDlgItem(hMainWnd,EditBox1),buffer,1024)
	buffer[ln] = 0
	START()'解析始まり。
	SetWindowText(GetDlgItem(hMainWnd,EditBox2),buffer2)
End Sub

コード: 全て選択

'字句解析

Function IsCharNumeric(ByVal c As Byte) As Long
	If Asc("0") <= c And c <= Asc("9") Then
		IsCharNumeric = TRUE
	Else
		IsCharNumeric = FALSE
	Endif
End Function
Dim read_char_p As Long
Dim buffer[1024] As Byte
Function read_char() As Byte
	read_char = buffer[read_char_p]
	read_char_p = read_char_p + 1 
End Function
'------------------------------------
Enum LEX_KIND
	FUNC = 1'関数
	REG = 2'変数
	NUM = 3'数値
	KIGOU = 4'その他
End Enum
Enum FUNC_KIND
	SIN'Sin
	COS'Cos
End Enum
Enum STATE'内部状態
	INIT_STATE
	EXIT_STATE
	KIGOU_STATE
	NUM_STATE
	SYOUSU_STATE
	NAME_STATE
	FUNC_STATE
End Enum
Dim c As Byte
Function Init()
	read_char_p = 0
	c = read_char()
End Function

Dim text[100] As Byte'単語がそのまま入る
Dim val As Double'単語が数字なら数値が入る
Dim reg As Long'単語が変数なら添え字が入る
Dim symbol As Byte'単語がその他の文字ならその文字が入る。
Dim func As *Function(x As Double) As Double'単語が関数なら関数ポインターが入る。(引数1つのものだけ)

'単語を読む
Function read_symbol() As LEX_KIND
	Dim state As STATE
	Dim text_p As Long
	state = INIT_STATE
	text_p = 0
	While state <> EXIT_STATE
		Select Case state
			Case INIT_STATE
				If IsCharNumeric(c) = TRUE Then
					state = NUM_STATE
				Elseif IsCharAlpha(c) = TRUE Then
					state = NAME_STATE
				Else
					state = KIGOU_STATE
				End If
			Case KIGOU_STATE
				read_symbol = KIGOU
				state = EXIT_STATE
			Case NUM_STATE
				If IsCharNumeric(c) = TRUE Then
					state = NUM_STATE
				ElseIf c = Asc(".") Then
					state = SYOUSU_STATE
				Else
					state = EXIT_STATE
					read_symbol = NUM
				End If
			Case SYOUSU_STATE
				If IsCharNumeric(c) = TRUE Then
					state = SYOUSU_STATE
				Else
					state = EXIT_STATE
					read_symbol = NUM
				End If
			Case NAME_STATE
				if IsCharAlphaNumeric(c) Then
					state = FUNC_STATE
				Else
					state = EXIT_STATE'一文字の場合
					read_symbol = REG
				End If
			Case FUNC_STATE
				If IsCharAlphaNumeric(c) Then
					state = FUNC_STATE
				Else
					state = EXIT_STATE
					read_symbol = FUNC
				End If
		End Select

		If state <> EXIT_STATE Then
			text[text_p] = c
			text_p = text_p + 1
			c = read_char()
		End If
	Wend
	text[text_p] = 0
	Select Case read_symbol
		Case FUNC
			If lstrcmp(text,"Sin") = 0 Then
				func = AddressOf(Sin)
			Elseif lstrcmp(text,"Cos") = 0 Then
				func = AddressOf(Cos)
			End If
		Case NUM
			val = Val(text)
		Case REG
			If IsCharUpper(text[0]) = TRUE Then
				reg = text[0] - Asc("A")
			ElseIf IsCharLower(text[0]) = TRUE Then
				reg = text[0] - Asc("a") + 26
			End If
		Case KIGOU
			symbol = text[0]
	End Select
End Function

コード: 全て選択

'構文解析

Dim t As LEX_KIND
Dim buffer2[1024] As Byte
Dim regs[54]

Sub START()
	Init()
	buffer2[0] = 0
	t = read_symbol()
	S()
	If t = KIGOU And symbol = 0 Then
		'成功
	Else
		'失敗
		lstrcpy(buffer2,"ERROR")
	End If
End Sub
Sub S()'プログラムかどうかを解析
	If t = KIGOU And symbol=0 Then
		ExitSub
	Else if t = REG then 'S->B\nS
		
		B()
		If t = KIGOU And symbol = 13 Then'LF
			t = read_symbol()'
			If t = KIGOU And symbol = 10 Then
				t = read_symbol()
				S()
			End If
		End If
	End If
End Sub
Sub B()'文かどうか
	Dim p As Long
	Dim reg_name As Byte
	If t = REG Then'B->REG=F(代入文のみです。)
		p = reg
		reg_name = text[0]
		t = read_symbol()
		if t = KIGOU And symbol = Asc("=") then
			t = read_symbol()
			regs[p] = F()
		End If
		lstrcat(buffer2,Chr$(reg_name) & "=" & Str$(regs[p])+Chr$(13)+Chr$(10))
	End If
End Sub
Function F() As Double
	Dim u As Double
	u = T()
	F = F1(u)

End Function
Function T() As Double
	Dim u As Double
	u = A()
	T = T1(u)
End Function
Function T1(x As Double) As Double
	Select Case t
		Case KIGOU
			Select Case symbol
				Case Asc("*")
					t = read_symbol()
					T1 = T1(x * A())
				Case Asc("/")
					t = read_symbol()
					T1 = T1(x / A())
				Case Else' Asc("+"),Asc("-"),Asc(")"),0
					T1 = x
			End Select
	End Select
End Function
Function F1(x As Double) As Double
	Select Case t
		Case KIGOU
			Select Case symbol
				Case Asc("+")
					t = read_symbol()
					F1 = F1(x + T())
				Case Asc("-")
					t = read_symbol()
					F1 = F1(x - T())
				Case Else' Asc(")"),0
					F1 = x
			End Select
	End Select
End Function
Function A() As Double
	Dim u As Double
	Dim g As *Function(x As Double) As Double 
	If t = REG Then
		A = regs[reg]
		t = read_symbol()
	Elseif t = FUNC Then
		g = func
		t = read_symbol()
		If t = KIGOU And symbol = Asc("(") Then
			t = read_symbol()
			u = F()
			If t = KIGOU And symbol = Asc(")") Then
				A = func(u) 
				t = read_symbol()
			End If
		End If
	Elseif t = NUM Then
		A = val
		t  = read_symbol()
	Elseif t = KIGOU Then
		If symbol = Asc("(") Then
			t =  read_symbol()
			u = F()
			If t = KIGOU And symbol = Asc(")") Then
				t = read_symbol()
				A = u
			End If
		ElseIf symbol = Asc("-") Then
			t = read_symbol()
			u = - A()
		End If
	End If
End Function