４つの数字で10を作る（道半ば） - Infomentのブログ～Excel VBA奮闘記～

面白いテーマがあったので、挑戦してみた。

４つの数字で、四則演算を用い10を作る

ナンバープレートの数字で、誰でも一度は遊んだことある？
f:id:Infoment:20200824223340p:plain

作戦としては、こうだ。

任意の４つの数字を選ぶ。
４つの数字の全ての組合せ（24通り）を得る。
24通りの組合せに対し、11通りの括弧を含む式を作成。
11通りの括弧を含む式に登場する３個の演算子に対し、
「+-*/」の４種類をループで充てて計算。
10になるものをひたすら探す。

何通りの計算が必要なのかと天を仰いだが、地道にやってみた。

まず、組合せを得る関数がこちら。

' ４つの数字からなる全ての組合せを、コレクションとして返す関数。
Function GetCombination(source As Long, _
               Optional digit_number As Long) As Collection

    ' 常用対数を用いて、桁数チェック。
    Dim SourceDigit As Long
        SourceDigit = WorksheetFunction.RoundUp(WorksheetFunction.Log10(source), 0)

    ' 与えられた数の桁数が指定桁数より小さい場合に対応。
    ' 例）sourceが「123」（３桁）で、digit_numberが４の場合。
    ' 　　これは、「0123」で処理することを意図している。
        If digit_number <= SourceDigit Then
            digit_number = SourceDigit
        End If
    
    ' 元の数を一つずつばらばらにして、一次元配列に格納。
    Dim s() As Variant
    ReDim s(1 To digit_number)
    Dim i As Long
        For i = 1 To digit_number
            s(i) = CLng(Mid(Format(source, WorksheetFunction.Rept(0, digit_number)), i, 1))
        Next
    
    Dim col As Collection
    Set col = New Collection
    Dim temp() As Variant
    Dim j As Long
        
        ' 指定桁数の全ての値をループして、全ての組合せを抽出。
        ' 例）３桁なら、100～999をループして、「123,132,213,231,312,321」を抽出。
        On Error Resume Next
        For i = 10 ^ (digit_number - 1) To 10 ^ digit_number - 1
            ReDim temp(1 To digit_number)
            For j = 1 To digit_number
                temp(CLng(Mid(i, j, 1))) = CLng(Mid(i, j, 1))
            Next
            If WorksheetFunction.Sum(temp) = digit_number * (digit_number + 1) / 2 Then
                For j = 1 To digit_number
                    temp(j) = s(CLng(Mid(i, j, 1)))
                Next
                col.Add CLng(Join(temp, vbNullString))
                
                ' n個の数の組合せは､nの階乗個｡
                If col.Count = WorksheetFunction.Fact(digit_number) Then
                    Exit For
                End If
            End If
        Next
        
    Set GetCombination = col

End Function

抽出した24通りの組み合わせを、一つずつ確認するのがこちら。

Function Answer(source_number As Long, Optional answer_number As Long = 10) As Variant
    
    ' ４つの数字の組合せ（２４通り）を格納するコレクション。
    ' ※同じ数字であっても、別物とみなす。従って、例えば「9999」で
    ' 　取りうる組合せは１つだが、これも２４通りとして扱っている。
    Dim col As Collection
    Set col = GetCombination(source_number)
    Dim a As Variant
    Dim c As Variant
    Dim arr As Variant
        arr = Array()
    Dim TempArray
        For Each c In col
            ' 組合せの一つずつから、答えが10になる式を求める。
            ' 求めた式は複数の場合もあるため、配列として取得。
            TempArray = GetAnswer(CLng(c))
            If UBound(TempArray) <> -1 Then
                For Each a In TempArray
                    ReDim Preserve arr(UBound(arr) + 1)
                    arr(UBound(arr)) = a
                Next
            End If
        Next
    
    ' 得られた式が重複する場合を考慮し、辞書のkeyが重複を
    ' 許さない性質を用いて重複除去を行う。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
        For Each a In arr
            Dict(a) = 1
        Next
                
        Answer = Dict.Keys
End Function

Function GetAnswer(source_number As Long, Optional answer_number As Long = 10) As Variant
    Static Dict As Object
        If Dict Is Nothing Then
            Set Dict = CreateObject("Scripting.Dictionary")
                Dict(1) = "+"
                Dict(2) = "-"
                Dict(3) = "*"
                Dict(4) = "/"
        End If
    
    Dim i As Long
    
    Dim i1 As Long: i1 = Mid(Format(source_number, "0000"), 1, 1)
    Dim i2 As Long: i2 = Mid(Format(source_number, "0000"), 2, 1)
    Dim i3 As Long: i3 = Mid(Format(source_number, "0000"), 3, 1)
    Dim i4 As Long: i4 = Mid(Format(source_number, "0000"), 4, 1)
    
    Dim j1 As Long
    Dim j2 As Long
    Dim j3 As Long
    Dim arr(1 To 11) As Variant
    Dim temp As Double
    Dim Ans As Variant
        Ans = Array()
        On Error Resume Next
        For j1 = 1 To 4
            For j2 = 1 To 4
                For j3 = 1 To 4
                    ' a+b+c+d
                    arr(1) = "=" & i1 & Dict(j1) & i2 & Dict(j2) & i3 & Dict(j3) & i4
                    ' (a+b)+c+d
                    arr(2) = "=" & "(" & i1 & Dict(j1) & i2 & ")" & Dict(j2) & i3 & Dict(j3) & i4
                    ' a+(b+c)+d
                    arr(3) = "=" & i1 & Dict(j1) & "(" & i2 & Dict(j2) & i3 & ")" & Dict(j3) & i4
                    ' a+b+(c+d)
                    arr(4) = "=" & i1 & Dict(j1) & i2 & Dict(j2) & "(" & i3 & Dict(j3) & i4 & ")"
                    '(a+b+c)+d
                    arr(5) = "=" & "(" & i1 & Dict(j1) & i2 & Dict(j2) & i3 & ")" & Dict(j3) & i4
                    ' a+(b+c+d)
                    arr(6) = "=" & i1 & Dict(j1) & "(" & i2 & Dict(j2) & i3 & Dict(j3) & i4 & ")"
                    ' (a+b)+(c+d)
                    arr(7) = "=" & "(" & i1 & Dict(j1) & i2 & ")" & Dict(j2) & "(" & i3 & Dict(j3) & i4 & ")"
                    ' ((a+b)+c)+d
                    arr(8) = "=" & "((" & i1 & Dict(j1) & i2 & ")" & Dict(j2) & i3 & ")" & Dict(j3) & i4
                    ' (a+(b+c))+d
                    arr(9) = "=" & "(" & i1 & Dict(j1) & "(" & i2 & Dict(j2) & i3 & "))" & Dict(j3) & i4
                    ' a+((b+c)+d)
                    arr(10) = "=" & i1 & Dict(j1) & "((" & i2 & Dict(j2) & i3 & ")" & Dict(j3) & i4 & ")"
                    ' a+(b+(c+d))
                    arr(11) = "=" & i1 & Dict(j1) & "(" & i2 & Dict(j2) & "(" & i3 & Dict(j3) & i4 & "))"
        
                    For i = 1 To 11
                        temp = Evaluate(arr(i))
                        If IsNumeric(temp) Then
                            If temp = answer_number Then
                                ReDim Preserve Ans(UBound(Ans) + 1)
                                Ans(UBound(Ans)) = arr(i)
                                Exit For
                            End If
                        End If
                    Next
        Next j3, j2, j1
        
        GetAnswer = Ans
End Function

　
それでは、「６，７，８，９」の４つで試してみよう。

Sub Hoge()
    Dim arr As Variant
        arr = Answer(6789)
        Range("A2").Resize(UBound(arr) + 1) = WorksheetFunction.Transpose(arr)
End Sub

↓ 結果がこちら。
なかなか奇抜な数式も幾つかあって、それなりに満足のいく結果になったと思う。
f:id:Infoment:20200824230724p:plain

実質的には同じ式を、別の式として扱っているという、大きな課題が残っている。
f:id:Infoment:20200824230908p:plain

しかし今回はマクロを組みながら、課題の難しさから何度も頭が音を立てて破裂しており（※比喩）、これ以上は頭蓋骨が持ちそうにない。

ということで、道半ばではあるが、今回はこれで良しとしよう。

参考まで。