トロPのVBAホビラボ 32ビット符号無し整数その5：Pウォッチ：SSブログ

	ブログをはじめるログイン

トロPのVBAホビラボ 32ビット符号無.. ｜トロPのVBAホビラボ 32ビット符号無.. ブログトップ

トロPのVBAホビラボ 32ビット符号無し整数その5　[トロPのVBAホビラボ] [編集]

さて、いよいよ最後の四則演算の除算（割り算）を実現しましょう。これでようやく符号なし整数がそこそこ不便無く使えるようになりますね。

おおまかなロジック

単純に考えると何回引けたか数えればよいのですが、&HFFFFFFFFから1を引くことを考えると、その膨大な数の引き算は割りに合いません。そこで、また筆算を考えます。

2進数ですので、各桁の計算は1回引けるのか全く引けないのかだけを判定していきます。

被除数の一番上の桁に除数の一番上の桁を合わせるために、除数をShiftLeftLogicallyで左シフトして調整した除数を作ります。
被除数から調整した除数を引き、引けたのなら1、引けなかったのなら0を立てます。1を立てるのに実際には、LngBitXtrValで除数の調整のときと同じだけ1をシフトして結果に足せばよいでしょう。0を立てるのには、何もしなければよいです。

実に単純ですね。これを被序数と除数の桁差の分だけ繰り返せばよいだけです。唯一未解決なのは、今まで出てこなかった桁差の計算をどうするかという問題です。

桁差の計算

被除数、除数それぞれの桁数を求めて、その差をULngsSubで取れば計算できます。ということは、桁数を求められれば問題は解決します。

桁数とは、上の桁から順に見て行って初めて0以外（つまり1）になっている桁位置のことです。というわけで今度は指定桁位置の値が欲しいところです。

ある桁が1かどうかは、LngBitXtrValで10...0を作って、これと検査したい数値のAndをとって0かどうか比較するだけでわかりますね。

サンプル
Public Function BitOf(ByVal Value As Long, ByVal Column As Long) As Long Dim l_Bit As Long Dim l_ColPos As Long Dim l_ColVal As Long l_ColVal = LngBitXtrVal(Column) If 0& <> (Value And l_ColVal) Then l_Bit = 1& Else l_Bit = 0& End If BitOf = l_Bit End Function

サンプル

Public Function BitOf(ByVal Value As Long, ByVal Column As Long) As Long

    Dim l_Bit    As Long
    Dim l_ColPos As Long
    Dim l_ColVal As Long

    l_ColVal = LngBitXtrVal(Column)

    If 0& <> (Value And l_ColVal) Then
        l_Bit = 1&
    Else
        l_Bit = 0&
    End If

    BitOf = l_Bit

End Function

細かい点を決めておきましょう。

値を取得する桁位置は1から32の範囲とします。LngBitXtrValと同じ条件ですので、特別にエラー判定をする必要が無くなります。
0は一般的には1桁かもしれませんが、ここでは0桁と考えることにします。

先ほどのBitOfを使って、桁数を求めるプロシージャーは次のようになります。

サンプル
Public Function ULngDigLevel(ByVal Value As Long) As Long Dim l_ColIdx As Long Dim l_ColVal As Long l_ColIdx = 32& Do l_ColVal = BitOf(Value, l_ColIdx) If 0& < l_ColVal _ Then Exit Do On Error Resume Next l_ColIdx = ULngsSub(l_ColIdx, 1&) If l_ColIdx < 1& _ Then Exit Do Loop ULngDigLevel = l_ColIdx End Function

サンプル

Public Function ULngDigLevel(ByVal Value As Long) As Long

    Dim l_ColIdx As Long
    Dim l_ColVal As Long

    l_ColIdx = 32&

    Do

        l_ColVal = BitOf(Value, l_ColIdx)
        If 0& < l_ColVal _
            Then Exit Do
        On Error Resume Next
        l_ColIdx = ULngsSub(l_ColIdx, 1&)
        If l_ColIdx < 1& _
            Then Exit Do

    Loop

    ULngDigLevel = l_ColIdx

End Function

除算実現！

はい、前回と同じパターンのタイトリングですね。注意点を確認して実装してしまいましょう。

"Division by zero."のエラーメッセージでおなじみですが、0で割ることはできません。（無限を表現したいというほどの動機があれば別ですが。）はっきり言ってこれだけです。

では結果です。ひとまずおつかれさまでした。

サンプル
Public Function ULngsDiv(ByVal Value1 As Long, ByVal Value2 As Long) As Long Dim l_DigLv1 As Long Dim l_DigLv2 As Long Dim l_Div As Long Dim l_EditedVal2 As Long Dim l_Upgrade As Long If ULngsComp(Value2, 1&) < 0& _ Then Err.Raise 9001&, , "Division by zero" l_DigLv1 = ULngDigLevel(Value1) l_DigLv2 = ULngDigLevel(Value2) If ULngsComp(l_DigLv1, l_DigLv2) < 0& Then ULngsDiv = 0& Exit Function End If l_Upgrade = ULngsSub(l_DigLv1, l_DigLv2) l_Div = 0& Do If ULngsComp(0&, l_Upgrade) < 0& Then l_EditedVal2 = ShiftLeftLogically(Value2, l_Upgrade) Else l_EditedVal2 = Value2 End If On Error Resume Next Value1 = ULngsSub(Value1, l_EditedVal2) If 9001& <> Err.Number _ Then l_Div = ULngsSum(l_Div, LngBitXtrVal(ULngsSum(l_Upgrade, 1&))) On Error GoTo 0 On Error Resume Next l_Upgrade = ULngsSub(l_Upgrade, 1&) If 9001& = Err.Number _ Then Exit Do On Error GoTo 0 Loop On Error GoTo 0 ULngsDiv = l_Div End Function

サンプル

Public Function ULngsDiv(ByVal Value1 As Long, ByVal Value2 As Long) As Long

    Dim l_DigLv1     As Long
    Dim l_DigLv2     As Long
    Dim l_Div        As Long
    Dim l_EditedVal2 As Long
    Dim l_Upgrade    As Long

    If ULngsComp(Value2, 1&) < 0& _
        Then Err.Raise 9001&, , "Division by zero"

    l_DigLv1 = ULngDigLevel(Value1)
    l_DigLv2 = ULngDigLevel(Value2)
    If ULngsComp(l_DigLv1, l_DigLv2) < 0& Then
        ULngsDiv = 0&
        Exit Function
    End If
    l_Upgrade = ULngsSub(l_DigLv1, l_DigLv2)

    l_Div = 0&
    Do
        If ULngsComp(0&, l_Upgrade) < 0& Then
            l_EditedVal2 = ShiftLeftLogically(Value2, l_Upgrade)
        Else
            l_EditedVal2 = Value2
        End If
        On Error Resume Next
        Value1 = ULngsSub(Value1, l_EditedVal2)
        If 9001& <> Err.Number _
            Then l_Div = ULngsSum(l_Div, LngBitXtrVal(ULngsSum(l_Upgrade, 1&)))
        On Error GoTo 0
        On Error Resume Next
        l_Upgrade = ULngsSub(l_Upgrade, 1&)
        If 9001& = Err.Number _
            Then Exit Do
        On Error GoTo 0
    Loop
    On Error GoTo 0

    ULngsDiv = l_Div

End Function

次回は全体を振り返って、細かい修正をして32ビット符号無し整数のまとめにしましょう。それではまた。