こちらの続きです。
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個です。
(殆どが利用されていない)
良く考えなかったので(と言うかわかっていなかった為)オリジナルの
ように大量の配列を用意していたのですが、空間番号をキーとした
ハッシュテーブルを利用すれば、無駄に大きな配列を用意する必要が無い事に、
今朝の通勤中に気が付きました。 ん~直すかな・・・。