Demo 3d - Ocean

Everything related to 3D programming
User avatar
DK_PETER
Addict
Addict
Posts: 898
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Re: Demo 3d - Ocean

Post by DK_PETER »

Yesterday, I needed some ocean and I recalled this excellent
piece of code made by pf_shadoko. It is way better than the
one in Purebasic. So I've made it into a reusable module.
It has some quirks (doesn't look right) and if someone can spot the error or missing/misplaced
variables - it would be appreciated. I've gone blind looking at the code - for now.

Code: Select all

DeclareModule Sea
  
  Declare.i InitWater(l = 128, wamp = 8, wlissage = 0)
  Declare.i UpdateSea()
  Declare.i Amplitude(valu = 1)
  Declare.i Smoothing(valu = 1)
  
EndDeclareModule

Module Sea
  Global wlarg = 128, wlarg1 = wlarg-1, awamp, wamp=8, awlissage, wlissage=0
  Global Dim t.w(wlarg1,wlarg1)
  Global Dim tf.f(wlarg1,wlarg1)
  Global Dim atf.f(wlarg1,wlarg1)
  Global Dim MeshData.PB_MeshVertex(0)
  Global Dim ewater.i(81)
  
  Procedure.f Mini(v1.f,v2.f)
    If v1<v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
  EndProcedure
  
  Procedure.f Maxi(v1.f,v2.f)
    If v1>v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
  EndProcedure
  
  Procedure limite(V, i, s)
    If V < i :v=i:EndIf
    If V > s :v=s:EndIf
    ProcedureReturn V
  EndProcedure
  
  Procedure carte(Array t.w(2), dx.w, dy.w, Re.w)
    Protected i,j,ii,jj,im,jm,ip,jp,n,d,dd,dx1=dx-1,dy1=dy-1,l,ap,ap2,R, rr
    Macro calcij(v)
      im=(i - v) & dx1
      jm=(j - v) & dy1
      ip=(i + v) & dx1
      jp=(j + v) & dy1
    EndMacro
    n = 1<<re
    dd=mini(dx,dy) / n: If dd<1:dd=1:EndIf
    Dim t.w(dy1, dx1)
    ap = $1fff:ap2=ap>>1
    For jj = 0 To dy/dd - 1:j=jj*dd: For ii = 0 To dx/dd - 1:i=ii*dd: t(j,i) = Random(ap)-ap2: Next: Next
    l = dd
    While dd > 1
      d = dd / 2
      rr = ap * Sqr(2): R = rr / 2
      For jj = 0 To dy/dd - 1  :j=jj*dd+d
        For ii = 0 To dx/dd - 1:i=ii*dd+d
          calcij(d)
          t(j,i) = (t(jm,im) + t(jm,ip) + t(jp,ip) + t(jp,im)) / 4 + Random(rr) - R * 2
        Next
      Next
      rr = ap: R = rr / 2
      For jj = 0 To dy/dd - 1  :j=jj*dd
        For ii = 0 To dx/dd - 1:i=ii*dd+d
          calcij(d)
          t(j,i) = (t(j,im) + t(j,ip) + t(jm,i) + t(jp,i)) / 4 + Random(rr) - R * Cos(2)
        Next
      Next
      For jj = 0 To dy/dd - 1  :j=jj*dd+d
        For ii = 0 To dx/dd - 1:i=ii*dd
          calcij(d)
          t(j,i) = (t(j,im) + t(j,ip) + t(jm,i) + t(jp,i)) / 4 + Random(rr) - R * 2
        Next
      Next
      l >> 1
      dd>>1
      ap >> 1
    Wend
  EndProcedure
  
  Procedure t2norme(Array t.w(2),dmin.w,dmax.w)
    Protected smin.w,smax.w,dx1,dy1,i,j,sr,dr
    dy1 = ArraySize(t(), 1)
    dx1 = ArraySize(t(), 2)
    smax = -32768
    smin =  32767
    For j=0 To dy1
      For i=0 To dx1
        If t(j,i)>smax : smax=t(j,i): EndIf
        If t(j,i)<smin : smin=t(j,i): EndIf
      Next
    Next
    sr=smax-smin
    dr=dmax-dmin
    
    For j=0 To dy1
      For i=0 To dx1
        t(j,i)=(t(j,i)-smin)*dr/sr+dmin
      Next
    Next
  EndProcedure
  
  Procedure Tmodulo(Array T(1), max, marge)
    Protected i,d=max-(marge+1)/2
    Dim T(max + 2*marge+2): For i = 0 To max + 2*marge+2: T(i) = (i+d) % (max+1): Next
  EndProcedure
  
  Procedure lisser2D(Array s.w(2),di.w, dj.w,pass=1)
    If di=0 And dj=0:ProcedureReturn:EndIf
    Protected i,j,k,dii,djj,dx,dy,dij,tx
    dx = ArraySize(s(), 2):di=mini(di,dx)
    dy = ArraySize(s(), 1):dj=mini(dj,dy)
    Dim d.w(dy,dx)
    dii=di+1
    djj=dj+1
    dij = dii * djj
    Dim lx(0): Tmodulo (lx(), dx, di)
    Dim ly(0): Tmodulo (ly(), dy, dj)
    For k=1 To pass
      Dim ty.l(dx)
      For j = 0 To djj - 1: For i = 0 To dx: ty(i) + s(ly(j),i): Next: Next   
      For j = 0 To dy
        For i = 0 To dx: ty(i) + s(ly(djj+j),i) - s(ly(j),i): Next
        tx=0:For i = 0 To dii-1: tx+ty(lx(i)): Next
        For i = 0 To dx: tx + ty(lx(dii+i)) - ty(lx(i) ): d(j,i) = tx / dij: Next
      Next
      CopyArray(d(),s())
    Next
  EndProcedure
  
  Procedure Amplitude(valu = 1)
    wamp + Valu 
    wamp = limite(wamp,1,16)
  EndProcedure
  
  Procedure Smoothing(valu = 1)
    wlissage + Valu
    wlissage = limite(wlissage,0,8)
  EndProcedure

  Procedure initwater(l = 128, wamp = 8, wlissage = 0)
    Define foam, j,  z, x, y = 0
    
    ReDim tf.f(wlarg1, wlarg1)
    ReDim atf.f(wlarg1, wlarg1)
    RandomSeed(1)
    carte(t(), wlarg, wlarg, 1)
    lisser2d(t(), wlissage, wlissage)
    t2norme(t(), -wamp * 64, wamp * 64)
    awamp = wamp
    awlissage = wlissage
   
    CreateTexture(0,512,512)
    StartDrawing(TextureOutput(0))
    DrawingMode(#PB_2DDrawing_AllChannels  )
    DrawingMode(#PB_2DDrawing_AlphaBlend!#PB_2DDrawing_Gradient)
    GradientColor(0,$ff6666)
    GradientColor(0.2,$ff885500)
    GradientColor(0.4,$ff443300)
    GradientColor(0.6,$ff222200)
    GradientColor(1.0,$ff2222000)
    CircularGradient(256,160,600)     
    Box(0,0,512,512)
    StopDrawing()
    CreateMaterial(0, TextureID(0))
    AddMaterialLayer(0, TextureID(foam), #PB_Material_Add)
    ScrollMaterial(0, 0.006, 0.033, #PB_Material_Animated, 1)
    SetMaterialAttribute(0,#PB_Material_EnvironmentMap,#PB_Material_ReflectionMap)

    ;------------------- océan
    CreatePlane(0, wlarg+1, wlarg+1, wlarg, wlarg, 1, 1)
    For i=-4 To 4
      For j=-4 To 4
        If IsEntity(ewater(y)) : FreeEntity(ewater(y)) : EndIf  
          ewater(y) = CreateEntity(#PB_Any ,MeshID(0),MaterialID(0),i*(wlarg+1),0,j*(wlarg+1))
          y + 1
        ;CreateEntity(-1 ,MeshID(0),MaterialID(0),i*(wlarg+1),0,j*(wlarg+1))
      Next
    Next

    GetMeshData(0, 0, MeshData(), #PB_Mesh_Vertex,0, MeshVertexCount(0,0)-1)
  EndProcedure
  
  Procedure.i UpdateSea()
    Static.f dif
    Static i1, i2, di, dj, cpt, cv
    Define i, j, jj, c, v
    If wamp<>awamp Or wlissage<>awlissage:initwater(wlarg,wamp,wlissage):EndIf
    ;------------------- wave movement
    dif+0.1:di=dif
    For j=0 To wlarg1
      For i=0 To wlarg1
        i1=(i-di) & wlarg1
        i2=(i+di) & wlarg1
        tf(i,j)+((t(i1,j)+t(wlarg1-i2,wlarg1-j))/128-atf(i,j))*0.1       
      Next
    Next
    CopyArray(tf(),atf())
    cv=0
    For j=0 To wlarg
      jj=j & wlarg1
      For i=0 To wlarg
        MeshData(cv)\y = tf(jj, i & wlarg1) 
        cv+1
      Next
    Next
    SetMeshData(0,0, MeshData(), #PB_Mesh_Vertex, 0, MeshVertexCount(0,0)-1)
    NormalizeMesh(0)
    ProcedureReturn #True
  EndProcedure
  
EndModule

InitEngine3D()
InitSprite()
InitKeyboard()

OpenWindow(0, 0, 0, 800, 600, "Waves made by pf Shadoko - moduled by DK_PETER", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
OpenWindowedScreen(WindowID(0), 0, 0, 800, 600)
CreateCamera(0, 0, 0, 100, 100)
MoveCamera(0, 0, 10, 0)

Sea::InitWater()

Repeat
  Repeat : ev = WindowEvent() : Until ev = 0
  ExamineKeyboard()
  If KeyboardPushed(#PB_Key_A) ; Amplitude
    Sea::Amplitude()
  ElseIf  KeyboardReleased(#PB_Key_S) ; Smoothing
    Sea::Smoothing()
  EndIf
  ret = Sea::UpdateSea()
  RenderWorld()
  
  FlipBuffers()
  
Until KeyboardReleased(#PB_Key_Escape)
Current configurations:
Ubuntu 20.04/64 bit - Window 10 64 bit
Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 281
Joined: Thu Jul 09, 2015 9:07 am

Re: Demo 3d - Ocean

Post by pf shadoko »

I'm going to do an update
User avatar
DK_PETER
Addict
Addict
Posts: 898
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Re: Demo 3d - Ocean

Post by DK_PETER »

pf shadoko wrote:I'm going to do an update
Ohhh yes, please! 8)
Current configurations:
Ubuntu 20.04/64 bit - Window 10 64 bit
Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
User avatar
DK_PETER
Addict
Addict
Posts: 898
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Re: Demo 3d - Ocean

Post by DK_PETER »

Until pf shadoko comes with more excellent magic, here's an updated module
version. It looks better now.

The example requires the following image: Put it at the same location as the code.

https://www.dropbox.com/s/lb0a87btel1vaup/foam.png?dl=0

Edit - again. Add layer error fixed

Code: Select all

DeclareModule Sea
  Declare.i InitWater(l = 128, wamp = 8, wlissage = 0)
  Declare.i UpdateSea()
  Declare.i AddAmplitude(valu = 1)
  Declare.i AddSmoothing(valu = 1)
  Declare.i SubAmplitude(valu = -1)
  Declare.i SubSmoothing(valu = -1)
  Declare.i UseBaseWaterImage(Image.i = -1)
  Declare.i AddTextureLayer(Texture.i, Mode = #PB_Material_Add)
  Declare.i RemoveTextureLayer()
  Declare.i ScrollLayer(Layer, xdir.f = 0.0, ydir.f = 0.0)
  Declare.i ScaleLayer(Layer, ScaleWidth.f = 1, ScaleHeight.f = 1)
EndDeclareModule

Module Sea
  #MAXLAYER = 7 
  Global wlarg = 128, wlarg1 = wlarg-1, awamp, wamp=8, awlissage, wlissage=0
  Global Dim t.w(wlarg1,wlarg1)
  Global Dim tf.f(wlarg1,wlarg1)
  Global Dim atf.f(wlarg1,wlarg1)
  Global Dim MeshData.PB_MeshVertex(0)
  Global Dim ewater.i(81)
  Global mesh.i, watermat.i = -1, BaseTexture.i = -1, BaseImage.i = -1, CurLayer.i = 0
  
  Structure move
    xdir.f
    ydir.f
  EndStructure 
  
  Structure scale
    scalewidth.f
    scaleheight.f
  EndStructure
  
  Structure TextureLayer
    id.i
    mode.i
    mov.move
    sc.scale
  EndStructure
  Global Dim txx.TextureLayer(#MAXLAYER)  

  Procedure.f Mini(v1.f,v2.f)
    If v1<v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
  EndProcedure
 
  Procedure.f Maxi(v1.f,v2.f)
    If v1>v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
  EndProcedure
 
  Procedure limite(V, i, s)
    If V < i :v=i:EndIf
    If V > s :v=s:EndIf
    ProcedureReturn V
  EndProcedure
 
  Procedure carte(Array t.w(2), dx.w, dy.w, Re.w)
    Protected i,j,ii,jj,im,jm,ip,jp,n,d,dd,dx1=dx-1,dy1=dy-1,l,ap,ap2,R, rr
    Macro calcij(v)
      im=(i - v) & dx1
      jm=(j - v) & dy1
      ip=(i + v) & dx1
      jp=(j + v) & dy1
    EndMacro
    n = 1<<re
    dd=mini(dx,dy) / n: If dd<1:dd=1:EndIf
    Dim t.w(dy1, dx1)
    ap = $1fff:ap2=ap>>1
    For jj = 0 To dy/dd - 1:j=jj*dd: For ii = 0 To dx/dd - 1:i=ii*dd: t(j,i) = Random(ap)-ap2: Next: Next
    l = dd
    While dd > 1
      d = dd / 2
      rr = ap * Sqr(2): R = rr / 2
      For jj = 0 To dy/dd - 1  :j=jj*dd+d
        For ii = 0 To dx/dd - 1:i=ii*dd+d
          calcij(d)
          t(j,i) = (t(jm,im) + t(jm,ip) + t(jp,ip) + t(jp,im)) / 4 + Random(rr) - R * 2
        Next
      Next
      rr = ap: R = rr / 2
      For jj = 0 To dy/dd - 1  :j=jj*dd
        For ii = 0 To dx/dd - 1:i=ii*dd+d
          calcij(d)
          t(j,i) = (t(j,im) + t(j,ip) + t(jm,i) + t(jp,i)) / 4 + Random(rr) - R * Cos(2)
        Next
      Next
      For jj = 0 To dy/dd - 1  :j=jj*dd+d
        For ii = 0 To dx/dd - 1:i=ii*dd
          calcij(d)
          t(j,i) = (t(j,im) + t(j,ip) + t(jm,i) + t(jp,i)) / 4 + Random(rr) - R * Sin(2)
        Next
      Next
      l >> 1
      dd>>1
      ap >> 1
    Wend
  EndProcedure
 
  Procedure t2norme(Array t.w(2),dmin.w,dmax.w)
    Protected smin.w,smax.w,dx1,dy1,i,j,sr,dr
    dy1 = ArraySize(t(), 1)
    dx1 = ArraySize(t(), 2)
    smax = -32768
    smin =  32767
    For j=0 To dy1
      For i=0 To dx1
        If t(j,i)>smax : smax=t(j,i): EndIf
        If t(j,i)<smin : smin=t(j,i): EndIf
      Next
    Next
    sr=smax-smin
    dr=dmax-dmin
   
    For j=0 To dy1
      For i=0 To dx1
        t(j,i)=(t(j,i)-smin)*dr/sr+dmin
      Next
    Next
  EndProcedure
 
  Procedure Tmodulo(Array T(1), max, marge)
    Protected i,d=max-(marge+1)/2
    Dim T(max + 2*marge+2): For i = 0 To max + 2*marge+2: T(i) = (i+d) % (max+1): Next
  EndProcedure
 
  Procedure lisser2D(Array s.w(2),di.w, dj.w,pass=1)
    If di=0 And dj=0:ProcedureReturn:EndIf
    Protected i,j,k,dii,djj,dx,dy,dij,tx
    dx = ArraySize(s(), 2):di=mini(di,dx)
    dy = ArraySize(s(), 1):dj=mini(dj,dy)
    Dim d.w(dy,dx)
    dii=di+1
    djj=dj+1
    dij = dii * djj
    Dim lx(0): Tmodulo (lx(), dx, di)
    Dim ly(0): Tmodulo (ly(), dy, dj)
    For k=1 To pass
      Dim ty.l(dx)
      For j = 0 To djj - 1: For i = 0 To dx: ty(i) + s(ly(j),i): Next: Next   
      For j = 0 To dy
        For i = 0 To dx: ty(i) + s(ly(djj+j),i) - s(ly(j),i): Next
        tx=0:For i = 0 To dii-1: tx+ty(lx(i)): Next
        For i = 0 To dx: tx + ty(lx(dii+i)) - ty(lx(i) ): d(j,i) = tx / dij: Next
      Next
      CopyArray(d(),s())
    Next
  EndProcedure
 
  Procedure AddAmplitude(valu = 1)
    wamp + Valu
    wamp = limite(wamp,1,16)
  EndProcedure
 
  Procedure AddSmoothing(valu = 1)
    wlissage + Valu
    wlissage = limite(wlissage,0,8)
  EndProcedure

  Procedure SubAmplitude(valu = -1)
    wamp + Valu
    wamp = limite(wamp,1,16)
  EndProcedure
 
  Procedure SubSmoothing(valu = -1)
    wlissage + Valu
    wlissage = limite(wlissage,0,8)
  EndProcedure
  
  Procedure.i UseBaseWaterImage(Image.i = -1)
    If IsImage(Image)
      BaseImage = Image
    Else
      If IsImage(BaseImage) : FreeImage(BaseImage) : EndIf
      BaseImage = -1
    EndIf
  EndProcedure
  
  Procedure.i ScrollLayer(Layer, xdir.f = 0.0, ydir.f = 0.0) 
    If IsMaterial(watermat) 
      If CountMaterialLayers(watermat)-1 >= Layer
        With txx(Layer)
          \mov\xdir = xdir
          \mov\ydir = ydir
        EndWith
        ScrollMaterial(watermat, xdir, ydir, #PB_Relative, Layer)
      EndIf
    EndIf
  EndProcedure
  
  Procedure.i ScaleLayer(Layer, ScaleWidth.f = 1, ScaleHeight.f = 1)
    If IsMaterial(watermat) 
      If CountMaterialLayers(watermat)-1 >= Layer
        With txx(Layer)
          \sc\scalewidth = ScaleWidth
          \sc\scaleheight = ScaleHeight
        EndWith
        ScaleMaterial(watermat, ScaleWidth, ScaleHeight, Layer)
      EndIf
    EndIf
  EndProcedure
  
  Procedure.i RemoveTextureLayer()
    If IsMaterial(watermat)  
      If CountMaterialLayers(watermat)-1 > 1
        RemoveMaterialLayer(watermat)
        If CurLayer > CountMaterialLayers(watermat)-1
          CurLayer = CountMaterialLayers(watermat)-1
          If IsTexture(txx(CurLayer-2))
            FreeTexture(txx(CurLayer-2))
            With txx(CurLayer+1)
              \mov\xdir = 0.0
              \mov\ydir = 0.0
              \sc\scalewidth = 1.0
              \sc\scaleheight = 1.0
            EndWith
          EndIf
        EndIf
      EndIf
    EndIf
  EndProcedure
  
  Procedure.i AddTextureLayer(Texture.i, Mode = #PB_Material_Add)
    Protected tx
    If IsMaterial(watermat)
      If IsImage(Texture) > 0
        tx = CreateTexture(#PB_Any, ImageWidth(Texture), ImageHeight(Texture), "WaterLayer_" + Str(Random(2000)))
        StartDrawing(TextureOutput(tx))
        DrawImage(ImageID(Texture), 0, 0)
        StopDrawing()
        AddMaterialLayer(watermat, TextureID(tx), Mode)
        CurLayer = CountMaterialLayers(watermat)-1
        With txx(CurLayer-1)
          \id = tx
          \mode = mode  
        EndWith
      ElseIf IsTexture(Texture) > 0
        AddMaterialLayer(watermat, TextureID(Texture), Mode)
        CurLayer = CountMaterialLayers(watermat)-1
        With txx(CurLayer-1)
          \id = Texture
          \mode = Mode
        EndWith
      EndIf
    EndIf
  EndProcedure
  
  Procedure initwater(l = 128, wamp = 8, wlissage = 0)
    Define fo, j,  z, x, y = 0
   
    ReDim tf.f(wlarg1, wlarg1)
    ReDim atf.f(wlarg1, wlarg1)
    RandomSeed(1)
    carte(t(), wlarg, wlarg, 1)
    lisser2d(t(), wlissage, wlissage)
    t2norme(t(), -wamp * 64, wamp * 64)
    awamp = wamp
    awlissage = wlissage
    If IsMaterial(watermat) : FreeMaterial(watermat) : EndIf
    If BaseImage = -1
      BaseTexture = CreateTexture(#PB_Any,512,512, "water_" + Str(Random(1000)))
      StartDrawing(TextureOutput(BaseTexture))
      DrawingMode(#PB_2DDrawing_AllChannels  )
      DrawingMode(#PB_2DDrawing_AlphaBlend!#PB_2DDrawing_Gradient)
      GradientColor(0,$888888)
      GradientColor(0,$ff885500)
      GradientColor(0.4,$ff443300)
      GradientColor(0.6,$ff443300)
      GradientColor(1.0,$ff443300)
      CircularGradient(256,160,512)     
      Box(0,0,512,512)
      StopDrawing()
    Else
      BaseTexture = CreateTexture(#PB_Any, ImageWidth(BaseImage), ImageHeight(BaseImage), "water" + Str(Random(1000)))
      StartDrawing(TextureOutput(BaseTexture))
      DrawImage(ImageID(BaseImage), 0, 0)
      StopDrawing()
    EndIf
    If IsMaterial(watermat) : FreeMaterial(watermat) : EndIf
    watermat = CreateMaterial(#PB_Any, TextureID(BaseTexture))
    AddMaterialLayer(watermat, TextureID(BaseTexture), #PB_Material_Add)
    ScaleMaterial(watermat, 0.5, 0.5, 1)
    ScrollMaterial(watermat, 0.1, 0.2, #PB_Relative,0)
    ScrollMaterial(watermat, 0.02, 0.01, #PB_Relative, 1)
    SetMaterialAttribute(watermat, #PB_Material_EnvironmentMap, #PB_Material_ReflectionMap)
    
    ;Apply extra texture(s), if any
    For fo = 0 To #MAXLAYER
      With txx(fo)
        If IsTexture(\id)
          AddMaterialLayer(watermat, TextureID(\id), \mode)
          ScaleMaterial(watermat, \sc\scalewidth, \sc\scaleheight )
          ScrollMaterial(watermat, \mov\xdir, \mov\ydir, #PB_Relative)
          CurLayer = CountMaterialLayers(watermat)-1
        EndIf
      EndWith
    Next
    
    ;------------------- océan
    If IsMesh(mesh) = 0 : mesh = CreatePlane(#PB_Any, wlarg+1, wlarg+1, wlarg, wlarg, 1, 1) : EndIf
    For i=-4 To 4
      For j=-4 To 4
        If IsEntity(ewater(y)) : FreeEntity(ewater(y)) : EndIf 
          ewater(y) = CreateEntity(#PB_Any, MeshID(mesh), MaterialID(watermat), i*(wlarg+1), 0, j*(wlarg+1))
          y + 1
      Next
    Next
    GetMeshData(mesh, 0, MeshData(), #PB_Mesh_Vertex,0, MeshVertexCount(mesh,0)-1)
  EndProcedure
 
  Procedure.i UpdateSea()
    Static.f dif
    Static i1, i2, di, dj, cpt, cv
    Define i, j, jj, c, v
    If wamp <> awamp Or wlissage <> awlissage : initwater(wlarg, wamp, wlissage) : EndIf
    ;------------------- wave movement
    dif+0.1:di=dif
    For j=0 To wlarg1
      For i=0 To wlarg1
        i1=(i-di) & wlarg1
        i2=(i+di) & wlarg1
        tf(i,j)+((t(i1,j)+t(wlarg1-i2,wlarg1-j))/128-atf(i,j))*0.1       
      Next
    Next
    CopyArray(tf(),atf())
    cv=0
    For j=0 To wlarg
      jj=j & wlarg1
      For i=0 To wlarg
        MeshData(cv)\y = tf(jj, i & wlarg1)
        cv+1
      Next
    Next
    SetMeshData(mesh, 0, MeshData(), #PB_Mesh_Vertex, 0, MeshVertexCount(mesh, 0)-1)
    NormalizeMesh(mesh)
    ProcedureReturn #True
  EndProcedure
 
EndModule

UsePNGImageDecoder()

InitEngine3D()
InitSprite()
InitKeyboard()

OpenWindow(0, 0, 0, 800, 600, "Waves made by pf Shadoko - moduled by DK_PETER", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
OpenWindowedScreen(WindowID(0), 0, 0, 800, 600)
CreateCamera(0, 0, 0, 100, 100)
CameraBackColor(0, $FFA326)
MoveCamera(0, 0, 25, 0)

im = LoadImage(#PB_Any, "foam.png")
Sea::InitWater()

Sea::AddTextureLayer(im, #PB_Material_Add) ;can be an image or texture (First addTexturelayer is at 2)
Sea::ScrollLayer(2, 0.1, 0.01)              

Repeat
  Repeat : ev = WindowEvent() : Until ev = 0
  ExamineKeyboard()
  
  If KeyboardPushed(#PB_Key_F1) ; Amplitude
    Sea::AddAmplitude()
  ElseIf  KeyboardReleased(#PB_Key_F3) ; Smoothing
    Sea::AddSmoothing()
  ElseIf KeyboardPushed(#PB_Key_F2) ; Amplitude
    Sea::SubAmplitude()
  ElseIf  KeyboardReleased(#PB_Key_F4) ; Smoothing
    Sea::SubSmoothing()
  EndIf
  
  ret = Sea::UpdateSea()
  
  RenderWorld()
 
  FlipBuffers()
 
Until KeyboardReleased(#PB_Key_Escape)
Current configurations:
Ubuntu 20.04/64 bit - Window 10 64 bit
Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
User avatar
Psychophanta
Addict
Addict
Posts: 4974
Joined: Wed Jun 11, 2003 9:33 pm
Location: Lípetsk, Russian Federation
Contact:

Re: Demo 3d - Ocean

Post by Psychophanta »

pf shadoko wrote:I'm going to do an update
:o :D
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
Will never leave this forum until the absolute bugfree PB :mrgreen:
User avatar
Psychophanta
Addict
Addict
Posts: 4974
Joined: Wed Jun 11, 2003 9:33 pm
Location: Lípetsk, Russian Federation
Contact:

Re: Demo 3d - Ocean

Post by Psychophanta »

Does not work in PB6.10
http://www.zeitgeistmovie.com

While world=business:world+mafia:Wend
Will never leave this forum until the absolute bugfree PB :mrgreen:
Post Reply