Hello, coders,
a little update of my cave demo with normal mapping
it uses a script embedded in pb 5.72
this one works only under windows (HLSL), the demo works however in degraded mode
(if someone can convert to GLSL...)
the textures are based on a simple Heightmap
- the diffuse texture is obtained from a color gradient based on the heightmap
- the normalmap texture is obtained via the 'textureArray2NM' procedure (which converts a heightmap array into a normalmap)
it's rudimentary, but it's enough to give a very realistic rendering...
Code: Select all
; demo 3d - grotte-v2 - Pf Shadoko - 2019
EnableExplicit
;{ ============================= biblio
Structure f2
x.f
y.f
EndStructure
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
Macro vec3d(v,vx,vy,vz)
v\x=vx
v\y=vy
v\z=vz
EndMacro
Macro sub3D(p,p1,p2)
p\x=p1\x-p2\x
p\y=p1\y-p2\y
p\z=p1\z-p2\z
EndMacro
Macro add3d(p,p1,p2)
p\x=p1\x+p2\x
p\y=p1\y+p2\y
p\z=p1\z+p2\z
EndMacro
Macro mul3d(p1,v)
p1\x*(v)
p1\y*(v)
p1\z*(v)
EndMacro
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 Pvectoriel3d(*r.f3,*p.f3,*q.f3)
*r\x=*p\y * *q\z - *p\z * *q\y
*r\y=*p\z * *q\x - *p\x * *q\z
*r\z=*p\x * *q\y - *p\y * *q\x
EndProcedure
Procedure defmatrot(*p.f3,w.f, orientation=0)
Global.f3 lo_p,lo_q,lo_r
Protected pp.f3, l.f
vec3d(lo_p,*p\x,*p\y,*p\z)
l=lng3d(lo_p)
Select orientation
Case 0:vec3d(pp,Cos(w),0,Sin(w))
Case 1:vec3d(pp,0,Cos(w),Sin(w))
Case 2:vec3d(pp,Cos(w),Sin(w),0)
EndSelect
pvectoriel3d(lo_q,lo_p,pp ):Norme3d(lo_q,l)
pvectoriel3d(lo_r,lo_p,lo_q):Norme3d(lo_r,l)
EndProcedure
Procedure calcmatrot(*v.f3, *u.f3)
Protected.f x=*u\x, y=*u\y, z=*u\z
*v\x=lo_p\x * x + lo_q\x * y + lo_r\x * z
*v\y=lo_p\y * x + lo_q\y * y + lo_r\y * z
*v\z=lo_p\z * x + lo_q\z * y + lo_r\z * z
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
Macro interpol(v,v1,v2,r=0.5)
v=v1*(1-r)+v2*r
EndMacro
Procedure interpol3D(*R.f3, *V1.f3, *V2.f3, r.f)
*R\x = *V1\x + r * (*V2\x - *V1\x)
*R\y = *V1\y + r * (*V2\y - *V1\y)
*R\z = *V1\z + r * (*V2\z - *V1\z)
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 string2f2(Array s.f2(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 GradientToArray(Array pal.l(1),n,gradient.s,inv.b=0,alpha.b=0)
Protected Dim lt.s(0)
Protected i,j, apos,pos, acol.l,col.l,p
n-1
Dim pal(n)
split(lt(),gradient,"/")
Macro lparam(i)
pos=ValF(lt(i))*n
p=FindString(lt(i),",")
If p: col=Val(Mid(lt(i),p+1)):Else:col=acol:EndIf
If inv :col=CoRBinv(col):EndIf
If alpha:col | $ff000000:EndIf
EndMacro
lparam(1)
For i=2 To ArraySize(lt())
apos=pos
acol=col
lparam(i)
For j=apos To pos:pal(j)=ColorBlend(acol,col,(j-apos)/(pos-apos)):Next
Next
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.f2(0)
string2f2(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.l(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.l(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.l(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 heightmap(Array t.l(2),rnd, dx.w, dy.w, Re.w)
Protected i,j,n,d,dd,dx1=dx-1,dy1=dy-1,R, rr,dec,tt
Dim t.l(dy1, dx1)
RandomSeed(rnd)
n = 1<<re
dd=min(dx,dy) / n: If dd<1:dd=1:EndIf
rr = $4000-1:r=rr>>1
j=0:While j<dy1:i=0:While i<dx1: t(j,i) = Random(rr) - R:i+dd:Wend:j+dd:Wend
While dd > 1
d = dd / 2
j=d:While j<dy
i=d:While i<dx
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
i+dd:Wend
j+dd:Wend
dec=0
j=0:While j<dy:dec=1-dec
i=dec*d:While i<dx
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
i+dd:Wend
j+d:Wend
dd/2:r/2:rr/2:d=dd/2
Wend
EndProcedure
Procedure.i triangle(Array t.l(2),*p1.f3, *p2.f3, *p3.f3)
Protected.f3 e,p1,p2,p3,p4, vg,vd, vdg,vdd
Protected i,j, dx1,dy1,dc.f
dx1=ArraySize(t(),1)
dy1=ArraySize(t(),2)
vec3d(p1,*p1\x,*p1\y,*p1\z)
vec3d(p2,*p2\x,*p2\y,*p2\z)
vec3d(p3,*p3\x,*p3\y,*p3\z)
If p1\y>p3\y:e=p1:p1=p3:p3=e:EndIf
If p1\y>p2\y:e=p1:p1=p2:p2=e:EndIf
If p2\y>p3\y:e=p2:p2=p3:p3=e:EndIf
interpol3D(p4,p1,p3,(p2\y-p1\y)/(p3\y-p1\y))
If p4\x>p2\x:e=p4:p4=p2:p2=e:EndIf
Macro demitriangle(pgh,pgb,pdh,pdb)
vg=pgh:sub3d(vdg,pgb,pgh):mul3d(vdg,1/(pgb\y-pgh\y))
vd=pdh:sub3d(vdd,pdb,pdh):mul3d(vdd,1/(pdb\y-pdh\y))
For j=pgh\y To pgb\y-1
For i=vg\x To vd\x:t(i & dx1,j & dy1)=vg\z+(i-vg\x)*dc:Next
add3d(vg,vg,vdg)
add3d(vd,vd,vdd)
Next
EndMacro
dc=(p4\z-p2\z)/(p4\x-p2\x)
If p4\y>p1\y:demitriangle(p1,p4,p1,p2):EndIf
If p3\y>p4\y:demitriangle(p4,p3,p2,p3):EndIf
EndProcedure
Procedure heightmapcristal(Array h.l(2),rnd, dx.w, dy.w, d.w)
Protected i,j,dx1=dx-1,dy1=dy-1,r=d*0.25,n=dx/d,n1=n-1
Protected.f3 t00,t10,t01,t11,e
Dim t.f3(n,n)
Dim h(dx1,dy1)
RandomSeed(rnd)
For j=0 To n
For i=0 To n
With t(i,j)
\x=i*d+Random(2*r)-r
\y=j*d+Random(2*r)-r
\z=Random(4000)
EndWith
Next:Next
For i=0 To n:t(i,n)=t(i,0):t(i,n)\y+n*d:Next
For j=0 To n:t(n,j)=t(0,j):t(n,j)\x+n*d:Next
For i=0 To n1:For j=0 To n1
t00=t(i+0,j+0)
t10=t(i+1,j+0)
t01=t(i+0,j+1)
t11=t(i+1,j+1)
If Random(1):e=t00:t00=t10:t10=e: e=t01:t01=t11:t11=e:EndIf
triangle(h(),t00,t11,t01)
triangle(h(),t00,t11,t10)
Next:Next
EndProcedure
Procedure textureArray2NM(Array hm.l(2),imgNM,amplitude.f)
Protected i,j,dx,dy,h00,h10,h01
Protected.f x,y,z,l, max=255/amplitude,max2=max*max
Protected.f3 p
dx=ArraySize(hm(),2)+1
dy=ArraySize(hm(),1)+1
Dim bmp.l(dy-1,dx-1)
For j=0 To dy-1
For i=0 To dx-1
h00=hm(j,i)
h10=hm(j,(i+1) % dx)
h01=hm((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,255)
Next
Next
CreateTexture(imgNM,dx,dy)
StartDrawing(TextureOutput(imgNM)):CopyMemory(@bmp(0,0),DrawingBuffer(),dx*dy*4):StopDrawing()
EndProcedure
Procedure textureHM2NM(imgHM,imgNM,amplitude.f)
Protected i,j,dx,dy,c
StartDrawing(TextureOutput(imgHM))
dx=OutputWidth()
dy=OutputHeight()
Dim hm.l(dy-1,dx-1)
Dim bmp.l(dy-1,dx-1)
CopyMemory(DrawingBuffer(),@bmp(0,0),dx*dy*4)
StopDrawing()
For j=0 To dy-1
For i=0 To dx-1
c=bmp(j,i)
hm(j,i)=Red(c)+Green(c)+Blue(c)
Next
Next
textureArray2NM(hm(),imgNM,amplitude/3)
EndProcedure
Procedure Embos(Array s.l(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.l(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 superpose(Array s.l(2),n.w=1)
Protected i,j,k,dx,dy,x,y,ii,jj
dy = ArraySize(s(), 1)
dx = ArraySize(s(), 2)
Dim T.l(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 minauto(Array s.l(2),n.w=1)
Protected i,j,dx,dy,dy1,dy2
dy = ArraySize(s(), 1):dy2=dy/2
dx = ArraySize(s(), 2)
Dim t.l(0,0):CopyArray(s(),t())
For j=0 To dy:For i=0 To dx:s(j,i)=min(t(j,i),t((j+dy2) & dy,i)):Next:Next
EndProcedure
Procedure contraste(Array s.l(2),lissage.w=1)
Protected i,j,k,dx,dy
dy = ArraySize(s(), 1)
dx = ArraySize(s(), 2)
Dim T.l(dy,dx)
CopyArray(s(),t())
lisser2d(t(),lissage,lissage)
For j=0 To dy
For i=0 To dx
s(i,j)-t(i,j)
Next
Next
EndProcedure
Procedure texture(tex,dx,dy,rnd=0,f=0,lissage=0,embos=100,amplitude.f=1,profil.s="0,0/1,1",grad.s="0,$000000/1,$ffffff")
Protected Dim t.l(0,0)
Protected Dim bmp.l(dy-1,dx-1)
Protected Dim grad.l(0):gradienttoarray(grad(),1024,grad,1)
Protected i,j,n
heightmap(t(),rnd,dx,dy,f)
;heightmapcristal(t(),rnd,dx,dy,16)
lisser2d(t(),lissage,lissage,2)
If Embos<>100:Embos(t(),Embos,0):EndIf
;minauto(t())
;superpose(t(),2)
;contraste(t(),2)
t2norme(t(),0,1023,profil)
For j=0 To dy-1:For i=0 To dx-1:bmp(j,i)=grad(t(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()
textureArray2NM(t(),tex+1,amplitude)
ProcedureReturn tex
EndProcedure
;}===================================================================================================================================================
;######################################################################################################
#halo=20
#eau=21
Global lum=1,ex,ey
Global Dim plight.f3(7)
Global Dim blight(7)
Global Dim ligness.f3(0)
Procedure grotte(num=1)
Protected i,j,k,kj, di=128,di1=di-1,di2=di/2, dj=1024,dj1=dj-1, icolor, ntile=8,brillance,stadens
Protected.f r,a,x,y,z, sta, liss,ampl, ray,rayam
Protected.f3 p1,p2,n,ni,dir,ddir,adir,diram,p,pc,rnd
Dim hmr.l(0,0)
Dim ligness.f3(dj+1)
Dim rayon.f(dj+1)
Select num
Case 1:brillance= 8:stadens=20:liss=2:ampl=0.5:texture(1,512,512,0, 4,1,100,2,"0,0/0.7,0.4/1,1","0,$66ccff/0.4,$4488ff/0.4,$4477ff/1,$4477ff")
Case 2:brillance= 1:stadens= 0:liss=1:ampl=0.6:texture(1,512,512,1, 4,0,100,2,"0,0/0.8,1/1,0","0,$88bbff/0.7,$4488bb/1,$ffffff")
Case 3:brillance=10:stadens= 0:liss=2:ampl=0.8:texture(1,512,512,1, 2,0,100,2,"0,1/0.4,0.5/0.5,0/0.6,0.5/1,1","0,$6699aa/0.5,$99eeff/1,$77ddff")
Case 4:brillance= 8:stadens=20:liss=1:ampl=0.7:texture(1,512,512,1, 2,2,10,2,"0,0/0.3,0.7/1,1","0,$88bbff/0.7,$4488bb/1,$ffffff")
Case 5:brillance= 4:stadens= 5:liss=0:ampl=0.6:texture(1,512,512,0, 4,1,100,4,"0,0/0.6,0.6/0.75,0.8/1,1","0,$0088ff/0.6,$0055bb/1,$2288ff")
Case 6:brillance=4:stadens= 0:liss=1:ampl=0.5:texture(1,512,512,0, 3,2,0,1,"0,1/0.4,0.8/0.8,0/1,0","0,$006688/0.7,$00aaff/1,$ffffff")
Case 7:brillance=2:stadens= 0:liss=2:ampl=0.7:texture(1,512,512,0, 3,1,100,4,"0,0/0.4,0.3/0.6,0.7/1,1","0,$66bbff/0.3,$6688bb/0.35,$44aaff/0.6,$4488bb/0.65,$66bbee/1,$4488ff")
;Case 8:brillance=8:stadens= 0:liss=1:ampl=0.5:texture(1,512,512,1, 3,1,100,1,"0,1/0.4,0.5/0.45,0.3/0.5,0/0.55,0.3/0.6,0.5/1,1","0,$446688/0.5,$88ccff/1,$ffffff")
;Case 8:brillance=8:stadens= 0:liss=0:ampl=0.5:texture(1,512,512,1, 5,0,100,2,"0,0/1,1","0,$00ffff/1,$ffff00")
Case 8:brillance=4:stadens= 0:liss=2:ampl=0.5:texture(1,512,512,1, 3,4,100,4,"0,0/0.5,0.5/1,1","0,$00ffff/1,$ffff00")
EndSelect
CreateBillboardGroup(0,MaterialID(#halo),0.5,0.5):HideBillboardGroup(0,1-lum)
SetLightColor(10, #PB_Light_SpecularColor, $111111*brillance):HideLight(10,lum)
MoveCamera(0,0,0,0.5,#PB_Absolute):CameraLookAt(0,0,0,2)
;texture paroie
GetScriptMaterial(1,"ParallaxOcclusionMapping"):MaterialTextureAliases(1,TextureID(1),TextureID(2),0,0)
;CreateMaterial(1,TextureID(1))
MaterialFilteringMode(1,#PB_Material_Anisotropic,4)
;relief
heightmap(hmr(),num,di,dj,2)
lisser2d(hmr(),liss,liss,1)
t2norme(hmr(),-1024,1024,"0,0/0.1,0/0.9,1/1,1")
RandomSeed(num)
r=0.01
vec3d(ddir,0,0,10)
For j=0 To dj+1
ray=ray+pom(1)-(ray-2)*0.01
interpol(rayam,rayam,ray,0.01)
rayam=limite(rayam,1,3)
rayon(j)=rayam
vec3d(rnd,pom(1)-p\x*r,pom(1/4)-p\y*r*4,0.05)
add3d(ddir,ddir,rnd):norme3d(ddir,rayon(j)*4)
add3d(dir,dir,ddir)
norme3d(dir,0.1)
interpol3D(diram,diram,dir,0.1)
add3d(p,p,diram)
ligness(j)=p
Next
rayon(0)=0
Dim t.PB_MeshVertexV(di,128)
For k=0 To (dj-1)/128
pc=ligness(k*128+64)
For j=0 To 128:kj=k*128+j
adir=dir:sub3d(dir,ligness(kj+1),ligness(kj))
defmatrot(dir,0)
For i=0 To di
r=rayon(kj)*10*(1+hmr(kj & dj1,i & di1)/1024*ampl)
a=i/di*2*#PI
vec3d(p,0,-Cos(a)*r,-Sin(a)*r)
calcmatrot(p,p)
add3d(p,p,ligness(kj))
sub3d(p,p,pc)
If Random(1000)<stadens And Abs(i-di2)<16 And j>0 And j<127 And r>25:sta=pom(0.4)+0.4:Else:sta=0:EndIf
vec3d(t(i,j)\p,p\x,p\y-sta, p\z)
t(i,j)\u= i/di*ntile
t(i,j)\v=kj/128*ntile
Next
Next
CreateDataMesh(k,t())
NormalizeMesh(k)
BuildMeshTangents(k)
CreateEntity(k,MeshID(k),MaterialID(1),pc\x,pc\y,pc\z)
CreateLight(k, $111111*15, pc\x,pc\y,pc\z)
SetLightColor(k, #PB_Light_SpecularColor, $111111*brillance)
LightAttenuation(k, 30,1)
HideLight(k,1-lum)
blight(k)= AddBillboard(0,pc\x,pc\y,pc\z)
;Debug BillboardX(1,0)
;BillboardLocate(0,0,pc\x,pc\y,pc\z)
plight(k)=pc
Next
EndProcedure
Procedure affiche3d()
Static.f MouseX,Mousey,keyx,keyz, fdf.l, i.l,a,ai,n.i,pl.f3
Repeat
ExamineMouse()
MouseX = -MouseDeltaX() * 0.05
MouseY = -MouseDeltaY() * 0.05
ExamineKeyboard()
keyx=(-Bool(KeyboardPushed(#PB_Key_Left)<>0)+Bool(KeyboardPushed(#PB_Key_Right)<>0))*0.02
keyz=(-Bool(KeyboardPushed(#PB_Key_Down)<>0)+Bool(KeyboardPushed(#PB_Key_Up )<>0)+MouseButton(1)-MouseButton(2))*0.02+MouseWheel()*2
For i=1 To 7
If KeyboardReleased(#PB_Key_F1+i-1):grotte(i):EndIf
Next
If KeyboardReleased(#PB_Key_F11):lum=1-lum:HideLight(10,lum):HideBillboardGroup(0,1-lum):For i=0 To 7:HideLight(i,1-lum):Next:EndIf
If KeyboardReleased(#PB_Key_F12):fdf=1-fdf:If fdf:CameraRenderMode(0,#PB_Camera_Wireframe):Else:CameraRenderMode(0,#PB_Camera_Textured):EndIf:EndIf
RotateCamera(0, MouseY, MouseX, 0, #PB_Relative):MoveCamera (0, KeyX, 0, -keyz) :MoveCamera(0,CameraX(0),max(CameraY(0),-1.9),CameraZ(0),#PB_Absolute)
For i=0 To 7:ai=a+i:pl=plight(i):pl\x+Sin(ai*3)/2:pl\y+Sin(ai*5)/2:pl\z+Sin(ai*7)/2:MoveLight(i,pl\x,pl\y,pl\z,#PB_Absolute):BillboardLocate(blight(i),0,pl\x,pl\y,pl\z):Next:a+0.01
;For i=0 To 7:pl=plight(i):MoveLight(i,pl\x,pl\y+Sin(a),pl\z,#PB_Absolute):BillboardLocate(blight(i),0,pl\x,pl\y+Sin(a),pl\z):Next:a+0.1
;For i=0 To 7:pl=ligness((n+i*128)& 1023):MoveLight(i,pl\x,pl\y+Sin(a),pl\z,#PB_Absolute):BillboardLocate(blight(i),0,pl\x,pl\y+Sin(a),pl\z):Next:n+1
MoveLight(10,CameraX(0),CameraY(0),CameraZ(0),#PB_Absolute):LightDirection(0,CameraDirectionX(0),CameraDirectionY(0),CameraDirectionZ(0))
CameraReflection(1,0,EntityID(#eau))
RenderWorld()
DisplayTransparentSprite(0,8,8)
FlipBuffers()
Until WindowEvent()=#PB_Event_CloseWindow Or KeyboardPushed(#PB_Key_Escape) Or MouseButton(2)
EndProcedure
Procedure menu()
Protected p=6
Macro DT(t1,t2)
DrawText(8,p,t1)
DrawText(100,p,t2)
p+21
EndMacro
CreateSprite(0,220,180,#PB_Sprite_AlphaBlending)
StartDrawing(SpriteOutput(0))
DrawingMode(#PB_2DDrawing_AllChannels)
DrawingFont(FontID(0))
Box(0,0,220,180,$44000000)
DrawingMode(#PB_2DDrawing_AllChannels|#PB_2DDrawing_Outlined)
Box(0,0,220,180,$44ffffff)
BackColor($44000000)
FrontColor($ffffffff)
dt("Moving:","")
dt("Arrow keys + Mouse","")
dt("","")
dt("Controls:","")
dt("[F1] -> [F7]","Select cave")
dt("[F11]","Flashlight")
dt("[F12]","Wireframe")
dt("[Esc]","Quit")
StopDrawing()
EndProcedure
Procedure main()
InitKeyboard():InitMouse():InitEngine3D():InitSprite()
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))
LoadFont(0,"arial",12)
menu()
;-------------------- scene
Add3DArchive(#PB_Compiler_Home + "examples/3d/Data/Scripts/MaterialScriptsGeneric", #PB_3DArchive_FileSystem )
Parse3DScripts()
CreateLight( 10, $111111*15, 0, 0, 0,#PB_Light_Spot):SpotLightRange(10, 0, 80,2):LightAttenuation(10, 50,1)
AmbientColor($111111*2)
CreateCamera(0, 0, 0, 100, 100)
CameraBackColor(0,$ff8888)
CameraRange(0,0,100000)
; halo lumineux
CreateTexture(#halo,256,256):StartDrawing(TextureOutput(#halo))
DrawingMode(#PB_2DDrawing_Gradient):GradientColor(0,$ffffff):GradientColor(1,0):CircularGradient(128,128,128):Circle(128,128,128,$ffffff)
StopDrawing()
CreateMaterial(#halo,TextureID(#halo))
MaterialBlendingMode(#halo,#PB_Material_Add)
SetMaterialColor(#halo,#PB_Material_SelfIlluminationColor,$ffffff)
; eau
CreateCamera(1,0,0,100,100) :CameraBackColor(1,$ff8888)
CreateRenderTexture(#eau,CameraID(1),ex/2,ey/2)
CreateMaterial(#eau,TextureID(#eau))
SetMaterialColor(#eau,#PB_Material_SelfIlluminationColor,$ffffffff)
SetMaterialAttribute(#eau,#PB_Material_ProjectiveTexturing,1)
CreateTexture(#eau+1,4,4):StartDrawing(TextureOutput(#eau+1)):DrawingMode(#PB_2DDrawing_AllChannels):Box(0,0,4,4,$88ffcc88):StopDrawing()
AddMaterialLayer(#eau,TextureID(#eau+1),#PB_Material_Modulate)
MaterialBlendingMode(#eau,#PB_Material_AlphaBlend)
CreatePlane(#eau,25,100,1,1,1,1)
CreateEntity(#eau,MeshID(#eau),MaterialID(#eau),0,-2,50)
grotte(1)
affiche3d()
EndProcedure
main()