Salut l'équipe,
Une variante de la v3 avec 2 couches UV, pour rendre les strates rocheuse
je pense pas approfondir cette variante, mais comme le rendu est assez réaliste, je vous la montre
pour la v4, je rajoute de la végétation : juste de l'herbe pour l'instant, mais vous allez voir on peux en mettre beaucoup
c'est quand même plus chouette de se promener dans des prairies fleuries...
[EDIT 14/10/19]
quelques améliorations, notamment :
- meilleur coloration (nécessite la 5.71)
- champ de vision 2x plus lointain
Code : Tout sélectionner
; ----------------------------------------------------------------------------------------------------------
; Paysage V3-variante 2 couches UV - pf Shadoko - 2018
; ----------------------------------------------------------------------------------------------------------
;{ ============================= biblio
Structure Vector2
x.f
y.f
EndStructure
Structure Vector3
x.f
y.f
z.f
EndStructure
Macro vec3d(v,vx,vy,vz)
v\x=vx
v\y=vy
v\z=vz
EndMacro
Procedure.f lng3D(*v.Vector3)
ProcedureReturn Sqr(*V\x * *V\x + *V\y * *V\y + *V\z * *V\z)
EndProcedure
Procedure Norme3D(*V.Vector3,l.f=1)
Protected.f lm
lm = l / lng3d(*v)
*V\x * lm
*V\y * lm
*V\z * lm
EndProcedure
Macro sub3D(p,p1,p2)
p\x=p1\x-p2\x
p\y=p1\y-p2\y
p\z=p1\z-p2\z
EndMacro
Procedure.f Max(v1.f,v2.f)
If v1>v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
EndProcedure
Procedure.f Min(v1.f,v2.f)
If v1<v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
EndProcedure
Procedure.f limite(V.f, i.f, s.f)
If V < i :v=i:EndIf
If V > s :v=s:EndIf
ProcedureReturn V
EndProcedure
Procedure.f iif(cond.b,voui.f,vnon.f)
If cond:ProcedureReturn voui:Else:ProcedureReturn vnon:EndIf
EndProcedure
Macro vec2d(v,vx,vy)
v\x=vx
v\y=vy
EndMacro
Procedure.f interpolarray2d(Array tt.w(2),x.f,y.f)
Protected.l i0, j0,i1,j1,dx1,dy1
Protected.f dx, dy
dx1=ArraySize(tt(),1)
dy1=ArraySize(tt(),2)
i0 = Int(X) & dx1:i1=(i0+1) & dx1: dx = X - Int(x)
j0 = Int(Y) & dy1:j1=(j0+1) & dy1: dy = Y - Int(y)
ProcedureReturn (((1 - dx) * tt(j0,i0) + dx * tt(j0,i1)) * (1 - dy) + ((1 - dx) * tt(j1,i0) + dx * tt(j1,i1)) * dy)
EndProcedure
Procedure.f POM(v.f)
ProcedureReturn (Random(v*1000)-v*500)/500
EndProcedure
Procedure Split(Array t.s(1),l.s,sep.s=",",nmax=100)
Protected ap.l,p.l,n,ls
Dim t(nmax)
ls=Len(sep)
l+sep
p=1-ls
Repeat
ap=p+ls:p=FindString(l,sep,ap)
If p=0:Break:EndIf
n+1
t(n)= Mid(l,ap,p-ap)
ForEver
ReDim t(n)
EndProcedure
Procedure string2vector2(Array s.vector2(1),txt.s)
Dim tt.s(0)
Dim t.s(0)
Protected i,n
split(tt(),txt,"/",100)
n=ArraySize(tt())
Dim s(n-1)
For i=1 To n
split(t(),tt(i)+",0",",")
With s(i-1)
\x=ValF(t(1))
\y=ValF(t(2))
EndWith
Next
EndProcedure
Procedure CoRBinv(c.l)
ProcedureReturn RGBA(Blue(c),Green(c),Red(c),Alpha(c))
EndProcedure
Procedure ColorBlend(color1.l, color2.l, blend.f)
Protected r.w,g.w,b.w,a.w
r= Red(color1) + (Red(color2) - Red(color1)) * blend
g=Green(color1) + (Green(color2) - Green(color1)) * blend
b= Blue(color1) + (Blue(color2) - Blue(color1)) * blend
a=Alpha(color1) + (Alpha(color2) - Alpha(color1)) * blend
ProcedureReturn RGBA(r,g,b,a)
EndProcedure
Procedure Finterpol(Array F.f(1),t.s,rx.f=1,ry.f=1,oy.f=0)
Protected.l i,j,n,c,ac
Protected.f y,dx,dy,p
Protected Dim s.vector2(0)
string2vector2(s(),t)
n=ArraySize(s())
For i=0 To n
s(i)\x*rx
s(i)\y*ry+oy
Next
Dim f(Int(s(n)\x))
For j=0 To n-1
y=s(j)\y
dx=s(j+1)\x-s(j)\x
dy=s(j+1)\y-s(j)\y
p=dy/dx
ac=c
While c<=s(j+1)\x
f(c)=y+p*(c-ac):c+1
Wend
Next
EndProcedure
Procedure t2norme(Array t.w(2),dmin.w,dmax.w,profil.s="")
Protected smin.w,smax.w,dx1,dy1,i,j,sr,dr
If profil="":profil="0,0/1,1":EndIf
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
Protected Dim conv.f(sr)
Finterpol(conv(),profil,sr,dr,dmin)
For j=0 To dy1
For i=0 To dx1
t(j,i)=conv(t(j,i)-smin)
Next
Next
EndProcedure
Procedure Tmodulo(Array T(1), max, marge)
Protected i,d=max-marge/2
Dim T(max + 2*marge): For i = 0 To max + 2*marge: T(i) = (i+d) % (max+1): Next
EndProcedure
Procedure Tlimite(Array T(1), max, marge)
Protected i
Dim T(max + 2*marge): For i = 0 To max + 2*marge: T(i) = limite(i-1-marge/2, 0, max): Next
EndProcedure
Procedure lisser2D(Array s.w(2),di.w, dj.w,pass=1,loop=1)
If di=0 And dj=0:ProcedureReturn:EndIf
Protected i,j,k,dii,djj,dx,dy,dij,tx
dx = ArraySize(s(), 2):di=min(di,dx)
dy = ArraySize(s(), 1):dj=min(dj,dy)
Dim d.w(dy,dx)
dii=di+1
djj=dj+1
dij = dii * djj
Dim lx(0)
Dim ly(0)
If loop
Tmodulo (lx(), dx, di+1)
Tmodulo (ly(), dy, dj+1)
Else
Tlimite(lx(), dx, di+1)
Tlimite(ly(), dy, dj+1)
EndIf
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 Embos(Array s.w(2), px.w=0, py.w=0)
Protected i,j,dx,dy
px=1<<Int(Abs(px))*Sign(px)
py=1<<Int(Abs(py))*Sign(py)
Macro gra(j0,i0,j1,i1)
t(j0,i0)=Abs(s(j0,i0)-s(j0,i1)+px)+Abs(s(j0,i0)-s(j1,i0)+py)
EndMacro
dy = ArraySize(s(), 1)
dx = ArraySize(s(), 2)
Dim T.w(dy,dx)
For j=0 To dy-1
For i=0 To dx-1
gra(j,i,j+1,i+1)
Next
gra(j,dx,j+1,0)
Next
For i = 0 To dx-1
gra(dy,i,0,i+1)
Next
gra(dy,dx,0,0)
CopyArray(t(),s())
EndProcedure
Procedure heightmap(Array t.w(2),rnd, dy.w, dx.w, Re.w)
Protected i,j,ii,jj,n,d,dd,dx1=dx-1,dy1=dy-1,l,R, rr,dec
RandomSeed(rnd)
n = 1<<re
dd=min(dx,dy) / n: If dd<1:dd=1:EndIf
Dim t.w(dy-1, dx-1)
rr = $1fff:r=rr>>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(rr) - R: Next: Next
l = dd
While dd > 1
d = dd / 2
For jj = 0 To dy/dd - 1 :j=jj*dd+d
For ii = 0 To dx/dd - 1:i=ii*dd+d
t(j,i) = (t((j - d) & dy1,(i - d) & dx1) + t((j - d) & dy1,(i + d) & dx1) + t((j + d) & dy1,(i + d) & dx1) + t((j + d) & dy1,(i - d) & dx1)) / 4 + Random(rr) - R
Next
Next
For jj = 0 To dy/d - 1 :j=jj*d:dec=1- jj & 1
For ii = 0 To dx/dd - 1:i=ii*dd+dec*d
t(j,i) = (t(j,(i - d) & dx1) + t(j,(i + d) & dx1) + t((j - d) & dy1,i) + t((j + d) & dy1,i)) / 4 + Random(rr) - R
Next
Next
l/2
dd/2
r/2:rr/2
Wend
EndProcedure
;}
;######################################################################################################
Structure PB_MeshVertexV2
p.vector3
n.vector3
t.vector3
u.f
v.f
u2.f
v2.f
color.l
EndStructure
Procedure CreateDataMesh2(mesh,Array t.PB_MeshVertexV2(2))
Protected p,i,j,m,diag,nx=ArraySize(t(),2),nz=ArraySize(t(),1)
Protected.vector3 d1,d2,n
If mesh>-2:m=CreateMesh(mesh):If mesh=-1:mesh=m:EndIf:EndIf
For j=0 To nz
For i=0 To nx
With t(j,i)
MeshVertex(\P\x,\p\y,\p\z,\u,\v,\color,\n\x,\n\y,\n\z):MeshVertexTextureCoordinate(\u2,\v2)
EndWith
Next
Next
For j=0 To nz-1
For i=0 To nx-1
p=j*(nx+1)+i
sub3d(d1,t(j,i)\p,t(j+1,i+1)\p)
sub3d(d2,t(j+1,i)\p,t(j,i+1)\p)
If lng3d(d1)>lng3d(d2):diag=1:Else:diag=-1:EndIf
If diag=1
MeshFace(p,p+1,p+nx+1): MeshFace(p+nx+2,p+nx+1,p+1)
Else
MeshFace(p+nx+1,p,p+nx+2): MeshFace(p+1,p+nx+2,p)
EndIf
Next
Next
If mesh>-2:FinishMesh(1):UpdateMeshBoundingBox(mesh):EndIf
ProcedureReturn mesh
EndProcedure
;######################################################################################################
#tt=64:#tt1=#tt-1:#tt2=#tt/2
#di=1024:#di1=#di-1:#dit=#di/#tt:#dit1=#dit-1
#dj=1024:#dj1=#dj-1:#djt=#dj/#tt:#djt1=#djt-1
#da=1024*2:#dat=#da/#tt:#dat1=#dat-1
#nblod=3
Global lumnb,lum,ex,ey
Global Dim h.w(0,0)
Global Dim h2.w(#di,#dj)
Global Dim g.w(0,0)
Global Dim v.PB_MeshVertexV2(#di,#dj)
Enumeration objet:#ciel=10:#eau:#terrain=100:EndEnumeration
Procedure terrain_tile(pi,pj,n, r=1)
Protected i,j,k,o,im, tt=#tt/r, tt1=tt+1, nv, decx=pi+#tt2,decz=pj+#tt2
Protected.f x,y,z,a,ca,sa, x1,y1,z1, x2,y2,z2, h,l,nb,nsm
Protected.PB_MeshVertexV2 vv
Dim t.PB_MeshVertexV2(tt,tt)
For j=0 To tt
For i=0 To tt
t(i,j)=v(pi+i* r,pj+j* r)
t(i,j)\p\x-decx
t(i,j)\p\z-decz
Next
Next
CreateMesh(n):CreateDataMesh2(-2,t())
; ------------- jointure des tuiles de LOD differents
Macro addv:MeshVertex(vv\p\x-decx,vv\p\y,vv\p\z-decz, vv\u,vv\v, vv\color, vv\n\x,vv\n\y,vv\n\z):MeshVertexTextureCoordinate(vv\u2,vv\v2):nv+1:EndMacro
nv=MeshVertexCount(n)
If r>1
For i=0 To tt-1
im=i*r+r/2
vv=v(pi,pj+im) :addV:MeshFace(nv,i+1,i)
vv=v(pi+#tt,pj+im):addV:MeshFace(nv,i+tt1*tt,i+1+tt1*tt)
vv=v(pi+im,pj) :addV:MeshFace(nv,i*tt1,(i+1)*tt1)
vv=v(pi+im,pj+#tt):addV:MeshFace(nv,(i+1)*tt1+tt,i*tt1+tt)
Next
EndIf
SetMeshMaterial(n,MaterialID(1))
FinishMesh(1)
EndProcedure
Procedure terrain(rep,liss,hmin,hmax,profil.s,c1,c2,cp,cb)
Protected i,j,k,n,r ,h,h2,g, c
c1 | $ff000000
c2 | $ff000000
cp | $ff000000
cb | $ff000000
heightmap(h(),5,#di,#dj,rep)
lisser2d(h(),liss,liss)
t2norme(h(),hmin,hmax,profil)
For j=0 To #dj1:For i=0 To #dj1:h2(i,j)=Sin(i*#PI/512)*Sin(j*#PI/512)*200:h(i,j)+h2(i,j):Next:Next
CopyArray(h(),g())
embos(g(),0,0)
For j=0 To #dj1
For i=0 To #dj1
h=h(i,j)
h2=h2(i,j)
g=g(i,j)
c=$ffffffff
If h<1000+pom(100):If Random(1):c=c1:Else:c=c2:EndIf:EndIf
If h<40+pom(20):c=cb:EndIf
If h<-20:c=$ff44ff88:EndIf
If g>30:c=cp:EndIf
With v(i,j)
vec3d(\p,i,h/16,j)
vec3d(\n,h-h((i+1) & #di1,j),16,h-h(i,(j+1) & #dj1)):norme3d(\n)
\u=i/8
\v=j/8
\u2=Random(4)*0.005
\v2=(h-h2)/12+pom(0.2)
\color=c
EndWith
Next
Next
For i=0 To #di:v(i,#dj)=v(i,0):v(i,#dj)\p\z=#dj:v(i,#dj)\v=#dj/8:Next
For j=0 To #dj:v(#di,j)=v(0,j):v(#di,j)\p\x=#di:v(#di,j)\u=#di/8:Next
For j=0 To #djt1
For i=0 To #dit1
For k=0 To #nblod:r=1<<k
n=#terrain+j*#dit+i
terrain_tile(i*#tt,j*#tt,n+256*k,r)
If k:AddMeshManualLOD(n,n+256*k,100*r):EndIf
Next
Next
Next
EndProcedure
Procedure rendertile(init=0)
Static api,pi=1000, apj,pj=1000, i0,i1, j0,j1, e,m,cpt
If init:api=0:pi=1000:apj=0:pj=1000:EndIf
Protected i,j
api=pi:pi=(CameraX(0)-#da/2)/#tt:If pi<api:i0=pi:i1=api-1:Else:i0=api+1+#dat1:i1=pi+#dat1:EndIf
apj=pj:pj=(CameraZ(0)-#da/2)/#tt:If pj<apj:j0=pj:j1=apj-1:Else:j0=apj+1+#dat1:j1=pj+#dat1:EndIf
cpt=0
For j=pj To pj+#dat1
For i=pi To pi+#dat1
If (i>=i0 And i<=i1) Or (j>=j0 And j<=j1)
e=#terrain+(j & #dat1)*#dat+(i & #dat1)
m=#terrain+(j & #djt1)*#dit+(i & #dit1)
CreateEntity(e,MeshID(m),#PB_Material_None,i*#tt+#tt2,0,j*#tt+#tt2)
cpt+1
EndIf
Next
Next
MoveEntity(#eau,pi*#tt+#da/2,0.1,pj*#tt+#da/2,#PB_Absolute)
EndProcedure
Procedure selectterrain(n)
Select n
Case 1:terrain(3,2,-200,1600,"0,0/0.4,0.2/0.7,0.4/1,1",$44cc88,$33ccaa,$88aaaa,$44ccff)
Case 2:terrain(3,2,-200,1000,"0,0.3/0.3,0.2/0.6,0.0/0.7,0.5/1,1",$00bbbb,$0088ff,$ffffff,$006666)
Case 3:terrain(2,1,-200,2000,"0,1/0.3,0.6/0.5,0.0/0.7,0.4/1,1",$aaaa88,$cc8888,$666666,$88ffff)
Case 4:terrain(3,1,-200,1000,"0,0/0.4,0.2/0.45,0.4/0.7,0.6/0.8,1/1,0.9",$226644,$228866,$aaccff,$ffffff)
Case 5:terrain(3,1,-200,1200,"0,0/0.5,0.2/0.51,0.3/0.58,0.33/0.59,0.5/0.62,0.51/0.63,0.6/0.69,0.62/0.71,0.75/0.75,0.78/0.76,0.85/1,1",$4466aa,$5588cc,$66aaff,$006644)
EndSelect
rendertile(1)
EndProcedure
Procedure affiche3d()
Static.f MouseX,Mousey, mdx,mdy,amo=0.05,keyx,keyy,keyz,y, ysol
Protected i, fly=1, fdf, ac
CameraReflection(1,0,EntityID(#eau))
Repeat
ExamineMouse()
mdx+(MouseDeltaX()-mdx)*amo:MouseX-mdx * 0.1
mdy+(MouseDeltaY()-mdy)*amo:MouseY-mdy * 0.1
ExamineKeyboard()
If KeyboardReleased(#PB_Key_F1):selectterrain(1):EndIf
If KeyboardReleased(#PB_Key_F2):selectterrain(2):EndIf
If KeyboardReleased(#PB_Key_F3):selectterrain(3):EndIf
If KeyboardReleased(#PB_Key_F4):selectterrain(4):EndIf
If KeyboardReleased(#PB_Key_F5):selectterrain(5):EndIf
If KeyboardReleased(#PB_Key_F11):fly=1-fly:amo=1-fly*0.95:EndIf
If KeyboardReleased(#PB_Key_F12):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)))*0.1
keyz=(-Bool(KeyboardPushed(#PB_Key_Down))+Bool(KeyboardPushed(#PB_Key_Up )))*0.1+MouseWheel()*10
RotateCamera(0, MouseY, MouseX, -mdx *fly, #PB_Absolute)
MoveCamera (0, KeyX, 0, -keyz-fly*0.1)
ysol=max(0.2,interpolarray2d(h(), CameraZ(0)+#dj*100, CameraX(0)+#di*100)/16+1.6):If fly:y=max(ysol,CameraY(0)):Else:y=ysol:EndIf
MoveCamera(0,CameraX(0),y,CameraZ(0),#PB_Absolute)
rendertile()
CameraReflection(1,0,EntityID(#eau))
RenderWorld()
DisplayTransparentSprite(0,8,8)
FlipBuffers()
Until KeyboardPushed(#PB_Key_Escape)
EndProcedure
Procedure menu()
Protected p=4
Macro DT(t1,t2)
DrawText(8,p,t1)
DrawText(100,p,t2)
p+22
EndMacro
CreateSprite(0,220,182,#PB_Sprite_AlphaBlending)
StartDrawing(SpriteOutput(0))
DrawingMode(#PB_2DDrawing_AllChannels)
DrawingFont(FontID(0))
Box(0,0,220,182,$44000000)
DrawingMode(#PB_2DDrawing_AllChannels|#PB_2DDrawing_Outlined)
Box(0,0,220,182,$44ffffff)
BackColor($44000000)
FrontColor($ffffffff)
dt("Moving :","")
dt("Arrow keys + Mouse","")
dt("","")
dt("Controls :","")
dt("[F1]->[F5]","Select terrain")
dt("[F11]","Fly / Walk")
dt("[F12]","Wireframe")
dt("[Esc]","Quit")
StopDrawing()
EndProcedure
Procedure main()
Protected i,r.f=1
ExamineDesktops()
ex=DesktopWidth(0)*r
ey=DesktopHeight(0)*r
InitKeyboard():InitMouse():InitEngine3D():InitSprite()
;OpenWindow(0,0,0,ex,ey,"",#PB_Window_BorderLess|#PB_Window_ScreenCentered):OpenWindowedScreen(WindowID(0), 0, 0, WindowWidth(0),WindowHeight(0))
OpenScreen(ex,ey,32,"")
LoadFont(0,"arial",12)
menu()
;-------------------- scene
CreateLight(0, $ffffff, 10000, 10000, 10000)
AmbientColor($444444)
CreateCamera(0, 0, 0, 100, 100)
CameraLookAt(0, 0, 0, 1)
Add3DArchive(#PB_Compiler_Home + "examples/3d/Data/Textures", #PB_3DArchive_FileSystem)
Parse3DScripts()
Fog($ff8888,100,0,#da*0.6)
;terrain
LoadTexture(1,"soil_wall.jpg")
CreateMaterial(1,TextureID(1));:MaterialCullingMode(1,#PB_Material_NoCulling)
MaterialFilteringMode(1,#PB_Material_Anisotropic,4)
;SetLightColor(0,#PB_Light_SpecularColor,$777777):MaterialShininess(1,10):SetMaterialColor(1,#PB_Material_SpecularColor,$00444444)
;SetMaterialColor(1, #PB_Material_AmbientColor,-1)
DisableDebugger:SetMaterialAttribute(1,21,3):EnableDebugger
AddMaterialLayer(1,TextureID(1),#PB_Material_Modulate,1):ScaleMaterial(1,1,32,1)
;eau
CreateCamera(1,0,0,100,100)
CreateRenderTexture(#eau,CameraID(1),ex/1,ey/1)
CreateMaterial(#eau,TextureID(#eau))
SetMaterialAttribute(#eau,#PB_Material_ProjectiveTexturing,1)
CreateTexture(#eau+1,4,4):StartDrawing(TextureOutput(#eau+1)):DrawingMode(#PB_2DDrawing_AllChannels):Box(0,0,4,4,$bbffccaa):StopDrawing()
AddMaterialLayer(#eau,TextureID(#eau+1),#PB_Material_Modulate)
MaterialBlendingMode(#eau,#PB_Material_AlphaBlend)
CreatePlane(#eau,#da,#da,1,1,1,1)
CreateEntity(#eau,MeshID(#eau),MaterialID(#eau))
;ciel
CameraBackColor(0,$ff8888):CameraRange(0,0.1,10000)
LoadTexture(#ciel,"clouds.jpg")
CreateMaterial(#ciel,TextureID(#ciel))
SetMaterialColor(#ciel,#PB_Material_SelfIlluminationColor,$ffffff):MaterialCullingMode(#ciel, #PB_Material_AntiClockWiseCull)
CreatePlane(#ciel,100000,100000,1,1,400,400): CreateEntity(#ciel,MeshID(#ciel),MaterialID(#ciel),0,200,0)
selectterrain(5)
affiche3d()
EndProcedure
main()
Merci et chapeau pour ce superbe travail de vos méninges...pf Shadoko
