曲線と戦ってみる11 - 曲線の最小Rを求める

曲線内の最小Rとなる部分を見つけ出せば、何か糸口が掴めるかな？
と思っています。　指定した曲線の最小Rって "式" で取得できる事
知っていましたか?

こんな感じです。

f:id:kandennti:20160630183732p:plain
"長さ" のﾊﾟﾗﾒｰﾀを作成して、画像のような "式" を作ると取得可能です。
これも、"Unofficial CATIA User Forum" で、ここなさんが
書かれていたんですけどね。
"式" で利用できるのであれば、ﾏｸﾛでも利用できます。

ですが、困った事に最小Rのｻｲｽﾞは取得できるのですが、肝心な
"どの位置で？" が取得できないです。
そこで、何とか最小Rの位置に点を作成するﾏｸﾛに挑戦してみました。

'vba using-'KCL' GetMinimumCurvatureRadiusPoint
Option Explicit

Private Const MinRange = 0.001 '最小Rを検出する範囲

Sub CATMain()
    '曲線選択
    Dim Msg$: Msg = "曲線を選択して下さい : ESCｷｰ 終了"
    Dim SelElem As SelectedElement
    Set SelElem = KCL.SelectElement(Msg, Array("HybridShape"))
    If KCL.IsNothing(SelElem) Then Exit Sub
    Dim CurveOj As AnyObject: Set CurveOj = SelElem.Value
    Dim CurveRef As Reference: Set CurveRef = SelElem.Reference
    
    '各種設定
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(CurveRef, "PartDocument")
    Dim Pt As Part: Set Pt = Doc.Part
    Dim Sel As Selection: Set Sel = Doc.Selection
    CATIA.RefreshDisplay = False
    
    '曲線の全長取得
    Dim CurveLength#: CurveLength = GetCurveLength(Pt, CurveRef)
    
    '最小Rとなる比率の範囲
    Dim MinRangeRatio#: MinRangeRatio = MinRange / CurveLength
    
    '曲線全体に対しての最小R取得
    Dim MinR_Param As Length: Set MinR_Param = InitParam_Len(Pt)
    Dim MinR_Formula As Formula: Set MinR_Formula = InitFormula(Pt, MinR_Param, CurveOj)
    Dim MinR#: MinR = MinR_Param.Value
    Call DelItem(Sel, Array(MinR_Formula, MinR_Param))
    
    '作業用形状ｾｯﾄ
    Dim HB As HybridBody: Set HB = Pt.HybridBodies.Add
    HB.Name = "temp"
    
    '比率初期設定
    Dim Low#: Low = 0#
    Dim Mid#: Mid = 0.5
    Dim High#: High = 1#
    
    'ﾄﾘﾑ用点作成
    Dim LowPnt As HybridShapePointOnCurve: Set LowPnt = InitPnt(Pt, CurveRef, Low)
    Dim LowRef As Reference: Set LowRef = Pt.CreateReferenceFromObject(LowPnt)
    Dim LowRatio As RealParam: Set LowRatio = LowPnt.Ratio
    Call HB.AppendHybridShape(LowPnt)
    
    Dim MidPnt As HybridShapePointOnCurve: Set MidPnt = InitPnt(Pt, CurveRef, Mid)
    Dim MidRef As Reference: Set MidRef = Pt.CreateReferenceFromObject(MidPnt)
    Dim MidRatio As RealParam: Set MidRatio = MidPnt.Ratio
    Call HB.AppendHybridShape(MidPnt)
    
    Dim HighPnt As HybridShapePointOnCurve: Set HighPnt = InitPnt(Pt, CurveRef, High)
    Dim HighRef As Reference: Set HighRef = Pt.CreateReferenceFromObject(HighPnt)
    Dim HighRatio As RealParam: Set HighRatio = HighPnt.Ratio
    Call HB.AppendHybridShape(HighPnt)
    
    '上下分割曲線
    Dim LwrCrv As HybridShapeSplit: Set LwrCrv = InitSplit(Pt, CurveRef, LowRef, MidRef)
    Call HB.AppendHybridShape(LwrCrv)
    
    Dim UprCrv As HybridShapeSplit: Set UprCrv = InitSplit(Pt, CurveRef, MidRef, HighRef)
    Call HB.AppendHybridShape(UprCrv)
    
    '上下分割曲線に対しての最小R
    Dim Lwr_Param As Length: Set Lwr_Param = InitParam_Len(Pt)
    Dim Lwr_Formula As Formula: Set Lwr_Formula = InitFormula(Pt, Lwr_Param, LwrCrv)
    
    Dim Upr_Param As Length: Set Upr_Param = InitParam_Len(Pt)
    Dim Upr_Formula As Formula: Set Upr_Formula = InitFormula(Pt, Upr_Param, UprCrv)
    
    '二分探索木-非再帰
    Dim MinR_Ratio#
    Do
        '十分な精度を満たしたか？
        If Not (High - Low) > MinRangeRatio Then
            MinR_Ratio = Mid
            Exit Do
        End If
        
        'どっち?
        Select Case True
            Case Lwr_Param.Value = Upr_Param.Value
                If (High - Low) > MinRangeRatio * 3 Then
                    Msg = "同一の最小Rとなる部分が、複数存在している可能性があります。" + vbNewLine _
                        + "出来上がった点を元に分割し、それぞれの曲線で再度実行することをお勧めします"
                    MsgBox Msg, vbOKOnly + vbExclamation
                End If
                MinR_Ratio = Mid
                Exit Do
            Case Lwr_Param.Value < Upr_Param.Value
                High = Mid
                HighRatio.Value = High
            Case Lwr_Param.Value > Upr_Param.Value
                Low = Mid
                LowRatio.Value = Low
        End Select
        Mid = (Low + High) * 0.5
        MidRatio.Value = Mid
        
        'UpDete
        Dim UpDateFG As Boolean 'UpDateのｴﾗｰ用
        UpDateFG = UpDateAry(Pt, Array(MidRatio, MidPnt, _
                                 LowRatio, LowPnt, LwrCrv, Lwr_Param, _
                                 HighRatio, HighPnt, UprCrv, Upr_Param))
        If Not UpDateFG Then
            MinR_Ratio = Mid
            Exit Do
        End If
    Loop
    
    '全て削除
    Call DelItem(Sel, Array(Lwr_Formula, Upr_Formula, _
                            Lwr_Param, Upr_Param, _
                            LwrCrv, UprCrv, LowPnt, HighPnt))
    
    '結果
    HB.Name = "Result"
    Mid = MinR_Ratio
    Call UpDateAry(Pt, Array(MidRatio, MidPnt))
    MidPnt.Name = CurveOj.Name + "_MinR-" + CStr(MinR) + _
                  " : Ratio-" + CStr(MinR_Ratio)
    CATIA.RefreshDisplay = True
    
    '終了
    MsgBox "終了"
End Sub

'要素のUpDate
'Return:True-正常終了  False-ｴﾗｰ発生
Private Function UpDateAry(ByVal Pt As Part, ByVal Ary As Variant) As Boolean
    Dim i&
    UpDateAry = True
    For i = 0 To UBound(Ary)
        On Error GoTo Catch
        Call Pt.UpdateObject(Ary(i))
    Next
    Exit Function
Catch:
    '精度が過剰。この時点で十分求まっているはず
    UpDateAry = False
End Function

'曲線長さ取得
Private Function GetCurveLength#(ByVal Pt As Part, ByVal Ref As Reference)
    GetCurveLength = Pt.Parent.GetWorkbench("SPAWorkbench").GetMeasurable(Ref).Length
End Function

'要素の削除
Private Sub DelItem(ByVal Sel As Selection, ByVal Ary As Variant)
    Dim i&
    With Sel
        .Clear
        For i = 0 To UBound(Ary)
            .Add Ary(i)
        Next
        .Delete
    End With
End Sub

'分割
Private Function InitSplit(ByVal Pt As Part, ByVal CrvRef As Reference, _
                           ByVal FstRef As Reference, _
                           ByVal ScdRef As Reference) _
                           As HybridShapeSplit
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    Dim CrvSplit As HybridShapeSplit
    Set CrvSplit = Fact.AddNewHybridSplit(CrvRef, FstRef, -1)
    Call CrvSplit.AddCuttingElem(ScdRef, 1)
    Call Pt.UpdateObject(CrvSplit)
    Set InitSplit = CrvSplit
End Function

'曲線上の点
Private Function InitPnt(ByVal Pt As Part, ByVal CurveRef As Reference, _
                         Optional ByVal Ratio# = 0#) As HybridShapePointOnCurve
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    Dim Pnt As HybridShapePointOnCurve
    Set Pnt = Fact.AddNewPointOnCurveFromPercent(CurveRef, Ratio#, False)
    Call Pt.UpdateObject(Pnt)
    Set InitPnt = Pnt
End Function

'ﾊﾟﾗﾒｰﾀ
Private Function InitParam_Len(ByVal Pt As Part) As Length
    Set InitParam_Len = Pt.Parameters.CreateDimension("", "LENGTH", 0#)
End Function

'式
Private Function InitFormula(ByVal Pt As Part, ByVal Param As Length, _
                             ByVal AnyOj As AnyObject) As Formula
    Dim UseNameInRelation$
    UseNameInRelation = Replace(Pt.Parameters.GetNameToUseInRelation(AnyOj), "`", "")
    Set InitFormula = Pt.Relations.CreateFormula( _
                        AnyOj.Name + "_MinR", _
                        "", _
                        Param, _
                        "minimumCurvatureRadius(`" + UseNameInRelation + "` ) ")
End Function