移动一根火柴，使等式成立

爱疯

'入口
Dim Dic1, Dic2, Dic3, Result
Sub huocai()
    Dim Exp
    Exp = InputBox("移动一根火柴，使其成立", "提问", "1-2=6")
    If Exp = "" Then End
    If IsExp(Exp) = False Then MsgBox "不是算术等式", , "提示": End
    Result = Exp & vbLf & "可变成"
    Call Init
    Call Method1(Exp, Dic1)
    Call Method2(Exp, Dic3)
    MsgBox IIf(Len(Result) > Len(Exp) + 4, Result, "不能"), , "回答"
End Sub


'初始化
Private Sub Init()

    '可变：在自身上移动一根，可变成别的字符
    Set Dic1 = CreateObject("scripting.dictionary")
    Dic1("0") = Array(6, 9)
    Dic1("2") = Array(3)
    Dic1("3") = Array(2, 5)
    Dic1("5") = Array(3)
    Dic1("6") = Array(0, 9)
    Dic1("9") = Array(0, 6)
    Dic1("+") = Array("=")
    Dic1("=") = Array("+")

    '可加：在自身上增加一根，可变成别的字符
    Set Dic2 = CreateObject("scripting.dictionary")
    Dic2("0") = Array(8)
    Dic2("1") = Array(7)
    Dic2("3") = Array(9)
    Dic2("5") = Array(6, 9)
    Dic2("6") = Array(8)
    Dic2("9") = Array(8)
    Dic2("-") = Array("=", "+")
    Dic2("/") = Array("*")

    '可减：在自身上减少一根，可变成别的字符
    Set Dic3 = CreateObject("scripting.dictionary")
    Dic3("6") = Array(5)
    Dic3("7") = Array(1)
    Dic3("8") = Array(0, 6, 9)
    Dic3("9") = Array(3, 5)
    Dic3("+") = Array("-")
    Dic3("=") = Array("-")
    Dic2("*") = Array("/")

End Sub


'方法1(表达式，字典)
Sub Method1(Exp, d)
    Dim i, j, ch, A, Exp1
    For i = 1 To Len(Exp)
        ch = Mid(Exp, i, 1)
        If d.exists(ch) Then
            A = d(ch)
            For j = LBound(A) To UBound(A)
                Exp1 = Exp
                Mid(Exp1, i, 1) = A(j)
                Call IsEqual(Exp1)
            Next j
        End If
    Next i
End Sub


'方法2(表达式，字典)
Sub Method2(Exp, d)
    Dim ch, Exp1, A, B, i, j
    For i = 1 To Len(Exp)
        ch = Mid(Exp, i, 1)
        If d.exists(ch) Then    '遍历Exp的可减字符
            A = d(ch)
            For j = LBound(A) To UBound(A)     '遍历Exp的可减字符的替换值
                Exp1 = Exp
                Mid(Exp1, i, 1) = A(j)    '变成减少一根火柴的状态
                Call Method1(Exp1, Dic2)   '1
                Call ChangeSign(Exp1)
            Next j
        End If
    Next i
End Sub


'改变运算符(表达式)
Sub ChangeSign(Exp1)
    Dim i, Exp, ch, temp
    For i = 1 To Len(Exp1)
        ch = Mid(Exp1, i, 1)
        temp = ""
        If ch = "-" Then temp = "+"
        If ch = "/" Then temp = "*"
        If temp <> "" Then
            Exp = Exp1
            Mid(Exp, i, 1) = temp
            Call IsEqual(Exp)
        End If
    Next i
End Sub


'是否相等
Sub IsEqual(Exp)
'    If IsExp(Exp) Then
'        If InStr(Result, Exp) = 0 Then
'            If Application.Evaluate(Exp) = True Then
'                Result = Result & vbLf & Exp
'            End If
'        End If
'    End If
    Dim A
    If IsExp(Exp) Then
        A = Split(Exp, "=")
        A(0) = wkh(A(0))
        A(1) = wkh(A(1))
        If A(0) = A(1) And InStr(Result, Exp) = 0 Then Result = Result & vbLf & Exp
    End If
End Sub


'是不是表达式
Function IsExp(Exp) As Boolean
    Dim i, c, str, A, b1, b2, b3

    '1. 只能包含数字，加号，减号，等号
    b1 = True
    str = "0123456789-+*/="
    For i = 1 To Len(Exp)
        c = Mid(Exp, i, 1)
        If InStr(str, c) = 0 Then b1 = False: Exit For
    Next i

    '2. 只有1个等号
    b2 = UBound(Split(Exp, "=")) = 1

    '3. 不可连续是运算符
    b3 = True
    Call Exp2Arr(Exp, A)
    For i = 1 To UBound(A) Step 2
        If IsNumeric(A(i)) = b3 Then b3 = False: Exit For
    Next i

    IsExp = b1 And b2 And b3
End Function


'表达式转成数组
Sub Exp2Arr(ByVal Exp, A)
    Dim i
    A = Array("+", "-", "*", "/")
    For i = LBound(A) To UBound(A)
        Exp = Replace(Exp, A(i), "," & A(i) & ",")
    Next i
    A = Split(Exp, ",")
End Sub


'说明：数组前3个元素总存放前组（2个数和1个运算符）表达式，循环拿后组与之比较优先级
'无括号(表达式)
Function wkh(ByVal Exp)
    Dim A, i
    Call Exp2Arr(Exp, A)
    Select Case UBound(A)
    Case 0    '无运算符
        wkh = Exp + 0
    Case 2    '一个运算符
        wkh = js(A(0), A(2), A(1))
    Case Else    '多个运算符
        For i = 3 To UBound(A) Step 2
            If p(A(1)) < p(A(i)) Then
                A(2) = js(A(i - 1), A(i + 1), A(i))
            Else
                A(0) = js(A(0), A(2), A(1))
                A(1) = A(i)
                A(2) = A(i + 1)
            End If
        Next i
        wkh = js(A(0), A(2), A(1))
    End Select
End Function


'优先级(运算符)
Function p(ch)
    Select Case ch
    Case "+", "-"
        p = 1
    Case "*", "/"
        p = 2
    End Select
End Function


'计算两个数(数1, 数2, 运算符)
Function js(x, y, z)
    Select Case z
    Case "+"
        js = x + 0 + y
    Case "-"
        js = x - 0 - y
    Case "*"
        js = x * 1 * y
    Case "/"
        If y <> 0 Then js = x / 1 / y
    End Select
End Function

huocai_1.rar (117.41 KB, 下载次数: 13)

2019-3-14 09:05 上传

点击文件名下载附件