滝の音

滝の音

名こそ流れてなお聞こえけれ

VBAで中学数学の問題を扱おう! その3 同類項をまとめる

 

中学数学の問題を扱おうのその3は「足し算」です。

正確には「同類項をまとめる」ですが。

 

その1,2で単項式の掛け算を行いましたが

その知識を使う場面はあるだろうかないだろうか。。。

 

今回も簡単なケースを考えてそれを処理できるコードを書いていくようにします。

 

  • 同類項をまとめるとは?

同じ文字式の単項式を

それらの係数を用いて計算する。

ということで。

 

  • ケース1 3+8

方針としては。

式を単項式に分ける。

同類項をまとめる。

表記する。

という感じ。

 

式を単項式に分けるための仕組みは

前回の「文字式の仕分け」プロシージャに似ているのでそれをちょっと修正する感じで。

Sub 単項式への分解(trgt, kou)

 Dim char As String         '処理用の箱
 Dim stock As Integer       '処理用の箱
 Dim n As Integer           'kouの数を指定
 Dim minus As Integer       '-の処理用の箱
 
 minus = 1
 n = 0
 ReDim Preserve kou(n)
 
 For j = 1 To Len(trgt)
    char = Mid(trgt, j, 1)
    Select Case Asc(char) - 96
        Case -51        '-の場合
            If n <> 0 Then
                Call 項の切り替え(n, kou, stock, minus)
            End If
            minus = -1
        Case -53        '+の場合
            Call 項の切り替え(n, kou, stock, minus)
        Case -48 To -39 '0~9の場合
            stock = stock & Val(char)
        Case -2         '^の場合
        Case 1 To 26    'アルファベットの場合
        Case Else
            MsgBox "考慮されていない文字が入っています"
            Stop
    End Select
 Next
 n = UBound(kou)
 kou(n) = stock * minus
End Sub

ーーーーーーーーーーーーーー

Sub 項の切り替え(n, kou, stock, minus)
 n = UBound(kou)
 kou(n) = stock * minus
 stock = 0
 minus = 1
 ReDim Preserve kou(n + 1)
End Sub

ちょっと今回の処理には高級すぎるコードですが

変に劣化させて書くのもなーと思ったのでこんな感じに。

おそらくこの部分は最後まで大きな変化なく終えるでしょう。

前がんばったのでこれくらいはいいよねw

 

次は同類項をまとめる処理。

こちらは始めて書くコードなのでどんどん変化させていくことになるでしょう。

Sub 同類項をまとめる(kou, cul)
 For i = 0 To UBound(kou)
    cul = cul + Val(kou(i))
 Next
End Sub

われながら低級なコードですが。

3+5+4-8みたいな複数の単項式の計算にも耐えられる設計なのはほめられるところ。

 

まとめてみると。

Private Sub CB1_Click()

 Dim siki As String
 Dim kou() As String
 Dim cul As Integer
 Dim answer As String
 
 siki = TB1
 trgt = siki
 Call 単項式への分解(trgt, kou)
 Call 同類項をまとめる(kou, cul)
 answer = Format(cul)
 TB2 = answer

End Sub

ーーーーーーーーーーーーーーーーーーー

Sub 単項式への分解(trgt, kou)

 Dim char As String         '処理用の箱
 Dim stock As Integer       '処理用の箱
 Dim n As Integer           'kouの数を指定
 Dim minus As Integer       '-の処理用の箱
 
 minus = 1
 n = 0
 ReDim Preserve kou(n)
 
 For j = 1 To Len(trgt)
    char = Mid(trgt, j, 1)
    Select Case Asc(char) - 96
        Case -51        '-の場合
            If n <> 0 Then
                Call 項の切り替え(n, kou, stock, minus)
            End If
            minus = -1
        Case -53        '+の場合
            Call 項の切り替え(n, kou, stock, minus)
        Case -48 To -39 '0~9の場合
            stock = stock & Val(char)
        Case -2         '^の場合
        Case 1 To 26    'アルファベットの場合
        Case Else
            MsgBox "考慮されていない文字が入っています"
            Stop
    End Select
 Next
 n = UBound(kou)
 kou(n) = stock * minus
 
End Sub

Sub 項の切り替え(n, kou, stock, minus)
 n = UBound(kou)
 kou(n) = stock * minus
 stock = 0
 minus = 1
 ReDim Preserve kou(n + 1)
End Sub
ーーーーーーーーーーーーーーーーー

Sub 同類項をまとめる(kou, cul)
 For i = 0 To UBound(kou)
    cul = cul + Val(kou(i))
 Next
End Sub

 

f:id:nozomi-hayashi:20180618064826g:plain

  • ケース2 a+2a

f:id:nozomi-hayashi:20180618064900g:plain

もうはいはいって感じですねw

前回起きた問題と大体同じ。

 

文字を認識する。

aの係数が1とする。

 

がクリアすべき問題。

 

今回のやり方はなんだか回りくどい感じがするのですが

現状の自分の力ではこれよりうまくかけないですね。。

 

まずは単項式に分解する際に一工夫。

文字への対応のためにstock_lineを足しました。

Sub 単項式への分解(trgt, kou)

 Dim char As String         '処理用の箱
 Dim stock As Integer       '処理用の箱
 Dim stock_line As String   '処理用の箱
 Dim n As Integer           'kouの数を指定
 Dim minus As Integer       '-の処理用の箱
 
 minus = 1
 n = 0
 ReDim Preserve kou(n)
 
 For j = 1 To Len(trgt)
    char = Mid(trgt, j, 1)
    Select Case Asc(char) - 96
        Case -51        '-の場合
            If n <> 0 Then
                Call 項の切り替え(n, kou, stock, stock_line, minus)
            End If
            minus = -1
        Case -53        '+の場合
            Call 項の切り替え(n, kou, stock, stock_line, minus)
        Case -48 To -39 '0~9の場合
            stock = stock & Val(char)
        Case -2         '^の場合
        Case 1 To 26    'アルファベットの場合
            stock_line = stock_line & char
    End Select
 Next
 n = UBound(kou)
 kou(n) = Format(stock * minus) & "," & stock_line
End Sub

ーーーーーーーーーーーーーーーー

Sub 項の切り替え(n, kou, stock, stock_line, minus)
 If stock = 0 Then stock = 1
 If stock_line = "" Then stock_line = "0"
 n = UBound(kou)
 kou(n) = Format(stock * minus) & "," & stock_line
 stock = 0
 stock_line = ""
 minus = 1
 ReDim Preserve kou(n + 1)
End Sub

 

これによって

kou(0)=1,a

kou(1)=2,a

というように係数と文字式の間にカンマが入ります。

 

つぎにcoという配列を使ってkouの係数と文字式を別の箱に入れます。

これは次の処理を書きやすくするため。

次の処理とは。

同じ文字式の係数を計算すること。

この処理のこなし方が下手だなという気がするのですが

ちょっと改善の方法がわからないので今回はこんな感じで。

Sub 同類項をまとめる(kou)
 Dim trgt As String
 Dim tmp As Integer
 Dim co() As String
 Dim n As Integer
 
 ReDim co(UBound(kou), 1)
 For i = 0 To UBound(kou)
    trgt = kou(i)
    tmp = InStr(trgt, ",")
    co(i, 0) = Mid(trgt, 1, tmp - 1)
    co(i, 1) = Mid(trgt, tmp + 1)
 Next
 
 For j = 0 To UBound(kou) - 1
    For i = j + 1 To UBound(kou)
        If co(j, 1) = co(i, 1) Then
            co(i, 0) = Val(co(i, 0)) + Val(co(j, 0))
            co(j, 0) = ""
        End If
    Next
 Next
 
 n = 0
 ReDim kou(n)
 
 For i = 0 To UBound(co, 1)
    If co(i, 1) <> "" Then
    ReDim Preserve kou(n)
    kou(n) = co(i, 1) & co(i, 2)
    n = n + 1
    End If
 Next
End Sub

最後に計算結果を出すための関数restoration2について。

そのうち名前を変えるかもですw

シンプルな機能なのでコードを読んでください。

Function restoration2(kou) As String
 For i = 0 To UBound(kou)
   
    If Left(kou(i), 1) <> "-" And i > 0 Then
        tmp = tmp & "+"
    End If
   
    tmp = tmp & kou(i)
 Next
 restoration2 = tmp
End Function

 

なんか。

うまく書けたーと思うことがあるんですが。

自分で条件を難しくしてそれをがんばってクリアしているだけなことがあって。

やっぱり格好いいコードはシンプルなんだろうなぁと思います。

今回のコードはぜんぜんシンプルじゃないw

最後にまとめると。

Private Sub CB1_Click()

 Dim siki As String
 Dim kou() As String
 Dim cul As Integer
 Dim answer As String
 
 siki = TB1
 trgt = siki
 Call 単項式への分解(trgt, kou)

 Call 同類項をまとめる(kou)
 answer = restoration2(kou)
 TB2 = answer
 
End Sub

ーーーーーーーーーーーーーーーーーーー

Sub 単項式への分解(trgt, kou)

 Dim char As String         '処理用の箱
 Dim stock As Integer       '処理用の箱
 Dim stock_line As String   '処理用の箱
 Dim n As Integer           'kouの数を指定
 Dim minus As Integer       '-の処理用の箱
 
 minus = 1
 n = 0
 ReDim Preserve kou(n)
 
 For j = 1 To Len(trgt)
    char = Mid(trgt, j, 1)
    Select Case Asc(char) - 96
        Case -51        '-の場合
            If n <> 0 Then
                Call 項の切り替え(n, kou, stock, stock_line, minus)
            End If
            minus = -1
        Case -53        '+の場合
            Call 項の切り替え(n, kou, stock, stock_line, minus)
        Case -48 To -39 '0~9の場合
            stock = stock & Val(char)
        Case -2         '^の場合
        Case 1 To 26    'アルファベットの場合
            stock_line = stock_line & char
      
    End Select
 Next
 n = UBound(kou)
 kou(n) = Format(stock * minus) & "," & stock_line
 
End Sub


Sub 項の切り替え(n, kou, stock, stock_line, minus)
 If stock = 0 Then stock = 1
 If stock_line = "" Then stock_line = "0"
 n = UBound(kou)
 kou(n) = Format(stock * minus) & "," & stock_line
 stock = 0
 stock_line = ""
 minus = 1
 ReDim Preserve kou(n + 1)
End Sub

ーーーーーーーーーーーーー

Sub 同類項をまとめる(kou)
 Dim trgt As String
 Dim tmp As Integer
 Dim co() As String
 Dim n As Integer
 
 ReDim co(UBound(kou), 1)
 For i = 0 To UBound(kou)
    trgt = kou(i)
    tmp = InStr(trgt, ",")
    co(i, 0) = Mid(trgt, 1, tmp - 1)
    co(i, 1) = Mid(trgt, tmp + 1)
 Next
 
 For j = 0 To UBound(kou) - 1
    For i = j + 1 To UBound(kou)
        If co(j, 1) = co(i, 1) Then
            co(i, 0) = Val(co(i, 0)) + Val(co(j, 0))
            co(j, 0) = ""
        End If
    Next
 Next
 
 n = 0
 ReDim kou(n)
 
 For i = 0 To UBound(co, 1)
    If co(i, 1) <> "" Then
    ReDim Preserve kou(n)
    kou(n) = co(i, 1) & co(i, 2)
    n = n + 1
    End If
 Next
 
End Sub

ーーーーーーーーーーーーーーーーーーーー

Function restoration2(kou) As String
 For i = 0 To UBound(kou)
   
    If Left(kou(i), 1) <> "-" And i > 0 Then
        tmp = tmp & "+"
    End If
   
    tmp = tmp & kou(i)
 Next
 restoration2 = tmp
End Function

 

  • ケース3 2a^2 +4a^2

これが今回の最後かな。

現状のコードでは答えが空欄になってしまいます。

が。

ちょっとした工夫をするだけで簡単にクリアできます。

 

んー。

じゃあこれはクイズにしておきますw

興味のある方は考えてみてください。

 

あ。

コードを動かしていて気づいたのですが。

1bをbと表記するコードを入れ忘れていました。

じゃあそれの書き方もクイズにしておきます。

これは前回のブログでふれた気がするので気になる方は前回のものを読んでみてください。

 

f:id:nozomi-hayashi:20180618085212g:plain

 

 

今回は分数の処理は処理は省略で。

二項の計算なら見やすくかけるのですが

それより多い項数の計算は醜くなってしまうので。。。

 

ふう。

結構疲れてきました。。

 

次は(多項式)×(多項式)です。

また近いうちに。

 

VBAで中学数学の問題を扱おう! その1 (単項式)×(単項式)の計算(後半)

 

とりあえず前回の復習

ケース1: 2×3

ケース2: 2a×3

ケース3: 2b×ac

 

以上をクリアできるコード

 

Private Sub CB1_Click()

 Dim siki(1) As String '扱う式を代入
 Dim answer As String  '答え
 
 siki(0) = TB1
 siki(1) = TB2
 
 Dim trgt As String             '処理用の箱
 Dim tmp As Integer             '処理用の箱
 Dim element(1, 26) As String   '数と文字を割り振る
 
 For j = 0 To 1
    For i = 1 To Len(siki(j))
       trgt = Mid(siki(j), i, 1)
       If trgt Like "[a-z]" Then
           tmp = Asc(trgt) - 96
           element(j, tmp) = element(j, tmp) & trgt
       Else
           element(j, 0) = element(j, 0) & trgt
       End If
    Next
 Next
 
 '未定義のkazuを1と定義
 For i = 0 To 1
    If element(i, 0) = "" Then
        element(i, 0) = 1
    End If
 Next
 
 Dim pre As String
 
 For i = 1 To 26
    pre = pre & element(0, i) & element(1, i)
 Next
 
 answer = Val(element(0, 0)) * Val(element(1, 0))
 answer = answer & pre
 
 TB3 = answer
End Sub

 

  • ケース4 ab×ab

現状のコードでは答えが1aabbになってしまいます。

これをどうやってa^2b^2にするか。

a^2b^2って見にくいですが我慢しましょうw

いずれ見やすくします。

 

まずは文字のほうの処理。

この解決策は言われてみれば簡単。

今まではaをaと記録していましたが

これからはaを1と記録すればよい。

a,b,cそれぞれのアルファベットは別の場所に記録される仕組みを取っているのでそれでも不都合は起こりません。

siki(0)とsiki(1)を数値で認識してす。

とりあえずここまでのコードを。

Dim element(1, 26) As Integer   '数と文字を割り振る
 
 For j = 0 To 1
    For i = 1 To Len(siki(j))
       trgt = Mid(siki(j), i, 1)
       If trgt Like "[a-z]" Then
           tmp = Asc(trgt) - 96
           element(j, tmp) = 1
       Else
           element(j, 0) = element(j, 0) & trgt
       End If
    Next
 Next

 

それらの数値を処理します。

For i = 1 To 26
    tmp = element(0, i) + element(1, i)
    If tmp = 1 Then
        pre = pre & Chr(96 + i)
    ElseIf tmp > 1 Then
        pre = pre & Chr(96 + i) & "^" & tmp
    End If
 Next

これでとりあえず答えが1a^2b^2になります。

この1を消すのが次の問題ですが。

これはもっと簡単。

 

answer = Val(element(0, 0)) * Val(element(1, 0))
 If Abs(Val(answer)) = 1 And pre <> "" Then
    answer = Replace(answer, 1, "")
 End If
 answer = answer & pre

 

たったこれだけでオッケー。

文字が存在して数値が+1か-1のときには1という表記を消す。

ということです。

 

コードをまとめます。

Private Sub CB1_Click()

 Dim siki(1) As String '扱う式を代入
 Dim answer As String  '答え
 
 siki(0) = TB1
 siki(1) = TB2
 
 Dim trgt As String             '処理用の箱
 Dim tmp As Integer             '処理用の箱
 Dim element(1, 26) As Integer   '数と文字を割り振る
 
 For j = 0 To 1
    For i = 1 To Len(siki(j))
       trgt = Mid(siki(j), i, 1)
       If trgt Like "[a-z]" Then
           tmp = Asc(trgt) - 96
           element(j, tmp) = 1
       Else
           element(j, 0) = element(j, 0) & trgt
       End If
    Next
 Next
 
 '未定義のkazuを1と定義
 For i = 0 To 1
    If element(i, 0) = 0 Then
        element(i, 0) = 1
    End If
 Next
 
 Dim pre As String
 
 For i = 1 To 26
    tmp = element(0, i) + element(1, i)
    If tmp = 1 Then
        pre = pre & Chr(96 + i)
    ElseIf tmp > 1 Then
        pre = pre & Chr(96 + i) & "^" & tmp
    End If
 Next
 
 answer = Val(element(0, 0)) * Val(element(1, 0))
 If Abs(Val(answer)) = 1 And pre <> "" Then
    answer = Replace(answer, 1, "")
 End If
 answer = answer & pre
 
 TB3 = answer
End Sub

 

  • ここでいったんコードを整理

ちょっとコードを整えましょう。

書き始めたときには気づかなかったところ

コードを付け足した際に汚くなってしまっているところ

そのあたりをきれいに~

今回は機能的にというよりは見栄えを整える感じです。

 

まず現状のコードの機能面を書いていきます。

 

テキストボックスに書かれた式を認識する。

それぞれをの式を一文字ずつ処理する。

element(0,1)やelement(1,1)が未定義の場合は1とする。

文字を処理する。

数字を処理して文字を付け足す。

 

となっています。

 

まずは一文字ずつ処理をする。の箇所を直します。

 For j = 0 To 1
    For i = 1 To Len(siki(j))
       trgt = Mid(siki(j), i, 1)
       If trgt Like "[a-z]" Then
           tmp = Asc(trgt) - 96
           element(j, tmp) = 1
       Else
           element(j, 0) = element(j, 0) & trgt
       End If
    Next
 Next

まずsiki(j)があちこちに書かれている部分がいやですね。

それ以外の文字列を処理したい場合に不都合が出るのでそこを書き直し。

For j = 0 To 1
    trgt = siki(j)
    For i = 1 To Len(trgt)
       char = Mid(trgt, i, 1)
      
       If char Like "[a-z]" Then
           tmp = Asc(char) - 96
           element(j, tmp) = 1
       Else
           element(j, 0) = element(j, 0) & Val(char)
       End If
    Next
 Next

続いてはifの部分。

文字かどうかを判別してからAscの関数を使っていますが

これは二度手間です。

Ascの値が一定の領域にあればおのずとそれはa~zのどれかなので。

For j = 0 To 1
    trgt = siki(j)
    For i = 1 To Len(trgt)
        char = Mid(trgt, i, 1)
        tmp = Asc(char) - 96
        Select Case tmp
            Case 1 To 26
                element(j, tmp) = 1
            Case Else
                element(j, 0) = element(j, 0) & Val(char)
        End Select
    Next
 Next

コードが膨らんできたことと

この処理を後のどこかで使うかもしれないことを考慮して

この処理を別のsubプロシージャとして書き直します。

 For j = 0 To 1
    trgt = siki(j)
    Call 文字列を仕分ける(trgt, element)
 Next

ーーーーーーーーーーーーー

Sub 文字列を仕分ける(trgt, element)
 Dim char As String '処理用の箱
 Dim tmp As Integer '処理用の箱
 For i = 1 To Len(trgt)
    char = Mid(trgt, i, 1)
    tmp = Asc(char) - 96
   
    Select Case tmp
        Case 1 To 26
            element(j, tmp) = 1
        Case Else
            element(j, 0) = element(j, 0) & Val(char)
    End Select
 Next
End Sub

これでオッケー。

おそらくですが

このコードは単項式同士の足し算や因数分解に役立つんじゃないかなと思います。

 

あ。

あとは未定義のelement(0,0)などの処理も「文字列を処理する」プロシージャに入れてしまいましょう。

Sub 文字列を仕分ける(j, trgt, element)
 Dim char As String '処理用の箱
 Dim tmp As Integer '処理用の箱
 For i = 1 To Len(trgt)
    char = Mid(trgt, i, 1)
    tmp = Asc(char) - 96
   
    Select Case tmp
        Case 1 To 26
            element(j, tmp) = 1
        Case Else
            element(j, 0) = element(j, 0) & Val(char)
    End Select
 Next
 If element(j, 0) = 0 Then  'element(j,0)が未定義の場合は1とする
    element(j, 0) = 1
 End If
End Sub

 

続いては文字の処理および数字の処理。

これらは変数preとanswerを用いて行っていますが

めちゃくちゃ見栄えが悪いですね。

 

element(1,26)をelement(2,26)に拡張して

elemetn(0,k)とelement(1,k)の処理結果をelement(2,k)に入れる

それから処理を行うことにします。

 

文字の処理はこれからもあちこちで使いそうなので

関数化します。

element(2, 0) = Val(element(0, 0)) * Val(element(1, 0))
 
 For i = 1 To 26
    element(2, i) = element(0, i) + element(1, i)
 Next
 
answer= line_restoration(element)

ーーーーーーーーーーーーーーーーーー

Function line_restoration(element)
 Dim n As Integer
 Dim trgt As String
 For i = 1 To 26
    n = element(2, i)
    If n = 1 Then
        trgt = trgt & Chr(96 + i)
    ElseIf n > 1 Then
        trgt = trgt & Chr(96 + i) & "^" & n

    End If
 Next
 If Abs(Val(element(2, 0))) = 1 And trgt <> "" Then
    tmp = Replace(element(2, 0), 1, "")
 Else
    tmp = element(2, 0)
 End If
 
 line_restoration = tmp & trgt
End Function

 

こんな感じです。

はい。

修正したコードを載せます。

Private Sub CB1_Click()

 Dim siki(1) As String '扱う式を代入
 Dim answer As String  '答え
 
 '-------------------------
 '式を認識
 '-------------------------
 siki(0) = TB1
 siki(1) = TB2
 
 Dim trgt As String             '処理用の箱
 Dim tmp As Integer             '処理用の箱
 Dim element(2, 26) As Integer   '数と文字を割り振る
 '-------------------------
 '一文字ずつ処理
 '-------------------------
 For j = 0 To 1
    trgt = siki(j)
    Call 文字列を仕分ける(j, trgt, element)
 Next
 
 '-------------------------
 '数字と文字の処理
 '-------------------------
 element(2, 0) = Val(element(0, 0)) * Val(element(1, 0))
 
 For i = 1 To 26
    element(2, i) = element(0, i) + element(1, i)
 Next
 
 answer = line_restoration(element)
 
 TB3 = answer
End Sub

ーーーーーーーーーーーーーーーーーーーーーー

Sub 文字列を仕分ける(j, trgt, element)
 Dim char As String '処理用の箱
 Dim tmp As Integer '処理用の箱
 For i = 1 To Len(trgt)
    char = Mid(trgt, i, 1)
    tmp = Asc(char) - 96
   
    Select Case tmp
        Case 1 To 26
            element(j, tmp) = 1
        Case Else
            element(j, 0) = element(j, 0) & Val(char)
    End Select
 Next
 If element(j, 0) = 0 Then  'element(j,0)が未定義の場合は1とする
    element(j, 0) = 1
 End If
End Sub

ーーーーーーーーーーーーーーーーーーーーーー

Function line_restoration(element)
 Dim n As Integer
 Dim trgt As String
 Dim tmp As String
 For i = 1 To 26
    n = element(2, i)
    If n = 1 Then
        trgt = trgt & Chr(96 + i)
    ElseIf n > 1 Then
        trgt = trgt & Chr(96 + i) & "^" & n
    End If
 Next
 
 If Abs(element(2, 0)) = 1 And trgt <> "" Then '数字が+-1で文字列が存在する場合の処理
    tmp = Replace(element(2, 0), 1, "")
 Else
    tmp = element(2, 0)
 End If
 
 line_restoration = tmp & trgt
End Function

これ以上「見やすく」すると「これにしか使えなく」なる気がするので修正はこれくらいに。

ただ数字が+-1で~の処理はちょっときたないですね。。

 

  • ケース4 -a × -a^2

 

f:id:nozomi-hayashi:20180618031127g:plain

 

はい。

もう何が起きているんだかって結果ですねw

マイナスと累乗は現状のコードでは考慮されていないので

なんか変な風に処理されてこうなっているんですねw

これらの処理を担当するのは「文字列を仕分ける」プロシージャなのでそこを修正しましょう。

Sub 文字列を仕分ける(j, trgt, element)
 Dim char As String '処理用の箱
 Dim tmp As Integer '処理用の箱
 For i = 1 To Len(trgt)
    char = Mid(trgt, i, 1)
    tmp = Asc(char) - 96
   
    Select Case tmp
        Case -51
        Case -48 To -39
            element(j, 0) = element(j, 0) & Val(char)
        Case -2
        Case 1 To 26
            element(j, tmp) = 1
        Case Else
            MsgBox "考慮されていない文字が入っています"
            Stop
    End Select
 Next
 If element(j, 0) = 0 Then  'element(j,0)が未定義の場合は1とする
    element(j, 0) = 1
 End If
End Sub

これで-と^が認識されます。

そして想定しない文字が出てきた場合はstopする仕様にしました。

 

後はそれぞれの処理を書くだけ。

現状は文字が出てきたらその文字を担当する箱に1を入れていましたが

累乗を考慮するためにはそうは行かないですね。

 

数字が出てきたらとりあえずストックする。

-が出てきたら出てきたことを覚えておく。

文字が出てきたら。

ストックが0の場合は1とする。

ストックした数字に場合によっては-1をかけてから箱に入れる

箱を切り替える。

 

こんな感じにしますか。

Sub 文字列を仕分ける(j, trgt, element)
 Dim char As String                 '処理用の箱
 Dim tmp As Integer                 '処理用の箱
 Dim stock As Integer               '処理用の箱
 Dim reference_number As Integer    'あて先の指定
 Dim minus As Integer               '-の処理用の箱
 
 minus = 1
 reference_number = 0
 For i = 1 To Len(trgt)
    char = Mid(trgt, i, 1)
    tmp = Asc(char) - 96
   
    Select Case tmp
        Case -51        '-の場合
            minus = -1
        Case -48 To -39 '0~9の場合
            stock = stock & Val(char)
        Case -2         '^の場合
        Case 1 To 26    'アルファベットの場合
            If stock = 0 Then
                stock = 1
            End If
            element(j, reference_number) = minus * stock
            reference_number = tmp
            stock = 0
            minus = 1
        Case Else
            MsgBox "考慮されていない文字が入っています"
            Stop
    End Select
 Next
 
 If stock = 0 Then
    stock = 1
 End If
 element(j, reference_number) = minus * stock
 
End Sub

処理のおかげでelement(k,0)への特別な処理を省くことができました。

いや。

省けたわけではないのですが。

なんていうんだろう。

はみ出た感じが引っ込んだというか。。。

^の文字が出たときにスルーするというやり方、格好良くないですか?w

この処理を思いついたときはテンションがあがりました。

 

まぁ。

まだそのレベルの人間ということでw

 

f:id:nozomi-hayashi:20180618035054g:plain

 

やったね。

  • 分数の計算

 

これは結構悩みました。

実はシート上での分数の計算は表記法まで確立させているのですが

ユーザーフォームではどうしようかなーと。。

ただせっかくだし実装はしたいよなーと。。

 

ほんとにいろいろ考えたのですが。。。

ってしつこいですねw

整数の形と分数の形をひとつのユーザーフォームで見栄え良くこなすのは難しいと思ったので。

ユーザーフォームをあと2つ足すことにしました。

選択画面と分数の計算画面です。

 

分数への解決方法はほんとに何通りもあって

どれを選ぶかはセンスだと思います。

 

正直に言うと。

複数のユーザーフォームによる処理を書いたことがないのでやってみたくなったという気持ちが大きいのですが。。。

 

f:id:nozomi-hayashi:20180618052629g:plain

分数の計算の実装の概要を書きます。

 

分子で文字と数字の処理

分母で文字と数字の処理

約分の処理

表記

 

基本的には整数のときと同じで

いくつかの配列を分数用に拡張しています。

 

約分についてだけちょっとだけ。

element(0,k)とelement(1,k)でelement(4,k)を

element(2,k)とelement(3,k)でelement(5,k)を

やり方は整数のときと同じ。

element(4,k)とelement(5,k)でelement(6,k)を

詳しくはコードを読んでください。

element(6,k)にelement(4,k)とelement(5,k)の最大公約数を入れたところがグッドポイントかなと思っていますw

あとはpを使ってうまいことやっていますw


Private Sub CB1_Click()

 Dim siki(3) As String '扱う式を代入
 Dim answer(1) As String  '答え
 Dim trgt As String             '処理用の箱
 Dim tmp As Integer             '処理用の箱
 Dim element(6, 26) As Integer   '数と文字を割り振る
 
 '-------------------------
 '式を認識
 '-------------------------
 siki(0) = TB1
 siki(1) = TB2
 siki(2) = TB4
 siki(3) = TB5
 
 '-------------------------
 '一文字ずつ処理
 '-------------------------
 For i = 0 To 3
    trgt = siki(i)
    Call 文字列を仕分ける(i, trgt, element)
 Next
 
 '-------------------------
 '数字と文字の処理
 '-------------------------
 For i = 0 To 1
    element(4 + i, 0) = Val(element(2 * i, 0)) * Val(element(2 * i + 1, 0))
   
    For j = 1 To 26
       element(4 + i, j) = element(2 * i, j) + element(2 * i + 1, j)
    Next
 Next
 
 '-------------------------
 '約分
 '-------------------------
 
 For i = 1 To 26
    tmp = element(4, i) - element(5, i)
    element(6, i) = tmp
 Next
 
 element(6, 0) = WorksheetFunction.Gcd(element(4, 0), element(5, 0))
 
 p = 1
 answer(0) = line_restoration(element, p)
 p = -1
 answer(1) = line_restoration(element, p)
 
 TB3 = answer(0)
 TB6 = answer(1)

End Sub

ーーーーーーーーーーーーーーーーーーーー

Sub 文字列を仕分ける(i, trgt, element)
 Dim char As String                 '処理用の箱
 Dim tmp As Integer                 '処理用の箱
 Dim stock As Integer               '処理用の箱
 Dim reference_number As Integer    'あて先の指定
 Dim minus As Integer               '-の処理用の箱
 
 minus = 1
 reference_number = 0
 For j = 1 To Len(trgt)
    char = Mid(trgt, j, 1)
    tmp = Asc(char) - 96
   
    Select Case tmp
        Case -51        '-の場合
            minus = -1
        Case -48 To -39 '0~9の場合
            stock = stock & Val(char)
        Case -2         '^の場合
        Case 1 To 26    'アルファベットの場合
            If stock = 0 Then
                stock = 1
            End If
            element(i, reference_number) = minus * stock
            reference_number = tmp
            stock = 0
            minus = 1
        Case Else
            MsgBox "考慮されていない文字が入っています"
            Stop
    End Select
 Next
 
 If stock = 0 Then
    stock = 1
 End If
 element(i, reference_number) = minus * stock
 
End Sub

ーーーーーーーーーーーーーーーーーーーーーーーー

Function line_restoration(element, p)
 Dim n As Integer
 Dim trgt As String
 Dim tmp As String
 
 For i = 1 To 26
    n = element(6, i) * p
    If n = 1 Then
        trgt = trgt & Chr(96 + i)
    ElseIf n > 1 Then
        trgt = trgt & Chr(96 + i) & "^" & n
    End If
 Next
 
 q = 4.5 - 0.5 * p
 If Abs(element(q, 0)) = 1 And trgt <> "" Then '数字が+-1で文字列が存在する場合の処理
    tmp = Replace(element(q, 0), 1, "")
 Else
    tmp = element(q, 0) / element(6, 0)
 End If
 
 line_restoration = tmp & trgt
End Function

 

ふう。

これで(単項式)×(単項式)の計算はクリアです。

根号式やsinやlogには対応していませんがそれはまた別枠ですかね。

 

プログラミングの面白いところは

(単項式)×(単項式)は簡単だけどlogの計算は難しい

とかはないところですかも。

 

 

 

 

VBAで中学数学の問題を扱おう! その1 (単項式)×(単項式)の計算(前半)

こんばんは~。

VBAのことをブログに書いてからちょっとだけブログアクセス数が増えました。

ありがたいことです。

意外と需要があるのかな???

 

さて。

今回から数回にわたって「中学数学の問題を扱おう!」の記事を書きたいと思います。

 

ひとくちに中学数学といってもいろいろあると思いますが。。

今回はその中でも根幹に来るであろう「計算」について。

 

特に(単項式)×(単項式)について書きたいと思います。

今回からの記事ではできるだけコードについて説明を書いていこうと思っています。

 

とりあえずざっくりと単項式について定義して。

その後にいくつかのケースを解決するコードを書いてみようかなと。

 

  • 単項式って?

単項式は掛け算のみからなる式。

ということにしましょう!

 

  • ケース1  2×3

つまりは(数字)×(数字)ですね。

Sub ケース1()
 Dim siki(1) As Integer '扱う式を代入
 Dim answer As Integer  '答え
 siki(0) = 2
 siki(1) = 3
 answer = siki(0) * siki(1)
End Sub

 

ま。

この処理ができないのに今回のブログを書こうとは思わないですよねw

これで処理できますが。

とりあえずユーザーフォーム仕様にでもしよう。

。。。
Private Sub CB1_Click()
 Dim siki(1) As Integer '扱う式を代入
 Dim answer As Integer  '答え
 siki(0) = Val(TB1)
 siki(1) = Val(TB2)
 answer = siki(0) * siki(1)
 TB3 = answer
End Sub

 

f:id:nozomi-hayashi:20180615183615g:plain

テキストボックスを左からTB1,TB2,TB3

計算と表記されているコマンドボタンをCB1

と定義しています。

コード自体は最初に書いたものとほとんどおんなじです。

 

せっかく作ったことですし。

以降はユーザーフォームを使っていきましょうか。。

正直ユーザーフォームは初心者だからうまく使えるか不安。。

 

  • ケース2 2a×3

つまりは(文字式)×(数字)ですね。

文字式が入ってくると少しずつ難しくなってきます。。

まずはsikiとanswerをintegerからstringに変更します。

Dim siki(1) As String '扱う式を代入
 Dim answer As String  '答え
 siki(0) = TB1
 siki(1) = TB2

ここからはいろいろな処理方法があると思いますが。

僕が取ろうと思っている処理は。

 

それぞれの式を数字と文字に分ける。

数字同士を処理する。

文字同士を処理する。

 

です。

 

新しくmoji(1)とkazu(1)を定義します。

あとtrgtも定義します。これは処理用の仮箱?

 Dim trgt As String
 Dim kazu(1) As String
 Dim moji(1) As String

次にsiki(0)とsiki(1)をkazuとmojiに分けます。

一気に書くとわかりにくいのでとりあえずsiki(0)だけ処理しましょう。

 j = 0
 For i = 1 To Len(siki(j))
    trgt = Mid(siki(j), i, 1)
    If trgt Like "[a-z]" Then
        moji(j) = moji(j) & trgt
    Else
        kazu(j) = kazu(j) & trgt
    End If
 Next

次の処理を簡単に書くためにj=0として書きました。

中身にチラッと触れると。

 

trgtにsiki(0)の1文字目を入れる。

それがアルファベットだったらmojiに追加。

それ以外だったらkazuに追加。

 

です。

じつはこの処理にはめちゃくちゃ問題があるのですが。。。

少なくともケース2は処理できるので良しとします。

というか。

いきなり強すぎるコードを載せちゃうとつまらないですよねw

 

 For j = 0 To 1
    For i = 1 To Len(siki(j))
       trgt = Mid(siki(j), i, 1)
       If trgt Like "[a-z]" Then
           moji(j) = moji(j) & trgt
       Else
           kazu(j) = kazu(j) & trgt
       End If
    Next
 Next

 

これでsiki(0)とsiki(1)に処理を施しました。

次はmojiとkazuを処理します。

 answer = Val(kazu(0)) * Val(kazu(1))
 answer = answer & moji(0) & moji(1)

 

ちょっと横着しちゃいました。

とりあえずこれでケース2をクリア。

 

Private Sub CB1_Click()

 Dim siki(1) As String '扱う式を代入
 Dim answer As String  '答え
 
 siki(0) = TB1
 siki(1) = TB2
 
 Dim trgt As String     '処理用の箱
 Dim kazu(1) As String  '数を割り振る
 Dim moji(1) As String  '文字を割り振る
 
 For j = 0 To 1
    For i = 1 To Len(siki(j))
       trgt = Mid(siki(j), i, 1)
       If trgt Like "[a-z]" Then
           moji(j) = moji(j) & trgt
       Else
           kazu(j) = kazu(j) & trgt
       End If
    Next
 Next
 
 answer = Val(kazu(0)) * Val(kazu(1))
 answer = answer & moji(0) & moji(1)
 
 TB3 = answer
End Sub

 

  • ケース3 2b×ac

これは(文字式)×(文字式)

f:id:nozomi-hayashi:20180615192102g:plain

 

とりあえずケース2のコードで処理してみました。

ん???

いろいろ突っ込みどころがありますねw

 

まず本筋と違うところで。

画像が見にくいですねw

次から気をつけますw

 

次は本筋で。

 

なぜか数が0になっている。

文字の順番がアルファベット順になっていない。

 

2b×ac=2abc

でないとだめですよね。

 

逆に言うと上に書いた二つの問題をクリアすればケース3も合格なのですが。

 

まずは簡単なほうから修正しますか。

 

なぜか数が0になっていることから。

これは初期値が原因です。

kazuの初期値は""です。

今回はkazu(1)は""のまま。

そのせいでVal(kazu(0)) * Val(kazu(1))の結果が""になってしまいます。

解決策は初期値を変えること。

For i = 0 To 1
    If kazu(i) = "" Then
        kazu(i) = 1
    End If
 Next

。。。

うそついちゃいました。

初期値を変えるのはその後の処理が大きく変わってしまいそうなので。

未定義のkazuを1と定義することにしました。

 

2b×ac=2bac

修正1は完了。

 

次は文字をアルファベット順に並べます。

この解決策はわれながら頭いいなーと思っちゃいますw

なんちって

 

sikiの割り振りかたを大幅に変更。

moji(1)をmoji(1,26)と定義します。

26にピンとくるひともいるかな?

そう。アルファベットの数です。

siki(0)について

一文字ずつ処理。

もしも数字だったら今までどおりkazuに入れる。

もしも文字だったら。

aならmoji(0,1)に、cからmoji(0,3)に、xならmoji(0,24)に入れる。

 Dim tmp As Integer
 For j = 0 To 1
    For i = 1 To Len(siki(j))
       trgt = Mid(siki(j), i, 1)
       If trgt Like "[a-z]" Then
           tmp = Asc(trgt) - 96
           moji(j, tmp) = moji(j, tmp) & trgt
       Else
           kazu(j) = kazu(j) & trgt
       End If
    Next
 Next

f:id:nozomi-hayashi:20180615195323g:plain

 

ローカルウィンドウを見るとこんな感じになります。

この処理方法は。。

 Dim pre As String
 For i = 1 To 26
    pre = pre & moji(0, i) & moji(1, i)
 Next

answer = Val(kazu(0)) * Val(kazu(1))
 answer = answer & pre

f:id:nozomi-hayashi:20180615195734g:plain

いえーい。

クリア。

もしかするとめちゃくちゃ効率の悪い定義法なのかもしれませんが。

これなら確実に文字をアルファベット順に処理できます。

 

あー。

ついでにkazuの処理も変更しますか。

kazuという変数を除去してmoji(0,0)とmoji(1,0)に代用させます。

これは表記の問題なのですが変数は少ないほうが何かと楽かなと思います。

こうするとmojiという変数で数字を処理するのも気持ち悪いので。

moji(1,26)をelement(1,26)に変更しましょう。

 

ケース3を処理するコード。

Private Sub CB1_Click()

 Dim siki(1) As String '扱う式を代入
 Dim answer As String  '答え
 
 siki(0) = TB1
 siki(1) = TB2
 
 Dim trgt As String             '処理用の箱
 Dim tmp As Integer             '処理用の箱
 Dim element(1, 26) As String   '数と文字を割り振る
 
 For j = 0 To 1
    For i = 1 To Len(siki(j))
       trgt = Mid(siki(j), i, 1)
       If trgt Like "[a-z]" Then
           tmp = Asc(trgt) - 96
           element(j, tmp) = element(j, tmp) & trgt
       Else
           element(j, 0) = element(j, 0) & trgt
       End If
    Next
 Next
 
 '未定義のkazuを1と定義
 For i = 0 To 1
    If element(i, 0) = "" Then
        element(i, 0) = 1
    End If
 Next
 
 Dim pre As String
 
 For i = 1 To 26
    pre = pre & element(0, i) & element(1, i)
 Next
 
 answer = Val(element(0, 0)) * Val(element(1, 0))
 answer = answer & pre
 
 TB3 = answer
End Sub

 

ちょっと疲れてきたので。

今日はここまで。

一気に書くつもりでしたが。。

後半は後日ということで。。

VBAで将棋をつくろう!その2 とりあえず動かせるようになりました

今日は暇だったのでぽちぽちとプログラミングを書いて

さっき完成しましたー。

 

いくつか冗長な部分もある気がしますが

見直す気になれません笑

テストで答えの確認をしない子供みたいな感じ?笑

 

  • コード

メイン

Dim n As Integer '盤面の大きさ
Dim rp As Range '定点の定義
Dim field As Range 'フィールド領域の定義
Dim motigoma As Range 'モチゴマ領域の定義
Dim c As Range 'カウンターの定義
Dim d(2) As Variant '方向を定義
Dim e(3) As Variant 'targetとpre_targetの位置関係を定義
Dim pre_target As Range '動かすターゲットの定義
Dim pre As Range
Dim koma As Variant 'コマの定義
Dim turn As Variant 'ターンの定義
Dim flag As Boolean

Private Sub Worksheet_Activate()
Cells.ClearContents
Call 設定の共有(n, rp, field, motigoma, c, pre, koma, turn)
Call フィールドの形成(field)
Call フィールド初期化(n, rp, c, koma, motigoma, turn)

End Sub

Private Sub Worksheet_SelectionChange(ByVal target As Range)
Call 設定の共有(n, rp, field, motigoma, c, pre, koma, turn)
d(0) = turn(c Mod 2)
d(1) = turn*1

t = tmp.End(xlDown).Row - tmp.Row
If t = 0 Then
tmp = ""
Else
Application.EnableEvents = False
a = Range(tmp.Offset(1, 0), tmp.Offset(t, 0))
Range(tmp.Offset(0, 0), tmp.Offset(t, 0)) = ""
Range(tmp.Offset(0, 0), tmp.Offset(t - 1, 0)) = a
Application.EnableEvents = True
End If
c = c + 1
Exit Sub
End If

If pre = "" Then
If Right(target, 1) = d(1) Then GoTo syori 'preが未定の場合はそれを指定
pre = target
pre.Offset(1, 0) = target.Row
pre.Offset(2, 0) = target.Column
Exit Sub
End If

'------------------------------------
'以降はpre_targetが既定の場合
'------------------------------------
'モチゴマをおく場合

If Right(target, 1) = d(0) Then GoTo syori 'targetが自分のコマの場合は終了

'方向を定義
e(0) = target.Row - pre.Offset(1, 0)
e(0) = e(0) * d(2)
e(1) = target.Column - pre.Offset(2, 0)
e(2) = func1(e(0)) '方向ベクトル
e(3) = func1(e(1)) '方向ベクトル

Set pre_target = Cells(pre.Offset(1, 0), pre.Offset(2, 0))


If InStr(pre, "成") = 0 Then '成り金の処理
jdg = Left(pre, Len(pre) - 1)
Else
jdg = "金"
End If

Select Case jdg 'コマが動かせるかの判定
Case koma(2), koma(3), koma(4), koma(5) '銀、金、王、歩兵の判定
If Abs(e(0)) + Abs(e(1)) > 2 Then GoTo syori
flag = move_jdg1(jdg, koma, e)
Case koma(1) '桂馬の判定
If e(0) = 2 & Abs(e(1)) = 1 Then
flag = True
End If
Case Is = koma(0), koma(6), koma(8) '香車、飛車の判定
If Not (e(0) = 0 Or e(1) = 0) Then GoTo syori

tmp = WorksheetFunction.CountA(Range(target.Offset(e(2) * d(2), e(3)), pre_target))
If tmp = 1 Then
flag = True
End If
Case Is = koma(7), koma(9) '角の判定
If Abs(e(0)) <> Abs(e(1)) Then GoTo syori

Set tmp = pre_target

If Abs(e(0)) = 1 Then
flag = True
Else
For i = 1 To Abs(e(0)) - 1
Set tmp = tmp.Offset(e(2) * d(2), e(3))
If tmp <> "" Then GoTo syori
Next
flag = True
End If
End Select

If flag = True Then 'コマが動かせる場合
If target <> "" Then 'targetが相手のコマの場合
Call モチゴマにする(target, koma, c, d, motigoma)
End If

pre_target = ""
target = pre
c = c + 1
If (4 - (target.Row - rp.Row)) * d(2) * -1 > 1 Then '成りの処理
target = nari(target, koma, d)
End If
End If

syori:
Range(pre, pre.Offset(2, 0)) = ""

End Sub

 

サブ

Sub 設定の共有(n, rp, field, motigoma, c, pre, koma, turn)

n = 9 - 1
Set rp = Cells(2, 4)
Set field = Range(rp, rp.Offset(n, n))
Set motigoma = rp.Offset(n + 2, 0)
Set c = rp.Offset(0, 2 * n)
Set pre = rp.Offset(1, 2 * n)
koma = Array("香車", "桂馬", "銀", "金", "王", "歩", "飛車", "角", "龍", "馬")

turn = Array("-", "+")
End Sub

Sub フィールドの形成(field)
field.Rows.RowHeight = 30
field.Columns.ColumnWidth = 6

field.Borders.LineStyle = xlContinuous

End Sub

Sub フィールド初期化(n, rp, c, koma, motigoma, turn)
Cells.ClearContents
c = 0
Range(motigoma, motigoma.Offset(0, 1)) = "もちごま"
m = n / 2

With rp
.Offset(m - 3, m - 3) = koma(6) & turn(1)
.Offset(m + 3, m + 3) = koma(6) & turn(0)
.Offset(m - 3, m + 3) = koma(7) & turn(1)
.Offset(m + 3, m - 3) = koma(7) & turn(0)

For i = 0 To 8
tmp = WorksheetFunction.Min(i, n - i)
.Offset(m - 4, i) = koma(tmp) & turn(1)
.Offset(m + 4, i) = koma(tmp) & turn(0)
.Offset(m - 2, i) = koma(5) & turn(1)
.Offset(m + 2, i) = koma(5) & turn(0)
Next
End With

End Sub

Function move_jdg1(jdg, koma, e) As Boolean 'コマが動かせるかの判定の続き
Select Case jdg
Case Is = koma(2) '銀の判定
If e(0) = 0 Then
ElseIf e(0) = -1 And e(1) = 0 Then
Else
move_jdg1 = True
End If
Case Is = koma(3) '金の判定
If e(0) = -1 And e(1) = 1 Then
Else
move_jdg1 = True
End If
Case Is = koma(4) '王の判定
move_jdg1 = True
Case Is = koma(5) '歩兵の判定
If e(0) = 1 And e(1) = 0 Then
move_jdg1 = True
End If
End Select


End Function
Function func1(e) As Integer '方向ベクトルの取得
If e = 0 Then
func1 = 0
Else
func1 = e / Abs(e)
End If

End Function
Function nari(target, koma, d) As String

Select Case Left(target, Len(target) - 1)
Case Is = koma(6), koma(8)
nari = koma(6) & d(0)
Case Is = koma(7), koma(9)
nari = koma(9) & d(0)
Case Is = koma(3), koma(4)
nari = target
Case InStr(target, "成") = 0
nari = "成" & target
Case Else
nari = target
End Select

End Function

Sub モチゴマにする(target, koma, c, d, motigoma)
Dim tmp As Range
target = Replace(target, d(1), "")

Select Case target
Case Is = koma(8)
target = koma(6)
Case Is = koma(9)
target = koma(7)
Case InStr(target, "成") <> 0
target = Replace(target, "成", "")
End Select

target = target & d(0)

Set tmp = motigoma.Offset(0, c Mod 2)
If tmp.Offset(1, 0) = "" Then
tmp.Offset(1, 0) = target.Value
Else
t = tmp.End(xlDown).Row - tmp.Row
tmp.Offset(t + 1, 0) = target.Value
End If

End Sub

 

  • 思ったこと

今回はkoma配列単体では何もできない仕様で書きました。

それが僕が考えた「シンプルに書く方法」です。

 

komaにいくつかの文字を付け足して盤面で動かす。

認識の際にはそれらをはずすorそれを付けた効果を発揮した状態にする。

 

という感じです。

 

今回の主な反省点はコメントの書き方。

将棋のプログラミングくらいになるとどうしてもコードが長くなってしまう。

'------------

'ここは00です

'------------

上のコメント文。

ネットではよく見ていたのですが自分で使ったのは初めてでした。

コードを書いている後半になんとなく書いてみたら

めちゃくちゃ見やすくなりました。

 

ただほかの部分のコメントを書き直す気分になれなかったので

今回は全体を通しては扱えませんでしたが。。

 

次回からは積極的に使っていこうと思います。

 

ほかはなんだろうなー。

将棋の成りをコードで書くことに特に苦労しました。

結果としてはなかなかシンプルにかけたのでは?と思っているのですが

道中では「こりゃどうすりゃええんじゃああああ」って苦しんでいました。

 

シンプルな文字列を適宜改変してゆく。

という概念は今回得た思わぬ収穫でした。

 

  • 次回の予定

将棋はひとまず終わりにします。

次回は囲碁にしようかライフゲームにしようか考え中です。

どっちももう頭の中では出来上がっているので

今回の将棋のように苦しむことはないかなと思っています。

 

ではでは。

*1:c + 1) Mod 2)
d(2) = (-1) ^ ((c Mod 2) + 1)

If Application.Intersect(target, field) Is Nothing Then 'targetが番外の場合
If Right(target, 1) = d(0) Then 'targetがモチゴマの場合
pre.Offset(0, 1) = target
pre.Offset(1, 1) = target.Row
pre.Offset(2, 1) = target.Column
End If
Exit Sub
End If

If pre.Offset(0, 1) <> "" And target = "" Then 'preがモチゴマの場合
target = pre.Offset(0, 1)
pre.Offset(0, 1) = ""
Set tmp = Cells(pre.Offset(1, 1), pre.Offset(2, 1

VBAで将棋をつくろう! その1

VBAで○○をつくろう。

第一弾はオセロでしたが

今回第二段は将棋です!!!

その1ではコードは書きません。

将棋を選んだ理由とどうやって将棋をつくるのかを

できるだけ日本語で書きたいと思います。

 

じつはこの工程こそがプログラミングの肝なんじゃないかとちょっと感じています。

 

  • なぜ将棋?

それは将棋が数種類の駒を動かす種目だからです。

 

一文ですが要素が二つ。

 

まずは数種類の駒。

これは後にキャラクターになりますね。

 

そして駒を動かす。

これが将棋をつくるうえの肝かなと思っています。

一度にひとつのことしかできないコンピュータにどうやって「駒を動かす」をさせるかというと。

 

動かす駒を選ぶ。

動かす先を選ぶ。

 

というふたつの工程を踏むことで行わせます。

 

。。。

これが将棋のプログラミングにおけるほぼすべてなのかなーとか思ったり。

 

  • どうやって将棋をつくるの?

将棋を一手指すことを分解して考えてみます。

 

動かす駒を選ぶ(盤上or持ち駒)

動かす先を選ぶ

そこに動かすことができるか調べる

可能な場合は動かす

動かした先に相手の駒があった場合は駒をとる

動かした先が相手の領域だった場合は成る(駒をひっくり返す)

 

6工程

 

ちなみにオセロだと。

置く場所を選ぶ

置くことができるか調べる

置いて条件にあったところをひっくり返す

 

3工程

 

将棋のほうが工程が多いですね。

プラスで。

ご存知のとおり将棋には駒が数種類あります。

それぞれの駒が指定された場所に移動できるかどうかを調べる処理はどうしてもいくつかの具体的なことを書かないと実装できません。

 

オセロの場合は「自分の石」と「相手の石」の二種類しかなかったので

駒の種類が増えた場合の対応の仕方を考えないといけませんね。

 

あー。

オセロをつくろうのどこかのページで書いたのですが。

それを作ることは簡単だがシンプルに作ることは難しい。

と思うんです(たぶんフレーズは違いますが同じ概念のことを書いたと思います)。

 

将棋の場合はとりあえず駒が40個なので

40個すべてについて処理を書いていけばつくることはできます。

ただ面倒だしシンプルじゃない。

 

先に行ってしまいますが。

現在の自分のスキルでは将棋をすっげぇシンプルに書くことはできないと思っています。

いかにシンプルにつくるかはもちろん攻めますが。

一度つくってから二週間もすればぜんぜん違う様式でもっとシンプルにつくれると思います。

でも一度つくらないとその成長は約束されないのでつくります。

 

んー。

なんか日本語っぽくなくなってきたのでこれくらいに。

 

  • どうやってつくるか(もうちょっと詰めて)

上の章で書いた6工程それぞれをどうやって実装するのか。

もうちょっと詰めて書きます。

 

動かす駒を選ぶ(盤上or持ち駒)

fieldとmotigomaという領域を定義して

それらのうち自分が使用権を持つものがクリックされた場合に

selectという領域にその駒の名前を位置を書き込みます

 

動かす先を選ぶ

selectに情報が書き込まれている場合に発動します

新たにクリックされた場所を動かす先として認識します

具体的にいうとそのセルをtargetとします

 

そこに動かすことができるか調べる

selectとtargetからどの駒をどこからどこへ動かすつもりなのかがわかります

なのでそれが可能かどうかを調べます

ここが一番の難所かな

その駒が何かによって異なる処理を選びます

その処理でその駒をtargetへ動かすことができるか調べます

 

異なる処理。というところをもう少し突っ込みます。

ここをシンプルに書くことが僕がこのタイミングで将棋をつくる一番の理由です。

 

すべての駒に個別の処理を書く

   →80通り(駒が40枚でそれぞれに表裏があるため)

自分の駒20枚の処理で相手の駒の処理もこなす

   →40通り(80を2で割って)

王,飛車,龍,角,馬,金,銀,桂馬,香車,歩の処理を書いてそれぞれの駒の処理をこなす

   →10通り

(飛車,龍,角,馬,香車),(王,金,銀,桂馬,歩)について()に入った駒はできるだけ同じ処理でこなす

ここだけちょっと説明。。。

()の前者は動線に駒があると動けない駒たち

後者は動線がない(1マスしか進めない)ものか動線に駒があっても関係のない駒たち

実は前者は条件が後者よりひとつ多いんです。

ただその条件を調べる方法がどれも似ている(と感じる)ので()にくくりました。

   →2*5通り(ひとつ上のものよりシンプルなはず。。)

これでkomaは10種類でこの工程での分岐は2*5にまで絞れました。

この工程での分岐がもっと削れるんじゃないかと思うんですけど。

まぁ今の自分には思いつかないです。

あとはふるいを上手に設けて処理を簡略化するところで勝負します。

 

可能な場合は動かす

駒を動かせる場合にselectの情報からその位置にある駒を消して

targetに書き直します

 

動かした先に相手の駒があった場合は駒をとる

targetが相手の駒でありそこに自分の駒を動かせる場合は

targetに自分の駒を書き換える前に

相手の駒を自分のmotigoma領域に書きます

そしてtargetを書き換えます

 

動かした先が相手の領域だった場合は成る(駒をひっくり返す)

ここも難しい。

動かした先が相手の領域だった場合はその駒を書き換えるだけなので

上の工程がかけたならそのスキルで何とかできます。

問題はその先。

もしも成った駒が相手に取られた場合。

これは成る前の駒を相手に与えないといけませんよね。

これをどう実装するか。。。

 

ここは自分にとって面白い(つまり答えを知らない)のでいくつか案を出してみましょう。

えっと前提として駒はkomaという配列を使って表現するつもりです。

簡略化のために駒は「歩」「飛車」「王」の三種類だけとしましょう。

成る駒が2つと成らない駒が1つですね。

 

array関数を使う場合

 一次元で詰め込む場合

  (歩,金,飛車,龍,王,王)と詰める

  koma(o),koma(2)など基本は偶数のみを扱う

  成ったらkoma(0)をkoma(0+1)とする

  とられたらkoma(0)はkoma(0)としてkoma(1)はkoma(1-1)とする

  んー複雑そう。。

 二次元で詰め込む場合

  これはこの記事を書きながら思いつきました。

  *1と詰める

  基本はkoma(1,0),koma(2,0)を使う

  成ったらkoma(1,1)にしてとられたらkoma(1,0)にする

  んー。上よりはよいか??

シートを使う場合

 これも今思いついたやつなのですがトリッキーに感じる。。。

 あらかじめkomaシートに書いておく

 1列目に駒の表面を2列目に駒の裏面を記入しておく

 駒が成る場合にkomaシート参照してそれが一列目であった場合には二列目のものに書き換える

 駒がとられた場合にkomaシートを参照してそれが二列目であった場合には一列目のものに書き換える

 

んー。

残念ながら結論をうまく日本語で表現することができないのですが

現時点では表面と特殊な裏面(龍と馬?)だけarrayで宣言して

成る場合と取られる場合にシート参照するのが良いかなと思います。

 

正直けっこう感覚で喋っているので実際に書いているうちに気持ちが変わるかもしれません。

 

  • さいごに

はて。

ところどころ意味不明なことを書いている気がしますが。

とりあえずめちゃくちゃ疲れました。

でもプログラミングの道筋はほぼ見えました。

あとはいかにシンプルにするかだけ。

道筋を日本語で書く工程はめちゃくちゃ疲れるけどやはり大事な気がする。

なんだろ。

上位概念からのアクセスな感じがします。

 

おわり

 

 

*1:歩,金),(飛車,龍),(王,王

VBAでオセロをつくろう! その3 とりあえず敵を設定できました!

キレッキレだったのでその2に続いて投稿。

今日は調子よさそう笑

 

 毎回書く項目をしっかり決めないと。。

その1でもその2でもぜんぜん違う書き方になっていますね。。

 

  • 前回からの変更点

簡単に言うとタイトルの通り。

敵を設定しました。

どうやったかの説明をつらつらと。

前回のブログに書いた、星をつける、の機能をちょっと書き換えました。

 

一番おく価値のある場所のセル番地を返す関数を定義

そのセルに石を置いてひっくり返せる石は返す

 

というコードを書くことで敵の指す手を表現しました。

 

。。。

 

日本語で説明するの難しいですね。。

正直自分で書いていても概念が言葉より早く動いている感じがします。

あくまで処理においては言葉より数式?コード?のほうがアクセスが早いのだろうか。。。

 

とにかく。

いままでどおり自分がクリックしたところが正常な位置なら石を置いて周りをひっくり返す。

プラスで。

それに対応して石を自動で置いてそれに準じたひっくりかえしを行う。

 

自分が黒を持つときは素直にその通りに。

白を持つときは一手間加えます。

特別なセルを指定して、"後攻で~~"と記入しておきます。

僕はシートがアクティベイトされたときに自動でかかれるようにコードを書きました。

そしてそのセルがクリックされたらコンピューターが自動で一手指す使用に。

つまりコンピューターが黒を打って、自分は白を打つという風にひとつずらすことができます。

 

  • コード

メイン

Dim rp As Range         'フィールド形成の定点の定義
Dim n As Integer        '盤面の大きさの定義
Dim field As Range      'rpとnでフィールドの定義
Dim c As Range          'カウントセルの定義
Dim stone As Variant    '黒石と白石の定義
Dim turn As Variant     '手番プレートの定義

Private Sub Worksheet_Activate()
 'シートの状態を設定
 Cells.ClearContents
 Call 基礎値共有(rp, n, field, c, stone, turn)
 Call フィールド形成(rp, field, stone, turn, c, n)
 
End Sub

Private Sub Worksheet_SelectionChange(ByVal target As Range)
 
 Call 基礎値共有(rp, n, field, c, stone, turn)
 
 If target = c.Offset(3, 1) And c = 0 Then GoTo koukou
 Dim flag As Boolean    'flagはプロシージャを抜ける判定に使う
 Dim saizen As String
 Dim q(1) As String     'q0が自分の石でq(1)が相手の石
 
 q(0) = stone(c Mod 2)
 q(1) = stone*1
 Set c = rp.Offset(0, n + 2)
 stone = Array("●", "○")
 turn = Array("黒番", "白番")
End Sub

Sub フィールド形成(rp, field, stone, turn, c, n)
'フィールドの見た目を定義
With field
    .ClearContents
    .Rows.RowHeight = 50
    .Columns.ColumnWidth = 8
    .Interior.Color = RGB(200, 200, 200)
    .Borders().LineStyle = xlContinuous
 End With

 
'最初の4石を置く
With rp
    .Offset(n / 2 - 1, n / 2 - 1) = stone(0)
    .Offset(n / 2, n / 2) = stone(0)
    .Offset(n / 2 - 1, n / 2) = stone(1)
    .Offset(n / 2, n / 2 - 1) = stone(1)
 End With
 'カウントセルと手番の表示
 c.Value = 0
 c.Offset(1, 0) = turn(0)
 c.Offset(3, 1) = "後攻ではじめる"
End Sub

 


Function flag_p_rec(target, q) As Boolean

 Dim tmp As Range       '周辺認識用
 Dim stock As Range     '周辺認識用
 Dim d(1) As Integer    '周辺認識用
 
 'iでターゲットの周辺を認識
 For i = 0 To 8
    d(0) = i Mod 3 - 1
    d(1) = i \ 3 - 1
    Set tmp = target.Offset(d(0), d(1))
    Set stock = tmp
    If stock <> q(1) Then GoTo L1
        '周辺マスが敵の石だった場合の処理
    Do
        Set tmp = tmp.Offset(d(0), d(1))
        Select Case tmp.Value
            Case Is = q(0)
                stock = q(0)
                target = q(0)
                flag_p_rec = True
            Case Is = q(1)
                Set stock = Union(stock, tmp)
            Case Else
                Exit Do
        End Select
    Loop
L1:
 Next
End Function

Function cp_select(stone, field, c, q) As String

 Dim target As Range
 Dim first As Range
 Dim found As Range
 
 Dim d(1) As Integer
 Dim cnt As Integer
 Dim cnt_tmp As Integer
 Dim pre As Integer
 Dim hozon As String

 Set target = field.Find("")
 If target Is Nothing Then
    Exit Function
 Else
    Set first = target
 End If
 
 Do
    cnt = 0
    Set target = field.FindNext(target)
   
    For i = 0 To 8
        cnt_tmp = 0
        d(0) = i Mod 3 - 1
        d(1) = i \ 3 - 1
        Set tmp = target.Offset(d(0), d(1))
        If tmp <> q(1) Then GoTo L1
      
        Do
            Set tmp = tmp.Offset(d(0), d(1))
           
            Select Case tmp.Value
                Case Is = q(0)
                    cnt = cnt + cnt_tmp + 1
                    Debug.Print cnt_tmp + 1
                    If cnt >= pre Then
                        hozon = target.Address(False, False, xlA1, False)
                        pre = cnt
                    End If
                    Exit Do
                   
                Case Is = q(1)
                    cnt_tmp = cnt_tmp + 1
                Case Else
                    Exit Do
            End Select
        Loop
L1:
    Next
   
    If target.Address = first.Address Then
        Exit Do
    End If
 Loop
 
 If hozon = "" Then
    Exit Function
 End If
 cp_select = hozon
 
End Function

 

  • 次の予定

んー。

もうオセロはあんまりやる気ないです。

それよりほかのゲームに触れてみたい。

もしオセロに手を加えるとしたらコンピューターの手を強化することになりますが。僕自身がオセロが弱いので面倒くさいんですよね。。

 

ではでは。

*1:c + 1) Mod 2)
 
 
 'targetがフィールド外であればプロシージャから抜ける
 If Application.Intersect(target, field) Is Nothing Then
    Exit Sub
 End If
 
 '石が置けるかの判定および処理
 flag = flag_p_rec(target, q)
 
 'Call 周辺認識(target, q, flag)

 
 '石が置けなかった場合はプロシージャから抜ける
 If flag = False Then
    Exit Sub
 End If
 flag = False
 'クリック数と手番の更新
 c.Value = c.Value + 1
 
 
 'cpの手の定義
koukou:

 q(0) = stone(c Mod 2)
 q(1) = stone((c + 1) Mod 2)
 saizen = cp_select(stone, field, c, q)
 If saizen <> "" Then
    Set target = Range(saizen)
    flag = flag_p_rec(target, q)
 End If
 
 c.Value = c.Value + 1
 c.Offset(1, 0) = turn(c Mod 2)
 
End Sub

 

サブ

Sub 基礎値共有(rp, n, field, c, stone, turn)
 'ここで数値を指定する
 Set rp = Cells(2, 2)
 n = 8
 Set field = Range(rp, rp.Offset(n - 1, n - 1

VBAでオセロをつくろう! その2 次における場所を表示できるようになった!

その2では以下の3つを行います。

 

根幹プログラムの更新

新機能の増築

 

  • 根幹プログラムの更新

メイン

Dim rp As Range         'フィールド形成の定点の定義
Dim n As Integer        '盤面の大きさの定義
Dim field As Range      'rpとnでフィールドの定義
Dim c As Range          'カウントセルの定義
Dim stone As Variant    '黒石と白石の定義
Dim turn As Variant     '手番プレートの定義

Private Sub Worksheet_Activate()
 'シートの状態を設定
 Cells.ClearContents
 Call 基礎値共有(rp, n, field, c, stone, turn)
 Call フィールド形成(rp, field, stone, turn, c, n)
 
End Sub

Private Sub Worksheet_SelectionChange(ByVal target As Range)
 
 Call 基礎値共有(rp, n, field, c, stone, turn)
 
 Dim flag As Boolean    'flagはプロシージャを抜ける判定に使う
 Dim tmp As Range       '周辺認識用
 Dim stock As Range     '周辺認識用
 Dim d(1) As Integer    '周辺認識用
 Dim q(1) As String     'q0が自分の石でq(1)が相手の石
 
 q(0) = stone(c Mod 2)
 q(1) = stone*1
    Set stock = tmp
    If stock <> q(1) Then GoTo L1
        '周辺マスが敵の石だった場合の処理
    Do
        Set tmp = tmp.Offset(d(0), d(1))
        Select Case tmp
            Case Is = q(0)
                stock = q(0)
                target = q(0)
                flag = True
            Case Is = q(1)
                Set stock = Union(stock, tmp)
            Case Else
                Exit Do
        End Select
    Loop
L1:
 Next
 
 '石が置けなかった場合はプロシージャから抜ける
 If flag = False Then
    Exit Sub
 End If
 
 'クリック数と手番の更新
 c.Value = c.Value + 1
 c.Offset(1, 0) = turn(c Mod 2)
 
End Sub

 

サブ

Sub 基礎値共有(rp, n, field, c, stone, turn)
 'ここで数値を指定する
 Set rp = Cells(2, 2)
 n = 8
 Set field = Range(rp, rp.Offset(n - 1, n - 1))
 Set c = rp.Offset(0, n + 2)
 stone = Array("●", "○")
 turn = Array("黒番", "白番")
End Sub

Sub フィールド形成(rp, field, stone, turn, c, n)
'フィールドの見た目を定義
With field
    .ClearContents
    .Rows.RowHeight = 50
    .Columns.ColumnWidth = 8
    .Interior.Color = RGB(200, 200, 200)
    .Borders().LineStyle = xlContinuous
 End With

'最初の4石を置く
With rp
    .Offset(n / 2 - 1, n / 2 - 1) = stone(0)
    .Offset(n / 2, n / 2) = stone(0)
    .Offset(n / 2 - 1, n / 2) = stone(1)
    .Offset(n / 2, n / 2 - 1) = stone(1)
 End With
 'カウントセルと手番の表示
 c.Value = 0
 c.Offset(1, 0) = turn(0)
End Sub

 

その1のプログラムとの違いをつらつらと。

 

余計なcallを削った。

これが一番ですね。

なんでもcallするのが格好いい気がしていたのですが

逆に見にくいなと思って書き換えました。

フィットするレベルはまだ模索中。

 

コメントの書き方を変えた

dimの段階でこれは何をするものですよーと書いたほうがいいかなと思って書き換えました。

このあたりのデザインセンスは磨き続けるしかないですよね。。

あんまり他人の書いたコードを読んだことがないので

それをすれば適したところがわかるのかな。。

 

プログラミング1列ずつの細かい説明は面倒なので需要がない限りは省略します。。

 

  • 新機能の増築

新機能は2つ。

星をつける(次における場所に☆をつけ、その際にひっくり返せる相手の石の数を示す)

星をはずす(上の星と数字を消す)

 

Sub 星をつける()


 Dim target As Range
 Dim first As Range
 Dim found As Range
 Dim q(1) As String
 Dim d(1) As Integer
 Dim cnt As Integer
 
 Call 基礎値共有(rp, n, field, c, stone, turn)
 q(0) = stone(c Mod 2)
 q(1) = stone*2
        If tmp <> q(1) Then GoTo L1
       
        Do
            Set tmp = tmp.Offset(d(0), d(1))
            Select Case tmp
                Case Is = q(0)
                    cnt = cnt + 1
                    target = "☆" & cnt
                    Exit Do
                Case Is = q(1)
                    cnt = cnt + 1
                Case Else
                    Exit Do
            End Select
        Loop
L1:
    Next
   
    If target.Address = first.Address Then
        Exit Do
    End If

 Loop
 
End Sub

 

Sub 星を消す()
 Dim target As Range
 Dim first As Range
 Dim found As Range
 Dim q(1) As Integer
 
 Call 基礎値共有(rp, n, field, c, stone, turn)

 Set target = field.Find("☆", lookat:=xlPart)
 If target Is Nothing Then
    Exit Sub
 Else
    Set first = target
 End If
 
 target = ""
 Do
    Set target = field.FindNext(target)
    If target Is Nothing Then
        Exit Do
    Else
        target = ""
    End If
 Loop
 
End Sub

 

仮想の相手を作る際の両輪は。

おける場所を示すこと。

そこに置く価値を示すこと。

とりあえずボロボロながらも両方を設けました。

 

そこに置く価値はもう少し書かないとなぁ。

ただ自分がオセロ詳しくないので

強い敵を作るにはすこしオセロを勉強せねばなりませんが。。

 

そこまでのやる気はなさそうだな笑

 

  • 今後の予定

とりあえず仮想の敵を実装するのが次の課題ですね。

まぁもうほとんど部品はできているので

あとはそれを組むだけなのですが。

 

って。

そういうことはつくってから言いますね笑

 

ではでは。

 

 

 

 

*1:c + 1) Mod 2)
 
 
 'targetがフィールド外であればプロシージャから抜ける
 If Application.Intersect(target, field) Is Nothing Then
    Exit Sub
 End If
 
 'iでターゲットの周辺を認識
 
 For i = 0 To 8
    d(0) = i Mod 3 - 1
    d(1) = i \ 3 - 1
    Set tmp = target.Offset(d(0), d(1

*2:c + 1) Mod 2)

 Set target = field.Find("")
 If target Is Nothing Then
    Exit Sub
 Else
    Set first = target
 End If
 
 Do
    cnt = 0
    Set target = field.FindNext(target)
   
    For i = 0 To 8
        d(0) = i Mod 3 - 1
        d(1) = i \ 3 - 1
        Set tmp = target.Offset(d(0), d(1