こちらの続きです。
2D曲線の折れ線化を利用し、重複線の選択1 - C#ATIA
昨日の4分木ﾗｲﾌﾞﾗﾘを利用して、前回の重複線を選択した状態にする
ﾏｸﾛを改良しました。
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"
Dim QuadLst As Collection: Set QuadLst = Kcl_Quadtree.GetLinerQuadtreeList(RngLst, OVER_TOL)
Debug.Print "QuadLst- " & QuadLst.Count & "個 : " & KCL.SW_GetTime & "s"
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
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
Lst.Add Line2Poly(Geo)
Case catGeoTypeCircle2D
Lst.Add Circle2Poly(Geo)
Case Else
Lst.Add Curve2Poly(Geo)
End Select
Next
Set GetPolyList = Lst
End Function
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
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
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))
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&)
Dim TempLng#
Do
SumPara = (LoopEPara - LoopSPara) / (CutCount + 2)
Call Geo.GetPointAtParam(LoopSPara, LoopSPos)
Call Geo.GetPointAtParam(LoopEPara, LoopEPos)
Unit_Vec = Normaliz2d(LoopSPos, LoopEPos)
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
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
Private Function ArcCos(ByVal V As Double) As Double
ArcCos = Atn(-V / Sqr(-V * V + 1)) + 2 * Atn(1)
End Function
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
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
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
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
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
Private Function Dot2d(ByVal V1 As Variant, ByVal V2 As Variant) As Double
Dot2d = V1(0) * V2(0) + V1(1) * V2(1)
End Function
Private Function Cross2d(ByVal V1 As Variant, ByVal V2 As Variant) As Double
Cross2d = V1(0) * V2(1) - V1(1) * V2(0)
End Function
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
Private Sub Q_ISort_List(ByRef IdxList As Collection, ByVal LngList As Collection)
Dim THREASHOLD&: THREASHOLD = 16
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
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個です。
(殆どが利用されていない)
良く考えなかったので(と言うかわかっていなかった為)ｵﾘｼﾞﾅﾙの
ように大量の配列を用意していたのですが、空間番号をｷｰとした
ﾊｯｼｭﾃｰﾌﾞﾙを利用すれば、無駄に大きな配列を用意する必要が無い事に、
今朝の通勤中に気が付きました。 ん～直すかな･･･。
