Perlin noise field

Source-code only - please, don't post questions here.
tinram
Posts: 86
Joined: Nov 30, 2006 13:35
Location: UK

Perlin noise field

Postby tinram » Jan 10, 2011 19:49

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
Last edited by tinram on Nov 12, 2011 9:55, edited 2 times in total.
dodicat
Posts: 4003
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Perlin noise field

Postby dodicat » Jan 11, 2011 12:27

tinram wrote: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
Posts: 86
Joined: Nov 30, 2006 13:35
Location: UK

Postby tinram » Jan 11, 2011 15:57

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
Posts: 86
Joined: Nov 30, 2006 13:35
Location: UK

Postby tinram » Jan 11, 2011 19:47

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
Posts: 623
Joined: Oct 22, 2005 21:12
Location: Denmark

Postby h4tt3n » Jan 11, 2011 20:05

Runs fine on my laptop with amd dual core and windows vista. Looks good btw. :-)
tinram
Posts: 86
Joined: Nov 30, 2006 13:35
Location: UK

Postby tinram » Jan 11, 2011 21:34

Thank you h4tt3n :)
h4tt3n
Posts: 623
Joined: Oct 22, 2005 21:12
Location: Denmark

Postby h4tt3n » Jan 11, 2011 22:40

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
Posts: 86
Joined: Nov 30, 2006 13:35
Location: UK

Postby tinram » Jan 11, 2011 22:54

Wow, your fluid simulations are superb.

Yes, the effects are similar, especially if the CLS ~116 is commented out.
dodicat
Posts: 4003
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Jan 11, 2011 23:09

tinram wrote: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
Posts: 585
Joined: Jul 02, 2005 14:21
Location: Waterloo, Ontario, Canada
Contact:

Postby Oz » Nov 09, 2011 15:58

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
Posts: 261
Joined: Jan 29, 2008 11:20
Location: Romania
Contact:

Postby Mihail_B » Nov 11, 2011 12:24

Oz wrote: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
Posts: 86
Joined: Nov 30, 2006 13:35
Location: UK

Postby tinram » Nov 11, 2011 17:42

Thanks Oz for spotting this - you're correct, p should start at 0.
counting_pine
Site Admin
Posts: 5713
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Postby counting_pine » Nov 11, 2011 21:11

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
Posts: 86
Joined: Nov 30, 2006 13:35
Location: UK

Postby tinram » Nov 12, 2011 9:55

Yes, 512 array elements, starting at 0.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest