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

C#ATIA

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

2D曲線の折れ線化 - スプライン

CATIA_V5 VBA KCL

こちらの続きです。
2D曲線の折れ線化 - 円弧 - C#ATIA


前回のもののスプライン版です。

円弧版同様に、3DからリンクしたものはNGです。

'vba test_Curve2Polyline  using-'KCL0.09'
'2Dスプラインの折れ線化

Option Explicit

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

Sub CATMain()
    'ドキュメントのチェック
    If Not KCL.CanExecute("DrawingDocument") Then Exit Sub
    
    '選択
    Dim Geo As Curve2D: Set Geo = KCL.SelectItem("選択", "Curve2D")
    If KCL.IsNothing(Geo) Then Exit Sub
    
    '折れ線座標郡取得
    Dim PolyList As Collection: Set PolyList = Curve2Polyline(Geo)
    If KCL.IsNothing(PolyList) Then Exit Sub
    
    '点・線作成
    Dim View As DrawingView: Set View = KCL.GetParent_Of_T(Geo, "GeometricElements")
    Call DumpPnt2D(PolyList, View.Factory2D)
    Call DumpPoly2D(PolyList, View.Factory2D)
End Sub

'スプライン折れ線化 閉じた円弧はNG
Private Function Curve2Polyline(Geo As AnyObject) As Collection
    Const CutCount = 4 '分割数
    
    '円弧情報
    Dim Prm(1) '始点終点パラメータ
    Dim Pos(1) '座標
    Dim Lng# '長さ
    
    With Geo
        Call .GetParamExtents(Prm)
        Call .GetPointAtParam(Prm(0), Pos)
        Lng = .GetLengthAtParam(Prm(0), Prm(1))
    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)
        
        '分割点作成 距離チェック
        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) < m_PolyTol 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
        CutMax(0) = -1# '距離初期化
        
        If EQ(LoopSPara, LoopEPara) Then
            '始点と終点がほぼ同一 未対応
            Stop
        End If
    Loop
    Set Curve2Polyline = PntList
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 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))
    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


'確認用
'2D点
Private Sub DumpPnt2D(ByVal List As Collection, ByVal Fact As Factory2D)
    Dim Pos, P As Point2D
    For Each Pos In List
        Set P = Fact.CreatePoint(Pos(0), Pos(1))
        P.ReportName = 3
        P.Construction = False
    Next
End Sub

'2D線
Private Sub DumpPoly2D(ByVal List As Collection, ByVal Fact As Factory2D)
    Dim i&, L As Line2D
    For i = 1 To List.Count - 1
        Set L = Fact.CreateLine(List(i)(0), List(i)(1), _
                                List(i + 1)(0), List(i + 1)(1))
    Next
End Sub

CATIAの2Dは、円弧(Circle2D)は曲線(Curve2D)を継承している為、
選択フィルタを "Curve2D" 円弧も選択出来ちゃいます。円弧は
"特別な曲線" と言う扱いのようです。
(このマクロはチェックをしていない為、閉じた円弧はNGです)
円弧の場合は、演算で座標値を求めている為、前回のものの方が
処理が速いです。


実際に試した感じです。
f:id:kandennti:20170106193904p:plain
こんな感じのスプラインです。スプラインであれば閉じていたり自己交差
していても大丈夫です。

f:id:kandennti:20170106193910p:plain
マクロ実行後は、同様にトレランス以内となる点と直線を作ります。

f:id:kandennti:20170106193914p:plain
拡大した感じです。オレンジが元のスプラインで黒がマクロで作成した点と線です。
当然ですがトレランスを満たす為、曲率の大きい部分には多くの点が作成
されます。

f:id:kandennti:20170106193919p:plain
前回同様に、上記のコードはトレランス0.1mmとしていたので、スプラインの
両側0.1mmオフセットしたものが青色です。


当時、かなり悩みましたが思い付いた方法がこれでした。
後に調べたところ、"繰り返し折れ線近似法" と言う名称が一番近い
表現でした。

以前見つけたサイトが見つからなかったですが、こちらのアルゴリズムに
近かったです。(PDFがDLされちゃいます)
https://www.google.co.jp/url?sa=t&rct=j&q=&esrc=s&source=web&cd=1&cad=rja&uact=8&ved=0ahUKEwjw_tfJqa3RAhUIFJQKHXBnCVgQFggaMAA&url=https%3A%2F%2Fipsj.ixsq.nii.ac.jp%2Fej%2Findex.php%3Faction%3Dpages_view_main%26active_action%3Drepository_action_common_download%26item_id%3D119245%26item_no%3D1%26attribute_id%3D1%26file_no%3D1%26page_id%3D13%26block_id%3D8&usg=AFQjCNGoFx4jULe-WtjvRZWfs4rk3afBzA&bvm=bv.142059868,d.dGo


当時随分探したのですが 折れ線→スプラインは結構見つかるのですが、
逆はほぼ見つかりませんでした。
リンク先の方法だと最初に大量に点を作成する必要があるのですが、
その方法だと処理時間が長くなりすぎるので、出来るだけ無駄な点を
作成しないで折れ線化したいのですが、未だにベストな方法が見つかって
いません。

過去に、3Dスプラインの円弧近似化をこちらで行いましたが、
曲線と戦ってみる9 - C#ATIA
こちらは二分検索でやったのですが、こっちの方が速いのかな?