PureBasic Forums - English

Posted: **Tue Feb 20, 2018 9:23 pm**

Hello, guys,

I wanted to test the effectiveness of a simple method to simulate waves.
I found the result so realistic that I made a little demo of it.

PS: a small bug: the entities forming the ocean tiles sometimes disappear before they are completely removed from the screen, if someone finds the solution...

Code: Select all

; Démo 3D : Océan - Pf Shadoko - 2018

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
      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
      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
      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

;##########################################################################################
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)

Procedure menu()
  Protected p=8
  Macro DT(t1,t2)
    DrawText(8,p,t1)
    DrawText(100,p,t2)
    p+22
  EndMacro
  CreateSprite(0,220,200,#PB_Sprite_AlphaBlending)
  StartDrawing(SpriteOutput(0))
  DrawingMode(#PB_2DDrawing_AllChannels)
  DrawingFont(FontID(0))
  Box(0,0,220,200,$44000000)
  DrawingMode(#PB_2DDrawing_AllChannels|#PB_2DDrawing_Outlined)
  Box(0,0,220,200,$ffffffff)
  BackColor($44000000)
  FrontColor($ffffffff)
  dt("Moving:","")
  dt("Cursor + Mouse","")
  dt("","")
  dt("Commandes:","")
  dt("[F1] / [F2]","Amplitude: "+wamp)
  dt("[F3] / [F4]","smoothing: "+wlissage)
  dt("[F5]","Wireframe")
  dt("[Esc]","Quit")
  StopDrawing()
EndProcedure

Procedure initwater(l,wamp,wlissage)
  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
  menu()
EndProcedure

Procedure vagues3d()
  Define ex,ey
  Define.f x,y,z,dif
  Define i,j,jj,c,v
  Define i1,i2,  di,dj, cpt,cv
  
  Define.f MouseX,Mousey,keyx,keyy,keyz, fdf
  Dim MeshData.MeshVertex(0)
  
  InitEngine3D():InitSprite():InitKeyboard():InitMouse()
  
  OpenWindow(0, 0, 0, 0,0, "",#PB_Window_Maximize|#PB_Window_SystemMenu)
  ex=WindowWidth (0,#PB_Window_InnerCoordinate)
  ey=WindowHeight(0,#PB_Window_InnerCoordinate)
  OpenWindowedScreen(WindowID(0), 0, 0, ex, ey, 0, 0, 0)
  LoadFont(0,"arial",14)
  
  ;------------------- scene
  initwater(wlarg,wamp,wlissage)
  CreateCamera(0, 0, 0, 100, 100):MoveCamera(0,0,10,1)
  CameraBackColor(0,$ff8888) :CameraLookAt(0,-10,10,-10)
  CreateLight(0,$888888, 10000, 5000, 2000)
  AmbientColor($aaaaaa)
  Fog($ff8888,100,0,4*wlarg)
  
  CreateTexture(0,512,512)
  StartDrawing(TextureOutput(0))
  DrawingMode(#PB_2DDrawing_AllChannels  )
  DrawingMode(#PB_2DDrawing_AlphaBlend!#PB_2DDrawing_Gradient)
  GradientColor(0,$ffFFFF)
  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))
  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
      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)
  
  Repeat
    While WindowEvent()  :Wend
    ExamineMouse()
    ExamineKeyboard()
    MouseX = -MouseDeltaX() *  0.05
    MouseY = -MouseDeltaY() *  0.05
    wamp    +(KeyboardReleased(#PB_Key_F2)-KeyboardReleased(#PB_Key_F1)):wamp=limite(wamp,1,16)
    wlissage+(KeyboardReleased(#PB_Key_F4)-KeyboardReleased(#PB_Key_F3)):wlissage=limite(wlissage,0,8)
    If wamp<>awamp Or wlissage<>awlissage:initwater(wlarg,wamp,wlissage):EndIf
    If KeyboardReleased(#PB_Key_F5):fdf=1-fdf:If fdf:CameraRenderMode(0,#PB_Camera_Wireframe):Else:CameraRenderMode(0,#PB_Camera_Textured):EndIf:EndIf
    keyx=(-Bool(KeyboardPushed(#PB_Key_Left))+Bool(KeyboardPushed(#PB_Key_Right)))*1
    keyz=(-Bool(KeyboardPushed(#PB_Key_Up  ))+Bool(KeyboardPushed(#PB_Key_Down )))*1-MouseWheel()*2-1
    RotateCamera(0, MouseY, MouseX, 0, #PB_Relative):MoveCamera  (0, KeyX, 0, keyz) :MoveCamera(0,Mod(CameraX(0),wlarg+1),maxi(CameraY(0),0.1),Mod(CameraZ(0),wlarg+1),#PB_Absolute) 
    
    ;------------------- mouvement des vagues
    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)
    ;UpdateMeshBoundingBox(0)
    
    RenderWorld()
    DisplayTransparentSprite(0,8,8)
    FlipBuffers()
  Until KeyboardPushed(#PB_Key_Escape)
EndProcedure

vagues3d()

Posted: **Tue Feb 20, 2018 10:04 pm**

This is awesome!

Way above my level of understanding but it looks fantastic. Can you make it so going under the water turns the screen blue, instead of clear?

Posted: **Tue Feb 20, 2018 10:22 pm**

Wow! That is damn awesome!! Very nicely done!

Posted: **Tue Feb 20, 2018 10:28 pm**

Very nice

Posted: **Tue Feb 20, 2018 11:20 pm**

Awesome!

Posted: **Wed Feb 21, 2018 5:30 am**

very nice demo as usual.
Thanks

Posted: **Wed Feb 21, 2018 7:05 am**

Wow; I don't understand where comes all the water from

Great!

Posted: **Thu Feb 22, 2018 9:11 am**

This is very nice, thanks !

Posted: **Thu Feb 22, 2018 11:34 am**

PS: a small bug: the entities forming the ocean tiles sometimes disappear before they are completely removed from the screen, if someone finds the solution...

I've been looking at that, it seems to be a camera clipping issue.

If the camera is travelling when y is 0 then the mesh never disappears early.

If you manage to stop the camera moving when an error appears then you can look up and it disappears and down and it reappears.
It only seems to happen on the corners of an entity when there is a high point nearby.

I'll have another think and get back to you again

Posted: **Thu Feb 22, 2018 11:37 am**

I wish I had your talent. Would love to have those waves as a program heading with floating text above it.

Posted: **Thu Feb 22, 2018 3:16 pm**

i have faced this hole in the waves but can't repeat it again:
https://s18.postimg.org/hpskzic55/ocean.jpg
this is when stopping the camera from moving (by commenting -MouseWheel()*2-1 at the end of line 215) then going down and again up then looking down
but with the camera move sometimes a transient thing like in the picture happened but it is barely noticed.

Posted: **Thu Feb 22, 2018 6:03 pm**

for Dude:
replace line 216 by this

Code: Select all

    RotateCamera(0, MouseY, MouseX, 0, #PB_Relative):MoveCamera  (0, KeyX, 0, keyz) :MoveCamera(0,Mod(CameraX(0),wlarg),CameraY(0),Mod(CameraZ(0),wlarg),#PB_Absolute) 
    If CameraY(0)<0
      CameraBackColor(0,$332200):Fog($332200,100,0,200)
      MaterialCullingMode(0,#PB_Material_AntiClockWiseCull)
    Else
      CameraBackColor(0,$ff8888):Fog($ff8888,100,0,4* wlarg)
      MaterialCullingMode(0,#PB_Material_ClockWiseCull)
    EndIf

for ApplePi:
I didn't find the reason for this bug.
UpdateMeshBoundingBox does not change anything

Posted: **Thu Feb 22, 2018 10:15 pm**

Thanks for the "underwater" fix. Much more realistic now.

Posted: **Fri Feb 23, 2018 12:49 pm**

Looks great, but here it doesn't work with PB5.62, WinXP pro 32bit, nVidia GForce 730
With debugger:
Get Message "debugger quits unexpectatly", and program ends.
Without debugger:
Program just ends as soon is starts.

Posted: **Fri Feb 23, 2018 7:40 pm**

Incredible, but only runs with debugger for me?

PureBasic Forums - English

Demo 3d - Ocean

Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean

Re: Demo 3d - Ocean