4つの数字で10を作る(道半ば)
面白いテーマがあったので、挑戦してみた。
4つの数字で、四則演算を用い10を作る
ナンバープレートの数字で、誰でも一度は遊んだことある?
作戦としては、こうだ。
- 任意の4つの数字を選ぶ。
- 4つの数字の全ての組合せ(24通り)を得る。
- 24通りの組合せに対し、11通りの括弧を含む式を作成。
- 11通りの括弧を含む式に登場する3個の演算子に対し、
「+-*/」の4種類をループで充てて計算。
10になるものをひたすら探す。
何通りの計算が必要なのかと天を仰いだが、地道にやってみた。
まず、組合せを得る関数がこちら。
' 4つの数字からなる全ての組合せを、コレクションとして返す関数。 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」(3桁)で、digit_numberが4の場合。 ' これは、「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 ' 指定桁数の全ての値をループして、全ての組合せを抽出。 ' 例)3桁なら、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 ' 4つの数字の組合せ(24通り)を格納するコレクション。 ' ※同じ数字であっても、別物とみなす。従って、例えば「9999」で ' 取りうる組合せは1つだが、これも24通りとして扱っている。 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
それでは、「6,7,8,9」の4つで試してみよう。
Sub Hoge() Dim arr As Variant arr = Answer(6789) Range("A2").Resize(UBound(arr) + 1) = WorksheetFunction.Transpose(arr) End Sub
↓ 結果がこちら。
なかなか奇抜な数式も幾つかあって、それなりに満足のいく結果になったと思う。
実質的には同じ式を、別の式として扱っているという、大きな課題が残っている。
しかし今回はマクロを組みながら、課題の難しさから何度も頭が音を立てて破裂しており(※比喩)、これ以上は頭蓋骨が持ちそうにない。
ということで、道半ばではあるが、今回はこれで良しとしよう。
参考まで。