Vectors (forces): Normals, Attractors, Deformation, Cusps, Blebs
inflect script
Option Explicit
'Script written by Ezio Blasetti
'July 19th 2007 revision
Sub inflect()
Dim arrObjects : arrObjects = Rhino.GetObjects("select the objects to inflect", 12)
If IsNull(arrObjects) Then Exit Sub
Dim arrAttractors : arrAttractors = Rhino.GetObjects("select the attractors", 13)
If IsNull(arrAttractors) Then Exit Sub
Dim dblRadius, dblIntensity, blnAttr, blnCopy, arrOptions(6), strResult, strAllow
dblRadius = Rhino.GetSettings(Rhino.InstallFolder & "Inflect.ini", "infect", "Radius")
If IsNull(dblRadius) Then dblRadius = 5 Else dblRadius = CDbl (dblRadius)
dblIntensity = Rhino.GetSettings(Rhino.InstallFolder & "Inflect.ini", "infect", "Intensity")
If IsNull(dblIntensity) Then dblIntensity = .1 Else dblIntensity = CDbl (dblIntensity)
blnAttr = Rhino.GetSettings(Rhino.InstallFolder & "Inflect.ini", "infect", "Attract")
If IsNull(blnAttr) Then blnAttr = vbFalse Else blnAttr = CBool(blnAttr)
blnCopy = Rhino.GetSettings(Rhino.InstallFolder & "Inflect.ini", "infect", "Copy")
If IsNull(blnCopy) Then blnCopy = vbTrue Else blnCopy = CBool(blnCopy)
Dim arrNewObjs : arrNewObjs = array("Nothing")
Dim arrAllow(), i
strAllow = GetObjectsPoints(arrObjects, "Select control points to inflect", vbTrue)
ReDim arrAllow(UBound(strAllow))
If Not IsNull(strResult) Then
For i = 0 To UBound(strAllow)
arrAllow(i) = strAllow(i)
Next
End If
Do
Rhino.EnableRedraw vbFalse
Rhino.DeleteObjects arrNewObjs
rhino.Print "calculating...please wait."
arrNewObjs = InflectObjs(arrObjects, arrAttractors, blnAttr, dblRadius, dblIntensity, arrAllow, vbTrue)
If IsNull(arrNewObjs) Then arrNewObjs = Array("Nothing")
If Not blnCopy Then Rhino.HideObjects arrObjects Else Rhino.ShowObjects arrObjects
Rhino.EnableRedraw vbTrue
rhino.Print "done."
arrOptions(0) = "Radius_" & CStr(Int(dblRadius))
arrOptions(1) = "Intensity" & CStr(Int(dblIntensity))
arrOptions(2) = "Way_" & Bln2Str2(blnAttr)
arrOptions(3) = "Copy_" & Bln2Str(blnCopy)
arrOptions(4) = "Limit"
arrOptions(5) = "Accept"
arrOptions(6) = "Quit"
strResult = Rhino.GetString("Inflect; Current Radius Is: (" & dblRadius & ")", "Accept", arrOptions)
If IsNull(strResult) Then strResult = "Quit"
If IsNumeric(strResult) Then
dblRadius = Abs(CDbl(strResult))
Else
Select Case UCase(Left(strResult, 1))
Case "R"
strResult = Rhino.GetReal("Specify radius of affection", dblRadius, 0)
If Not IsNull(strResult) Then dblRadius = strResult
Case "I"
strResult = Rhino.GetReal("Specify intensity of affection", dblIntensity, 0)
If Not IsNull(strResult) Then dblIntensity = strResult
If strResult > 1 Then print "to avoid blebs keep intensity less or equal to 1..."
Case "W"
blnAttr = Not blnAttr
Case "C"
blnCopy = Not blnCopy
Case "L"
Rhino.EnableRedraw vbFalse
Rhino.DeleteObjects arrNewObjs
Rhino.ShowObjects arrObjects
strResult = GetObjectsPoints(arrObjects, "Select control points to inflect", vbFalse)
If Not IsNull(strResult) Then
For i = 0 To UBound(strResult)
arrAllow(i) = strResult(i)
Next
End If
Case "A"
Rhino.EnableRedraw vbFalse
Rhino.DeleteObjects arrNewObjs
rhino.Print "calculating...please wait."
arrNewObjs = InflectObjs(arrObjects, arrAttractors, blnAttr, dblRadius, dblIntensity, arrAllow, vbFalse)
Rhino.EnableRedraw vbTrue
Exit Do
Case "Q"
Rhino.ShowObjects arrObjects
Rhino.DeleteObjects arrNewObjs
Exit Sub
End Select
End If
Loop
Rhino.SaveSettings Rhino.InstallFolder & "Inflect.ini", "infect", "Radius", CStr(dblRadius)
Rhino.SaveSettings Rhino.InstallFolder & "Inflect.ini", "infect", "Intensity", CStr(dblIntensity)
Rhino.SaveSettings Rhino.InstallFolder & "Inflect.ini", "infect", "Attract", CStr(blnAttr)
Rhino.SaveSettings Rhino.InstallFolder & "Inflect.ini", "infect", "Copy", CStr(blnCopy)
If Not blnCopy Then
Rhino.DeleteObjects arrObjects
End If
rhino.Print "objects inflected."
End Sub
inflect
Function GetObjectsPoints(arrObjects, strMessage, blnAll)
GetObjectsPoints = Null
Dim arrPt, i, strObj, k
Dim objPt(), selPt, arrSelected()
k=0
For Each strObj In arrObjects
If Rhino.IsCurve(strObj) Then
arrPt = Rhino.CurvePoints(strObj)
Else
arrPt = rhino.SurfacePoints(strObj)
End If
Rhino.EnableRedraw vbFalse
For i = 0 To UBound(arrPt)
ReDim Preserve arrSelected(k)
arrSelected(k) = vbFalse
ReDim Preserve objPt(k)
objPt(k) = Rhino.AddPoint(arrPt(i))
Rhino.ObjectName objPt(k), k
k=k+1
Next
Next
If blnAll Then
selPt = objPt
Else
Rhino.EnableRedraw vbTrue
selPt = Rhino.GetObjects(strMessage, 1, vbFalse, vbFalse, vbTrue, objPt)
End If
If IsNull(selPt) Then Exit Function
For i = 0 To UBound(selPt)
arrSelected(CLng(Rhino.ObjectName(selPt(i)))) = vbTrue
Next
Rhino.DeleteObjects objPt
Rhino.EnableRedraw vbTrue
GetObjectsPoints = arrSelected
End Function
Function InflectObjs(arrObjects, arrAttractors, blnAttr, dblRadius, dblIntensity, arrAllow, ConvertToCurves)
InflectObjs = Null
Dim strObject, arrCurrentPt, arrInflObjects()
Dim arrPoints, strGeom
Dim i, j, k
ReDim arrInflObjects(Ubound(arrObjects))
Dim arrKnots, arrWeights, intDegree, ptCount, isoCurves
i=0
k=0
For Each strObject In arrObjects
If Rhino.IsCurve(strObject) Then
arrPoints = Rhino.CurvePoints(strObject)
strGeom = "Curve"
intDegree = Rhino.CurveDegree (strObject)
Else
arrPoints = rhino.SurfacePoints(strObject)
strGeom = "Surface"
ptCount = Rhino.SurfacePointCount(strObject)
arrKnots = Rhino.SurfaceKnots(strObject)
arrWeights = Rhino.SurfaceWeights(strObject)
intDegree = Rhino.SurfaceDegree(strObject)
End If
j=0
For Each arrCurrentPt In arrPoints
If arrAllow(k) Then
arrPoints(j) = InflectPoint(arrCurrentPt, arrAttractors, blnAttr, dblRadius, dblIntensity)
End If
k=k+1
j=j+1
Next
Select Case UCase(Left(strGeom, 1))
Case "C"
arrInflObjects(i) = Rhino.AddCurve (arrPoints , intDegree)
Case "S"
arrInflObjects(i) = Rhino.AddNurbsSurface(ptCount, arrPoints, arrKnots(0), arrKnots(1), intDegree, arrWeights)
End Select
i=i+1
Next
InflectObjs = arrInflObjects
End Function
Function InflectPoint(arrCurrentPt, arrAttractors, blnAttr, dblRadius, dblIntensity)
InflectPoint = arrCurrentPt
Dim dblCurrentDistance, strCurrentAttractor, arrCurrentAttractor, arrCurrentVector, dblParameter, arrParam
Dim arrNewPt : arrNewPt = arrCurrentPt
Dim arrVector: arrVector = array(0, 0, 0)
For Each strCurrentAttractor In arrAttractors
If Rhino.IsPoint(strCurrentAttractor) Then
arrCurrentAttractor = Rhino.PointCoordinates (strCurrentAttractor)
ElseIf Rhino.IsCurve(strCurrentAttractor) Then
dblParameter = Rhino.CurveClosestPoint (strCurrentAttractor, arrCurrentPt)
arrCurrentAttractor = Rhino.EvaluateCurve (strCurrentAttractor, dblParameter)
Else
arrParam = Rhino.SurfaceClosestPoint (strCurrentAttractor, arrCurrentPt)
arrCurrentAttractor = Rhino.EvaluateSurface(strCurrentAttractor, arrParam)
End If
dblCurrentDistance = Rhino.Distance (arrCurrentPt, arrCurrentAttractor)
If dblCurrentDistance<=dblRadius Then
arrCurrentVector = VectorCreate (arrCurrentPt, arrCurrentAttractor)
If dblCurrentDistance<>0 Then
arrCurrentVector = Rhino.VectorScale (arrCurrentVector, dblIntensity/dblCurrentDistance)
End If
arrVector = VectorAdd (arrVector, arrCurrentVector)
End If
Next
If blnAttr Then
arrNewPt = array((arrCurrentPt(0) - arrVector(0)), _
(arrCurrentPt(1) - arrVector(1)), _
(arrCurrentPt(2) - arrVector(2)))
Else
arrNewPt = array((arrCurrentPt(0) + arrVector(0)), _
(arrCurrentPt(1) + arrVector(1)), _
(arrCurrentPt(2) + arrVector(2)))
End If
InflectPoint = arrNewPt
End Function
Function Bln2Str(blnIn)
Bln2Str = "No"
If blnIn Then Bln2Str = "Yes"
End Function
Function Bln2Str2(blnIn)
Bln2Str2 = "Attract"
If blnIn Then Bln2Str2 = "Repulse"
End Function
Function VectorCreate(p1, p2)
VectorCreate = Null
If Not IsArray(p1) Or (UBound(p1) <> 2) Then Exit Function
If Not IsArray(p2) Or (UBound(p2) <> 2) Then Exit Function
VectorCreate = Array(p2(0) - p1(0), p2(1) - p1(1), p2(2) - p1(2))
End Function
Function VectorAdd(v1, v2)
VectorAdd = Null
If Not IsArray(v1) Or (UBound(v1) <> 2) Then Exit Function
If Not IsArray(v2) Or (UBound(v2) <> 2) Then Exit Function
VectorAdd = Array(v1(0) + v2(0), v1(1) + v2(1), v1(2) + v2(2))
End Function
Function VectorUnitize(v)
VectorUnitize = Null
If Not IsArray(v) Or (UBound(v) <> 2) Then Exit Function
Dim dist, x, y, z, x2, y2, z2
x = v(0) : y = v(1) : z = v(2)
x2 = x * x : y2 = y * y : z2 = z * z
dist = x2 + y2 + z2
If (dist < 0.01) Then
VectorUnitize = Array(0, 0, 0)
Exit Function
End If
dist = sqr(dist)
x = x / dist
y = y / dist
z = z / dist
VectorUnitize = Array(x, y, z)
End Function
'Script written by Ezio Blasetti
'July 19th 2007 revision
Sub inflect()
Dim arrObjects : arrObjects = Rhino.GetObjects("select the objects to inflect", 12)
If IsNull(arrObjects) Then Exit Sub
Dim arrAttractors : arrAttractors = Rhino.GetObjects("select the attractors", 13)
If IsNull(arrAttractors) Then Exit Sub
Dim dblRadius, dblIntensity, blnAttr, blnCopy, arrOptions(6), strResult, strAllow
dblRadius = Rhino.GetSettings(Rhino.InstallFolder & "Inflect.ini", "infect", "Radius")
If IsNull(dblRadius) Then dblRadius = 5 Else dblRadius = CDbl (dblRadius)
dblIntensity = Rhino.GetSettings(Rhino.InstallFolder & "Inflect.ini", "infect", "Intensity")
If IsNull(dblIntensity) Then dblIntensity = .1 Else dblIntensity = CDbl (dblIntensity)
blnAttr = Rhino.GetSettings(Rhino.InstallFolder & "Inflect.ini", "infect", "Attract")
If IsNull(blnAttr) Then blnAttr = vbFalse Else blnAttr = CBool(blnAttr)
blnCopy = Rhino.GetSettings(Rhino.InstallFolder & "Inflect.ini", "infect", "Copy")
If IsNull(blnCopy) Then blnCopy = vbTrue Else blnCopy = CBool(blnCopy)
Dim arrNewObjs : arrNewObjs = array("Nothing")
Dim arrAllow(), i
strAllow = GetObjectsPoints(arrObjects, "Select control points to inflect", vbTrue)
ReDim arrAllow(UBound(strAllow))
If Not IsNull(strResult) Then
For i = 0 To UBound(strAllow)
arrAllow(i) = strAllow(i)
Next
End If
Do
Rhino.EnableRedraw vbFalse
Rhino.DeleteObjects arrNewObjs
rhino.Print "calculating...please wait."
arrNewObjs = InflectObjs(arrObjects, arrAttractors, blnAttr, dblRadius, dblIntensity, arrAllow, vbTrue)
If IsNull(arrNewObjs) Then arrNewObjs = Array("Nothing")
If Not blnCopy Then Rhino.HideObjects arrObjects Else Rhino.ShowObjects arrObjects
Rhino.EnableRedraw vbTrue
rhino.Print "done."
arrOptions(0) = "Radius_" & CStr(Int(dblRadius))
arrOptions(1) = "Intensity" & CStr(Int(dblIntensity))
arrOptions(2) = "Way_" & Bln2Str2(blnAttr)
arrOptions(3) = "Copy_" & Bln2Str(blnCopy)
arrOptions(4) = "Limit"
arrOptions(5) = "Accept"
arrOptions(6) = "Quit"
strResult = Rhino.GetString("Inflect; Current Radius Is: (" & dblRadius & ")", "Accept", arrOptions)
If IsNull(strResult) Then strResult = "Quit"
If IsNumeric(strResult) Then
dblRadius = Abs(CDbl(strResult))
Else
Select Case UCase(Left(strResult, 1))
Case "R"
strResult = Rhino.GetReal("Specify radius of affection", dblRadius, 0)
If Not IsNull(strResult) Then dblRadius = strResult
Case "I"
strResult = Rhino.GetReal("Specify intensity of affection", dblIntensity, 0)
If Not IsNull(strResult) Then dblIntensity = strResult
If strResult > 1 Then print "to avoid blebs keep intensity less or equal to 1..."
Case "W"
blnAttr = Not blnAttr
Case "C"
blnCopy = Not blnCopy
Case "L"
Rhino.EnableRedraw vbFalse
Rhino.DeleteObjects arrNewObjs
Rhino.ShowObjects arrObjects
strResult = GetObjectsPoints(arrObjects, "Select control points to inflect", vbFalse)
If Not IsNull(strResult) Then
For i = 0 To UBound(strResult)
arrAllow(i) = strResult(i)
Next
End If
Case "A"
Rhino.EnableRedraw vbFalse
Rhino.DeleteObjects arrNewObjs
rhino.Print "calculating...please wait."
arrNewObjs = InflectObjs(arrObjects, arrAttractors, blnAttr, dblRadius, dblIntensity, arrAllow, vbFalse)
Rhino.EnableRedraw vbTrue
Exit Do
Case "Q"
Rhino.ShowObjects arrObjects
Rhino.DeleteObjects arrNewObjs
Exit Sub
End Select
End If
Loop
Rhino.SaveSettings Rhino.InstallFolder & "Inflect.ini", "infect", "Radius", CStr(dblRadius)
Rhino.SaveSettings Rhino.InstallFolder & "Inflect.ini", "infect", "Intensity", CStr(dblIntensity)
Rhino.SaveSettings Rhino.InstallFolder & "Inflect.ini", "infect", "Attract", CStr(blnAttr)
Rhino.SaveSettings Rhino.InstallFolder & "Inflect.ini", "infect", "Copy", CStr(blnCopy)
If Not blnCopy Then
Rhino.DeleteObjects arrObjects
End If
rhino.Print "objects inflected."
End Sub
inflect
Function GetObjectsPoints(arrObjects, strMessage, blnAll)
GetObjectsPoints = Null
Dim arrPt, i, strObj, k
Dim objPt(), selPt, arrSelected()
k=0
For Each strObj In arrObjects
If Rhino.IsCurve(strObj) Then
arrPt = Rhino.CurvePoints(strObj)
Else
arrPt = rhino.SurfacePoints(strObj)
End If
Rhino.EnableRedraw vbFalse
For i = 0 To UBound(arrPt)
ReDim Preserve arrSelected(k)
arrSelected(k) = vbFalse
ReDim Preserve objPt(k)
objPt(k) = Rhino.AddPoint(arrPt(i))
Rhino.ObjectName objPt(k), k
k=k+1
Next
Next
If blnAll Then
selPt = objPt
Else
Rhino.EnableRedraw vbTrue
selPt = Rhino.GetObjects(strMessage, 1, vbFalse, vbFalse, vbTrue, objPt)
End If
If IsNull(selPt) Then Exit Function
For i = 0 To UBound(selPt)
arrSelected(CLng(Rhino.ObjectName(selPt(i)))) = vbTrue
Next
Rhino.DeleteObjects objPt
Rhino.EnableRedraw vbTrue
GetObjectsPoints = arrSelected
End Function
Function InflectObjs(arrObjects, arrAttractors, blnAttr, dblRadius, dblIntensity, arrAllow, ConvertToCurves)
InflectObjs = Null
Dim strObject, arrCurrentPt, arrInflObjects()
Dim arrPoints, strGeom
Dim i, j, k
ReDim arrInflObjects(Ubound(arrObjects))
Dim arrKnots, arrWeights, intDegree, ptCount, isoCurves
i=0
k=0
For Each strObject In arrObjects
If Rhino.IsCurve(strObject) Then
arrPoints = Rhino.CurvePoints(strObject)
strGeom = "Curve"
intDegree = Rhino.CurveDegree (strObject)
Else
arrPoints = rhino.SurfacePoints(strObject)
strGeom = "Surface"
ptCount = Rhino.SurfacePointCount(strObject)
arrKnots = Rhino.SurfaceKnots(strObject)
arrWeights = Rhino.SurfaceWeights(strObject)
intDegree = Rhino.SurfaceDegree(strObject)
End If
j=0
For Each arrCurrentPt In arrPoints
If arrAllow(k) Then
arrPoints(j) = InflectPoint(arrCurrentPt, arrAttractors, blnAttr, dblRadius, dblIntensity)
End If
k=k+1
j=j+1
Next
Select Case UCase(Left(strGeom, 1))
Case "C"
arrInflObjects(i) = Rhino.AddCurve (arrPoints , intDegree)
Case "S"
arrInflObjects(i) = Rhino.AddNurbsSurface(ptCount, arrPoints, arrKnots(0), arrKnots(1), intDegree, arrWeights)
End Select
i=i+1
Next
InflectObjs = arrInflObjects
End Function
Function InflectPoint(arrCurrentPt, arrAttractors, blnAttr, dblRadius, dblIntensity)
InflectPoint = arrCurrentPt
Dim dblCurrentDistance, strCurrentAttractor, arrCurrentAttractor, arrCurrentVector, dblParameter, arrParam
Dim arrNewPt : arrNewPt = arrCurrentPt
Dim arrVector: arrVector = array(0, 0, 0)
For Each strCurrentAttractor In arrAttractors
If Rhino.IsPoint(strCurrentAttractor) Then
arrCurrentAttractor = Rhino.PointCoordinates (strCurrentAttractor)
ElseIf Rhino.IsCurve(strCurrentAttractor) Then
dblParameter = Rhino.CurveClosestPoint (strCurrentAttractor, arrCurrentPt)
arrCurrentAttractor = Rhino.EvaluateCurve (strCurrentAttractor, dblParameter)
Else
arrParam = Rhino.SurfaceClosestPoint (strCurrentAttractor, arrCurrentPt)
arrCurrentAttractor = Rhino.EvaluateSurface(strCurrentAttractor, arrParam)
End If
dblCurrentDistance = Rhino.Distance (arrCurrentPt, arrCurrentAttractor)
If dblCurrentDistance<=dblRadius Then
arrCurrentVector = VectorCreate (arrCurrentPt, arrCurrentAttractor)
If dblCurrentDistance<>0 Then
arrCurrentVector = Rhino.VectorScale (arrCurrentVector, dblIntensity/dblCurrentDistance)
End If
arrVector = VectorAdd (arrVector, arrCurrentVector)
End If
Next
If blnAttr Then
arrNewPt = array((arrCurrentPt(0) - arrVector(0)), _
(arrCurrentPt(1) - arrVector(1)), _
(arrCurrentPt(2) - arrVector(2)))
Else
arrNewPt = array((arrCurrentPt(0) + arrVector(0)), _
(arrCurrentPt(1) + arrVector(1)), _
(arrCurrentPt(2) + arrVector(2)))
End If
InflectPoint = arrNewPt
End Function
Function Bln2Str(blnIn)
Bln2Str = "No"
If blnIn Then Bln2Str = "Yes"
End Function
Function Bln2Str2(blnIn)
Bln2Str2 = "Attract"
If blnIn Then Bln2Str2 = "Repulse"
End Function
Function VectorCreate(p1, p2)
VectorCreate = Null
If Not IsArray(p1) Or (UBound(p1) <> 2) Then Exit Function
If Not IsArray(p2) Or (UBound(p2) <> 2) Then Exit Function
VectorCreate = Array(p2(0) - p1(0), p2(1) - p1(1), p2(2) - p1(2))
End Function
Function VectorAdd(v1, v2)
VectorAdd = Null
If Not IsArray(v1) Or (UBound(v1) <> 2) Then Exit Function
If Not IsArray(v2) Or (UBound(v2) <> 2) Then Exit Function
VectorAdd = Array(v1(0) + v2(0), v1(1) + v2(1), v1(2) + v2(2))
End Function
Function VectorUnitize(v)
VectorUnitize = Null
If Not IsArray(v) Or (UBound(v) <> 2) Then Exit Function
Dim dist, x, y, z, x2, y2, z2
x = v(0) : y = v(1) : z = v(2)
x2 = x * x : y2 = y * y : z2 = z * z
dist = x2 + y2 + z2
If (dist < 0.01) Then
VectorUnitize = Array(0, 0, 0)
Exit Function
End If
dist = sqr(dist)
x = x / dist
y = y / dist
z = z / dist
VectorUnitize = Array(x, y, z)
End Function