This script does not work inflate polisurfaces

vikthor · December 24, 2016, 1:13am

Can somebody help me,

It was great to create these shapes:

Option Explicit
'Script written and copyrighted by Gelfling '04 aka David Rutten
'http://www.nurbs.tk info@nurbs.tk
'Last script revision on 25 april 2004

Sub Balloon()
	Dim idBalloon, idHairs, idInfBalloon
	Dim arrStart, dblRadius
	Dim strResult, arrOptions(6)
	Dim selWall, defWalls
	Dim uvDensity
	Dim stepSize
	Dim i, CP, radAuto

	selWall = Rhino.GetObject("Seleccione una superficie (poli) cerrada...", 8 + 16, vbTrue, vbTrue)
	If IsNull(selWall) Then Exit Sub
	If IsNull(Rhino.SurfaceVolume(selWall)) Then Exit Sub
	
	arrStart = Array(1E100, 1E100, 1E100)
	Do Until Rhino.IsPointInSurface(selWall, arrStart)
		arrStart = Rhino.GetPoint("Elija un punto dentro del volumen para comenzar el crecimiento...")
		If IsNull(arrStart) Then Exit Sub
	Loop

	defWalls = ExtractWalls(selWall)
	uvDensity = Rhino.GetSettings(Rhino.InstallFolder & "Gelfling.ini", "Balloon", "uvDensity")
	If IsNull(uvDensity) Then uvDensity = 20 Else uvDensity = CInt(uvDensity)
	dblRadius = Rhino.GetSettings(Rhino.InstallFolder & "Gelfling.ini", "Balloon", "Radius")
	If IsNull(dblRadius) Then dblRadius = 1 Else dblRadius = CDbl(dblRadius)
	stepSize = Rhino.GetSettings(Rhino.InstallFolder & "Gelfling.ini", "Balloon", "stepSize")
	If IsNull(stepSize) Then stepSize = 1 Else stepSize = CDbl(stepSize)
	
	idBalloon = "Nothing"
	idHairs = Array("Nothing")

	Do
		Rhino.EnableRedraw vbFalse
		Rhino.Prompt "Generating preview..."
		Rhino.DeleteObject idBalloon
		Rhino.DeleteObjects idHairs
		idBalloon = AddBalloon(arrStart, dblRadius, uvDensity)
		idHairs = AddGrowLines(arrStart, dblRadius, stepSize)
		Rhino.SelectObjects idHairs
		Rhino.EnableRedraw vbTrue

		arrOptions(0) = "Insertion_Point"
		arrOptions(1) = "Radius"
		arrOptions(2) = "AutoRadius"
		arrOptions(3) = "Density_" & uvDensity
		arrOptions(4) = "Stepsize"
		arrOptions(5) = "Infl8"
		arrOptions(6) = "Quit"
		strResult = Rhino.GetString("Inflación sólida...", "Infl8", arrOptions)
		If IsNull(strResult) Then strResult = "Quit"
		If IsNumeric(strResult) Then
			strResult = Abs(CDbl(strResult))
			If strResult < Rhino.UnitAbsoluteTolerance Then strResult = Rhino.UnitAbsoluteTolerance
			stepSize = strResult
			strResult = "xxx"
		End If

		Select Case UCase(Left(strResult, 3))
			Case "INS"
				strResult = Rhino.GetPoint("Elija un nuevo punto para comenzar el crecimiento (debe estar encerrado el volumen)", arrStart)
				If Not IsNull(strResult) Then arrStart = strResult
			Case "RAD"
				strResult = Rhino.GetReal("Especifique un nuevo radio de globo inicial...", dblRadius, Rhino.UnitAbsoluteTolerance)
				If Not IsNull(strResult) Then dblRadius = strResult
			Case "AUT"
				radAuto = 1E12
				For i = 0 To UBound(defWalls)
					CP = Rhino.EvaluateSurface(defWalls(i), Rhino.SurfaceClosestPoint(defWalls(i), arrStart))
					If Rhino.Distance(arrStart, CP) < radAuto Then radAuto = Rhino.Distance(arrStart, CP)
				Next
				If radAuto = 1E12 Then
					msgBox "An error occured..." & vbNewLine & _
						"unable to determine an optimal radius.", vbOkOnly Or vbError, "Dang!"
				Else
					dblRadius = radAuto * 0.95
				End If
			Case "DEN"
				strResult = Rhino.GetInteger("Especifique una nueva densidad de globo...", uvDensity, 10, 1000)
				If Not IsNull(strResult) Then uvDensity = strResult
			Case "STE"
				strResult = Rhino.GetReal("Especifique un nuevo tamaño de paso de inflado...", stepSize, Rhino.UnitAbsoluteTolerance)
				If Not IsNull(strResult) Then stepSize = strResult
			Case "INF"
				Rhino.EnableRedraw vbFalse
				Rhino.DeleteObjects idHairs
				Rhino.EnableRedraw vbTrue
				Exit Do
			Case "QUI"
				Rhino.EnableRedraw vbFalse
				ShowObjects defWalls
				Rhino.DeleteObjects defWalls
				Rhino.DeleteObjects idBalloon
				Rhino.DeleteObjects idHairs
				Rhino.EnableRedraw vbTrue
				Exit Sub
		End Select
	Loop
	
	Rhino.SaveSettings Rhino.InstallFolder & "Gelfling.ini", "Balloon", "uvDensity", CStr(uvDensity)
	Rhino.SaveSettings Rhino.InstallFolder & "Gelfling.ini", "Balloon", "Radius", CStr(dblRadius)
	Rhino.SaveSettings Rhino.InstallFolder & "Gelfling.ini", "Balloon", "stepSize", CStr(stepSize)

	idInfBalloon = InflateSurface(idBalloon, stepSize, defWalls, uvDensity)

	Rhino.EnableRedraw vbFalse
	ShowObjects defWalls
	Rhino.DeleteObjects defWalls
	Rhino.DeleteObject idBalloon
	Rhino.EnableRedraw vbTrue
	Exit Sub

	Rhino.Print "Balloon fully inflated..."
End Sub
Balloon

Function InflateSurface(idSurface, stepSize, arrWalls, GridSize)
	InflateSurface = Null
	Dim arrPoints, i, j
	Dim fixState()
	Dim idCopy
	Dim uvCP, vecN, Ray
	Dim arrX, blnComplete

	idCopy = Rhino.CopyObject(idSurface)
	arrPoints = Rhino.SurfacePoints(idCopy)
	If IsNull(arrPoints) Then Exit Function
	ReDim fixState(UBound(arrPoints))
	For i = 0 To UBound(fixState)
		fixState(i) = vbFalse
	Next

	Rhino.EnableRedraw vbFalse
	Do
		arrPoints = Rhino.SurfacePoints(idCopy)

		For i = 0 To UBound(arrPoints)
			If Not fixState(i) Then
				If i / GridSize = i \ GridSize And i <> 0 Then
					fixState(i) = fixState(0)
					arrPoints(i) = arrPoints(0)
				ElseIf (i + 1) / GridSize = (i + 1) \ GridSize And i + 1 <> GridSize Then
					fixState(i) = fixState(GridSize - 1)
					arrPoints(i) = arrPoints(GridSize - 1)
				Else
					uvCP = Rhino.SurfaceClosestPoint(idCopy, arrPoints(i))
					vecN = Rhino.SurfaceNormal(idCopy, uvCP)
					If IsNull(vecN) Then vecN = Array(Array(0, 0, 0), Array(0, 0, 0))
					If Rhino.Distance(array(vecN(0), vecN(1))) <> 0 Then
						For j = 0 To 2
							vecN(1)(j) = arrPoints(i)(j) + (vecN(1)(j) - vecN(0)(j))
							vecN(0)(j) = arrPoints(i)(j)
						Next
						vecN = ResizeVector(vecN, stepSize)
						Ray = Rhino.AddLine(vecN(0), vecN(1))
						If Not IsNull(Ray) Then
							For j = 0 To UBound(arrWalls)
								arrX = Rhino.CurveSurfaceIntersection(Ray, arrWalls(j))
								If IsArray(arrX) Then
									'If Rhino.IsPointOnSurface(arrWalls(j), arrX(0,1)) Then
									fixState(i) = vbTrue
									If Rhino.Distance(vecN(0), vecN(1)) > Rhino.Distance(vecN(0), arrX(0, 1)) Then
										vecN(1) = arrX(0, 1)
									End If
									'End If
								End If
							Next
							Rhino.DeleteObject Ray
						End If
						arrPoints(i) = vecN(1)
					Else
						fixState(i) = vbFalse
					End If
				End If
			End If
		Next

		Rhino.DeleteObject idCopy
		idCopy = Rhino.AddNurbsSurface(Rhino.SurfacePointCount(idSurface), _
			arrPoints, _
			Rhino.SurfaceKnots(idSurface)(0), _
			Rhino.SurfaceKnots(idSurface)(1), _
			Rhino.SurfaceDegree(idSurface), _
			Rhino.SurfaceWeights(idSurface))
		Rhino.EnableRedraw vbTrue
		Rhino.EnableRedraw vbFalse
		blnComplete = vbTrue
		For i = 0 To UBound(fixState)
			If Not fixState(i) Then blnComplete = vbFalse
		Next
		If blnComplete Then Exit Do
	Loop
	Rhino.EnableRedraw vbTrue
	InflateSurface = idCopy
End Function

Function AddBalloon(arrStart, dblRadius, uvDensity)
	AddBalloon = Null
	Dim idSphere

	idSphere = Rhino.AddSphere(arrStart, dblRadius)
	If IsNull(idSphere) Then Exit Function
	Rhino.UnselectAllObjects
	Rhino.SelectObject idSphere
	Rhino.Command "-_Rebuild _UPointCount=" & uvDensity & _
		" _VPointCount=" & uvDensity & _
		" _UDegree=3 _VDegree=3 _DeleteInput=Yes _CurrentLayer=Yes _ReTrim=No _Enter", vbFalse
	Rhino.Prompt "Generating preview..."
	If Not Rhino.IsObject(idSphere) Then Exit Function
	AddBalloon = idSphere
End Function

Function AddGrowLines(O, R, S)
	AddGrowLines = Null
	Dim Hair(5)
	Hair(0) = Rhino.AddLine(Array(O(0) + R, O(1), O(2)), Array(O(0) + R + S, O(1), O(2)))
	Hair(1) = Rhino.AddLine(Array(O(0) - R, O(1), O(2)), Array(O(0) - R - S, O(1), O(2)))
	Hair(2) = Rhino.AddLine(Array(O(0), O(1) + R, O(2)), Array(O(0), O(1) + R + S, O(2)))
	Hair(3) = Rhino.AddLine(Array(O(0), O(1) - R, O(2)), Array(O(0), O(1) - R - S, O(2)))
	Hair(4) = Rhino.AddLine(Array(O(0), O(1), O(2) + R), Array(O(0), O(1), O(2) + R + S))
	Hair(5) = Rhino.AddLine(Array(O(0), O(1), O(2) - R), Array(O(0), O(1), O(2) - R - S))
	AddGrowLines = Hair
End Function

Function ExtractWalls(idSurface)
	If Rhino.IsSurface(idSurface) Then
		ExtractWalls = Array(Rhino.CopyObject(idSurface))
		Rhino.HideObjects ExtractWalls
		Exit Function
	Else
		ExtractWalls = Rhino.ExplodePolySurfaces(idSurface, vbFalse)
		Rhino.HideObjects ExtractWalls
		Exit Function
	End If
	ExtractWalls = Null
End Function

Function ResizeVector(vecIn, newLength)
	ResizeVector = vecIn
	Dim vecOut(1)

	vecOut(0) = Array(vecIn(0)(0), vecIn(0)(1), vecIn(0)(2))
	vecOut(1) = Array((vecIn(0)(0) + (vecIn(1)(0) - vecIn(0)(0)) * newLength), _
		(vecIn(0)(1) + (vecIn(1)(1) - vecIn(0)(1)) * newLength), _
		(vecIn(0)(2) + (vecIn(1)(2) - vecIn(0)(2)) * newLength))
	ResizeVector = vecOut
End Function

vikthor · December 24, 2016, 12:12pm

please!
I am currently performing this but I want to do the inflated shape.

anon55473861 · December 25, 2016, 11:55pm

@DavidRutten can you help?

vikthor · December 29, 2016, 12:51am

Hi
Por favor ayuda It’s a great script
@pascal @clement @Helvetosaur @DavidRutten
Long ago i use it now it does not work

I think the error is only on line 152, an array is missing

clement · December 29, 2016, 5:14am

Hi @vikthor, this script is from ancient Rhino 3 times and i do not even speak the language the prompts are written in

I think there are a few minor things wrong, eg. in line 94:

ShowObjects defWalls

should be:

Rhino.ShowObjects defWalls

But the major problem is that after Rhino 3, the Rhino.SurfaceNormal method in line 150 changed. In ancient times it returned 2 points as an array, the first one sitting on the surface, and the other was a normal added to this point with a length of 1. After Rhino 3 this method changed and now returns a normalized vector at the world origin.

To get something like the old behaviour i’ve changed something near line 150 and added the missing point on the surface (ptx) and added the normal Rhino 5 returns to the point on the surface, so the variable vecN now contains the normal like in Rhino 3. Note that i have added this line first, in the start section of the InflateSurface function:

Dim ptx

then later made this change for the surface normal:

...
uvCP = Rhino.SurfaceClosestPoint(idCopy, arrPoints(i))
vecN = Rhino.SurfaceNormal(idCopy, uvCP)
                    
' NEW VARIABLE 
ptx = Rhino.EvaluateSurface(idCopy, uvCP)
' NEW SURFACE NORMAL LIKE IN RHINO 3
vecN = Array(ptx, Rhino.VectorAdd(ptx, vecN))
...

the error you get in line 152 comes from this line for sure:

If Rhino.Distance(array(vecN(0), vecN(1))) <> 0 Then

this cannot work, since Rhino.Distance is expecting 2 points not an array. I changed it to:

If Rhino.Distance(vecN(0), vecN(1)) <> 0 Then

After some testing with a cube, the script seems to finish but takes a while. I am not sure if all these options still work, just tested with some simple boxes…

I would recommend to run it in Wireframe display mode to prevent the render mesh creation while it runs. I`ve added a few comments where i did the changes:

Inflate.rvb (9.1 KB)

@DavidRutten, i hope this is ok. Quite amazing what you did 14 years ago !

c.

DavidRutten · December 29, 2016, 11:03am

Thanks, looking at the script I felt pretty lost myself. I’m having a hard time getting back into VB.NET these days, let alone RhinoScript.

vikthor · December 29, 2016, 11:53am

Many thanks. @clement
I apologize for the inconvenience,
If the script was something old
It works perfect

I think I have air leaks on the polysurface

dinhchien2103 · February 17, 2023, 4:37am

please tell me how to set the code to do what you are doing with this inflatable