2D曲線の折れ線化 - ｽﾌﾟﾗｲﾝ

こちらの続きです。
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です)
円弧の場合は、演算で座標値を求めている為、前回のものの方が
処理が速いです。

実際に試した感じです。

こんな感じのｽﾌﾟﾗｲﾝです。ｽﾌﾟﾗｲﾝであれば閉じていたり自己交差
していても大丈夫です。

ﾏｸﾛ実行後は、同様にﾄﾚﾗﾝｽ以内となる点と直線を作ります。

拡大した感じです。ｵﾚﾝｼﾞが元のｽﾌﾟﾗｲﾝで黒がﾏｸﾛで作成した点と線です。
当然ですがﾄﾚﾗﾝｽを満たす為、曲率の大きい部分には多くの点が作成
されます。

前回同様に、上記のｺｰﾄﾞはﾄﾚﾗﾝｽ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
こちらは二分検索でやったのですが、こっちの方が速いのかな?