読者です 読者をやめる 読者になる 読者になる

C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA

2D曲線の折れ線化を利用し、重複線の選択2

こちらの続きです。
2D曲線の折れ線化を利用し、重複線の選択1 - C#ATIA


昨日の4分木ライブラリを利用して、前回の重複線を選択した状態にする
マクロを改良しました。

'vba test_Select_Overlap_Curve2D ver0.0.2
'using-'KCL0.09' -'KCL_Quadtree0.0.1'
'指定ビュー内の重複線を選択

Option Explicit

'*** 設定 ***
Private Const POLY_TOL = 0.1        '折れ線化トレランス
Private Const OVER_TOL = 0.1        '重複判断トレランス
Private Const EPS = 0.0001          'イコール判断
'************

Sub CATMain()
    'ドキュメントのチェック
    If Not KCL.CanExecute("DrawingDocument") Then Exit Sub
    
    '選択
    Dim View As DrawingView: Set View = KCL.SelectItem("ビューを選択してください", "DrawingView")
    If KCL.IsNothing(View) Then Exit Sub
    
    'ドキュメント取得
    Dim Doc As DrawingDocument: Set Doc = KCL.GetParent_Of_T(View, "DrawingDocument")
    
    '線取得
    KCL.SW_Start: Debug.Print "** Obj Start 002 ** :" & vbNewLine & "POLY_TOL-" & POLY_TOL & " : OVER_TOL-" & OVER_TOL
    Dim CrvLst As Collection: Set CrvLst = GetCurveList_Obj(View)
    Debug.Print "CrvLst- " & CrvLst.Count & "個 : " & KCL.SW_GetTime & "s"
    If KCL.IsNothing(CrvLst) Then Exit Sub
    
    '範囲取得
    Dim RngLst As Collection: Set RngLst = GetRangeBoxList(CrvLst)
    Debug.Print "RngLst- " & RngLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '長さ取得
    Dim LngLst As Collection: Set LngLst = GetLength_Prm(CrvLst)
    Debug.Print "LngLst- " & LngLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '折れ線化
    Dim PolyLst As Collection: Set PolyLst = GetPolyList(CrvLst)
    Debug.Print "PolyLst- " & PolyLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '4分木
    Dim QuadLst As Collection: Set QuadLst = Kcl_Quadtree.GetLinerQuadtreeList(RngLst, OVER_TOL)
    Debug.Print "QuadLst- " & QuadLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '重複線Idx取得
    Dim OverLst As Collection: Set OverLst = GetOverlapList(QuadLst, PolyLst, LngLst)
    Debug.Print "OverLst- " & OverLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '選択
    Call SelectOverCrv(OverLst, CrvLst, Doc.Selection)
    Debug.Print "SelectOverCrv - " & Doc.Selection.Count2 & "個 : " & KCL.SW_GetTime & "s"
End Sub


'*** catia ***
'コレクション要素の選択
Private Sub SelectOverCrv(ByVal OverList As Collection, ByVal CrvList As Collection, ByVal Sel As Selection)
    Dim Idx
    CATIA.HSOSynchronized = False
    With Sel
        .Clear
        For Each Idx In OverList
            .Add CrvList(Idx)
        Next
    End With
    CATIA.HSOSynchronized = True
End Sub

'線取得
Private Function GetCurveList_Obj(ByVal Vew As DrawingView) As Collection
    Dim Lst As Collection: Set Lst = New Collection
    Dim Geos As GeometricElements: Set Geos = Vew.GeometricElements
    Dim Geo As GeometricElement
    For Each Geo In Geos
        Select Case Geo.GeometricType
            Case catGeoTypeUnknown, catGeoTypeAxis2D, catGeoTypeControlPoint2D, catGeoTypePoint2D
                '処理無し
            Case Else
                Lst.Add Geo
        End Select
    Next
    Set GetCurveList_Obj = Lst
End Function

'長さリスト取得
Private Function GetLength_Prm(ByVal Geos As Collection) As Collection
    Set GetLength_Prm = Nothing
    
    Dim Lst As Collection: Set Lst = New Collection
    Dim Geo As GeometricElement
    Dim Prm(1)
    For Each Geo In Geos
        With Geo
            Call .GetParamExtents(Prm)
            Lst.Add .GetLengthAtParam(Prm(0), Prm(1))
        End With
    Next
    Set GetLength_Prm = Lst
End Function

'領域リスト取得
Private Function GetRangeBoxList(ByVal Geos As Collection) As Collection
    Set GetRangeBoxList = Nothing
    
    Dim Lst As Collection: Set Lst = New Collection
    Dim Geo As GeometricElement
    Dim Range(3)
    For Each Geo In Geos
        Call Geo.GetRangeBox(Range)
        Lst.Add Array(Array(Range(0), Range(1)), Array(Range(2), Range(3)))
    Next
    Set GetRangeBoxList = Lst
End Function

'折れ線化リスト取得
Private Function GetPolyList(ByVal Geos As Collection) As Collection
    Set GetPolyList = Nothing
    
    Dim Lst As Collection: Set Lst = New Collection
    Dim Geo As GeometricElement
    For Each Geo In Geos
        Select Case Geo.GeometricType
            Case catGeoTypeLine2D '"Line2D"
                Lst.Add Line2Poly(Geo)
            Case catGeoTypeCircle2D '"Circle2D"
                Lst.Add Circle2Poly(Geo)
            Case Else '"Spline2D", "Curve2D"
                Lst.Add Curve2Poly(Geo)
        End Select
    Next
    Set GetPolyList = Lst
End Function

'PolyAに対しPolyBが重複しているか?
Private Function IsOverlap(PolyA As Collection, PolyB As Collection) As Boolean
    IsOverlap = False

    Dim MinLng#, TempLng#, i&, j&
    For i = 1 To PolyB.Count
        MinLng = OVER_TOL + 1#
        For j = 1 To PolyA.Count - 1
            TempLng = Dist_AB_C(PolyA(j), PolyA(j + 1), PolyB(i))
            If MinLng > TempLng Then MinLng = TempLng
        Next
        If MinLng > OVER_TOL Then
            Exit Function
        End If
    Next
    IsOverlap = True
End Function

'重複線リスト取得
Private Function GetOverlapList(ByVal QuadList As Collection, _
                                ByVal PolyList As Collection, _
                                ByVal LngList As Collection) As Collection
    Set GetOverlapList = Nothing

    Dim i&, j&, Spe As Collection
    Dim OvList As Collection: Set OvList = New Collection
    
    Dim EnumLst_T As Collection
    Dim EnumLst_U As Collection
    Dim OvAry '重複Fg 0-しない 1-参照のみ 2-重複
    OvAry = InitValueAry(PolyList.Count, 0)
    
    For Each Spe In QuadList
        '空間-空間
        Set EnumLst_T = Spe.Item(1)
        Call Q_ISort_List(EnumLst_T, LngList)
        For i = 1 To EnumLst_T.Count '重複線を判断する側(長いほうの線)
            For j = i + 1 To EnumLst_T.Count '重複線を判断される側
                If OvAry(EnumLst_T(j)) > 0 Then Exit For
                If IsOverlap(PolyList(EnumLst_T(i)), PolyList(EnumLst_T(j))) Then
                    OvList.Add EnumLst_T(j)
                    OvAry(EnumLst_T(j)) = 2
                End If
            Next
        Next
        
        '上位-空間
        Set EnumLst_U = Spe.Item(2)
        Call Q_ISort_List(EnumLst_U, LngList)
        For i = 1 To EnumLst_U.Count '重複線を判断する側
            For j = 1 To EnumLst_T.Count '重複線を判断される側
                If OvAry(EnumLst_T(j)) > 0 Then Exit For
                If LngList(EnumLst_U(i)) > LngList(EnumLst_T(j)) Then
                    If IsOverlap(PolyList(EnumLst_U(i)), PolyList(EnumLst_T(j))) Then
                        OvList.Add EnumLst_T(j)
                        OvAry(EnumLst_T(j)) = 2
                    End If
                End If
            Next
        Next
    Next
    Set GetOverlapList = OvList
End Function

'*** PolyLine ***
'線分折れ線化
Private Function Line2Poly(ByVal Geo As AnyObject) As Collection
    Set Line2Poly = Nothing
    
    Dim Prm(1) '始点終点パラメータ
    Dim Pos(3) '座標
    Dim StPos '始点座標
    Dim EnPos '終点座標
    
    'スプライン情報
    Call Geo.GetEndPoints(Pos)
    StPos = Array(Pos(0), Pos(1))
    EnPos = Array(Pos(2), Pos(3))
    
    'コピペされた座標軸対策
    'If Lng >= 2000000 Then Exit Function
    
    '折れ線化
    Dim List As Collection: Set List = New Collection
    Call List.Add(StPos)
    Call List.Add(EnPos)
    
    Set Line2Poly = List
End Function

'円弧折れ線化
Private Function Circle2Poly(ByVal Geo As AnyObject) As Collection
    Set Circle2Poly = Nothing
    
    '円弧情報
    Dim Prm(1) '始点終点パラメータ
    Dim StPos(1) '始点座標
    Dim EnPos(1) '終点座標
    Dim CnPos(1) '中心座標
    Dim R# '半径
    
    With Geo
        Call .GetParamExtents(Prm)
        Call .GetPointAtParam(Prm(0), StPos)
        Call .GetPointAtParam(Prm(1), EnPos)
        Call .GetCenter(CnPos)
        R = .Radius
    End With
    
    'トレランス内の増分パラメータ算出
    Dim IncPara# 'パラメータ増分
    Dim E_SPara# '終点-始点パラメータ
    Dim LoopCount& 'カウンタ
    If R * 0.5 < POLY_TOL Then
        '小さな円弧への対応
        IncPara = (Prm(1) - Prm(0)) * 0.5
    Else
        '通常の円弧
        IncPara = ArcCos(1 - POLY_TOL / R) * 2
        E_SPara = Prm(1) - Prm(0)
        LoopCount = Fix(E_SPara / IncPara) + 1
        IncPara = E_SPara / LoopCount
    End If
    
    '増分の三角関数
    Dim SinTheta#, CosTheta#
    SinTheta = Sin(IncPara)
    CosTheta = Cos(IncPara)
    
    '折れ線化
    Dim AD#, BD# '回転前の点と中心点の距離
    Dim List As Collection: Set List = New Collection
    Dim i&
    Call List.Add(Array(StPos(0), StPos(1)))
    For i = 2 To LoopCount
        AD = List(i - 1)(0) - CnPos(0)
        BD = List(i - 1)(1) - CnPos(1)
        Call List.Add(Array(AD * CosTheta - BD * SinTheta + CnPos(0), _
                            AD * SinTheta + BD * CosTheta + CnPos(1)))
    Next
    Call List.Add(Array(EnPos(0), EnPos(1)))
    Set Circle2Poly = List
End Function

'スプライン折れ線化
Private Function Curve2Poly(ByVal Geo As AnyObject) As Collection
    Set Curve2Poly = Nothing
    
    Const CutCount = 4 '分割数
    
    'スプライン情報
    Dim Prm(1) '始点終点パラメータ
    Dim Pos(1) '座標
    
    With Geo
        Call .GetParamExtents(Prm)
        Call .GetPointAtParam(Prm(0), Pos)
    End With
    
    'ループ準備
    Dim PntList As Collection '折れ線化リスト
    Set PntList = New Collection: Call PntList.Add(Pos)
    Dim CrvSPara#: CrvSPara = Prm(0) 'カーブ始点パラメータ
    Dim CrvEPara#: CrvEPara = Prm(1) 'カーブ終点パラメータ
    Dim LoopSPara#: LoopSPara = CrvSPara 'ループ始点パラメータ
    Dim LoopEPara#: LoopEPara = CrvEPara 'ループ終点パラメータ
    
    '非再帰折れ線近似化
    Dim SumPara# '増分パラメータ
    Dim LoopSPos(1) 'ループ始点
    Dim LoopEPos(1) 'ループ終点
    Dim Unit_Vec 'ループ始点からループ終点の単位ベクトル
    Dim i&
    Dim CutPara#(CutCount) '分割パラメータ
    Dim CutPos(CutCount) '分割座標
    Dim CutMax: CutMax = Array(-1#, -1&) '分割点の最大距離とID
    Dim TempLng#  '一時距離
    Do
        'ループ初期設定
        SumPara = (LoopEPara - LoopSPara) / (CutCount + 2)
        Call Geo.GetPointAtParam(LoopSPara, LoopSPos)
        Call Geo.GetPointAtParam(LoopEPara, LoopEPos)
        Unit_Vec = Normaliz2d(LoopSPos, LoopEPos)
        
        
        '閉じた曲線-強制的に1点を登録
        If IsEmpty(Unit_Vec) Then
            CutPara(0) = Geo.GetParamAtLength(LoopSPara, POLY_TOL)
            Call Geo.GetPointAtParam(CutPara(0), Pos)
            Call PntList.Add(Pos)
            LoopSPara = CutPara(0)
            LoopEPara = CrvEPara
            GoTo Continue_Close
        End If
        
        '分割点作成 距離チェック
        For i = 0 To CutCount
            CutPara(i) = LoopSPara + SumPara * (i + 1)
            Call Geo.GetPointAtParam(CutPara(i), Pos)
            CutPos(i) = Pos
            TempLng = Lng_V_P(Unit_Vec, Sub2d(CutPos(i), LoopSPos))
            If CutMax(0) < TempLng Then '最大分割点更新
                CutMax(1) = i: CutMax(0) = TempLng
            End If
        Next
        
        '最大距離から節確定 LoopEParaが終点ならループ終了
        If CutMax(0) < POLY_TOL Then
            If LoopEPara >= CrvEPara Then
                Call Geo.GetPointAtParam(CrvEPara, Pos)
                Call PntList.Add(Pos)
                Exit Do 'ループ抜ける
            Else
                Call PntList.Add(LoopEPos)
                LoopSPara = LoopEPara
                LoopEPara = CrvEPara
            End If
        Else
            LoopEPara = CutPara(CutMax(1)) '再度処理
        End If
Continue_Close:
        CutMax(0) = -1# '距離初期化
        
        If EQ(LoopSPara, LoopEPara) Then
            '始点と終点がほぼ同一 未対応
            Stop
        End If
    Loop
    Set Curve2Poly = PntList
End Function


'*** Math ***
'ArcCos
Private Function ArcCos(ByVal V As Double) As Double
    ArcCos = Atn(-V / Sqr(-V * V + 1)) + 2 * Atn(1)
End Function

'2点距離の平方数
Private Function LengSqr(ByVal P1 As Variant, ByVal P2 As Variant) As Double
    Dim A#: A = P2(0) - P1(0)
    Dim B#: B = P2(1) - P1(1)
    LengSqr = A * A + B * B
End Function

'イコール
Private Function EQ(ByVal A As Double, ByVal B As Double) As Boolean
    EQ = IIf(Abs((A) - (B)) < EPS, True, False)
End Function


'*** Vecter ***
'参考サイト:http://www.deqnotes.net/acmicpc/2d_geometry/lines#intersection_of_lines
'参考サイト:http://marupeke296.com/COL_main.html
'点A,Bを端点とする線分と点Cとの距離
Private Function Dist_AB_C(ByVal A As Variant, ByVal B As Variant, ByVal C As Variant) As Double
    If Dot2d(Sub2d(B, A), Sub2d(C, A)) < EPS Then
        Dist_AB_C = Abs(Sqr(LengSqr(C, A)))
        Exit Function
    End If
    If Dot2d(Sub2d(A, B), Sub2d(C, B)) < EPS Then
        Dist_AB_C = Abs(Sqr(LengSqr(C, B)))
        Exit Function
    End If
    Dist_AB_C = Lng_AB_C(A, B, C)
End Function

'ベクトルABと点Cの距離
Private Function Lng_AB_C(ByVal A As Variant, ByVal B As Variant, ByVal C As Variant) As Double
    Lng_AB_C = Abs(Cross2d(Sub2d(B, A), Sub2d(C, A))) / Abs(Sqr(LengSqr(B, A)))
End Function

'単位ベクトルVと点Pの距離
Private Function Lng_V_P(ByVal V As Variant, ByVal P As Variant) As Double
    Lng_V_P = Abs(Cross2d(V, P))
End Function

'単位ベクトル
Private Function Normaliz2d(ByVal V1 As Variant, ByVal V2 As Variant) As Variant
    Dim vec: vec = Sub2d(V2, V1)
    Dim tmp: tmp = Sqr(Dot2d(vec, vec))
    If EQ(tmp, 0#) Then
        Normaliz2d = Empty
        Exit Function
    End If
    Normaliz2d = Array(vec(0) / tmp, vec(1) / tmp)
End Function

'差2D
Private Function Sub2d(ByVal V1 As Variant, ByVal V2 As Variant) As Variant
    Sub2d = Array(V1(0) - V2(0), V1(1) - V2(1))
End Function

'内積2D
Private Function Dot2d(ByVal V1 As Variant, ByVal V2 As Variant) As Double
    Dot2d = V1(0) * V2(0) + V1(1) * V2(1)
End Function

'外積2D
Private Function Cross2d(ByVal V1 As Variant, ByVal V2 As Variant) As Double
    Cross2d = V1(0) * V2(1) - V1(1) * V2(0)
End Function


'*** etc ***
'初期化済みコレクション生成
Private Function InitRangeList(ByVal Count&) As Collection
    Dim List As Collection: Set List = New Collection
    Dim i&
    For i = 1 To Count
        List.Add i
    Next
    Set InitRangeList = List
End Function

'初期化済み配列生成
Private Function InitValueAry(ByVal Count&, ByVal Value&) As Variant
    Dim Ary(): ReDim Ary(Count + 1)
    Dim i&
    For i = 1 To Count
        Ary(i) = Value
    Next
    InitValueAry = Ary
End Function

'長さ順の列挙用Idxを取得するQIソート
Private Sub Q_ISort_List(ByRef IdxList As Collection, ByVal LngList As Collection)
    Dim THREASHOLD&: THREASHOLD = 16 '64
    Dim Stack As Collection: Set Stack = New Collection
    Stack.Add 1, CStr(Stack.Count + 1)
    Stack.Add IdxList.Count, CStr(Stack.Count + 1)
    
    Dim Pivot, Temp1, Temp2
    Dim LeftIdx&, RightIdx&, i&, j&
    Do While Stack.Count > 0
        LeftIdx = Stack(CStr(Stack.Count - 1))
        RightIdx = Stack(CStr(Stack.Count))
        Stack.Remove Stack.Count
        Stack.Remove Stack.Count
        'クイックソート
        If LeftIdx < RightIdx Then
            Pivot = LngList(IdxList((LeftIdx + RightIdx) / 2))
            i = LeftIdx
            j = RightIdx
            
            Do While i <= j
                Do While LngList(IdxList(i)) > Pivot
                    i = i + 1
                Loop
                Do While LngList(IdxList(j)) < Pivot
                    j = j - 1
                Loop
                If i <= j Then
                    Temp1 = IdxList(i)
                    Temp2 = IdxList(j)
                    IdxList.Add Temp1, After:=j
                    IdxList.Remove j
                    IdxList.Add Temp2, After:=i
                    IdxList.Remove i
                    i = i + 1
                    j = j - 1
                End If
            Loop
            
            If RightIdx - i >= 0 Then
                If RightIdx - i <= THREASHOLD Then
                    ComboInsertionSort IdxList, i, RightIdx, LngList
                Else
                    Stack.Add i, CStr(Stack.Count + 1)
                    Stack.Add RightIdx, CStr(Stack.Count + 1)
                End If
            End If
            
            If j - LeftIdx >= 0 Then
                If j - LeftIdx <= THREASHOLD Then
                    ComboInsertionSort IdxList, LeftIdx, j, LngList
                Else
                    Stack.Add LeftIdx, CStr(Stack.Count + 1)
                    Stack.Add j, CStr(Stack.Count + 1)
                End If
            End If
        End If
    Loop
End Sub

'長さ順の列挙用Idxを取得するQIソート用
Private Sub ComboInsertionSort(ByRef IdxList, ByVal MinIdx&, ByVal MaxIdx&, ByVal LngList As Collection)
    Dim Temp1, Temp2
    Dim i&, j&: j = 1
    For j = MinIdx To MaxIdx
        i = j - 1
        Do While i >= 1
        
            If LngList(IdxList(i + 1)) > LngList(IdxList(i)) Then
                Temp1 = IdxList(i + 1)
                Temp2 = IdxList(i)
                IdxList.Add Temp2, After:=i + 1
                IdxList.Remove i + 1
                IdxList.Add Temp1, After:=i
                IdxList.Remove i
            Else
                Exit Do
            End If
            i = i - 1
        Loop
    Next
End Sub

重複線をチェックしている "GetOverlapList" のクズっぷりが半端じゃないの
ですが・・・。(一時的に配列に入れて、長さの短いものだけを抜き出すとか
すれば良いかも)

前回のものと比較する為、各2回実行してみました。

Ver0.0.1

** Obj Start 001 ** :
POLY_TOL-0.1 : OVER_TOL-0.1
CrvLst- 3955個 : 2.021s
RngLst- 3955個 : 2.6s
LngLst- 3955個 : 4.21s
PolyLst- 3955個 : 15.424s
EnumLst- 3955個 : 17.562s
OverLst- 21779個 : 746.115s
SelectOverCrv - 2876個 : 748.404s

** Obj Start 001 ** :
POLY_TOL-0.1 : OVER_TOL-0.1
CrvLst- 3955個 : 3.537s
RngLst- 3955個 : 4.155s
LngLst- 3955個 : 5.442s
PolyLst- 3955個 : 18.873s
EnumLst- 3955個 : 21.02s
OverLst- 21779個 : 752.552s
SelectOverCrv - 2876個 : 755.09s

---------------------
Ver0.0.2
(分割最大レベル Lv5)

** Obj Start 002 ** :
POLY_TOL-0.1 : OVER_TOL-0.1
CrvLst- 3955個 : 2.533s
RngLst- 3955個 : 3.148s
LngLst- 3955個 : 4.44s
PolyLst- 3955個 : 16.873s
QuadLst- 290個 : 40.142s
OverLst- 2487個 : 75.37s
SelectOverCrv - 2487個 : 76.099s

** Obj Start 002 ** :
POLY_TOL-0.1 : OVER_TOL-0.1
CrvLst- 3955個 : 3.575s
RngLst- 3955個 : 4.204s
LngLst- 3955個 : 5.51s
PolyLst- 3955個 : 19.187s
QuadLst- 290個 : 43.989s
OverLst- 2487個 : 79.469s
SelectOverCrv - 2487個 : 80.05s

処理速度は1割ぐらいまで短縮できたのですが、
SelectOverCrvの行の個数が重複線と判断したものです。
総当りに比べて、400個ぐらい見落としている・・・。
何処が悪いんだろう?

又、QuadLstの行の290個は、分割した空間内に要素が存在していた
空間数なのですが、最大レベル5の場合の空間数は1365個です。
(殆どが利用されていない)
良く考えなかったので(と言うかわかっていなかった為)オリジナルの
ように大量の配列を用意していたのですが、空間番号をキーとした
ハッシュテーブルを利用すれば、無駄に大きな配列を用意する必要が無い事に、
今朝の通勤中に気が付きました。 ん~直すかな・・・。