Option Explicit
'Author: YukiukiH
'Date: 08/10/03
'compatibility: Rhino4
''branching using vector
'first things first...
'----------------------------------------------------------------------------------------------
Dim strRtPts
strRtPts = Rhino.GetObjects ("select root points", 1)
Call Rhino.AddLayer ("ptCloudRT", RGB(0,0,0)) 'black
Call Rhino.ObjectLayer (strRtPts, "ptCloudRT")
Dim strALLREFPts
strALLREFPts = Rhino.GetObjects ("select reference points", 1)
Call Rhino.AddLayer ("ptCloudREF", RGB(105,105,105)) 'gray
Call Rhino.ObjectLayer (strALLREFPts, "ptCloudREF")
Dim dblNumber
dblNumber = 8 '4
Dim dblBoundary
dblBoundary = 100 '100
Call Rhino.Print ("minimize rhino window")
Call branch (strRtPts, strALLREFPts, dblNumber, dblBoundary)
Call Rhino.print("execution completed")
'----------------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------------
Function branch (strRtPts, strALLREFPts, dblNumber, dblBoundary)
Dim arrResult()
'coordinate extraction
'----------------------------------------------------------------------------------------------
Dim i, arrRtPts(), arrALLREFPts()
For i = 0 To UBound(strRtPts)
ReDim Preserve arrRtPts(i)
arrRtPts(i) = Rhino.PointCoordinates (strRtPts(i))
Next
For i = 0 To UBound(strALLREFPts)
ReDim Preserve arrALLREFPts(i)
arrALLREFPts(i) = Rhino.PointCoordinates (strALLREFPts(i))
Next
'for each RootPoint,
'----------------------------------------------------------------------------------------------
Dim dblmaxX, dblminX, dblmaxY, dblminY
Dim arrREFPts(), arrMinLength(), dblMinLength
Dim strShortests()
Dim j
For j = 0 To UBound(arrRtPts)
Call Rhino.Print ("Round " & CStr(j+1))
'set boundary
'---------------------------------------
dblmaxX = arrRtPts(j)(0) +dblBoundary
dblminX = arrRtPts(j)(0) -dblBoundary
dblmaxY = arrRtPts(j)(1) +dblBoundary
dblminY = arrRtPts(j)(1) -dblBoundary
Dim n, m
n = 0
For m = 0 To UBound(arrALLREFPts)
If dblmaxX>arrALLREFPts(m)(0) And arrALLREFPts(m)(0)>dblminX And dblmaxY>arrALLREFPts(m)(1) And arrALLREFPts(m)(1)>dblminY Then
ReDim Preserve arrREFPts(n)
arrREFPts(n) = arrALLREFPts(m)
n = n+1
End If
Next
'---------------------------------------
'find dblNumber shortest
'---------------------------------------
Dim arrVectorTemp, dblLengthTemp
Dim arrVector01, dblLength01
Dim arrPrevShortest, dblPrevShortest
Dim arrCurrShortest, dblCurrShortest
dblMinLength = 0
For i = 0 To dblNumber-1
'make one to begin comparison with
arrVectorTemp = Rhino.VectorCreate (arrREFPts(0), arrRtPts(j))
dblLengthTemp = Rhino.VectorLength (arrVectorTemp)
arrPrevShortest = arrVectorTemp
dblPrevShortest = dblLengthTemp
If dblPrevShortest <= dblMinLength Then
dblPrevShortest = dblPrevShortest * 100
End If
For n = 0 To UBound(arrREFPts)
arrVector01 = Rhino.VectorCreate (arrREFPts(n), arrRtPts(j))
dblLength01 = Rhino.VectorLength (arrVector01)
If dblLength01 <= dblPrevShortest And dblLength01 > dblMinLength Then
arrCurrShortest = arrVector01
dblCurrShortest = dblLength01
Else
arrCurrShortest = arrPrevShortest
dblCurrShortest = dblPrevShortest
End If
'prepare for next round
arrPrevShortest = arrCurrShortest
dblPrevShortest = dblCurrShortest
Next 'arrREFPts
ReDim Preserve arrMinLength(i)
arrMinLength(i) = arrCurrShortest
dblMinLength = dblCurrShortest
Call Rhino.Print (CStr(i+1) & " shortest:" & " " & CStr(dblMinLength))
Call Rhino.AddLayer (CStr(i+1) & " shortest", RGB(255-i*20, 50+i*24, 0))
Call Rhino.CurrentLayer (CStr(i+1) & " shortest")
ReDim Preserve strShortests(i)
strShortests(i) = Rhino.Addline (arrRtPts(j), Rhino.VectorAdd (arrRtPts(j), arrMinLength(i)))
Next 'i
ReDim Preserve arrResult(j)
arrResult(j) = strShortests
'---------------------------------------
Next 'j
Call Rhino.CurrentLayer ("0")
branch = arrResult
End Function
'----------------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------------
