EXCEL VBAで覆面算を解いてみる その三

前回は覆面算の式だけを与えて覆面算を解くプログラムを作ってみました。
これは割り算を含む式でも解けるという優れものでしたが、速度の面で不満がありました。

今回は割り算には対応しないことにして、速度の向上に取り組んでみたいと思います。

高速化したい場合、画面更新を非表示にするのが効果的とよく言われます。
Application.ScreenUpdating = False
で画面が更新されなくなり、
Application.ScreenUpdating = True
で画面が更新されるようになります。
プログラムの最初で非表示にして、最後にそれを解除すると、
プログラム実行中の画面表示に要する処理がばっさりとなくなりますので早くなるわけです。
画面への出力が多い場合には非常に有効な手法だと思います。
しかしながら、覆面算を解くプログラムでは画面に出力するのは答えが見つかったときだけですので、
この方法ではほとんど速度の向上にはつながらないでしょう。

変数の定義をきちんとするとか、再帰呼び出しをやめるということも考えましたが、
もっと効果的と思われる方法がありますので、先にそちらを試してみます。

その方法とは、少ない種類の記号でできる式から判定するということです。
例えば、SEND+MORE=HONEYという式の場合、
1の位に注目すれば、D=1,E=2,Y=5という組み合わせが不適なことはすぐに分かります。
他の記号の値が何であっても不適です。
前回のプログラムではすべての記号について値を決めてから、不適かどうかの判定をしていました。
先程の例のように、まずD,E,Yの3つについてだけ値を決め、そこで不適なものを除外することにすれば、
大幅に処理を短縮することができるはずです。

足し算、引き算、掛け算のみを含む式の場合、同様のことが言えます。
例えば、
123+45*67-890
という式を計算すると結果は2248です。
各項の下1桁(1の位)のみを使って計算すると、
3+5*7-0=38
となり、下1桁は最初の式の結果の下1桁に一致します。
各項の下2桁のみを使って計算すると、
23+45*67-90=2948
となり、下2桁は最初の式の結果の下2桁に一致します。
この性質は計算する桁数を増やしても成り立ちます。

まず、下1桁の計算に必要な記号の値を決め、不適なものを除きます。
次に下2桁の計算に必要な記号の値を決め、不適なものを除きます。
このように途中で判定を入れて、処理の短縮を図ります。

連立覆面算にも対応するためもう少しややこしいことをしていますが、
基本的な考えは上で述べた通りです。
この考えで作ったプログラムを最後に載せておきます。
使える演算子は+,-,*の3種類。演算子の個数や式の長さには特に制限はありません。
エラーになる場合は配列のサイズを大きくしてください。
()も使えます。
数の桁数は10桁以内ならオーバーフローにならずに計算できると思います。
KSU(ENO, VNO + 1) <= 6 のところはオーバーフローを防ぐためのものです。
式は10個まで指定できます。
ERASE EQの直後に EQ(1)= "(A+B)*C=100" EQ(2)= "A+B+C=10" のように記述します。


これは早くていいですね。
記号が10種類の場合でも一瞬で終わります。
どの桁も10種類使っているような式の場合には効果はありませんが、
普通の覆面算なら圧倒的に早くなるはずです。
プログラム的には改善の余地は多々あると思いますが、 実用的に十分な速さになりましたので、
これで満足です。
オーバーフローになるのがちょっと不満なのでなんとかできないか考えてみたいと思います。


◇◇◇
Public SIKI As String
 Public VSU As Integer
 Public VLIST As String
 Public ESU As Integer
 Public FSU As Integer
 Public FORM(100) As String
 Public ELM1(100) As Integer
 Public ELM2(100) As Integer
 Public OPR(100) As String
 Public INTE(100) As Integer
 Public DECI(100) As Integer
 Public USE(10) As Integer
 Public NONZERO(10) As Integer
 Public OUTRAW As Integer
 Public SU(9) As Integer
 Public EFNO(10) As Integer
 Public KSU(10, 10) As Integer

 Sub SOLVE()
 Dim EQ(10) As String
 Erase EQ
 EQ(1) = "SEND+MORE=HONEY"
 STARTTIME = Time
 Dim FNO As Integer
 FSU = 1
 Erase FORM, ELM1, OPR, ELM2, USE, NONZERO
 VSU = 0: VLIST = ""
 ENO = 1: ESU = 0
 Do While EQ(ENO) <> ""
 SIKI = EQ(ENO)
 SIKI = Replace(SIKI, " ", "")
 If InStr(SIKI, "=") > 0 Then SIKI = Replace(SIKI, "=", "-(") + ")"
 If Mid(SIKI, 1, 1) = "-" Then SIKI = "0" + SIKI
 FSU = FSU + 1
 FORM(FSU) = SIKI: EFNO(ENO) = FSU
 SPLIT (FSU)
 ENO = ENO + 1
 Loop
 If VSU <= 0 Or VSU > 10 Then
 MsgBox ("入力エラー")
Exit Sub
 End If
 ESU = ENO - 1

 Dim WLIST(10) As String
 ENO = 1: ESU = 0
 Do While EQ(ENO) <> ""
 SIKI = Replace(EQ(ENO), " ", "")
 KETA = 0
 For I = 1 To Len(SIKI)
 CHARA = Mid(SIKI, Len(SIKI) - I + 1, 1)
 If InStr("()+-*=", CHARA) > 0 Then
 KETA = 0
 Else
 KETA = KETA + 1
 If (CHARA < "0" Or CHARA > "9") And InStr(WLIST(KETA), CHARA) = 0 Then WLIST(KETA) = WLIST(KETA) + CHARA
 End If
 Next I
 If InStr(SIKI, "=") > 0 Then SIKI = Replace(SIKI, "=", "-(") + ")"
 If Mid(SIKI, 1, 1) = "-" Then SIKI = "0" + SIKI
 FSU = FSU + 1
 FORM(FSU) = SIKI: EFNO(ENO) = FSU
 SPLIT (FSU)
 ENO = ENO + 1
 Loop
 If VSU <= 0 Or VSU > 10 Then
 MsgBox ("入力エラー")
Exit Sub
 End If
 ESU = ENO - 1
 VLIST = WLIST(1)

 KETA = 2
 Do Until Len(VLIST) = VSU
 SIKI = WLIST(KETA)
 For I = 1 To Len(SIKI)
 CHARA = Mid(SIKI, I, 1)
 If InStr(VLIST, CHARA) = 0 Then VLIST = VLIST + CHARA
 Next I
 KETA = KETA + 1
 Loop

 Dim KOSU(10, 10) As Integer
 Erase KOSU
 For ENO = 1 To ESU
 SIKI = Replace(EQ(ENO), " ", "")
 KETA = 0: SAVENO = 0
 For I = 1 To Len(SIKI)
 CHARA = Mid(SIKI, Len(SIKI) - I + 1, 1)
 If InStr("()+-*=", CHARA) > 0 Then
 If SAVENO > 0 Then NONZERO(SAVENO - 1) = 1
 KETA = 0: SAVENO = 0
 Else
 KETA = KETA + 1
 VNO = InStr(VLIST, CHARA)
 If VNO > 0 Then
 If KOSU(ENO, KETA) < VNO Then KOSU(ENO, KETA) = VNO
 If KETA > 1 Then SAVENO = VNO Else SAVENO = 0
 End If
 End If
 Next I
 If SAVENO > 0 Then NONZERO(SAVENO - 1) = 1
 VNO = KOSU(ENO, 1)
 For KETA = 2 To 10
 If KOSU(ENO, KETA) > 0 Then
 If KOSU(ENO, KETA) < VNO Then
 KOSU(ENO, KETA) = VNO
 Else
 VNO = KOSU(ENO, KETA)
 End If
 End If
 Next KETA
 Next ENO
 Erase KSU
 For ENO = 1 To ESU
 VNO = 0
 For I = 1 To 10
 If VNO < KOSU(ENO, I) Then VNO = KOSU(ENO, I)
 If KOSU(ENO, I) <> 0 Then KSU(ENO, VNO) = I
 Next I
 Next ENO
 FORM(0) = VLIST
 OUTRAW = 1
 Cells(OUTRAW, 1) = VLIST
 CHECK (0)
 OUTRAW = OUTRAW + 1
 ACOUNT = OUTRAW - 2
 Cells(OUTRAW, 1) = "答えは" + Format(ACOUNT, "#0") + "個"
Cells(OUTRAW + 1, 1) = ""
 SYORITIME = Time - STARTTIME
 Debug.Print Minute(SYORITIME) & "分" & second(SYORITIME) & "秒"
End Sub
 Function CHECK(ByVal VNO As Integer)
 Dim FNO As Integer
 Dim ENO As Integer
 Dim ERRFLAG As Integer
 If VNO = VSU Then
 ENO = 1: ERRFLAG = 0
 Do While ENO <= ESU And ERRFLAG = 0
 FNO = EFNO(ENO)
 If EVAL(FNO, 0) <> 0 Then Exit Function
 ENO = ENO + 1
 Loop
 If ERRFLAG = 0 Then
 OUTRAW = OUTRAW + 1
 Cells(OUTRAW, 1) = "'" + Format(EVAL(0, 0), Mid("0000000000", 1, VSU))
 End If
 Else
 For NM = 0 To 9
 If USE(NM) = 0 Then
 If NM <> 0 Or NONZERO(VNO) = 0 Then
 USE(NM) = 1
 SU(VNO) = NM
 ERRFLAG = 0
 For ENO = 1 To ESU
 If KSU(ENO, VNO + 1) > 0 And KSU(ENO, VNO + 1) <= 6 Then
 FNO = EFNO(ENO)
 If EVAL(FNO, KSU(ENO, VNO + 1)) <> 0 Then ERRFLAG = 1
 End If
 Next ENO
 If ERRFLAG <> 1 Then CHECK (VNO + 1)
 USE(NM) = 0
 End If
 End If
 Next NM
 End If
 End Function
 Function EVAL(ByVal FNO As Integer, ByVal SLEN As Integer) As Double
 Dim I As Integer
 If OPR(FNO) = "" Then
 If SLEN = 0 Then
 SIKI = FORM(FNO)
 Else
 SIKI = Right(FORM(FNO), SLEN)
 End If
 EVAL = 0
 For I = 1 To Len(SIKI)
 CHARA = Mid(SIKI, I, 1)
 Select Case CHARA
 Case " "
 Case "0" To "9"
 EVAL = EVAL * 10 + Val(CHARA)
 Case Else
 EVAL = EVAL * 10 + SU(InStr(VLIST, CHARA) - 1)
 End Select
 Next I
 Else
 Select Case OPR(FNO)
 Case "+"
 EVAL = EVAL(ELM1(FNO), SLEN) + EVAL(ELM2(FNO), SLEN)
 Case "-"
 EVAL = EVAL(ELM1(FNO), SLEN) - EVAL(ELM2(FNO), SLEN)
 Case "*"
 EVAL = EVAL(ELM1(FNO), SLEN) * EVAL(ELM2(FNO), SLEN)
 End Select
 If SLEN <> 0 Then EVAL = EVAL Mod (10 ^ SLEN)
 End If
 End Function
 Function SPLIT(ByVal FNO As Integer)
 Dim SAVENO As Integer, SAVEPRI As Integer, SAVEPOS As Integer
 Dim SCOUNT As Integer
 Dim WKLEN As Integer
 Dim PAIR As Integer
 Dim CHARA As String
 Dim VNO As Integer
 SAVEPRI = 0: SAVEPOS = 0
 SIKI = FORM(FNO)
 PAIR = 0
 For I = 1 To Len(SIKI)
 PRI = 0
 CHARA = Mid(SIKI, I, 1)
 Select Case CHARA
 Case " "
 Case "+": PRI = 1
 Case "-": PRI = 1
 Case "*": PRI = 2
 Case "(": PAIR = PAIR + 1
 Case ")": PAIR = PAIR - 1
 Case "0" To "9"
 Case Else
 VNO = InStr(VLIST, CHARA) - 1
 If VNO < 0 Then
 VSU = VSU + 1: VLIST = VLIST + CHARA
 VNO = VSU
 End If
 End Select
 If PRI > 0 Then
 PRI = PRI + PAIR * 10
 If PRI <= SAVEPRI Or SAVEPRI = 0 Then
 SAVEPRI = PRI: SAVEPOS = I
 End If
 End If
 Next I
 If SAVEPOS > 0 Then
 OPR(FNO) = Mid(SIKI, SAVEPOS, 1)
 FSU = FSU + 1
 ELM1(FNO) = FSU
 FORM(FSU) = Mid(SIKI, 1, SAVEPOS - 1)
 FSU = FSU + 1
 ELM2(FNO) = FSU
 FORM(FSU) = Mid(SIKI, SAVEPOS + 1)
 SPLIT (ELM1(FNO))
 SPLIT (ELM2(FNO))
 Else
 OPR(FNO) = ""
 FORM(FNO) = Replace(FORM(FNO), "(", "")
 FORM(FNO) = Replace(FORM(FNO), ")", "")
 End If
 End Function