Perlin noise field

[tinram]

Perlin noise field generation.

Converted from Ron Valstar / Mario Klingemann's AS3 Class.

Can be useful for particle effects etc, although the aesthetic effects are better when anti-aliasing and filters are available.


Perlin.bi

Code: Select all

TYPE Perlin

	' Perlin Noise v.1.2 by Ron Valstar and Mario Klingemann
	' Converted from ActionScript3 to FreeBASIC by Tinram (Martin Latter) Jan 4 2011


	CONST AS INTEGER iOctaves = 4

	PRIVATE:

		AS INTEGER p(0 TO 511) = _
			{_
151,160,137,91,90,15,131,13,201,95,96,53,194,233,7,225,140,36,103,30,69,142,8,99,37,_
240,21,10,23,190,6,148,247,120,234,75,0,26,197,62,94,252,219,203,117,35,11,32,57,177,_
33,88,237,149,56,87,174,20,125,136,171,168,68,175,74,165,71,134,139,48,27,166,77,146,_
158,231,83,111,229,122,60,211,133,230,220,105,92,41,55,46,245,40,244,102,143,54,65,25,_
63,161,1,216,80,73,209,76,132,187,208,89,18,169,200,196,135,130,116,188,159,86,164,100,_
109,198,173,186,3,64,52,217,226,250,124,123,5,202,38,147,118,126,255,82,85,212,207,206,_
59,227,47,16,58,17,182,189,28,42,223,183,170,213,119,248,152,2,44,154,163,70,221,153,_
101,155,167,43,172,9,129,22,39,253,19,98,108,110,79,113,224,232,178,185,112,104,218,_
246,97,228,251,34,242,193,238,210,144,12,191,179,162,241,81,51,145,235,249,14,239,_
107,49,192,214,31,181,199,106,157,184,84,204,176,115,121,50,45,127,4,150,254,138,236,_
205,93,222,114,67,29,24,72,243,141,128,195,78,66,215,61,156,180,151,160,137,91,90,15,_
131,13,201,95,96,53,194,233,7,225,140,36,103,30,69,142,8,99,37,240,21,10,23,190,6,148,_
247,120,234,75,0,26,197,62,94,252,219,203,117,35,11,32,57,177,33,88,237,149,56,87,174,_
20,125,136,171,168,68,175,74,165,71,134,139,48,27,166,77,146,158,231,83,111,229,122,60,_
211,133,230,220,105,92,41,55,46,245,40,244,102,143,54,65,25,63,161,1,216,80,73,209,76,_
132,187,208,89,18,169,200,196,135,130,116,188,159,86,164,100,109,198,173,186,3,64,52,217,_
226,250,124,123,5,202,38,147,118,126,255,82,85,212,207,206,59,227,47,16,58,17,182,189,28,_
42,223,183,170,213,119,248,152,2,44,154,163,70,221,153,101,155,167,43,172,9,129,22,39,253,_
19,98,108,110,79,113,224,232,178,185,112,104,218,246,97,228,251,34,242,193,238,210,144,12,_
191,179,162,241,81,51,145,235,249,14,239,107,49,192,214,31,181,199,106,157,184,84,204,176,_
115,121,50,45,127,4,150,254,138,236,205,93,222,114,67,29,24,72,243,141,128,195,78,66,215,_
61,156,180}
 
                AS SINGLE aOctFreq(iOctaves) ' frequency per octave
                AS SINGLE aOctPers(iOctaves) ' persistence per octave
                AS SINGLE fPersistence = 0.5
                AS SINGLE fPersMax ' 1 / max persistence
                AS SINGLE fXoffset, fYoffset, fZoffset

                AS INTEGER iSeed = CINT(RND * 2147483647)
                AS INTEGER iInitialized = 0

                DECLARE SUB seedOffset()
                DECLARE SUB octFreqPers()

	PUBLIC:

		DECLARE FUNCTION noise(BYVAL fX2 AS SINGLE, BYVAL fY2 AS SINGLE = 1, BYVAL fZ2 AS SINGLE = 1) AS SINGLE
		DECLARE DESTRUCTOR()

END TYPE


FUNCTION Perlin.noise(BYVAL fX2 AS SINGLE, BYVAL fY2 AS SINGLE = 1, BYVAL fZ2 AS SINGLE = 1) AS SINGLE

	IF NOT iInitialized THEN ' ditched original init fn
		this.seedOffset()
		this.octFreqPers()
		this.iInitialized = 1
	END IF

	DIM AS SINGLE fFreq, fPers, fX, fY, fZ, fU, fV, fW, fX1, fY1, fZ1, fS = 0
	DIM AS SINGLE fG1, fG2, fG3, fG4, fG5, fG6, fG7, fG8
	DIM AS INTEGER iX3, iY3, iZ3, iXf, iYf, iZf, iA, iB, iAA, iAB, iBA, iBB, iHash

	fX2 += this.fXoffset
	fY2 += this.fYoffset
	fZ2 += this.fZoffset

	FOR i AS INTEGER = 0 TO this.iOctaves

		fFreq = this.aOctFreq(i)
		fPers = this.aOctPers(i)

		fX = fX2 * fFreq
		fY = fY2 * fFreq
		fZ = fZ2 * fFreq

		iXf = INT(fX) ' using INT() as Math.floor(), as in the AS3
		iYf = INT(fY)
		iZf = INT(fZ)

		iX3 = iXf AND 255
		iY3 = iYf AND 255
		iZ3 = iZf AND 255

		fX -= iXf
		fY -= iYf
		fZ -= iZf

		fU = fX * fX * fX * (fX * (fX * 6 - 15) + 10)
		fV = fY * fY * fY * (fY * (fY * 6 - 15) + 10)
		fW = fZ * fZ * fZ * (fZ * (fZ * 6 - 15) + 10)

		iA = p(iX3) + iY3
		iAA = p(iA) + iZ3
		iAB = p(iA + 1) + iZ3
		iB = p(iX3 + 1) + iY3
		iBA = p(iB) + iZ3
		iBB = p(iB + 1) + iZ3

		fX1 = fX - 1
		fY1 = fY - 1
		fZ1 = fZ - 1

		iHash = p(iBB + 1) AND 15
		fG1 = ( IIF(iHash AND 1 = 0, IIF(iHash < 8, fX1, fY1), IIF(iHash < 8, -fX1, -fY1)) ) + ( IIF(iHash AND 2 = 0, IIF(iHash < 4, fY1, IIF(iHash = 12, fX1, fZ1)), IIF(iHash < 4, -fY1, IIF(iHash = 14, -fX1, -fZ1))) )
		' original: fG1 = ((iHash & 1) == 0 ? (iHash < 8 ? fX1 : fY1) : (iHash < 8 ? -fX1 : -fY1)) + ((iHash & 2) == 0 ? iHash < 4 ? fY1 : (iHash == 12 ? fX1 : fZ1) : iHash < 4 ? -fY1 : (iHash == 14 ? -fX1 : -fZ1));

		iHash = p(iAB + 1) AND 15
		fG2 = ( IIF(iHash AND 1 = 0, IIF(iHash < 8, fX, fY1), IIF(iHash < 8, -fX, -fY1)) ) + ( IIF(iHash AND 2 = 0, IIF(iHash < 4, fY1, IIF(iHash = 12, fX, fZ1)), IIF(iHash < 4, -fY1, IIF(iHash = 14, -fX, -fZ1))) )

		iHash = p(iBA + 1) AND 15
		fG3 = ( IIF(iHash AND 1 = 0, IIF(iHash < 8, fX1, fY), IIF(iHash < 8, -fX1, -fY)) ) + ( IIF(iHash AND 2 = 0, IIF(iHash < 4, fY1, IIF(iHash = 12, fX1, fZ1)), IIF(iHash < 4, -fY, IIF(iHash = 14, -fX1, -fZ1))) )

		iHash = p(iAA + 1) AND 15
		fG4 = ( IIF(iHash AND 1 = 0, IIF(iHash < 8, fX, fY), IIF(iHash < 8, -fX, -fY)) ) + ( IIF(iHash AND 2 = 0, IIF(iHash < 4, fY, IIF(iHash = 12, fX, fZ1)), IIF(iHash < 4, -fY, IIF(iHash = 14, -fX, -fZ1))) )

		iHash = p(iBB) AND 15
		fG5 = ( IIF(iHash AND 1 = 0, IIF(iHash < 8, fX1, fY1), IIF(iHash < 8, -fX1, -fY1)) ) + ( IIF(iHash AND 2 = 0, IIF(iHash < 4, fY1, IIF(iHash = 12, fX1, fZ)), IIF(iHash < 4, -fY1, IIF(iHash = 14, -fX1, -fZ))) )

		iHash = p(iAB) AND 15
		fG6 = ( IIF(iHash AND 1 = 0, IIF(iHash < 8, fX, fY1), IIF(iHash < 8, -fX, -fY1)) ) + ( IIF(iHash AND 2 = 0, IIF(iHash < 4, fY1, IIF(iHash = 12, fX, fZ)), IIF(iHash < 4, -fY1, IIF(iHash = 14, -fX, -fZ))) )

		iHash = p(iBA) AND 15
		fG7 = ( IIF(iHash AND 1 = 0, IIF(iHash < 8, fX1, fY), IIF(iHash < 8, -fX1, -fY)) ) + ( IIF(iHash AND 2 = 0, IIF(iHash < 4, fY, IIF(iHash = 12, fX1, fZ)), IIF(iHash < 4, -fY, IIF(iHash = 14, -fX1, -fZ))) )

		iHash = p(iAA) AND 15
		fG8 = ( IIF(iHash AND 1 = 0, IIF(iHash < 8, fX, fY), IIF(iHash < 8, -fX, -fY)) ) + ( IIF(iHash AND 2 = 0, IIF(iHash < 4, fY, IIF(iHash = 12, fX, fZ)), IIF(iHash < 4, -fY, IIF(iHash = 14, -fX, -fZ))) )

		fG2 += fU * (fG1 - fG2)
		fG4 += fU * (fG3 - fG4)
		fG6 += fU * (fG5 - fG6)
		fG8 += fU * (fG7 - fG8)
		fG4 += fV * (fG2 - fG4)
		fG8 += fV * (fG6 - fG8)

		fS += (fG8 + fW * (fG4 - fG8)) * fPers

	NEXT i

	RETURN (fS * this.fPersMax + 1) * 0.5

END FUNCTION


SUB Perlin.OctFreqPers()

	DIM AS SINGLE fFreq, fPers
	this.fPersMax = 0

	FOR i AS INTEGER = 1 TO this.iOctaves
		fFreq = 2 ^ i
		fPers = fPersistence ^ i
		this.fPersMax += fPers
		aOctFreq(UBOUND(aOctFreq) - i) = fFreq ' was aOctFreq.push(fFreq) ' quick kludge, hmm...
		aOctPers(UBOUND(aOctPers) - i) = fPers
	NEXT i

	this.fPersMax = 1 / this.fPersMax

END SUB


SUB Perlin.seedOffset()

	this.fXoffset = this.iSeed = (this.iSeed * 16807) MOD 2147483647
	this.fYoffset = this.iSeed = (this.iSeed * 16807) MOD 2147483647
	this.fZoffset = this.iSeed = (this.iSeed * 16807) MOD 2147483647

END SUB


DESTRUCTOR Perlin()

	ERASE this.p ' erase p array

END DESTRUCTOR

quick example:

Code: Select all

' example Perlin noise field generation based on a Processing script by Kyle McDonald


#include "Perlin.bi"

' -------------------------------------------------------------------------------------

FUNCTION normalize(value AS SINGLE, minimum AS SINGLE, maximum AS SINGLE) AS SINGLE
	RETURN (value - minimum) / (maximum - minimum)
END FUNCTION


FUNCTION lerp(minimum AS SINGLE, maximum AS SINGLE, normValue AS SINGLE) AS SINGLE
	RETURN minimum + (maximum - minimum) * normValue
END FUNCTION

	' from Keith Peters' AS3
' -------------------------------------------------------------------------------------


CONST AS INTEGER iScreenDim = 500
CONST AS SINGLE c2PI =  4 * ATN(1) * 2 ' 2PI to separate u-noise from v-noise

RANDOMIZE (TIMER * 5000), 3


SCREENRES iScreenDim, iScreenDim, 32

DIM AS INTEGER iNumPoints = 3000
DIM AS INTEGER iComplexity = 2 ' wind complexity
DIM AS SINGLE fTimeSpeed = 0.02 ' wind variation speed
DIM SHARED AS SINGLE fMaxMass = 0.8 ' max pollen mass
DIM AS SINGLE fT, fX, fY, fNormX, fNormY, fU, fV, fSpeed
DIM AS STRING XClicked = CHR(255) + "k"
DIM AS Perlin oNoise1, oNoise2, oNoise3


TYPE Particle

	AS SINGLE x = RND * iScreenDim
	AS SINGLE y = RND * iScreenDim
	AS SINGLE mass = RND * fMaxMass
	AS UINTEGER col = RGB(RND * 255, RND * 255, RND * 255)

END TYPE


DIM AS Particle aParticles(iNumPoints)



DO

	fT = 30 * fTimeSpeed ' was AS3 frameRate

	FOR i AS INTEGER = 0 TO iNumPoints

		fX = aParticles(i).x
		fY = aParticles(i).y

		fNormX = normalize(fX, 0, iScreenDim)
		fNormY = normalize(fY, 0, iScreenDim)

		fU = oNoise1.noise(fT + c2PI, fNormX * iComplexity + c2PI, fNormY * iComplexity + c2PI)
		fV = oNoise2.noise(fT - c2PI, fNormX * iComplexity - c2PI, fNormY * iComplexity + c2PI)

		fSpeed = (1 + oNoise3.noise(fT, fU, fV)) / aParticles(i).mass

		fX += lerp(-fSpeed, fSpeed, fU)
		fY += lerp(-fSpeed, fSpeed, fV)

		IF fX < 0 THEN fX = RND * iScreenDim : fY = RND * iScreenDim
		IF fX > iScreenDim THEN fX = RND * iScreenDim : fY = RND * iScreenDim
		IF fY < 0 THEN fX = RND * iScreenDim : fY = RND * iScreenDim
		IF fY > iScreenDim THEN fX = RND * iScreenDim : fY = RND * iScreenDim

		aParticles(i).x = fX
		aParticles(i).y = fY

		PSET(fX, fY), aParticles(i).col

	NEXT i

LOOP UNTIL MULTIKEY(&h01) OR INKEY = XClicked

[dodicat]

Perlin noise field generation.

Converted from Ron Valstar / Mario Klingemann's AS3 Class.

Hi tinram
This works well on fb 18.5 (Linux).
However I get a crash on fb 21.1 (Win XP) at line 68
fSpeed = (1 + oNoise3.noise(fT, fU, fV)) / aParticles(i).mass

The oNoise3.noise bit seems to be the problem, if I substitute either of the other noises in this line I get a result.
Cheers.

[tinram]

Thanks Dodicat.

I coded this on FB 0.21.1 on Win7 - just tested on FB 0.21.1 on XP and the crash does exist due to oNoise3.noise(). Win7 compiles and runs this code from the forum fine.

Your fix is good - the resulting field is virtually the same.

I'll try to find a fix for XP later at home.

[tinram]

Compiled the above code on an XP machine with a graphics card and FB 0.21.1, and the resulting exe runs okay.

The XP I used in the last post was a nasty Celeron M laptop with onboard graphics.

I wonder if the problem can be related to Windows drivers and hardware? The worst Windows PC I have access to (a 2005 Celeron desktop with abysmal onboard graphics) will compile but not run any FreeBASIC GUI programs. Interesting that Linux FB 0.18.5 has no problems.

[h4tt3n]

Runs fine on my laptop with amd dual core and windows vista. Looks good btw. :-)

[tinram]

Thank you h4tt3n :)

[h4tt3n]

Your welcome. Btw it remind me of this small code I made a while back.

Code: Select all

'******************************************************************************'
'
'   (Press esc to quit)
'
'******************************************************************************'

''  set constants. experiment with these and see how the simulation reacts.
Const Time_Scale  	= 10           	''  time step
Const Num_Planets 	= 20000            	''  number of planets
Const Num_FociPts 	= 10            		''  number of foci points
Const Scrn_Wid 			= 600							''	screen width
Const Scrn_Hgt 			= 600							''	screen height
Const Scrn_Border		= 100							''	screen border

''  define types
Type Vector_Type
  As Single X, Y
End Type

Type Focus_Point
	As Integer Direction
	As Integer Magnitude
	As Vector_Type Psn
	As Vector_Type Vel
End Type

Type Planet_Type
  As Integer Col				''	color
  As Vector_Type Vel		''	velocity vector
  As Vector_Type Psn		''	position vector
  As Single Mass				''	mass 
  As Single Density			''	density
  As Single Radius			''	radius
End Type 

''  dimension variables
Dim As Vector_Type Dist, Normalized_Dist
Dim As Planet_Type Planet(Num_Planets)
Dim As Focus_Point Focus(Num_FociPts)
Dim As String X_Clicked = Chr(255)+"k"
Dim As Integer a, b, mx, my
Dim As Single Distance, Distance_Squared, Min_Distance, Force, Spawn_distance, Spawn_Angle

''  set screen width, height and bit depth
ScreenRes Scrn_Wid, Scrn_Hgt, 16

''  use timer to generate random numbers
Randomize

For a = Lbound(Focus) To Ubound(Focus)
  With Focus(a) 
  	If Rnd-Rnd < 0 Then .Direction = -1 Else .Direction = 1
  	.Magnitude = Rnd * 10
    .Psn.X  = Scrn_Border + Rnd*(scrn_wid-2*Scrn_Border)
    .Psn.Y  = Scrn_Border + Rnd*(scrn_hgt-2*Scrn_Border)
  End With 
Next 

For a = Lbound(Planet) To Ubound(Planet)
  With Planet(a) 
    .Psn.X    = Rnd*scrn_wid
    .Psn.Y    = Rnd*scrn_hgt
    .Col      = RGB(48+Rnd*208, 48+Rnd*208, 48+Rnd*208)
  End With 
Next 

''  main program loop
Do 
	
	GetMouse mx, my
	
	Focus(1).psn.x = mx
	Focus(1).psn.y = my
  
  ''  calculate gravitational force 
  ''  do colision detection
  For a = LBound(Focus) To Ubound(Focus)
  	
  	For b = Lbound(Planet) To Ubound(Planet)
      
      ''  find distance between planet 'a' and 'b' (Pythagoras)
      Dist.X = Focus(a).Psn.X-Planet(b).Psn.X
      Dist.Y = Focus(a).Psn.Y-Planet(b).Psn.Y
      Distance_Squared = Dist.X*Dist.X+Dist.Y*Dist.Y
      	
      ''	find the normalized distance vector
      ''	(since we normalize with distance squared
      ''	 we get an implicit 1/distance in our algo)
      Normalized_Dist.X = Dist.X/Distance_Squared
      Normalized_Dist.Y = Dist.Y/Distance_Squared
      
      Planet(b).vel.x += Focus(a).Direction * Normalized_Dist.y * Focus(a).Magnitude
      Planet(b).vel.y -= Focus(a).Direction * Normalized_Dist.x * Focus(a).Magnitude
        
    Next b
  Next a
  
  ''  update acceleration, velocity, and Position of point masses
  ''  (using the symplectic Euler 1st order integration algorithm)
  For a = Lbound(Planet) To Ubound(Planet)
    With Planet(a)
      
      .Psn.X += .Vel.X*Time_Scale
      .Psn.Y += .Vel.Y*Time_Scale
      
      .vel.x = 0
      .vel.y = 0
      
    End With
  Next
  
  ''  display graphics
  ScreenLock
    
    ''  clear screen
    Cls
    
		For a = Lbound(Focus) To Ubound(Focus)
		  With Focus(a) 
				Circle(.Psn.X, .Psn.Y), .Magnitude, RGB(255, 255, 0),,, 1
		  End With 
		Next 
    
    ''  draw planets
    For a = Lbound(Planet) To Ubound(Planet)
      With Planet(a)
        Pset(.Psn.X, .Psn.Y), .Col
      End With
    Next a
    
  ScreenUnlock
  
  ''	give the computer a break
  Sleep 10, 1
  
Loop Until Multikey(1) Or Inkey = X_Clicked

End

[tinram]

Wow, your fluid simulations are superb.

Yes, the effects are similar, especially if the CLS ~116 is commented out.

[dodicat]

Wow, your fluid simulations are superb.

Yes, the effects are similar, especially if the CLS ~116 is commented out.

@h4tt3n
Ok on my modest machine, p3, winXp booted at the moment.
@ tinram/h4tt3n
Nice fluid simulators, I havn't tried this stuff myself, not as such.
But I've tried this stuff, maybe too often:

http://www.freebasic.net/forum/viewtopi ... =brown+ale

[Oz]

Hey Tinram,

I found a fix for an error I was getting; change:

AS INTEGER p(1 TO 512)

to

AS INTEGER p(0 TO 512)

In your conversion from ActionScript, you must have missed that (since AS arrays start at index 0).

Take care,
-Alex

PS: Otherwise, this is really neat, and I think I could use it in a project I'm making.

[Mihail_B]

AS INTEGER p(1 TO 512)
to
AS INTEGER p(0 TO 512)

-- works for me with this fix (win7)--

------

this all so awesome ! cool !

[tinram]

Thanks Oz for spotting this - you're correct, p should start at 0.

[counting_pine]

Should it also perhaps end at 511? a(0 to n-1) is a common idiom to match C's a[n] array declarations.

[tinram]

Yes, 512 array elements, starting at 0.