C#ATIA

↑ﾀｲﾄﾙ詐欺　主にFusion360API　偶にCATIA V5 VBA(絶賛ネタ切れ中)

流用して、4分木る 3

VBA KCL

こちらの続きです。
流用して、4分木る 2 - C#ATIA

やっと、2度と見たくない程の汚いｺｰﾄﾞになってしまいましたが
組み合わせの効率化を促す、線形4分木が出来ました。

"KCL_Quadtree.bas" と言う名称の標準ﾓｼﾞｭｰﾙとします。
'KCL' と、先日のDotNET Framework ArrayList ﾗｯﾊﾟｰｸﾗｽ 'cList'
が必要です。
ArrayListﾗｯﾊﾟｰｸﾗｽをお借りしてみる2 - C#ATIA

'vba KCL_Quadtree Ver0.0.1
'KCL_Quadtree.bas - 標準ﾓｼﾞｭｰﾙ
'using-'KCL0.09' -'cList0.0.1'
'ﾓｰﾄﾝ順序を利用した4分木空間分割

Option Explicit

Private Const MAXLEVEL = 5&                     '有効空間分割最大ﾚﾍﾞﾙ
Private Const MAXCOUNT = 200&                   '同一空間内最大数(目安)
Private Const DUB_MAX = 1.79769313486231E+308   'Double Max
Private Const DUB_MIN = -1.79769313486231E+308  'Double Min
Private Const LNG_MAX = 2147483647              'Long Max
Private Const DBFG = False                      'ﾃﾞﾊﾞｯｸﾞ True/False
    
Private m_Level&                                '分割ﾚﾍﾞﾙ
Private m_Tolerance#                            'ﾄﾚﾗﾝｽ
Private m_AxisCount&                            '空間分割時の各軸の最大数
Private m_MinPos                                '空間最小座標
Private m_Unit                                  '空間単位ｻｲｽﾞ
Private m_CellCount&()                          'ﾚﾍﾞﾙ毎の空間数
Private m_CellAllCount&()                       '指定ﾚﾍﾞﾙまでの合計空間数
Private m_Tolerance_Offset                      'ﾄﾚﾗﾝｽｵﾌｾｯﾄ 左上右下用

'線形4分木ﾘｽﾄ取得
''' @param :Rngboxs-Collection(array(array(Double),array(Double))-座標値郡
''' @param :Tolerance-Double-一致ﾄﾚﾗﾝｽ
''' @return:Collection((Collection(long)-その空間Idx
'''                    (Collection(long))-上位空間Idx
Function GetLinerQuadtreeList(ByVal Rngboxs As Collection, ByVal Tolerance#) As Collection
    Set GetLinerQuadtreeList = Nothing
    
    'cList化
    Dim Vols As cList: Set Vols = InitList()
    Set Vols = Rngbox2Volume(Rngboxs)

    '座標値郡のIdxList作成
    Dim IdxList As cList: Set IdxList = InitRangeList(Vols.Count)
    
    '空間内最大数以下の場合、そのまま返す
    Dim DecidedList As cList: Set DecidedList = InitList()
    If Vols.Count < MAXCOUNT Then
        Call DecidedList.Add(InitSpace(IdxList.ToArray()))
        GoTo FuncEnd
    End If
    
    '初期設定
    If Not SetStart(Tolerance, MAXCOUNT) Then
        MsgBox "設定値が不正です"
        Exit Function
    End If
    
    '空間情報
    If Not SetSpaceInfo(Vols, IdxList) Then '空間が小さすぎる
        Call DecidedList.Add(InitSpace(IdxList.ToArray()))
        GoTo FuncEnd
    End If
    
    '空間ﾎﾟｲﾝﾀ配列
    Dim SpaceAryCount&: SpaceAryCount = m_CellAllCount(m_Level) - 1
    Dim SpeceAry: SpeceAry = InitRangeAry(SpaceAryCount, -1&)
    
    '空間に配置
    Dim Space, i&, Idx, Morton&
    Dim SpaceEnum As cList, UprIdxList As cList
    For Each Idx In IdxList
        Morton = GetLinerNumber(Vols.Item(Idx))
        If SpeceAry(Morton) < 0 Then
            Call DecidedList.Add(InitSpace())
            SpeceAry(Morton) = DecidedList.Count - 1
        End If
        Call DecidedList.Item(SpeceAry(Morton)).Item(0).Add(Idx)
    Next
    
    '有効空間Idx取得
    Set SpaceEnum = GetValidSpaceEnum(SpeceAry)
    Call SpaceEnum.Sort
    
    '上位空間Idx取得-上位空間から行う
    For Each Idx In SpaceEnum
        Set UprIdxList = GetUprSpaceIdxList(Idx, SpeceAry)
        Call UprIdxList.Sort
        Set DecidedList.Item(SpeceAry(Idx)).Item(1) = _
                        GetUprAllList(UprIdxList, DecidedList)
    Next
    If DBFG Then Call DumpSpaceAllIdx(DecidedList)
    
    '上位空間順に再配置
    Dim SortList As cList: Set SortList = InitList()
    For Each Idx In SpaceEnum
        SortList.Add DecidedList.Item(SpeceAry(Idx))
    Next
    Call SortList.TrinToSize
    Set DecidedList = SortList
    If DBFG Then Call DumpSpaceAllIdx(DecidedList)
    
FuncEnd:
    Set GetLinerQuadtreeList = SpaceList2IdxCol(DecidedList)
End Function

'*** Quadtree ***
'有効な上位空間Idx取得
''' @param :LinerNum-long-線形4分木Idx
''' @param :SpaAry-Array-空間ﾎﾟｲﾝﾀ
''' @return:cList(long)-線形4分木Idx
Private Function GetUprSpaceIdxList(ByVal LinerNum As Long, _
                                    ByVal SpeAry As Variant) As cList
    Dim Lst As cList: Set Lst = InitList()
    Set GetUprSpaceIdxList = Lst
    
    '全上位空間Idx
    Dim N: N = LinerNum
    Do Until N < 1
        N = Fix((N - 1) * 0.25)
        Lst.Add CLng(N)
    Loop
    If Lst.Count < 1 Then Exit Function
    
    '有効空間Idx
    Dim Upr As cList: Set Upr = InitList()
    Dim Idx
    For Each Idx In Lst
        If SpeAry(Idx) >= 0 Then
            Upr.Add SpeAry(Idx)
        End If
    Next
    
    Set GetUprSpaceIdxList = Upr
End Function

'有効空間取得
''' @param :SpaAry-Array-空間ﾎﾟｲﾝﾀ
''' @return:cList(long)
Private Function GetValidSpaceEnum(ByVal SpaAry As Variant) As cList
    Dim List As cList: Set List = InitList()
    Dim i&
    For i = 0 To UBound(SpaAry)
        If SpaAry(i) >= 0 Then List.Add i
    Next
    Set GetValidSpaceEnum = List
End Function

'有効空間全VolIdx取得
''' @param :IdxList-cList
''' @param :SpaList-cList
''' @return:cList(long)
Private Function GetUprAllList(ByVal IdxList As cList, ByVal SpaList As cList) As cList
    Dim UprLst As cList: Set UprLst = InitList()
    Set GetUprAllList = UprLst
    If IdxList.Count < 1 Then Exit Function
    
    Dim List As cList: Set List = InitList()
    Dim Idx, Upr
    For Each Idx In IdxList
        Set List = FlattenSpace(SpaList.Item(Idx))
        If KCL.IsNothing(List) Then GoTo Continue
        For Each Upr In List
            If Not UprLst.Contains(Upr) Then
                UprLst.Add Upr
            End If
        Next
Continue:
    Next
    
    Set GetUprAllList = UprLst
End Function

'空間作成
''' @param :This-Variant
''' @param :Upr-Variant
''' @return:cList(cList,cList)
Private Function InitSpace(Optional ByVal This, Optional ByVal Upr) As cList
    Set InitSpace = InitList()
    InitSpace.Add InitList(This)
    InitSpace.Add InitList(Upr)
End Function

'空間平坦化
''' @param :Space-cList(cList,cList)
''' @return:cList
Private Function FlattenSpace(ByVal Space As cList) As cList
    Set FlattenSpace = Nothing
    If Space.Count < 1 Then Exit Function
    Set FlattenSpace = List_join(Space.ItemObj(0), _
                       List_diff(Space.ItemObj(0), Space.ItemObj(1)))
End Function

'線形4分木準備
''' @param :Tolerance-Double-一致ﾄﾚﾗﾝｽ
''' @param :MaxCount-long-同一空間内最大数(目安)
''' @return:Boolean
Private Function SetStart(ByVal Tolerance#, ByVal MAXCOUNT&) As Boolean
    SetStart = False
    If Tolerance <= 0 Then Exit Function
    
    m_Tolerance = Tolerance
    
    ReDim m_CellCount(MAXLEVEL): m_CellCount(0) = 1
    ReDim m_CellAllCount(MAXLEVEL): m_CellAllCount(0) = 1
    Dim i&
    For i = 1 To UBound(m_CellCount)
        m_CellCount(i) = m_CellCount(i - 1) * 4
        m_CellAllCount(i) = m_CellAllCount(i - 1) + m_CellCount(i)
    Next
    
    m_Tolerance_Offset = Array(Tolerance * -1#, Tolerance)
    SetStart = True
End Function

'空間情報設定
''' @param :Pnts-cList(cList(array(Double),array(Double))-座標値郡
''' @param :Idxs-cList(long)-座標値郡Idx
''' @return:Boolean
Private Function SetSpaceInfo(ByVal Vols As cList, ByVal Idxs As cList) As Boolean
    SetSpaceInfo = False
    Dim SpSize: SpSize = GetSpaceSize_Idx(Vols, Idxs)
    m_MinPos = AryAdd(SpSize(0), m_Tolerance * -2)
    Dim W: W = ArySubAry(AryAdd(SpSize(1), m_Tolerance * 2), m_MinPos)
    If Not SetLevel(W) Then Exit Function
    m_Unit = AryDiv(W, m_AxisCount)
    
    SetSpaceInfo = True
End Function

'座標値郡から空間ｻｲｽﾞ取得
''' @param :EndPnts-cList(CcList(array(Double),array(Double))-座標値郡
''' @return:array(array(Double))-0:最小値 1:最大値
Private Function GetSpaceSize_Idx(ByVal EndPnts As cList, ByVal IdxList As cList) As Variant
    Dim Min: Min = InitRangeAry(1, DUB_MAX)
    Dim Max: Max = InitRangeAry(1, DUB_MIN)
    
    Dim Idx, i&, Pnt 'j&
    For Each Idx In IdxList
        For Each Pnt In EndPnts.Item(Idx) 'Obj
            For i = 0 To 1
                If Min(i) > Pnt(i) Then Min(i) = Pnt(i)
                If Max(i) < Pnt(i) Then Max(i) = Pnt(i)
            Next
        Next
    Next
    GetSpaceSize_Idx = Array(Min, Max)
End Function

'空間ｻｲｽﾞとﾄﾚﾗﾝｽからﾚﾍﾞﾙ算出し設定
''' @param :W-array(Double,Double)
''' @return:Boolean
Private Function SetLevel(ByVal W) As Boolean
    SetLevel = False
    Dim Min#: Min = DUB_MAX
    Dim i&
    For i = 0 To 1
         If Min > W(i) Then Min = W(i)
    Next
    Dim TmpLv&: TmpLv = Fix(Log_n((Min / m_Tolerance * 2), 2))
    If TmpLv > MAXLEVEL Then
        m_Level = MAXLEVEL
    Else
        m_Level = TmpLv
    End If
    
    If m_Level < 1 Then Exit Function
    m_AxisCount = sl(1, m_Level)
    SetLevel = True
End Function

'線形4分木RangeBoxに変換 左上と右下
''' @param :Vol-cList(array(Double),array(Double))-ﾎﾞﾘｭｰﾑ座標値
''' @return:cList(array(Double),array(Double))
Private Function GetMortonRngBox(ByVal Vol As cList) As cList
    If Vol(0)(0) > Vol(1)(0) Then Call SwapNum(Vol(0)(0), Vol(1)(0))
    If Vol(0)(1) < Vol(1)(1) Then Call SwapNum(Vol(0)(1), Vol(1)(1))
    
    Dim Mrb As cList: Set Mrb = InitList()
    Mrb.Add Vol(0)
    Mrb.Add Vol(1)
    Set GetMortonRngBox = Mrb
End Function

'ﾎﾞﾘｭｰﾑから線形4分木ｲﾝﾃﾞｯｸｽNoを取得
''' @param :Vol-cList(array(Double),array(Double))-ﾎﾞﾘｭｰﾑ座標値
''' @return:Long
Private Function GetLinerNumber(ByVal Vol As cList) As Long
    '点のﾓｰﾄﾝNoを算出
    Dim SwVol: Set SwVol = GetMortonRngBox(Vol)
    Dim Lt&: Lt = GetPointElem(AryAddAry(SwVol(0), m_Tolerance_Offset))
    Dim Rb&: Rb = GetPointElem(AryAddAry(SwVol(1), AryMul(m_Tolerance_Offset, -1)))
    
    'Xorで所属レベル取得
    Dim Def&: Def = Rb Xor Lt
    Dim HiLevel&
    If Def = 0 Then
        HiLevel = 0 '最小ﾚﾍﾞﾙで同一空間番号
    Else
        HiLevel = 1
        Dim i&, Check&
        For i = 0 To m_Level
            Check = (sr(Def, (i * 2))) And &H3
            If Not Check = 0 Then HiLevel = i + 1
        Next
    End If
    
    'ﾎﾞﾘｭｰﾑの空間番号とﾚﾍﾞﾙから線形4分木ｲﾝﾃﾞｯｸｽNoを算出
    Dim SpaceNum&: SpaceNum = sr(Rb, (HiLevel * 2))
    Dim AddNum&: AddNum = (m_CellCount(m_Level - HiLevel) - 1) / 3
    SpaceNum = SpaceNum + AddNum
    
    '不正ﾃﾞｰﾀﾁｪｯｸ
    If SpaceNum > m_CellAllCount(m_Level) - 1 Then
        GetLinerNumber = LNG_MAX
    End If
    GetLinerNumber = SpaceNum
End Function

'ﾋﾞｯﾄ分割関数2D
''' @param :n-long
''' @return:long
Private Function BitSeparateFor2D(ByVal N&) As Long
    Dim S&: S = N
    S = (S Or sl(S, 8)) And &HFF00FF
    S = (S Or sl(S, 4)) And &HF0F0F0F
    S = (S Or sl(S, 2)) And &H33333333
    BitSeparateFor2D = (S Or sl(S, 1)) And &H55555555
End Function

'4分木ﾓｰﾄﾝ順序算出関数
''' @param :x-long
''' @param :y-long
''' @return:long
Private Function Get2DMortonNumber(ByVal x&, ByVal y&) As Long
   Get2DMortonNumber = BitSeparateFor2D(x) Or _
                       sl(BitSeparateFor2D(y), 1)
End Function

'線形4分木ｲﾝﾃﾞｯｸｽ取得関数
''' @param :Pos-array(Double)
''' @return:long
Private Function GetPointElem(ByVal Pos As Variant) As Long
   GetPointElem = Get2DMortonNumber(Fix((Pos(0) - m_MinPos(0)) / m_Unit(0)), _
                                    Fix((Pos(1) - m_MinPos(1)) / m_Unit(1)))
End Function

'*** Math ***
'配列と配列の足し算
Private Function AryAddAry(ByVal A, ByVal B) As Variant
    AryAddAry = Array(A(0) + B(0), A(1) + B(1))
End Function

'配列同士の引き算
Private Function ArySubAry(ByVal A, ByVal B) As Variant
    ArySubAry = Array(A(0) - B(0), A(1) - B(1))
End Function

'配列と実数の足し算
Private Function AryAdd(ByVal A, ByVal B#) As Variant
    AryAdd = Array(A(0) + B, A(1) + B)
End Function

'配列と実数の掛け算
Private Function AryMul(ByVal A, ByVal B#) As Variant
    AryMul = Array(A(0) * B, A(1) * B)
End Function

'配列と実数の割り算
Private Function AryDiv(ByVal A, ByVal B#) As Variant
    AryDiv = Array(A(0) / B, A(1) / B)
End Function

'nを底とする対数
Private Function Log_n(x, N)
    Log_n = Log(x) / Log(N)
End Function

' 左シフト
Private Function sl(ByVal x&, ByVal N&) As Long
    If N = 0 Then
        sl = x
    Else
        Dim k: k = CLng(2 ^ (32 - N - 1))
        Dim D: D = x And (k - 1)
        Dim C: C = D * CLng(2 ^ N)
        If x And k Then C = C Or &H80000000
        sl = C
    End If
End Function

' 右シフト(算術(>>)ではなく論理(>>>)シフトに相当)
Private Function sr(ByVal x&, ByVal N&) As Long
    If N = 0 Then
        sr = x
    Else
        Dim y: y = x And &H7FFFFFFF
        Dim z
        If N = 32 - 1 Then
            z = 0
        Else
            z = y \ CLng(2 ^ N) 'ひょっとしたらCLng要らないかも
        End If
        If y <> x Then z = z Or CLng(2 ^ (32 - N - 1))
        sr = z
    End If
End Function


'*** List/Array/Collection ***
'ﾘｽﾄの作成
Private Function InitList(Optional ByVal Data) As cList
    Dim List As cList: Set List = New cList
    Set InitList = List
    If IsMissing(Data) Then Exit Function
    
    Select Case True
        Case IsArray(Data)
            Dim i&
            For i = 0 To UBound(Data)
                List.Add Data(i)
            Next
        Case TypeName(Data) = "Collection"
            Dim V
            For Each V In Data
                List.Add V
            Next
        Case Else
            List.Add V
    End Select
End Function

'初期化済みﾘｽﾄ生成
Private Function InitRangeList(ByVal Count&) As cList
    Dim List As cList: Set List = InitList()
    Dim i&
    For i = 0 To Count - 1
        List.Add i
    Next
    Set InitRangeList = List
End Function

'Lst1に対しLst2の重複を削除したcListを返す
Private Function List_diff(ByVal Lst1 As cList, ByVal Lst2 As cList) As cList
    Set List_diff = Nothing
    If Lst2.Count < 1 Then Exit Function
    If Lst1.Count < 1 Then
        Set List_diff = Lst2
        Exit Function
    End If
    
    Dim Lst As cList: Set Lst = InitList()
    Dim V
    For Each V In Lst2
        If Not Lst.Contains(V) Then Lst.Add V
    Next
    Set List_diff = Lst
End Function

'cList連結
Private Function List_join(ByVal Lst1 As cList, ByVal Lst2 As cList) As cList
    Set List_join = Nothing
    If KCL.IsNothing(Lst1) And KCL.IsNothing(Lst2) Then Exit Function
    If KCL.IsNothing(Lst1) Then Set List_join = Lst2: Exit Function
    If KCL.IsNothing(Lst2) Then Set List_join = Lst1: Exit Function
        
    Dim Diff As cList: Set Diff = List_diff(Lst1, Lst2)
    Dim Lst As cList: Set Lst = List_DeepCopy(Lst1)
    Dim V
    For Each V In Diff
        Lst.Add V
    Next
    Set List_join = Lst
End Function

'cListｸﾛｰﾝ
Private Function List_DeepCopy(ByVal Lst As cList) As cList
    Set List_DeepCopy = Nothing
    If KCL.IsNothing(Lst) Then Exit Function
        
    Dim DC As cList: Set DC = InitList()
    DC.capacity = Lst.Count + 1
    Dim V
    For Each V In Lst
        DC.Add V
    Next
    Set List_DeepCopy = DC
End Function

'初期化済み配列生成 - ｵﾌﾞｼﾞｪｸﾄNG
Private Function InitRangeAry(ByVal Count&, ByVal Value As Variant)
    Dim Ary() As Variant: ReDim Ary(Count)
    Dim i&
        For i = 0 To Count
            Ary(i) = Value
        Next
    InitRangeAry = Ary
End Function

'ｺﾚｸｼｮﾝの作成
'OffsetはcListとｺﾚｸｼｮﾝのｲﾝﾃﾞｯｸｽ違いを吸収する苦肉の策
Private Function InitCol(Optional ByVal Data, Optional ByVal Offset) As Collection
    Dim Col As Collection: Set Col = New Collection
    Set InitCol = Col
    If IsMissing(Data) Then Exit Function
    
    Select Case True
        Case IsArray(Data)
            Dim i&
            For i = 0 To UBound(Data)
                Col.Add Data(i)
            Next
        Case TypeName(Data) = "cList"
            Dim V
            If IsMissing(Offset) Then
                For Each V In Data
                    Col.Add V
                Next
            Else
                For Each V In Data
                    Col.Add V + Offset
                Next
            End If
        Case Else
            Col.Add V
    End Select
End Function


'*** etc ***
'Swap 値型
Private Sub SwapNum(ByRef A, ByRef B)
    Dim tmp: tmp = A: A = B: B = tmp
End Sub

'座標郡の型変換
''' @param :Col-Collection(Collection(array(Double),array(Double))
''' @return:cList(cList(array(Double),array(Double))
Private Function Rngbox2Volume(ByVal Rngboxs As Collection) As cList
    Dim Lst As cList: Set Lst = InitList()
    Dim Rb
    For Each Rb In Rngboxs
        Lst.Add InitList(Rb)
    Next
    Set Rngbox2Volume = Lst
End Function

'Idx郡の型変換
''' @param :Col-Collection(Collection(array(Double),array(Double))
''' @return:cList(cList(array(Double),array(Double))
Private Function SpaceList2IdxCol(ByVal SpaceList As cList) As Collection
    Dim Col As Collection: Set Col = New Collection
    Dim Spa As cList, UprLow As Collection, Lv
    For Each Spa In SpaceList
        Set UprLow = InitCol()
        UprLow.Add InitCol(Spa.Item(0), 1)
        UprLow.Add InitCol(Spa.Item(1), 1)
        Col.Add UprLow
    Next
    Set SpaceList2IdxCol = Col
End Function

'*** debug ***
'確認用
Private Sub DumpQuadIdx(ByVal PosList)
    Dim Pos
    Debug.Print " **** "
    For Each Pos In PosList
        Debug.Print "Pos:" & Pos(0) & "," & Pos(1), _
                    "MotonNo:" & GetPointElem(Pos)
    Next
End Sub

Private Sub DumpSpaceAllIdx(ByVal Spaces) ' As cList)
    Dim S, U, T, i&, Fs
    Debug.Print " **** "
    
    For Each S In Spaces
        If TypeName(S) = "cList" Then
            Fs = 0
        Else
            Fs = 1
        End If
    
        If S.Item(Fs).Count < 1 Then
            T = "無し"
        Else
            If TypeName(S) = "cList" Then
                T = Join(S.Item(Fs).ToArray(), ",")
            Else
                Set T = InitList(S.Item(Fs))
                T = Join(T.ToArray(), ",")
            End If
        End If
        
        If S.Item(Fs + 1).Count < 1 Then
            U = "無し"
        Else
            If TypeName(S) = "cList" Then
                U = Join(S.Item(Fs + 1).ToArray(), ",")
            Else
                Set U = InitList(S.Item(Fs + 1))
                U = Join(U.ToArray(), ",")
            End If
        End If
        
        Debug.Print "This: " & T
        Debug.Print "Upr : " & U
        Debug.Print
    Next
End Sub
'***********************
'ver0.0.1 - 完成

あまりに複雑すぎて、空間の再分割は諦めました。

GetLinerQuadtreeList関数に
第一引数 - 曲線のﾚﾝｼﾞﾎﾞｯｸｽ郡
第二引数 - ﾄﾚﾗﾝｽ
で投げると、ﾚﾝｼﾞﾎﾞｯｸｽと同一のｲﾝﾃﾞｯｸｽが、空間分割されたｺﾚｸｼｮﾝとして
戻ってきます。
戻り値は、 Collection(単位空間(空間内ｲﾝﾃﾞｯｸｽ郡,上位空間ｲﾝﾃﾞｯｸｽ郡))
の状態です。(他人にはわかり難い･･･自分でも忘れそう)

これにより、ｵﾘｼﾞﾅﾙで行っている衝突ﾘｽﾄの作成を避け、全空間を処理する
為の複雑なﾙｰﾌﾟ?処理を行わずに、単純に戻り値のｺﾚｸｼｮﾝを走査するだけで
終了できるようにしました。

重複線を処理する際の組み合わせは、
・空間内ｲﾝﾃﾞｯｸｽ同士の組み合わせで重複ﾁｪｯｸ
・空間内ｲﾝﾃﾞｯｸｽと上位空間ｲﾝﾃﾞｯｸｽの組み合わせで重複ﾁｪｯｸ
の2段階となりますが、恐らく大幅に組み合わせ数を減らす事が可能では
ないかな?　と思っています。

これを利用したﾏｸﾛは次回に。
出来れば、これを再度修正したりしたくないです･･･。