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

覆面算を解くプログラムを解くプログラムも第四回となりました。

EXCEL VBAで覆面算を解いてみる
SEND+MORE=HONEYという覆面算を解くプログラムを作成しました。
プログラムを変更すれば他の覆面算を解くこともできますが、変更箇所が多くて面倒です。

EXCEL VBAで覆面算を解いてみる その二
覆面算の式だけ書きかえればいいように改良しました。
演算子として+,-,*,/が使用可能。
分数で計算しますので、割り算を含む式でも正確に計算します。
連立覆面算も解けます。

EXCEL VBAで覆面算を解いてみる その三
速度面で不満がありましたので高速化を図りました。
割り算は使わないことにして分数での計算もやめました。

今回はオーバーフロー対策を考えます。

変数の型に応じて表現できる数の範囲は決まっています。
Integer(整数型)の場合、-32,768～32767
Long(長整数型)の場合、-2147486348～2147486347
整数型は2バイト、長整数型は4バイト。
2^16=2*32768、2^32=2*2147483648
であることから生じる制限です。

Single(単精度浮動小数点数型)やDouble(倍精度浮動小数点数型)を使えば
表現できる数の範囲は増えますが、正確な値ではなくなります。

式の値を一つの変数に格納しようとするとどうしても限界があるのです。
この限界を突破するために、各桁毎に値を格納することを考えました。
整数型の配列を定義して、各桁の値を配列の要素として格納するようにしました。
配列の要素数を増やせばいくらでも大きな数の計算ができます。

配列表現による足し算は各要素毎に足して、繰り上がった場合は次の要素に1を足すようにすればよいです。
掛け算は一つ目の配列の要素と二つ目の配列の要素のすべての組み合わせについて積を計算して合計すればよいです。
筆算と同じ計算をすればよいです。
引き算はちょっと面倒でした。
コンピュータは補数表現を使って計算しているようですが、私はあまり美しくない方法で計算しました。
なんとか計算できているようですのでいいでしょう。

これで
SENDXXXXXXXX+MORE00000000=HONEYXXXXXXXX
のような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) = "SENDXXXXXXXX+MORE00000000=HONEYXXXXXXXX"
 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(100) 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, 100) 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) = "'" + Mid(EVAL(0, 0), 2)
 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 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 String
 Dim I As Integer, J As Integer
 Dim E1 As String, E2 As String
 Dim L1 As Integer, L2 As Integer, L As Integer
 Dim DIGIT()
 If OPR(FNO) = "" Then
 FUGO = "+"
 If SLEN = 0 Then
 SIKI = FORM(FNO)
 Else
 SIKI = Right(FORM(FNO), SLEN)
 End If
 L = Len(SIKI)
 ReDim DIGIT(L)
 For I = 1 To L
 CHARA = Mid(SIKI, I, 1)
 Select Case CHARA
 Case " "
 Case "0" To "9"
 DIGIT(I) = CHARA
 Case Else
 DIGIT(I) = SU(InStr(VLIST, CHARA) - 1)
 End Select
 Next I
 Else
 E1 = EVAL(ELM1(FNO), SLEN): E2 = EVAL(ELM2(FNO), SLEN)
 If Mid(E1, 1, 1) = "+" Then S1 = 1 Else S1 = -1
 If Mid(E2, 1, 1) = "+" Then S2 = 1 Else S2 = -1
 E1 = Mid(E1, 2): E2 = Mid(E2, 2)
 L1 = Len(E1): L2 = Len(E2)
 If OPR(FNO) = "+" Or OPR(FNO) = "-" Then
 If OPR(FNO) = "-" Then S2 = -S2
 S = S1
 If S1 = S2 Then
 S1 = 1: S2 = 1
 Else
 If L1 < L2 Or (L1 = L2 And E1 < E2) Then
 S = S2
 S1 = -1: S2 = 1
 Else
 S1 = 1: S2 = -1
 End If
 End If
 If L1 > L2 Then L = L1 Else L = L2
 L = L + 1
 ReDim DIGIT(L)
 For I = 1 To L1
 DIGIT(L - I + 1) = S1 * Val(Mid(E1, L1 - I + 1, 1))
 Next I
 For J = 1 To L2
 DIGIT(L - J + 1) = DIGIT(L - J + 1) + Val(Mid(E2, L2 - J + 1, 1)) * S2
 Next J
 Else
 L = L1 + L2 + 1
 ReDim DIGIT(L)
 S = S1 * S2
 For I = 1 To L1
 For J = 1 To L2
 DIGIT(L - I - J + 2) = DIGIT(L - I - J + 2) + Val(Mid(E1, L1 - I + 1, 1)) * Val(Mid(E2, L2 - J + 1, 1))
 Next J
 Next I
 End If
 For I = L To 1 Step -1
 If DIGIT(I) >= 0 Then
 AMARI = DIGIT(I) Mod 10
 Else
 AMARI = 10 - (Abs(DIGIT(I)) Mod 10)
 If AMARI = 10 Then AMARI = 0
 End If
 DIGIT(I - 1) = DIGIT(I - 1) + (DIGIT(I) - AMARI) / 10
 DIGIT(I) = AMARI
 Next I
 If S >= 0 Then FUGO = "+" Else FUGO = "-"
 End If
 EVAL = Join(DIGIT, "")
 If SLEN <> 0 Then EVAL = Right(EVAL, SLEN)
 If FNO <> 0 Then EVAL = Replace(LTrim(Replace(EVAL, "0", " ")), " ", "0")
 If EVAL = "" Then
 EVAL = "+0"
 Else
 EVAL = FUGO + EVAL
 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 "/": 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