柿×食う＝客 ⑥ クラスモジュール化（一応完成）

昨日は、算数パズルを解く汎用マクロの完成を目指し、あれこれとクラスモジュールをいじってみた。
infoment.hatenablog.com
今回は、広げた風呂敷を綺麗に畳むことに挑戦する。

今回は、昨日までに作成したものを、更に発展させてみた。

1. 数式を引数として、文字の種類数や計算の種類を判別する。
2. 総当たりで計算して、条件に合致するパターンを抽出する。
3. 得られた結果をコレクションに格納して、戻り値とする。

クラスモジュール（ArithmeticPuzzleClass）

Option Explicit

' 正規表現：数式分解用。
Dim myReg As RegExp
Dim MatchCase As MatchCollection
Dim mySubMatches As SubMatches
' 文字の種類数。
Dim Digits As Long
' 文字の種類と順番を記録するための連想配列。
Dim CharacterDict As Dictionary
' 各文字列群の数字。
Dim CharacterGroup(1 To 4) As Variant

Private Sub Class_Initialize()
    Set myReg = New RegExp
        myReg.Pattern = "(.+)([＋－×÷／])(.+)(＝)(.+)"
    Set CharacterDict = New Dictionary
End Sub

Public Sub init(Equation As String)
    ' メタ文字が含まれる場合を考慮し、数式を全角化して処理する。
    Equation = StrConv(Equation, vbWide)
    If myReg.test(Equation) Then
        Set MatchCase = myReg.Execute(Equation)
        Set mySubMatches = MatchCase(0).SubMatches
    End If
    
    Digits = 1
    
    ' 各文字群から一文字ずつ取り出して、連想配列作成。
    ' 同時に文字の種類をカウントする。
    Dim i As Long
    Dim j As Long
    Dim s As String
        For i = 0 To 4 Step 2
            For j = 1 To Len(mySubMatches(i))
                s = Mid(mySubMatches(i), j, 1)
                If CharacterDict.Exists(s) = False Then
                    CharacterDict(s) = Digits
                    Digits = Digits + 1
                End If
            Next
        Next
        
        Digits = Digits - 1
End Sub

Public Property Get iMin() As Long
    ' 文字種の数から、ループの最小値を求める。
    iMin = 10 ^ (Digits - 1)
End Property
      
Public Property Get iMax() As Long
    ' 文字種の数から、ループの最大値を求める。
    iMax = 10 ^ Digits - 1
End Property

Function CheckDuplication(val As Long) As Boolean
    ' 各文字に充てられた数字が重複していないか確認。
    Dim Dict As Dictionary
    Set Dict = New Dictionary
    
    Dim i As Long
    For i = 1 To Digits
        If Dict.Exists(Mid(val, i, 1)) Then
            CheckDuplication = True
            Exit For
        Else
            Dict(Mid(val, i, 1)) = Mid(val, i, 1)
        End If
    Next
End Function

Public Function JudgeEstablishment(val As Long) As Boolean

    ' 文字 ⇒ ループ数のｎ番目を特定 ⇒ ｎ番目を抽出
    Dim i As Long
    Dim j As Long
    Dim str As String
    Dim myIndex As Long
    Dim temp As String
        For i = 0 To 4 Step 2
            For j = 1 To Len(mySubMatches(i))
                str = Mid(mySubMatches(i), j, 1)
                myIndex = CharacterDict(str)
                temp = temp & Mid(val, myIndex, 1)
            Next
            CharacterGroup(i / 2 + 1) = CLng(temp)
            
            ' 最大桁が０の場合を除外。
            If Len(mySubMatches(i)) <> Len(CharacterGroup(i / 2 + 1)) Then
                JudgeEstablishment = False
                Exit Function
            End If
            temp = vbNullString
        Next
        
        ' 演算子から計算の種類を決める。
        Select Case mySubMatches(1)
            Case "＋": CharacterGroup(4) = CharacterGroup(1) + CharacterGroup(2)
            Case "－": CharacterGroup(4) = CharacterGroup(1) - CharacterGroup(2)
            Case "×": CharacterGroup(4) = CharacterGroup(1) * CharacterGroup(2)
            Case "÷", "／": CharacterGroup(4) = CharacterGroup(1) / CharacterGroup(2)
        End Select
        
        ' 計算結果と当てはめた結果を比較。
        If CharacterGroup(3) <> CharacterGroup(4) Then
            JudgeEstablishment = False
        ElseIf CheckDuplication(val) = False Then
            JudgeEstablishment = True
        End If

End Function

Public Function Calc() As Collection

    ' 該当する数値をコレクションに可能する。
    
    Dim col As Collection
    Set col = New Collection
    
    Dim i As Long
    For i = iMin To iMax
        If JudgeEstablishment(i) Then
            col.Add CharacterGroup(1) & mySubMatches(1) & CharacterGroup(2) & "＝" & CharacterGroup(3)
            If col.Count >= 10 Then
                MsgBox "答えが１０個以上存在するため、" & _
                       "パズルとして成立していない恐れがあります。" & _
                       "※処理を中断します。"
                Set col = New Collection
                Exit For
            End If
        End If
    Next
    
    Set Calc = col

End Function

標準モジュール

殆どの機能をクラスモジュールに渡したため、こちらは大分簡素化できた。

Option Explicit
Sub テスト()
    Dim Equation As String
        Equation = "かき×くう＝きゃく"
        
    Call 算数パズル(Equation)
End Sub

Sub 算数パズル(Equation As String)
    Dim APC As ArithmeticPuzzleClass
    Set APC = New ArithmeticPuzzleClass
        APC.init Equation

    Dim c As Variant
        If APC.Calc.Count = 0 Then
            Debug.Print "解なし"
        Else
            For Each c In APC.Calc
                Debug.Print c
            Next
        End If
End Sub

↓ 答えもちゃんと出た。

それでは、有名な「あの式」（ABCD×4=DCBA）でも確認してみる。

↓ 出た。

「かき×くう＝きゃく」と一緒に出題された、もう一問も解いてみた。
「LEMON + MELON = APPLE」
↓ 出た。処理時間は、約180秒。

この問題は、手計算でも解けていた。解けたつもりになっていた。答え、二つあったのか・・・。

他にも自分で、算数パズルを作ることだって出来るかもしれない。

なかなか面白いものが出来たと思ってます。
今回は、ここまで。

参考まで。