私が持ってる玩具でジャマイカというのがあるのですが


http://www.masudaya.com/product/jamaica.html
これの最適解をExcelマクロで出す方法を考えてください。
詳細はコメント参照。

回答の条件
  • 1人2回まで
  • 登録:2009/10/28 15:35:56
  • 終了:2009/11/04 08:27:31

ベストアンサー

id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912009/11/04 01:00:06

ポイント200pt

何とか締め切りに間に合ったでしょうか。


ぎりぎりになったので、チェック漏れがあるかもしれませんが何となく動いているので回答します。

コードは一応下記に張っておきますがこれだけでは動きませんので、動作版はお手数ですがダイアリーを参照ください。


下準備

(1)まず、5つの数字の組み合わせによる四則演算の式は2048通りあります。

(2)これらのうち変形することによって同じ式になるものをまとめると、374通りになります。

(3)さらにこれらの式のうちサイコロの数値(1~6)を使用して11以上になるものは233通りです。

これはジャマイカにおいては一意に決まるものですから、あらかじめ用意しておきます。

(VBA では Expression というシートのA列にあることを前提にしています。)


さて実際の処理ですが、サイコロの目のパターン(最大120通り:重複によりこれ以下)をこの233通りにあてはめて計算することによって

最大の計算数を 120*233 以内で結果を出すことができます。


こちらでの実行結果はだいたい2~6秒くらいでした。

参考までにコードを提示します。

Option Explicit

Public Goal As Long            '// 目標値(黒ダイスの合計)
Public DiceArray(4) As Long    '// 白ダイス
Public OutRow As Long          '// 結果出力行

'-----------------------------------------------------------------
Sub Shoot()
'-----------------------------------------------------------------
    Columns("B").Value = ""
    
    Dim c
    For Each c In Array("Num1", "Num2", "Num3", "Num4", "Num5", "GNum2")
        Range(c).Value = Int(Rnd() * 6) + 1
    Next
    Range("GNum1").Value = 10 * (Int(Rnd() * 6) + 1)
End Sub

'-----------------------------------------------------------------
Sub Jamaica()
'-----------------------------------------------------------------
    Dim d, i As Long
    For Each d In Array("Num1", "Num2", "Num3", "Num4", "Num5")
        DiceArray(i) = Range(d)
        i = i + 1
    Next
    Goal = Range("GNum1").Value + Range("GNum2").Value
    
    If getMax() < Goal Then
        Range("B2") = "No Answer"
        Exit Sub
    End If
    OutRow = 2
    
    Dim comArray
    comArray = makeNumArray()
    
    Dim com, r As Long
    r = 1
    Do While Worksheets("Expression").Cells(r, "A") <> ""
        For Each com In comArray
            If expCalc(Worksheets("Expression").Cells(r, "A"), com) = True Then Exit For
        Next
        r = r + 1
    Loop
    If OutRow = 2 Then
        Cells(OutRow, "B") = "No Answer"
    Else
        Cells(OutRow, "B") = "END"
    End If
End Sub

'-----------------------------------------------------------------
Function expCalc(exp, com) As Boolean
'-----------------------------------------------------------------
    expCalc = False
    Dim i As Long, j As Long, ch As String
    Dim dstExp As String
    j = 1
    For i = 1 To Len(exp)
        ch = Mid(exp, i, 1)
        If ch = "#" Then
            dstExp = dstExp & Mid(com, j, 1)
            j = j + 1
        Else
            dstExp = dstExp & ch
        End If
    Next
    If CLng(Evaluate(dstExp)) = Goal Then
        Cells(OutRow, "B") = dstExp
        OutRow = OutRow + 1
        expCalc = True
    End If
End Function

'-----------------------------------------------------------------
Function makeNumArray()
'-----------------------------------------------------------------
    Dim objDic
    Dim cm As String
    Dim i1, i2, i3, i4, i5, ar1, ar2, ar3, ar4, ar5
    Set objDic = CreateObject("Scripting.Dictionary")
    For Each i1 In Array(0, 1, 2, 3, 4)
        ar2 = Replace(Replace("0,1,2,3,4,@", i1 & ",", ""), ",@", "")
    For Each i2 In Split(ar2, ",")
        ar3 = Replace(Replace(ar2 & ",@", i2 & ",", ""), ",@", "")
    For Each i3 In Split(ar3, ",")
        ar4 = Replace(Replace(ar3 & ",@", i3 & ",", ""), ",@", "")
    For Each i4 In Split(ar4, ",")
        i5 = CInt(Replace(Replace(ar4 & ",@", i4 & ",", ""), ",@", ""))
        cm = DiceArray(i1) & DiceArray(i2) & DiceArray(i3) & DiceArray(i4) & DiceArray(i5)
        If Not objDic.Exists(cm) Then
            objDic.Add cm, ""
        End If
    Next
    Next
    Next
    Next

    makeNumArray = objDic.keys
End Function

'-----------------------------------------------------------------
Function getMax() As Long
'-----------------------------------------------------------------
    Dim n%(7), i%, j%
    
    For i = 0 To 4
        n(DiceArray(i)) = n(DiceArray(i)) + 1
    Next
    
    Do While n(1) > 0
        n(1) = n(1) - 1
        For i = 1 To 6
            If n(i) > 0 Then
                n(i) = n(i) - 1
                n(i + 1) = n(i + 1) + 1
                Exit For
            End If
        Next
    Loop
    
    getMax = 1
    For i = 1 To 7
        For j = 1 To n(i)
            getMax = getMax * i
        Next
    Next
End Function
id:kine2525

短い!しかも分かりやすい!!

お疲れ様でした。

2009/11/04 08:26:23

その他の回答(2件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/10/31 23:20:17

ポイント50pt

やっとこそれっぽいものができたので回答します。

Mookさんの作った実行シートが面白かったのでそのまま使えるようにしました。


処理はかなり重いので、非力のPCの場合ステータスバーのパーセント表示が進まないこともありえるので、

その場合はDoEventsを入れてあるので、VBEからマクロを停止してください。

(Core2Duo 2.4Ghzで50秒くらいでした)


コードにコメントをつけてなかったり短い名前の変数が乱立しているので見づらいことをお詫びします。

コードはもう少し短くすることもできましたが、更にわかりづらくなるのでやめました。

実行速度については、組み合わせやソートを書くことで、ある程度改善できますが、

コードが長くなるのでしていません。(ソートはシート上でやっています)

ロジック的には大丈夫だと思いますが、結果漏れがあるかどうかは完全に検証はできていません。

結果の重複も同じです。括弧の解釈によりある意味一定の重複は取り除けています。


Option Explicit

Public Type Enzan
    s As Double
    n As String
    k As Integer
End Type

Private r As Long
Private lngC As Long

Sub Shoot()
    Columns("B").Value = ""
    
    Dim c
    For Each c In Array("Num1", "Num2", "Num3", "Num4", "Num5", "GNum2")
        Range(c).Value = Int(Rnd() * 6) + 1
    Next
    Range("GNum1").Value = 10 * (Int(Rnd() * 6) + 1)
End Sub

Sub jamaica()
    Application.ScreenUpdating = False
    Dim i As Integer
    Dim e(4) As Enzan
    
    Columns("AG").Value = ""
    Range("AF1:AF5").NumberFormatLocal = "@"
    
    r = 2
    lngC = 0
    
    For i = 0 To 4
        e(i).s = Range("Num" & i + 1).Value
        e(i).n = Range("Num" & i + 1).Value
        e(i).k = 2
    Next i

    Call Saiki(e, 4)

    If Range("B2") = "" Then Range("B2") = "NO ANSWER"
    Application.StatusBar = ""
    Range("AF1:AF5").Value = ""
    Columns("AG").Value = ""

    Application.ScreenUpdating = True
End Sub

Sub Saiki(e3() As Enzan, j As Integer)
    Dim i1 As Integer
    Dim i2 As Integer
    Dim i3 As Integer
    Dim s1 As Double
    Dim s2 As Double
    Dim n1 As String
    Dim n2 As String
    Dim k1 As Integer
    Dim k2 As Integer
    Dim c As Integer
    Dim i As Integer
    Dim e() As Enzan
    Dim e1() As Enzan
    Dim n5 As String
    Dim n6 As String
    Dim str As String
    
    For i1 = 0 To j
        For i2 = 0 To j
            If i1 <> i2 Then
                e = e3
                s1 = e(i1).s
                n1 = e(i1).n
                k1 = e(i1).k
                s2 = e(i2).s
                n2 = e(i2).n
                k2 = e(i2).k
                c = 0
                For i = 0 To j
                    If i <> i1 And i <> i2 Then
                        e(c) = e(i)
                        c = c + 1
                    End If
                Next i
                e1 = e
                For i3 = 0 To 3
                    DoEvents
                    lngC = lngC + 1
                    Application.StatusBar = Int(lngC / 832592 * 100) & "%"
                    e = e1
                    n5 = n1
                    n6 = n2
                    Select Case i3
                        Case 0
                            e(j - 1).s = s1 + s2
                            e(j - 1).n = n5 & "+" & n6
                            e(j - 1).k = 0
                        Case 1
                            e(j - 1).s = s1 - s2
                            If k2 < 2 Then
                                n6 = "(" & n2 & ")"
                            End If
                            e(j - 1).n = n5 & "-" & n6
                            e(j - 1).k = 1
                        Case 2
                            e(j - 1).s = s1 * s2
                            If k1 < 2 Then
                                n5 = "(" & n1 & ")"
                            End If
                            If k2 < 2 Then
                                n6 = "(" & n2 & ")"
                            End If
                            e(j - 1).n = n5 & "*" & n6
                            e(j - 1).k = 2
                        Case 3
                            If s2 = 0 Then Exit For
                            e(j - 1).s = s1 / s2
                            If k1 < 2 Then
                                n5 = "(" & n1 & ")"
                            End If
                            If Len(n2) > 1 Then
                                n6 = "(" & n2 & ")"
                            End If
                            e(j - 1).n = n5 & "/" & n6
                            e(j - 1).k = 3
                    End Select
                    e(j).s = 0
                    e(j).n = ""
                    e(j).k = 2
                    If j > 1 Then
                        Call Saiki(e, j - 1)
                    Else
                        If e(0).s = Range("GNum1").Value + Range("GNum2").Value Then
                            str = Sort(e(0).n)
                            If Range("AG:AG").Find(str) Is Nothing Then
                                Cells(r, "AG").Value = str
                                Cells(r, 2).Value = e(0).n
                                r = r + 1
                            End If
                        End If
                    End If
                Next i3
            End If
        Next i2
    Next i1
End Sub

Function Sort(ByVal s As String) As String
    Dim i As Integer
    Dim j As Integer
    Dim f As Boolean
    Dim h(9) As Variant
    Dim c As Integer
    Dim sp As Integer
    Dim ep As Integer
    Dim st As String
    Dim res As String
    Dim str As String
    
    For i = 1 To Len(s)
        Select Case Mid(s, i, 1)
            Case "+", "-"
                If j = 0 Then
                    f = True
                End If
            Case "("
                j = j + 1
            Case ")"
                j = j - 1
        End Select
    Next i
    
    j = 0
    sp = 1
    If f Then
        s = "+" & s
        For i = 1 To Len(s)
            Select Case Mid(s, i, 1)
                Case "+", "-"
                    If j = 0 Then
                        If sp > 1 Then
                            str = Mid(s, sp, i - sp)
                            If i - sp > 1 Then
                                If Check(str) Then
                                    h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
                                Else
                                    h(c) = st & Sort(str)
                                End If
                            Else
                                h(c) = st & str
                            End If
                            c = c + 1
                        End If
                        h(c) = "+"
                        st = Mid(s, i, 1)
                        c = c + 1
                        sp = i + 1
                    End If
                Case "("
                    j = j + 1
                Case ")"
                    j = j - 1
            End Select
        Next i
        str = Mid(s, sp, i - sp)
        If i - sp > 1 Then
            If Check(str) Then
                h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
            Else
                h(c) = st & Sort(str)
            End If
        Else
            h(c) = st & str
        End If
    Else
        s = "*" & s
        For i = 1 To Len(s)
            Select Case Mid(s, i, 1)
                Case "*", "/"
                    If j = 0 Then
                        If sp > 1 Then
                            str = Mid(s, sp, i - sp)
                            If i - sp > 1 Then
                                If Check(str) Then
                                    h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
                                Else
                                    h(c) = st & Sort(str)
                                End If
                            Else
                                h(c) = st & str
                            End If
                            c = c + 1
                        End If
                        h(c) = "*"
                        st = Mid(s, i, 1)
                        c = c + 1
                        sp = i + 1
                    End If
                Case "("
                    j = j + 1
                Case ")"
                    j = j - 1
            End Select
        Next i
        str = Mid(s, sp, i - sp)
        If i - sp > 1 Then
            If Check(str) Then
                h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
            Else
                h(c) = st & Sort(str)
            End If
        Else
            h(c) = st & str
        End If
    End If
    
    For i = 1 To 5
        Cells(i, "AF").Value = h(i * 2 - 1)
    Next i
    Range("AF1:AF5").Sort Key1:=Range("AF1")
    For i = 1 To 5
        h(i * 2 - 1) = Cells(i, "AF").Value
    Next i
    
    For i = 0 To 9
        res = res & h(i)
    Next
    
    Sort = res
End Function

Function Check(s As String) As Boolean
    Dim i As Integer
    Dim j As Integer
    Dim f As Boolean
    
    If Left(s, 1) = "(" And Right(s, 1) = ")" Then
        f = True
        For i = 1 To Len(s)
            Select Case Mid(s, i, 1)
                Case "("
                    j = j + 1
                Case ")"
                    j = j - 1
                    If j = 0 And i <> Len(s) Then
                        f = False
                        Exit For
                    End If
            End Select
        Next i
    End If
    Check = f
End Function
id:kine2525

いくつかの数字で動作確認しましたが、確かに速度に難はありますがきちんと動きました。

ただ素人目、結構重複している部分があるように見受けられるので更に最適化行けそうです。

(作った本人はもう弄りたくないって気分かもですが・・・)

2009/11/02 22:48:25
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/11/03 21:27:23

ポイント50pt

コード中に間違いがあったので修正しました。

質問では短いコードということでしたが、実行速度を早くする変更を加えましたのその分コードは長くなりました。


変更点は、組み合わせを作るときに1つ目と2つ目というように順番をつけて、演算子を引き算と割り算のときに逆の場合を追加したこと。これで3分の1くらいになりました。

更に、同じ数字がある場合に1度で済むようにしました。これにより同じ数字があるほど処理が早く終わるようになっています。

私の環境では、0秒~25秒くらいです。


Option Explicit

Public Type Enzan
    s As Double
    n As String
    k As Integer
End Type

Private r As Long
Private hai() As String
Private c1 As Integer

Sub Shoot()
    Columns("B").Value = ""
    Dim c
    For Each c In Array("Num1", "Num2", "Num3", "Num4", "Num5", "GNum2")
        Range(c).Value = Int(Rnd() * 6) + 1
    Next
    Range("GNum1").Value = 10 * (Int(Rnd() * 6) + 1)
End Sub

Sub jamaica()
    Dim i As Integer
    Dim e(4) As Enzan
    Dim stTime
    ReDim hai(0)
    Dim en As Integer
    
    stTime = Time
    Range("AF1:AF5").NumberFormatLocal = "@"
    Columns("B").Value = ""
    
    Application.ScreenUpdating = False
    
    r = 2
    lngC = 0
    en = 1
    For i = 0 To 4
        e(i).s = Range("Num" & i + 1).Value
        e(i).n = Range("Num" & i + 1).Value
        e(i).k = 3
        en = en * e(i).s
    Next i

    If en >= Range("GNum1").Value + Range("GNum2").Value Then
        Call Saiki(e, 4)
    End If

    If Range("B2") = "" Then Range("B2") = "NO ANSWER"
    Application.StatusBar = DatePart("s", Time - stTime) & "秒"
    Range("AF1:AF5").Value = ""

    Application.ScreenUpdating = True
End Sub

Sub Saiki(e3() As Enzan, j As Integer)
    Dim i1 As Integer
    Dim i2 As Integer
    Dim i3 As Integer
    Dim s1 As Double
    Dim s2 As Double
    Dim n1 As String
    Dim n2 As String
    Dim k1 As Integer
    Dim k2 As Integer
    Dim c As Integer
    Dim i As Integer
    Dim e() As Enzan
    Dim e1() As Enzan
    Dim n5 As String
    Dim n6 As String
    Dim str As String
    Dim f2 As Boolean
    Dim f3 As Boolean
    Dim f4 As Boolean
    Dim h1(10) As String
    Dim h2(10) As String
    Dim c2 As Integer
    
    c2 = 0
    For i1 = 0 To j - 1
        For i2 = i1 + 1 To j
            f4 = False
            For i = 0 To c2
                If (h1(i) = e3(i1).n And h2(i) = e3(i2).n) Or (h1(i) = e3(i2).n And h2(i) = e3(i1).n) Then
                    f4 = True
                    Exit For
                End If
            Next i
            If Not f4 Then
                c2 = c2 + 1
                h1(c2) = e3(i1).n
                h2(c2) = e3(i2).n
                
                e = e3
                s1 = e(i1).s
                n1 = e(i1).n
                k1 = e(i1).k
                s2 = e(i2).s
                n2 = e(i2).n
                k2 = e(i2).k
                c = 0
                For i = 0 To j
                    If i <> i1 And i <> i2 Then
                        e(c) = e(i)
                        c = c + 1
                    End If
                Next i
                e1 = e
                For i3 = 0 To 5
                    DoEvents
                    f2 = False
                    e = e1
                    n5 = n1
                    n6 = n2
                    Select Case i3
                        Case 0
                            e(j - 1).s = s1 + s2
                            e(j - 1).n = n5 & "+" & n6
                        Case 1
                            e(j - 1).s = s1 - s2
                            If k2 < 3 Then
                                n6 = "(" & n2 & ")"
                            End If
                            e(j - 1).n = n5 & "-" & n6
                        Case 2
                            e(j - 1).s = s2 - s1
                            If k1 < 3 Then
                                n5 = "(" & n1 & ")"
                            End If
                            e(j - 1).n = n6 & "-" & n5
                        Case 3
                            e(j - 1).s = s1 * s2
                            If k1 < 3 Then
                                n5 = "(" & n1 & ")"
                            End If
                            If k2 < 3 Then
                                n6 = "(" & n2 & ")"
                            End If
                            e(j - 1).n = n5 & "*" & n6
                        Case 4
                            If s2 <> 0 Then
                                e(j - 1).s = s1 / s2
                                If k1 < 3 Then
                                    n5 = "(" & n1 & ")"
                                End If
                                If Len(n2) > 1 Then
                                    n6 = "(" & n2 & ")"
                                End If
                                e(j - 1).n = n5 & "/" & n6
                            Else
                                f2 = True
                            End If
                        Case 5
                            If s1 <> 0 Then
                                e(j - 1).s = s2 / s1
                                If k2 < 3 Then
                                    n6 = "(" & n2 & ")"
                                End If
                                If Len(n1) > 1 Then
                                    n5 = "(" & n1 & ")"
                                End If
                                e(j - 1).n = n6 & "/" & n5
                            Else
                                f2 = True
                            End If
                    End Select
                    If Not f2 Then
                        e(j - 1).k = i3
                        e(j).s = 0
                        e(j).n = ""
                        e(j).k = 3
                        If j > 1 Then
                            Call Saiki(e, j - 1)
                        Else
                            If e(0).s = Range("GNum1").Value + Range("GNum2").Value Then
                                str = Sort(e(0).n)
                                f3 = False
                                For i = 0 To UBound(hai)
                                    If hai(i) = str Then
                                        f3 = True
                                        Exit For
                                    End If
                                Next i
                                If Not f3 Then
                                    ReDim Preserve hai(c1)
                                    hai(c1) = str
                                    c1 = c1 + 1
                                    Cells(r, 2).Value = e(0).n
                                    r = r + 1
                                End If
                            End If
                        End If
                    End If
                Next i3
            End If
        Next i2
    Next i1
End Sub

Function Sort(ByVal s As String) As String
    Dim i As Integer
    Dim j As Integer
    Dim f As Boolean
    Dim h(9) As Variant
    Dim c As Integer
    Dim sp As Integer
    Dim ep As Integer
    Dim st As String
    Dim res As String
    Dim str As String
    Dim m1 As String
    Dim m2 As String
    
    For i = 1 To Len(s)
        Select Case Mid(s, i, 1)
            Case "+", "-"
                If j = 0 Then
                    f = True
                End If
            Case "("
                j = j + 1
            Case ")"
                j = j - 1
        End Select
    Next i
    
    j = 0
    sp = 1
    If f Then
        m1 = "+"
        m2 = "-"
    Else
        m1 = "*"
        m2 = "/"
    End If
    s = m1 & s
    For i = 1 To Len(s)
        Select Case Mid(s, i, 1)
            Case m1, m2
                If j = 0 Then
                    If sp > 1 Then
                        str = Mid(s, sp, i - sp)
                        If i - sp > 1 Then
                            If Check(str) Then
                                h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
                            Else
                                h(c) = st & Sort(str)
                            End If
                        Else
                            h(c) = st & str
                        End If
                        c = c + 1
                    End If
                    h(c) = m1
                    st = Mid(s, i, 1)
                    c = c + 1
                    sp = i + 1
                End If
            Case "("
                j = j + 1
            Case ")"
                j = j - 1
        End Select
    Next i
    str = Mid(s, sp, i - sp)
    If i - sp > 1 Then
        If Check(str) Then
            h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
        Else
            h(c) = st & Sort(str)
        End If
    Else
        h(c) = st & str
    End If

    
    For i = 1 To 5
        Cells(i, "AF").Value = h(i * 2 - 1)
    Next i
    Range("AF1:AF5").Sort Key1:=Range("AF1")
    For i = 1 To 5
        h(i * 2 - 1) = Cells(i, "AF").Value
    Next i
    
    For i = 0 To 9
        res = res & h(i)
    Next
    
    Sort = res
End Function

Function Check(s As String) As Boolean
    Dim i As Integer
    Dim j As Integer
    Dim f As Boolean
    
    If Left(s, 1) = "(" And Right(s, 1) = ")" Then
        f = True
        For i = 1 To Len(s)
            Select Case Mid(s, i, 1)
                Case "("
                    j = j + 1
                Case ")"
                    j = j - 1
                    If j = 0 And i <> Len(s) Then
                        f = False
                        Exit For
                    End If
            End Select
        Next i
    End If
    Check = f
End Function

更なる高速化については、最初に式が成り立つかだけを計算して、成り立つ組み合わせだけを

後から文字列を作るという方法が考えられますが、大幅な変更が必要になるので今回は辞めておきます。

また、初回に別のシートに組み合わせのデータベースを作るという方法もあります。

その場合は初回だけ時間が掛かりますが、2回目以降は瞬時に結果が出るでしょう。

それは気が向いたらブログの方に作るかもしれません。

id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912009/11/04 01:00:06ここでベストアンサー

ポイント200pt

何とか締め切りに間に合ったでしょうか。


ぎりぎりになったので、チェック漏れがあるかもしれませんが何となく動いているので回答します。

コードは一応下記に張っておきますがこれだけでは動きませんので、動作版はお手数ですがダイアリーを参照ください。


下準備

(1)まず、5つの数字の組み合わせによる四則演算の式は2048通りあります。

(2)これらのうち変形することによって同じ式になるものをまとめると、374通りになります。

(3)さらにこれらの式のうちサイコロの数値(1~6)を使用して11以上になるものは233通りです。

これはジャマイカにおいては一意に決まるものですから、あらかじめ用意しておきます。

(VBA では Expression というシートのA列にあることを前提にしています。)


さて実際の処理ですが、サイコロの目のパターン(最大120通り:重複によりこれ以下)をこの233通りにあてはめて計算することによって

最大の計算数を 120*233 以内で結果を出すことができます。


こちらでの実行結果はだいたい2~6秒くらいでした。

参考までにコードを提示します。

Option Explicit

Public Goal As Long            '// 目標値(黒ダイスの合計)
Public DiceArray(4) As Long    '// 白ダイス
Public OutRow As Long          '// 結果出力行

'-----------------------------------------------------------------
Sub Shoot()
'-----------------------------------------------------------------
    Columns("B").Value = ""
    
    Dim c
    For Each c In Array("Num1", "Num2", "Num3", "Num4", "Num5", "GNum2")
        Range(c).Value = Int(Rnd() * 6) + 1
    Next
    Range("GNum1").Value = 10 * (Int(Rnd() * 6) + 1)
End Sub

'-----------------------------------------------------------------
Sub Jamaica()
'-----------------------------------------------------------------
    Dim d, i As Long
    For Each d In Array("Num1", "Num2", "Num3", "Num4", "Num5")
        DiceArray(i) = Range(d)
        i = i + 1
    Next
    Goal = Range("GNum1").Value + Range("GNum2").Value
    
    If getMax() < Goal Then
        Range("B2") = "No Answer"
        Exit Sub
    End If
    OutRow = 2
    
    Dim comArray
    comArray = makeNumArray()
    
    Dim com, r As Long
    r = 1
    Do While Worksheets("Expression").Cells(r, "A") <> ""
        For Each com In comArray
            If expCalc(Worksheets("Expression").Cells(r, "A"), com) = True Then Exit For
        Next
        r = r + 1
    Loop
    If OutRow = 2 Then
        Cells(OutRow, "B") = "No Answer"
    Else
        Cells(OutRow, "B") = "END"
    End If
End Sub

'-----------------------------------------------------------------
Function expCalc(exp, com) As Boolean
'-----------------------------------------------------------------
    expCalc = False
    Dim i As Long, j As Long, ch As String
    Dim dstExp As String
    j = 1
    For i = 1 To Len(exp)
        ch = Mid(exp, i, 1)
        If ch = "#" Then
            dstExp = dstExp & Mid(com, j, 1)
            j = j + 1
        Else
            dstExp = dstExp & ch
        End If
    Next
    If CLng(Evaluate(dstExp)) = Goal Then
        Cells(OutRow, "B") = dstExp
        OutRow = OutRow + 1
        expCalc = True
    End If
End Function

'-----------------------------------------------------------------
Function makeNumArray()
'-----------------------------------------------------------------
    Dim objDic
    Dim cm As String
    Dim i1, i2, i3, i4, i5, ar1, ar2, ar3, ar4, ar5
    Set objDic = CreateObject("Scripting.Dictionary")
    For Each i1 In Array(0, 1, 2, 3, 4)
        ar2 = Replace(Replace("0,1,2,3,4,@", i1 & ",", ""), ",@", "")
    For Each i2 In Split(ar2, ",")
        ar3 = Replace(Replace(ar2 & ",@", i2 & ",", ""), ",@", "")
    For Each i3 In Split(ar3, ",")
        ar4 = Replace(Replace(ar3 & ",@", i3 & ",", ""), ",@", "")
    For Each i4 In Split(ar4, ",")
        i5 = CInt(Replace(Replace(ar4 & ",@", i4 & ",", ""), ",@", ""))
        cm = DiceArray(i1) & DiceArray(i2) & DiceArray(i3) & DiceArray(i4) & DiceArray(i5)
        If Not objDic.Exists(cm) Then
            objDic.Add cm, ""
        End If
    Next
    Next
    Next
    Next

    makeNumArray = objDic.keys
End Function

'-----------------------------------------------------------------
Function getMax() As Long
'-----------------------------------------------------------------
    Dim n%(7), i%, j%
    
    For i = 0 To 4
        n(DiceArray(i)) = n(DiceArray(i)) + 1
    Next
    
    Do While n(1) > 0
        n(1) = n(1) - 1
        For i = 1 To 6
            If n(i) > 0 Then
                n(i) = n(i) - 1
                n(i + 1) = n(i + 1) + 1
                Exit For
            End If
        Next
    Loop
    
    getMax = 1
    For i = 1 To 7
        For j = 1 To n(i)
            getMax = getMax * i
        Next
    Next
End Function
id:kine2525

短い!しかも分かりやすい!!

お疲れ様でした。

2009/11/04 08:26:23
  • id:kine2525
    質問の再提出です。詳細はこちらを参照ください

    http://q.hatena.ne.jp/1256599368


  • id:kia_44
    A B C D をそれぞれの出目とし、
    a b c をそれぞれ演算子とすると

    AaBbCcD=目標数(x) という式ができるので、

    小文字の組み合わせをすべてあげてみる。

    左からそれぞれ
    + + +
    + + -
    + + /
    + + *
    + - +
    と続けていくと
    * * *
    までに64パターン出来上がります。

    すべてのパターンの式を入力しておき、

    上記すべての式を書いて、A~DとXに対して出目を入力

    という方法ならVBAじゃなくてもできそうですね。

    具体的には
    +=1 -=2 /=3 *=4としてフィルを使用して総パターンを出力
    その後置換で演算子に変換。文字列結合して、それを式とするとかでできそうな~。

    エクセルが手元に無いのでコメントにて。
  • id:SALINGER
    そこにカッコがつくので単純じゃないのです。
    カッコってようするに演算順序と考えればいいわけだけど。
  • id:kine2525
    演算と()を別々のアルゴリズムで作るのはどうでしょう?
    PoP&Push方式で演算して、演算処理を元に後付けでカッコつけるのは駄目かな、と思ったのですが。
    よく情報処理の試験とかで()つきの計算式を逆ポーランド記法にしたり、その逆にするとかよく出てくるのですが。
  • id:kine2525
    多分、演算でカッコが必要かという理由に、「掛け算割り算は足し算引き算に優先する」という四則計算のルールがあるからだと思うんですよ。
    だから、そのルールを取っ払って順番に演算かけて、あとは実際の四則計算のルールに当てはめて表示をかきかえてやる・・・という方法がとれないかなと。
    もし自分の考えが根本的に間違ってたら申し訳ないですが、少しでもヒントになれば幸いです。
  • id:SALINGER
    9割方はすぐにできたんだけど、最後の重複を無くすところで数日悩んでたりする。
  • id:SALINGER
    重複を無くす為には
    1 最初から重複が起きないアルゴリズムを考える。
    2 後から重複を調べて削除する。
    今は2の方向で考えてて、どうやって数式を評価するかで悩んでます。
  • id:takashi_m17
    僕も頭から計算すれば良いやって思ってたんですが、
    (A+B)*(C+D) の計算が出来ないので悩み中
    カッコもパターン化させて総当たりすると多過ぎるし

    重複も
    1 最初から重複が起きないアルゴリズムを考える。
    が出来たら一番いいんですがねー
  • id:SALINGER
    なんだかできたみたいです。
    掲載するにあたりコードがあまりに汚いので、最適化するか迷うところ。
  • id:SALINGER
    回答した後に組み合わせの数(実効速度)を3/4にする方法と、
    演算に使う5つの数字に同じ数字があった場合に実行速度を早くできることに気づいた。
    また、コードは長くなるけど同じ処理でももっと早くする方法はあります。
  • id:kine2525
    おっ>SALINGERさん
    とりあえずオープンしますよ?
  • id:kine2525
    とりあえず11/4が自動締め切りみたいなので
    明日いっぱいまで受け付けたいと思います。
  • id:SALINGER
    >素人目、結構重複している部分があるように見受けられる
    Sortってサブルーチンに二つの山があるけど、ほとんど違わないので一つにはできます。
  • id:SALINGER
    >素人目、結構重複している部分があるように見受けられる
    ひょっとしてそれって結果の数式に同じものがあるということ?
  • id:SALINGER
    偶然、結果に抜けがあることが判明しました。
    例えば、2,2,2,2,2で32のとき(2+2)*2*(2+2)一つしか答えを出しません。
    修正してみますが、できるかどうか。
  • id:SALINGER
    ↑原因がわかりました。後で修正したものを再掲します。
  • id:kine2525
    お二人ともご苦労様でした。

    質問はここで打ち切りますが、改定などありましたらブログの方を覗かせていただきます。
    こういう頭を使って組むプログラムは回答者も、質問者である自分自身も勉強になりますので定期的に出題できたらと思います。
    というか、ジャマイカは本当ボケ防止というか頭のトレーニングにいいっすよ?
    大きめな文房具屋で1000円ぐらいで売ってます。

    まぁ、お金出してまで頭使いたくないというのなら切符などについてる四桁ぐらいの数字を四則計算で1~10まで作ってみるのもいいかもしれません。同じ数の4並びなら20ぐらいまでいけます。(一部は乗数とか、45のように数字を重ねないと無理だったりしますが)
    以上、長々と雑談失礼しました。
  • id:SALINGER
    質問を終了してしまったのですか。
    Mookさんのプログラムの結果と比べると、私の方にも抜けがあったようなので修正しようと思ってたのですが残念です。
  • id:SALINGER
    私の方の原因がわかりました。後で余計な機能を追加したせいでした。
    5つの数字の演算の最大値は5つを掛け合わせた物と考えて、解が以下なら直にNO ANSERとしたのですが、
    1が含まれる場合必ずしもそうならないということでした。
    その機能は取り除くだけなのでブログの方に掲載しておきます。
  • id:Mook
    イルカ賞とポイントありがとうございました。

    SALINGER さんからコメントいただきわかったのですが、どうやら数式パターンに漏れがありそうです。
    新しい結果が判明したら、ご報告します。

    解放を求めるマクロはシンプルなのですが、そのためにあらかじめ計算パターンを計算するマクロの作成はこちらの数倍時間がかかりました。規模も数倍なので(w)、どこかに問題があったようです。

    数値の処理と違って数式の処理はなかなか面倒です。
    でもおかげでなかなか楽しい時間をすごせました。

    中学のころfour fours(4つの4)を一生懸命計算したことを思い出しました。
    http://ja.wikipedia.org/wiki/4%E3%81%A4%E3%81%AE4

    今なら(四則演算以外を使えば)、20くらいまでいけそうですね。
    (今度のダイアリのネタにしようw。)

    ジャマイカ、楽しませていただきました。
  • id:SALINGER
    >Mookさん
    一つお願いなのですが、後学の為に上記の「あらかじめ計算パターンを計算するマクロ」をブログに提示していただけないでしょうか?
    ここ数日間、いかに効率よく全てのパターンを作り重複を無くすかということで試行錯誤してきました。
    それこそがこのプログラムの本質だったからです。
    Mookさんが回答していたので、自分以外の解法が見れると思っていたのですが、その方法が回答に無かったので残念でなりません。
    不完全でも構いませんので教えていただけないでしょうか?
  • id:Mook
    ファイルを修正しアップしました(数式作成部の処理マクロも収録)。

    結果として当初の374式は692式になりました。
    最大値が11未満の式を外せば、400程度になるかと思いますが、この処理はまだしていません。
    時間を見て対応したいと思いますが、まずは誤りの修正まで。
  • id:SALINGER
    >Mookさん
    数式作成部の処理マクロを見せていただきありがとうございました。
    私と違うアプローチの仕方でとても参考になりました。
    ただ残念ながら、この数式作成部の処理マクロは692式中135式は同じパターンを作り出すようです。
    例えば、
    (#/(#-#+(#*#)))
    (#/((#*#)+#-#))
    (#/((#*#)-#+#))

    なんでこんなことが直にわかるかと言うと実は私のSortプロシージャは数式を比較できるように還元するマクロです。
    それに全てのパターンを通すと同じ式が含まれていないかどうかがわかるのです。
    コードを拝見したところ、パターンを列挙して置換しているoperateReorderInLevelが
    新たに()付きのパターンが加わったことでうまく機能しなくなったように思われます。
  • id:Mook
    重複の指摘ありがとうございます。

    アドホックな数式変形で対応するとバグが残りそうなので、
    構造的な数式解析、ソート、再構成をし重複確認をしました。
    (そのため式変形の処理も不要になりました)

    結果、現時点では 692 より 168 少ない 522式 が重複削除の結果となっています。
    残念ながら SALINGER さんの指摘数と一致しませんでしたが、とりあえずそれより
    少なくなったので良しとしましょう。
  • id:SALINGER
    >Mookさ~ん
    1・2・3・5・6で合計24のとき、5×6-1×2×3が出ないようです。
    私は重複は134式(一つ多いでした)として、Mookさんは170式としていました。
    これは以前ブログのコメントに書いたように、数式変形の解釈の違いによるものだと単純に思ってましたがそれだけではないようです。
    こちらでコードは確認できませんが、確認できるシートの522式の中に、((#*#)-(#*#*#))等が抜け落ちています。
  • id:Mook
    検証ありがとうございます。

    確かになさそうですね。
    ((#*#*#)-(#*#))は残っているので、ソートの部分が怪しいかなぁ。

    今全体を検証中なので、この点も含めて再確認します。

  • id:Mook
    やっぱりソートの条件が抜けていました。
    とりあえずこの点は修正。

この質問への反応(ブックマークコメント)

トラックバック

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません