Demo 3D - Mountain v3
Posted: Mon Mar 20, 2023 8:44 am
I didn't get tired for v3, I just added some mist (more or less successful)
but this time there's no need to copy scripts anymore, everything is in the code
(important for those like me, too lazy to test a code that needs more effort than a copy/paste)
there are 6 sets : F1 -> F6
but this time there's no need to copy scripts anymore, everything is in the code
(important for those like me, too lazy to test a code that needs more effort than a copy/paste)
there are 6 sets : F1 -> F6
Code: Select all
DeclareModule ext_3D
EnableExplicit
Structure f3
x.f
y.f
z.f
EndStructure
Structure PB_MeshVertexV
p.f3
n.f3
t.f3
u.f
v.f
color.l
EndStructure
;________________ Lib ________________
Declare f3(*v.f3,vx.f,vy.f,vz.f)
Declare add3d(*p.f3,*p1.f3,*p2.f3)
Declare sub3D(*p.f3,*p1.f3,*p2.f3)
Declare mul3d(*p1,v.f)
Declare.f lng3D(*v.f3)
Declare norme3d(*v.f3,l.f=1)
Declare.f Max(v1.f,v2.f)
Declare.f Min(v1.f,v2.f)
Declare.f limite(V.f, i.f, s.f)
Declare.i Modi(v,divisor)
Declare.f interpolarray2d(Array tt.f(2),x.f,y.f)
Declare CoRBinv(c.l)
Declare ColorBlend(color1.l, color2.l, blend.f)
Declare GradientToArray(Array pal.l(1),n,gradient.s,inv.b=0,alpha.b=0)
Declare Array2Dclamp(Array t.f(2),min.f,max.f)
Declare Noise2d(Array t.f(2), dx.w, dy.w,rnd, oinit.b, onb.b=16)
Declare blur2D(Array s.f(2),di.w, dj.w,pass=1,loop=1)
Declare Embos2D(Array s.f(2), px.w=0, py.w=0)
Declare grad2D(Array s.f(2),delta=1)
Declare add2D(Array s.f(2),Array t.f(2),ampl.f=1,x=0,y=0)
Declare outline2d(Array t.f(2),dmin.f,dmax.f,outline.s="0,0/1,1",sminl.f=0,smaxl.f=0)
Declare textureArrayToColor(tex,Array t.f(2),grad.s="0,$000000/1,$ffffff")
Declare textureArrayToNM(tex,Array t.f(2),amplitude.f,alphavalue=0)
EndDeclareModule
Module ext_3D
DisableDebugger
; ============================= biblio
Procedure f3(*v.f3,vx.f,vy.f,vz.f)
*v\x=vx
*v\y=vy
*v\z=vz
EndProcedure
Procedure sub3D(*p.f3,*p1.f3,*p2.f3)
*p\x=*p1\x-*p2\x
*p\y=*p1\y-*p2\y
*p\z=*p1\z-*p2\z
EndProcedure
Procedure add3d(*p.f3,*p1.f3,*p2.f3)
*p\x=*p1\x+*p2\x
*p\y=*p1\y+*p2\y
*p\z=*p1\z+*p2\z
EndProcedure
Procedure mul3d(*p1.f3,v.f)
*p1\x*v
*p1\y*v
*p1\z*v
EndProcedure
Procedure.f lng3D(*v.f3)
ProcedureReturn Sqr(*V\x * *V\x + *V\y * *V\y + *V\z * *V\z)
EndProcedure
Procedure Norme3D(*V.f3,l.f=1)
Protected.f lm
lm = l / lng3d(*v)
*V\x * lm
*V\y * lm
*V\z * lm
EndProcedure
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.i Modi(v,divisor)
ProcedureReturn (V+$10000*divisor) % divisor
EndProcedure
Procedure.f POM(v.f)
ProcedureReturn (Random(v*1000)-v*500)/500
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 GradientToArray(Array pal.l(1),n,gradient.s,inv.b=0,alpha.b=0)
Protected i,j, apos,pos, acol.l,col.l,p,lt.s
n-1
Dim pal(n)
Repeat
apos=pos
acol=col
i+1
lt=StringField(gradient,i,"/"):If lt="":Break:EndIf
pos=ValF(lt)*n
p=FindString(lt,",")
If p
col=Val(Mid(lt,p+1))
If inv :col=CoRBinv(col):EndIf
If alpha:col | $ff000000:EndIf
Else
col=acol
EndIf
For j=apos To pos:pal(j)=ColorBlend(acol,col,(j-apos)/(pos-apos)):Next
ForEver
EndProcedure
Procedure Array2Dlimit(Array t.f(2),*min.float,*max.float)
Protected i,j,dx1,dy1
Protected.f v,smin,smax
dy1 = ArraySize(t(), 1)
dx1 = ArraySize(t(), 2)
smax = -1e10
smin = 1e10
For j=0 To dy1
For i=0 To dx1
v=t(j,i)
If v<smin : smin=v: EndIf
If v>smax : smax=v: EndIf
Next
Next
*min\f=smin
*max\f=smax
EndProcedure
Procedure Array2Dclamp(Array t.f(2),min.f,max.f)
Protected i,j,dx1,dy1
dy1 = ArraySize(t(), 1)
dx1 = ArraySize(t(), 2)
For j=0 To dy1
For i=0 To dx1
t(j,i)=limite(t(j,i),min,max)
Next
Next
EndProcedure
Procedure blur2D(Array s.f(2),di.w, dj.w,pass=1,loop=1)
If di=0 And dj=0:ProcedureReturn:EndIf
Protected i,j,k,d,dii,djj,dx,dy,dij,tx.f
dx = ArraySize(s(), 2):di=min(di,dx)
dy = ArraySize(s(), 1):dj=min(dj,dy)
Dim d.f(dy,dx)
dii=di+1
djj=dj+1
dij = dii * djj
If loop
d=dx-dii/2:Dim lx(dx + 2*dii): For i = 0 To dx + 2*dii: lx(i) = (i+d) % (dx+1): Next
d=dx-dii/2:Dim ly(dy + 2*djj): For i = 0 To dy + 2*djj: ly(i) = (i+d) % (dy+1): Next
Else
Dim lx(dx + 2*dii): For i = 0 To dx + 2*dii: lx(i) = limite(i-1-dii/2, 0, dx): Next
Dim ly(dy + 2*djj): For i = 0 To dy + 2*djj: ly(i) = limite(i-1-djj/2, 0, dy): Next
EndIf
For k=1 To pass
Dim ty.f(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 Embos2D(Array s.f(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.f(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 grad2D(Array s.f(2),delta=1)
Protected i,j,dx,dy
dy = ArraySize(s(), 1)
dx = ArraySize(s(), 2)
Dim d.f(dy,dx)
For j=0 To dy
For i=0 To dx
d(j,i)= 4*s(j,i) -s(j,(i-delta) & dx)-s(j,(i+delta) & dx)-s((j-delta) & dy,i)-s((j+delta) & dy,i)
Next
Next
CopyArray(d(),s())
EndProcedure
Procedure add2D(Array s.f(2),Array t.f(2),ampl.f=1,x=0,y=0)
Protected i,j,k,dx,dy
dy = ArraySize(s(), 1)
dx = ArraySize(s(), 2)
For j=0 To dy
For i=0 To dx
s(j,i)+t((j+y) & dy,(i+x) & dx)*ampl
Next
Next
EndProcedure
Procedure superpose(Array s.f(2),n.w=1)
Protected i,j,k,dx,dy,x,y,ii,jj
dy = ArraySize(s(), 1)
dx = ArraySize(s(), 2)
Dim T.f(dy,dx)
For k=1 To n
x=Random(dx)
y=Random(dy)
For j=0 To dy
For i=0 To dx
t(i,j)+s((i+x) & dx,(j+y) & dy)
Next
Next
Next
CopyArray(t(),s())
EndProcedure
Procedure Noise2d(Array t.f(2), dx.w, dy.w,rnd, oinit.b, onb.b=16)
Protected i,j,n,d,dd,d3,dx1=dx-1,dy1=dy-1,coef.f=9,den.f=1/(2*coef-2),amp.f=1/$1000
Dim t(dy1, dx1)
RandomSeed(rnd)
n = 1<<oinit
dd=min(dx,dy) / n: If dd<1:dd=1:EndIf
j=0:While j<dy1:i=0:While i<dx1: t(j,i) = (Random($2000) - $1000)*amp:i+dd:Wend:j+dd:Wend
While dd > 1
If onb=0:amp=0:EndIf
d = dd / 2:d3=d*3:amp/2
j=d:While j<dy
i=0:While i<dx
t(j,i) = (-t((j - d3) & dy1,i) - t((j +d3) & dy1,i) + coef*(t((j - d) & dy1,i) + t((j + d) & dy1,i))) *den + (Random($2000) - $1000)*amp
i+dd:Wend
j+dd:Wend
j=0:While j<dy
i=d:While i<dx
t(j,i) = (-t(j,(i - d3) & dx1) - t(j,(i +d3) & dx1) + coef*(t(j,(i - d) & dx1) + t(j,(i + d) & dx1))) *den + (Random($2000) - $1000)*amp
i+dd:Wend
j+d:Wend
dd/2:onb-1
Wend
EndProcedure
Procedure Finterpol(Array F.f(1),profil.s,dmin.f=1,dmax.f=0)
Protected.l i,j,n,c,ac,rx, t.s
Protected.f y,dx,dy,p
rx=ArraySize(f())
n=CountString(profil,"/")
Dim s.f3(n)
For i=0 To n
t=StringField(profil,i+1,"/")
s(i)\x=ValF(t)*rx
s(i)\y=ValF(StringField(t,2,","))*(dmax-dmin)+dmin
Next
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 outline2d(Array t.f(2),dmin.f,dmax.f,outline.s="0,0/1,1",sminl.f=0,smaxl.f=0)
Protected dx1,dy1,i,ii,j,k,xi
Protected.f smin,smax,sr,tt,x,y0,y1,x0,dminl,dmaxl
dy1 = ArraySize(t(), 1)
dx1 = ArraySize(t(), 2)
Array2Dlimit(t(),@smin,@smax)
sr=smax-smin
Dim conv.f(256)
Finterpol(conv(),outline,dmin,dmax)
If smaxl-sminl<>0
ii=(sminl-smin)/sr*255:For i=0 To ii:conv(i)=conv(ii):Next
ii=(smaxl-smin)/sr*255:For i=ii To 255:conv(i)=conv(ii):Next
EndIf
For j=0 To dy1
For i=0 To dx1
x=(t(j,i)-smin)/sr*255
xi=Int(x):x0=x-xi
y0=conv(xi)
y1=conv(xi+1)
t(j,i)=y1*x0+y0*(1-x0)
Next
Next
EndProcedure
Procedure textureArrayToColor(tex,Array t.f(2),grad.s="0,$000000/1,$ffffff")
Protected i,j,n,dx,dy
Protected.f min,max,r
dx=ArraySize(t(),2)+1
dy=ArraySize(t(),1)+1
Dim bmp.l(dy-1,dx-1)
Protected Dim grad.l(0):gradienttoarray(grad(),1024,grad,1)
Array2Dlimit(t(),@min,@max):r=1023/(max-min)
For j=0 To dy-1:For i=0 To dx-1:n=(t(j,i)-min)*r:bmp(j,i)=grad(n):Next:Next
n=CreateTexture(tex,dx,dy):If tex=-1:tex=n:EndIf
StartDrawing(TextureOutput(tex)):CopyMemory(@bmp(0,0),DrawingBuffer(),dx*dy*4):StopDrawing()
ProcedureReturn tex
EndProcedure
Procedure textureArrayToNM(tex,Array t.f(2),amplitude.f,alphavalue=0)
Protected i,j,n,dx,dy
Protected.f h00,h10,h01,x,y,z,l, max=1/amplitude,max2=max*max
Protected.f3 p
dx=ArraySize(t(),2)+1
dy=ArraySize(t(),1)+1
Dim a.f(0,0) :CopyArray(t(),a())
Select alphavalue
Case 0:outline2d(a(),0,256)
Case 1:grad2d(a(),4):Array2Dclamp(a(),-0.4,0):outline2d(a(),0,256)
EndSelect
Dim bmp.l(dy-1,dx-1)
For j=0 To dy-1
For i=0 To dx-1
h00=t(j,i)
h10=t(j,(i+1) % dx)
h01=t((j+1) % dy,i)
p\x=h00-h10
p\y=h00-h01
l=min(p\x*p\x+p\y*p\y,max2)
p\z=Sqr(max2-l)
Norme3D(p,127)
bmp(j,i)=RGBA(p\z+128,p\y+128,p\x+128,a(j,i))
Next
Next
n=CreateTexture(tex,dx,dy):If tex=-1:tex=n:EndIf
StartDrawing(TextureOutput(tex)):CopyMemory(@bmp(0,0),DrawingBuffer(),dx*dy*4):StopDrawing()
ProcedureReturn tex
EndProcedure
Procedure.f interpolarray2d(Array tt.f(2),x.f,y.f)
Protected.l i0, j0,i1,j1,dx1,dy1,ix,iy
Protected.f rx, ry
x-0.5:y-0.5;
#max=$1000000
dx1=ArraySize(tt(),1)
dy1=ArraySize(tt(),2)
ix=Int(X+#max)-#max:i0 = ix & dx1:i1=(i0+1) & dx1: rx = X - ix
iy=Int(Y+#max)-#max:j0 = iy & dy1:j1=(j0+1) & dy1: ry = Y - iy
ProcedureReturn (((1 - rx) * tt(j0,i0) + rx * tt(j0,i1)) * (1 - ry) + ((1 - rx) * tt(j1,i0) + rx * tt(j1,i1)) * ry)
EndProcedure
EnableDebugger
EndModule
UseModule ext_3d
Procedure.f POM(v.f)
ProcedureReturn (Random(v*1000)-v*500)/500
EndProcedure
Procedure CreateDome(Mesh,rayon.f,hauteur.f,d=16)
Protected i,j ,d1=d-1,d2=d/2
Protected.f x,y,z, xo,yo, lat,lng, mx
Dim t.PB_MeshVertexv(d,d)
For j=0 To d
For i=0 To d
With t(i,j)
xo=1-i/d2
yo=1-j/d2
lng=ATan2(xo,yo)
mx=max(Abs(xo),Abs(yo))
\u=(Cos(lng)* mx)
\v=(Sin(lng)* mx)
lat=mx* #PI/2
x=Cos(lng)* Sin(lat)*rayon
z=Sin(lng)* Sin(lat)*rayon
y=Cos(lat)*hauteur
f3(\p,-x,y,z)
EndWith
Next
Next
ProcedureReturn CreateDataMesh(Mesh,t())
EndProcedure
Global ri=12,rf=5,l=1<<ri, l2=l/2, rd=3,t_size,t_view
Global Dim mem.i(ri,5,5)
Global ex,ey
Global Dim h.f(0,0)
Procedure render_tile(tx,ty,ri,x,y)
Protected *mem.integer,i,j,ix,iy,v,l=1<<ri, ri1=ri-1, l2=l/2, xx=(tx-x)>>ri1+1, yy=(ty-y)>>ri1+1
ix=(tx>>ri) +30000
iy=(ty>>ri) +30000
*mem=@ mem(ri,ix % 6,iy % 6)
If xx>=-rd And xx<rd And yy>=-rd And yy<rd And ri>rf
If IsEntity(*mem\i):FreeEntity(*mem\i):*mem\i=0:EndIf
For j=0 To 1
For i=0 To 1
render_tile(tx+i*l2,ty+j*l2,ri-1,x,y)
Next
Next
Else
If IsEntity(*mem\i)
MoveEntity(*mem\i,tx,0,ty,0)
Else
*mem\i=CreateEntity(-1,MeshID(ri),MaterialID(0),tx,0,ty)
;Debug ""+ri+" "+tx+" "+ty+" "+*mem\i
EndIf
EndIf
EndProcedure
Procedure renderTile()
Protected i,j,xx,yy, x=CameraX(0),y=CameraZ(0)
;CreateLine3D(0,x,0,y,$ff,x,200,y,$ff)
xx=((x-l/2)>>ri)<<ri
yy=((y-l/2)>>ri)<<ri
For j=-rd+1 To rd
For i=-rd+1 To rd
tx=xx+i*l
ty=yy+j*l
render_tile(tx,ty,ri,x,y)
Next
Next
;Protected k,nbe:For k=0 To ri:For j=0 To 5:For i=0 To 5:nbe+Bool(IsEntity(mem(k,i,j))):Next:Next:Next:Debug nbe
EndProcedure
Procedure initterrain(txsize=1024,prec.f=1)
Protected l,tt,tt1,nv,im.f,amp=1.25*256
t_size=txsize
tt=32/prec :tt1=tt+1
t_view =1<<(ri-1)*6
For k=rf To ri
l=(1<<k)
Dim v.PB_MeshVertexV(tt,tt)
For j=0 To tt:For i=0 To tt:f3(v(j,i)\p,j/tt*l,-amp+200,i/tt*l):Next:Next:v(tt/2,tt/2)\p\y=amp+200
CreateMesh(k):CreateDataMesh(-2,v())
If k>rf; ------------- jointure des tuiles de LOD differents
nv=MeshVertexCount(k)
For i=0 To tt-1
im=(i+0.5)/tt*l
MeshVertexPosition(0 ,0 ,im):nv+1:MeshFace(nv,i+1,i)
MeshVertexPosition(l ,0 ,im):nv+1:MeshFace(nv,i+tt1*tt,i+1+tt1*tt)
MeshVertexPosition(im ,0 ,0 ):nv+1:MeshFace(nv,i*tt1,(i+1)*tt1)
MeshVertexPosition(im ,0 ,l ):nv+1:MeshFace(nv,(i+1)*tt1+tt,i*tt1+tt)
Next
EndIf
FinishMesh(1)
Next
EndProcedure
Procedure.f Terrain_Height(x.f,z.f)
x*t_size/4096
z*t_size/4096
ProcedureReturn interpolarray2d(h(),x,z)*510-255+ (interpolarray2d(h(),x*8,z*8)*510-255)*0.125 +230+2
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]->[F6]","Select terrain")
dt("[F11]","Fly / Walk")
dt("[F12]","Wireframe")
dt("[Esc]","Quit")
StopDrawing()
EndProcedure
Procedure selectterrain(n=1,rnd=5)
Protected i,j,k, prof.s,blur,r
Protected.l fogc,skytype=2,skyc ,hrzc, waterc, valley.f,foga.f,fogy.f
Dim g.f(0,0)
For k=rf To ri:For j=0 To 5:For i=0 To 5:If mem(k,j,i):FreeEntity(mem(k,j,i)):mem(k,j,i)=0:EndIf:Next:Next:Next
#eau=20
fogc=$ffcccc:foga=500:fogy=50:skyc=$ff7722:hrzc=$4488ff:sunc=$ffffff
waterc=$00113300
Select n
Case 1:c1=$074488ff:c2=$11446666:c3=$44668888:blur=0:r=0:prof="0,0/0.2,0.3/0.6,0.4/1,1":fogc=$888888:fogy=120:skyc=$335588:valley=3:skytype=1
Case 2:c1=$22eeeecc:c2=$44ccaa88:c3=$11444444:blur=0:r=1:prof="0,0/0.3,0.1/1,1":fogy=250:foga=1000:waterc=$443322:valley=-4:skytype=1
Case 3:c1=$07004466:c2=$11004488:c3=$2288bbff:blur=0:r=0:prof="0,0/0.3,0.3/0.5,0.8/1,1":valley=1
Case 4:c1=$07007766:c2=$00113355:c3=$22446666:blur=0:r=1:prof="0,0/0.4,0.2/1,1":waterc=$00223311:valley=2:skytype=3
Case 5:c1=$004499ff:c2=$00224499:c3=$22666666:blur=0:r=0:prof="0,1/0.2,0.3/0.4,0.2/0.5,0/0.8,0.3/1,1":skytype=1
Case 6:c1=$00226688:c2=$00224499:c3=$22888899:blur=0:r=1:prof="0,0/0.2,0.1/0.3,0.3/0.5,0.45/0.56,0.6/0.8,0.72/0.86,0.9/1,1":fogy=50:valley=2
EndSelect
CreateCamera(0, 0, 0, 100, 100):MoveCamera(0,0,4,5):CameraLookAt(0,0,0,0):CameraBackColor(0,fogc):CameraRange(0,1,100000)
Fog(fogc,1,0,t_view)
CreateLight(0, sunc, -10000*2*2, 10000,0)
AmbientColor($111111*4)
;---- sky / ciel
Select skytype
Case 1: Noise2d(h(),1024,1024,0,0,3):Noise2d(g(),1024,1024,1,6):add2D(h(),g(),0.1):textureArrayToColor(60,h(),"0,$00eeeeee/0.5/0.8,$ffeeeeee/1,$ffbbbbbb")
Case 2: Noise2d(h(),1024,1024,0,3):Noise2d(g(),1024,1024,1,6):outline2d(g(),0,1,"0,1/0.5,0/1,1"):add2D(h(),g(),0.8):textureArrayToColor(60,h(),"0,$00eeeeee/0.5/0.8,$ffeeeeee/1,$ffbbbbbb")
Case 3: Noise2d(h(),1024,1024,0,2):Noise2d(g(),1024,1024,1,5):add2D(h(),g(),0.3):textureArrayToColor(60,h(),"0,$00eeeeee/0.4/0.6,$ffeeeeee/1,$ff999999")
EndSelect
CreateShaderMaterial(60,#PB_Material_SkyShader):MaterialShaderTexture(60,TextureID(60),0,0,0)
MaterialShaderParameter(60,1,"speed",4,0.5,0,0,0)
MaterialShaderParameter(60,1,"height",1,1000,0,0,0)
MaterialShaderParameter(60,1,"scale",1,16000,0,0,0)
MaterialCullingMode(60,#PB_Material_NoCulling)
SetMaterialColor(60,1,skyc)
SetMaterialColor(60,2,hrzc)
;ScaleMaterial(60,0.05,0.05)
CreateDome(60,t_view,t_view/6)
CreateEntity(60,MeshID(60),MaterialID(60))
;---- water / eau (surface)
Noise2d(h(),512,512,0,5,5):outline2d(h(),0,1,"0,1/0.5,0/1,1"):textureArraytoNM(#eau,h(),6)
CreateShader(1,"%%%#version 130%%uniform mat4 P0;//+0%varying vec2 ouv;%varying vec4 opos_w;%%varying float vdist;%varying vec2 vuv;%%void main()%{%ouv=(gl_TextureMatrix[0]*gl_MultiTexCoord0).xy;%opos_w=P0*gl_Vertex;%gl_Position=ftransform();%vdist=gl_Position.z;%}%%%%%%%%%%%",
"%%%#version 130%%varying vec2 ouv;%varying vec4 opos_w;%varying float vdist;%varying vec2 vuv;%uniform vec4 P30;//+30%uniform vec3 fog;//0.000 0.0005 200%uniform float P36;//+36%uniform vec4 P40;//+40%uniform vec4 P43;//+43%uniform vec4 P69;//+69%uniform vec4 P70;//+70%uniform vec4 P76;//+76%uniform float P86;//+86%uniform vec4 water_params;//0 0 40 0.025%%uniform sampler2D normalMap;//0%%void main()%{%float f;%vec4 fc;%if(P76.y<0)%{f=min(vdist*water_params.w,1);fc=vec4(P69.rgb,1);}%else%{f=min(vdist*mix(fog.x,fog.y,(min(P76.y,fog.z)-min(opos_w.y,fog.z))/(P76.y-opos_w.y)),1);fc=P30;}%if(f==1){gl_FragColor=fc;return;}%%vec2 duv=vec2(P86*0.01,0);%vec3 normal=normalize(texture(normalMap,ouv+duv).xyz+texture(normalMap,ouv+0.5-duv).xyz-1).xzy;%vec3 lightdir=normalize(P43.xyz-opos_w.xyz);lightdir.y*=sign(P76.y);%vec3 viewdir=normalize(P76.xyz-opos_w.xyz);%float cfresnel=1-abs(dot(viewdir,normal));%vec4 color=mix(P69,P70,cfresnel*cfresnel);%color+=P40*pow(max(dot(normalize(lightdir+viewdir),normal),0),P36);%%gl_FragColor=mix(color,fc,f);%}%%%%%%%%%%%")
CreateShaderMaterial(#eau,1):MaterialShaderTexture(#eau,TextureID(#eau),0,0,0)
MaterialShaderParameter(#eau,1,"fog",#PB_Shader_Vector3, 1/t_view, 1/foga, fogY, 0)
MaterialBlendingMode(#eau,#PB_Material_AlphaBlend)
MaterialShininess(#eau,256)
SetMaterialColor(#eau,2,waterc)
SetMaterialColor(#eau,4,$ff000000+ColorBlend(skyc,fogc,0.8))
MaterialFilteringMode(#eau,#PB_Material_Anisotropic)
MaterialCullingMode(#eau,#PB_Material_NoCulling)
CreatePlane(#eau,t_view*2,t_view*2,16,16,t_view/32,t_view/32)
CreateEntity(#eau,MeshID(#eau),MaterialID(#eau))
;---- terrain
noise2d(h(),1024,1024,1,3):outline2d(h(),0,1,"0,1/0.5,0/1,1"):textureArrayToNM(3,h(),8)
grad2D(h(),2):textureArrayToColor(2,h())
Noise2d(h(),t_size,t_size,rnd+n,r)
If valley:Noise2d(g(),t_size,t_size,1,r):outline2d(g(),0,1,"0,1/0.5,0/1,1"):add2D(h(),g(),valley):EndIf
outline2d(h(),0,1,prof)
blur2D(h(),blur,blur);
; Dim h(t_size-1,t_size-1):For i=0 To 10000:h(Random(t_size),Random(t_size))=pom(1):Next:outline2d(h(),0,1)
textureArraytoNM(0,h(),32)
CopyArray(h(),g())
embos2D(g(),0,0)
outline2d(g(),0,255)
Dim c.l(t_size-1,t_size-1)
For j=0 To t_size-1
For i=0 To t_size-1
Select g(j,i)
Case 0 To 30:color=c1
Case 30 To 60:color=c2
Default:color=c3
EndSelect
c(j,i)=CoRBinv(color)
Next
Next
CreateTexture(1,t_size,t_size):StartDrawing(TextureOutput(1)):CopyMemory(@c(0,0),DrawingBuffer(),t_size*t_size*4):StopDrawing()
If IsMaterial(0):FreeMaterial(0):EndIf
CreateShader(0,"%%#version 130%%uniform mat4 P0;//+0%uniform mat4 P16;//+16%uniform sampler2D alt;//0%uniform float height;//64%uniform float heightdec;//230%uniform float lng;//512%uniform float r;//8%%varying vec4 vposw;%varying vec2 vuv0;%varying vec2 vuv1;%varying float vdist;%%void main()//0%{%vposw=P0*gl_Vertex;%vuv0=(vposw.xz/r+0.25)/lng;%vuv1=(vposw.xz+0.25)/lng;%float tx0=texture(alt,vuv0).w-0.5;%float tx1=texture(alt,vuv1).w-0.5;%vposw.y=(tx0*r+tx1)*height+heightdec;%gl_Position=P16*vposw;%vdist=abs(gl_Position.z);%}%%%%",
"%%#version 130%%varying vec4 vposw;%varying vec2 vuv0;%varying vec2 vuv1;%varying float vdist;%uniform vec4 P30;//+30%uniform vec4 P31;//+31%uniform vec4 P35;//+35%uniform float P36;//+36%uniform vec4 P43;//+43%uniform vec4 P67;//+67%uniform vec4 P69;//+69%uniform vec4 P70;//+70%uniform vec4 P76;//+76%uniform vec3 fog;//0.000 0.0005 200%%uniform sampler2D alt;//0%uniform sampler2D color;//1%uniform sampler2D tcolor;//2%uniform sampler2D tnorm;//3%%uniform float height2;//8%uniform vec4 water_params;//0 0 20 0.050%%void main()%{%float f;vec4 fc;vec4 coloratt=vec4(1);%if(vposw.y<0)%{%if(P76.y>=0)f=min(vdist*-vposw.y/(P76.y-vposw.y)*water_params.w,1);else f=min(vdist*water_params.w,1);%fc=P35;if(f==1){gl_FragColor=fc;return;}%coloratt=vec4(0.8,0.8,0.8,0);%}%else%{%//f=min(vdist*P31.w,1);%f=(min(P76.y,fog.z)-min(vposw.y,fog.z))/(P76.y-vposw.y);%f=min(vdist*mix(fog.x,fog.y,f),1);%fc=P30;if(f==1){gl_FragColor=fc;return;}%}%%vec3 vlightdir=normalize(P43.xyz-vposw.xyz);%vec3 vviewdir=normalize(P76.xyz-vposw.xyz);%%vec4 tx1=texture(alt,vuv0)+texture(alt,vuv1)-1;tx1.xy*=height2;%vec4 tx2=texture(tnorm,vuv1*64)-0.5;tx2.xy*=(2+length(tx1.xy)*8);%vec3 nor=normalize(tx1.xzy+tx2.xzy);%vec4 vcolor=texture(color,vuv0)+texture(color,vuv1);%vec4 fcolor=vec4(texture(tcolor,vuv1*64).rgb,1)*vcolor*coloratt;%float dif=max(dot(vlightdir,nor),0);%float spe=pow(max(dot(normalize(vlightdir+vviewdir),nor),0),P36);%gl_FragColor=fcolor*(P67+P69*dif)+fcolor.a*P70*spe;%gl_FragColor=mix(gl_FragColor,fc,f);%}%%%%")
CreateShaderMaterial(0,0):MaterialShaderTexture(0,TextureID(0),TextureID(1),TextureID(2),TextureID(3))
MaterialShaderParameter(0,1,"fog",#PB_Shader_Vector3, 1/t_view, 1/foga, fogY, 0)
MaterialShininess(0,64,$ffffff)
SetMaterialColor(0,#PB_Material_SelfIlluminationColor,waterc)
ScaleMaterial(0,40,4)
EndProcedure
Procedure test3d()
InitEngine3D():InitSprite():InitKeyboard():InitMouse()
ExamineDesktops()
ex=DesktopWidth(0)
ey=DesktopHeight(0)
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",11*1/DesktopScaledX(1))
menu()
initterrain(1024,0.5)
selectterrain(6)
Protected.f MouseX,Mousey, mdx,mdy,amo=0.04,depx,depz, ysol, dist,cp.f3
Protected fly=1, fdf
Repeat
ExamineMouse()
mdx+(MouseDeltaX()-mdx)*amo:MouseX-mdx * 0.1
mdy+(MouseDeltaY()-mdy)*amo:MouseY-mdy * 0.1
ExamineKeyboard()
For i=0 To 5:If KeyboardReleased(#PB_Key_F1+i):selectterrain(1+i):EndIf:Next
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
depx=(-Bool(KeyboardPushed(#PB_Key_Left))+Bool(KeyboardPushed(#PB_Key_Right)))*0.1
depz=(-Bool(KeyboardPushed(#PB_Key_Down) Or MouseButton(2))+Bool(KeyboardPushed(#PB_Key_Up) Or MouseButton(1))+fly)*0.4+MouseWheel()*20
RotateCamera(0, MouseY, MouseX, -mdx *fly, #PB_Absolute)
dist+(depz-dist)*0.1
MoveCamera (0, depX, 0, -dist)
f3(cp,CameraX(0),CameraY(0),CameraZ(0))
ysol=Terrain_Height(cp\x,cp\z)+1.6:If fly:cp\y=Max(ysol,cp\y):Else:cp\y=ysol:EndIf
MoveCamera(0,cp\x,cp\y,cp\z,#PB_Absolute)
rendertile()
MoveEntity(60,cp\x,0,cp\z,#PB_Absolute)
MoveEntity(#eau,Int(cp\x/256)*256,0,Int(cp\z/256)*256,#PB_Absolute)
RenderWorld()
DisplayTransparentSprite(0,8,8)
FlipBuffers()
If IsWindow(0):While WindowEvent():Wend:EndIf
Until KeyboardPushed(#PB_Key_Escape) Or MouseButton(3)
EndProcedure
test3d()
Boah, my jaw just dropped
