Salut les codeurs,
j'ai fais une modélisation de grotte
à peine 200 lignes (en plus de mes fonctions de base)
je suis assez content du résultat
j'espere que ça en motivera certains pour se mettre à la 3d
PS: j'ai pas géré les collisions avec les parois, alors pour plus de réalisme vous être priez de pas passer au travers !
Code : Tout sélectionner
; demo 3d - grotte - Pf Shadoko - 2018
EnableExplicit
Structure vector2
x.f
y.f
EndStructure
Structure Vector3
x.f
y.f
z.f
EndStructure
Structure Svertex2
p.vector3
n.vector3
diag.b
ai.b
aj.b
uv.vector2
color.l
EndStructure
Procedure.f Maxi(v1.f,v2.f)
If v1>v2:ProcedureReturn v1:Else:ProcedureReturn v2:EndIf
EndProcedure
Procedure.f Mini(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 vec3d(v,vx,vy,vz)
v\x=vx
v\y=vy
v\z=vz
EndMacro
Macro vec2d(v,vx,vy)
v\x=vx
v\y=vy
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
Procedure Pvectoriel3d(*r.vector3,*p.vector3,*q.vector3)
*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
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 sub3D(p,p1,p2)
p\x=p1\x-p2\x
p\y=p1\y-p2\y
p\z=p1\z-p2\z
EndMacro
Macro interpol(v,v1,v2,r=0.5)
v=v1*(1-r)+v2*r
EndMacro
Procedure interpol3D(*R.Vector3, *V1.Vector3, *V2.Vector3, 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 defmatrot(*p.vector3,w.f, Array m.f(2),orientation=0)
Protected.vector3 pp,p,q,r
Protected.f l
vec3d(p,*p\x,*p\y,*p\z)
l=lng3d(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(q,p,pp):Norme3d(q,l)
pvectoriel3d(r,p,q) :Norme3d(r,l)
m(0,0)=p\x:m(0,1)=q\x:m(0,2)=r\x
m(1,0)=p\y:m(1,1)=q\y:m(1,2)=r\y
m(2,0)=p\z:m(2,1)=q\z:m(2,2)=r\z
EndProcedure
Procedure calcmatrot(*v.vector3, *u.vector3, Array m.f(2))
Protected.f x=*u\x, y=*u\y, z=*u\z
*v\x=m(0,0) * x + m(0,1) * y + m(0,2) * z
*v\y=m(1,0) * x + m(1,1) * y + m(1,2) * z
*v\z=m(2,0) * x + m(2,1) * y + m(2,2) * z
EndProcedure
Procedure addvertex(px.f,py.f,pz.f, nx.f,ny.f,nz.f, u.f,v.f,c=0)
MeshVertexPosition(px,py,pz)
MeshVertexNormal(nx,ny,nz)
MeshVertexTextureCoordinate(u,v)
MeshVertexColor(c)
EndProcedure
Procedure Createsurface(mesh,Array t.Svertex2(2))
Protected p,i,j,m,diag,nx=ArraySize(t(),2),nz=ArraySize(t(),1)
Protected.vector3 d1,d2,n
m=CreateMesh(mesh):If mesh=-1:mesh=m:EndIf
For j=0 To nz
For i=0 To nx
With t(j,i)
addvertex(\P\x,\p\y,\p\z,\n\x,\n\y,\n\z,\uv\x,\uv\y,\color)
EndWith
Next
Next
For j=0 To nz-1
For i=0 To nx-1
p=j*(nx+1)+i
diag=t(j,i)\diag
If diag=0
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
EndIf
If diag=1
MeshFace(p,p+nx+1,p+1): MeshFace(p+nx+2,p+1,p+nx+1)
Else
MeshFace(p+nx+1,p+nx+2,p): MeshFace(p+1,p,p+nx+2)
EndIf
Next
Next
FinishMesh(1)
NormalizeMesh(mesh)
UpdateMeshBoundingBox(mesh)
ProcedureReturn mesh
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 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
n-1
Dim pal(n)
split(lt(),gradient,"/")
Macro lparam(i)
pos=ValF(lt(i))*n
col=Val(Mid(lt(i),FindString(lt(i),",")+1))
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.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 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 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=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)
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
;Debug "-------------":For i=0 To ArraySize(lx()):Debug lx(i):Next
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.w(2),rnd, dx.w, dy.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=mini(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
;######################################################################################################
Global lumnb,lum
Procedure texture(tex,dx,dy,rnd=0,f=0,lissage=0,embos=-1000,grad.s="0,$000000/1,$ffffff")
Protected Dim t.w(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)
lisser2d(t(),lissage,lissage,2)
If embos<>-1000:embos(t(),embos,embos):EndIf
t2norme(t(),0,1023)
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()
ProcedureReturn tex
EndProcedure
Procedure grotte(num=1)
Protected i,j,k,ii,jj,is,js,di=128,di2=di/2, dj=1024, icolor, lhm=128,lhm1=lhm-1, ntile=16,brillance, strate_grad.s,stadens
Protected.f r,a,x,y,z, sta, liss,ampl, ray,rayam
Protected.vector3 p1,p2,n,ni,dir,ddir,adir,diram,p,ap,rnd
Dim hmr.w(0,0)
Dim hms.w(0,0)
Dim grads.l(0)
Dim ligness.vector3(dj)
Dim rayon.f(dj)
Dim mtx.f(2,2)
Select num
Case 1
texture(1,512,512,2,4,0,-1000,"0,$44aadd/0.7,$88eeff/1,$448888")
brillance=$444444
strate_grad="0,$000000/0.4,$004488/0.7,$888888/1,$888888"
stadens=20
liss=2
ampl=0.8
Case 2
texture(1,512,512,1,2,1,9,"0,$99ccee / 0.5,$3388bb / 1,$112244")
strate_grad="0,$664444/0.5,$004488/1,$888888"
stadens=5
liss=1
ampl=0.6
Case 3
texture(1,512,512,0,7,1,-1000,"0,$004488/0.7,$4488ff/0.7,$224466/1,$4488cc")
brillance=$222222
strate_grad="0,$0088ff / 0.4,$2244aa / 0.6,$888888 / 1,$0066ff"
liss=8
ampl=0.9
EndSelect
lumnb=0
MoveCamera(0,0,0,1,#PB_Absolute):CameraLookAt(0,0,0,2)
RandomSeed(num)
r=0.05
vec3d(ddir,0,0,10)
For j=0 To dj
ray=ray+pom(1)-(ray-2)*0.01
interpol(rayam,rayam,ray,0.01)
rayon(j)=limite(rayam,1,3)
vec3d(rnd,pom(1)-p\x*r,pom(1)-p\y*r,0.1)
add3d(ddir,ddir,rnd):norme3d(ddir,rayon(j)*4)
add3d(dir,dir,ddir)
norme3d(dir,0.1)
interpol3D(diram,diram,dir,0.05)
add3d(p,p,diram)
ligness(j)=p
Next
rayon(0)=0
Dim t.svertex2(di,dj-1)
;texture paroie
CreateMaterial(1,TextureID(1)):MaterialCullingMode(1,#PB_Material_NoCulling)
SetMaterialColor(1, #PB_Material_SpecularColor,brillance ):MaterialShininess(1, 20)
SetMaterialColor(1, #PB_Material_AmbientColor,-1)
MaterialFilteringMode(1,#PB_Material_Anisotropic,4)
SetMaterialColor(1, #PB_Material_AmbientColor,-1)
; relief
heightmap(hmr(),5,lhm,lhm,1)
lisser2d(hmr(),liss,liss,1)
t2norme(hmr(),-1024,1024,"")
;strates
heightmap(hms(),0,lhm,lhm,3)
lisser2d(hms(),0,0,1)
t2norme(hms(),0,1023,"")
gradienttoarray(grads(),1024,strate_grad)
For j=0 To dj-1
adir=dir:sub3d(dir,ligness(j+1),ligness(j))
defmatrot(dir,0,mtx(),0)
For i=0 To di
a=i/di*2*#PI
ii=i & lhm1
jj=j & lhm1
r=rayon(j)*10*(1+hmr(ii,jj)/1024*ampl+pom(0.0))
vec3d(p,0,-Cos(a)*r,Sin(a)*r)
calcmatrot(p,p,mtx())
add3d(p,p,ligness(j))
is=(j*4) & lhm1
js=Int(p\y*32) & lhm1
icolor=grads(hms(is,js))
If Random(1000)<stadens And Abs(i-di2)<16 And r>25:sta=pom(0.4)+0.4:icolor=$ffffff:Else:sta=0:EndIf
vec3d(t(i,j)\p,p\x,p\y-sta, p\z)
vec2d(t(i,j)\uv,i/lhm*ntile,j/lhm*ntile)
t(i,j)\color=icolor
If 1 And i=di2 And j & 127=64
lumnb+1
CreateLight(lumnb, $444444, p\x,p\y-0.5,p\z)
SetLightColor(lumnb, #PB_Light_SpecularColor, $444444)
LightAttenuation(lumnb, rayon(j)*15,0.5)
HideLight(lumnb,1-lum)
EndIf
Next
Next
createsurface(1,t())
CreateEntity(1,MeshID(1),MaterialID(1))
EndProcedure
Procedure affiche3d()
Static.f MouseX,Mousey,keyx,keyy,keyz,a, fdf
Protected i,event,transit=200
Repeat
event=WindowEvent()
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))*0.02+MouseWheel()*2
If KeyboardReleased(#PB_Key_F1):grotte(1):EndIf
If KeyboardReleased(#PB_Key_F2):grotte(2):EndIf
If KeyboardReleased(#PB_Key_F3):grotte(3):EndIf
If KeyboardReleased(#PB_Key_F11):lum=1-lum:HideLight(0,lum):For i=1 To lumnb: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),maxi(CameraY(0),-2.9),CameraZ(0),#PB_Absolute)
MoveLight(0,CameraX(0),CameraY(0),CameraZ(0),#PB_Absolute):LightDirection(0,CameraDirectionX(0),CameraDirectionY(0),CameraDirectionZ(0))
RenderWorld()
DisplayTransparentSprite(0,8,8)
FlipBuffers()
Until event=#PB_Event_CloseWindow Or KeyboardPushed(#PB_Key_Escape)
EndProcedure
Procedure menu()
Protected p=8
Macro DT(t1,t2)
DrawText(8,p,t1)
DrawText(100,p,t2)
p+22
EndMacro
CreateSprite(0,220,190,#PB_Sprite_AlphaBlending)
StartDrawing(SpriteOutput(0))
DrawingMode(#PB_2DDrawing_AllChannels)
DrawingFont(FontID(0))
Box(0,0,220,190,$44000000)
DrawingMode(#PB_2DDrawing_AllChannels|#PB_2DDrawing_Outlined)
Box(0,0,220,190,$ffffffff)
BackColor($44000000)
FrontColor($ffffffff)
dt("Moving:","")
dt("Cursor + Mouse","")
dt("","")
dt("Controls:","")
dt("[F1]->[F3]","Select cave")
dt("[F11]","Light on/off")
dt("[F12]","Wireframe")
dt("[Esc]","Quit")
StopDrawing()
EndProcedure
Procedure main()
Protected i,ex,ey,r.f=1
ExamineDesktops()
ex=DesktopWidth(0)
ey=DesktopHeight(0)
InitKeyboard():InitMouse():InitEngine3D():InitSprite()
OpenWindow(0,0,0,ex*r,ey*r,"",#PB_Window_BorderLess|#PB_Window_ScreenCentered)
OpenWindowedScreen(WindowID(0), 0, 0, WindowWidth(0),WindowHeight(0))
LoadFont(0,"arial",14)
menu()
;-------------------- scene
CreateLight(0, $444444, 100, 100, 0,#PB_Light_Spot):SetLightColor(0, #PB_Light_SpecularColor, $444444):SpotLightRange(0, 0, 80,2):LightAttenuation(0, 100,0)
AmbientColor($444444)
CreateCamera(0, 0, 0, 100, 100)
CameraBackColor(0,$ff8888)
CameraRange(0,0,100000)
CameraLookAt(0, 0, 0, 1)
grotte()
;eau
texture(2,256,256,0,4,0,-1000,"0,$aa226644/1,$aa000000")
CreateMaterial(2,TextureID(2))
SetMaterialColor(2, #PB_Material_SpecularColor, $ffffff):MaterialShininess(2, 5)
SetMaterialAttribute(2,#PB_Material_EnvironmentMap,#PB_Material_ReflectionMap)
MaterialBlendingMode(2,#PB_Material_AlphaBlend)
CreatePlane(2,25,100,64,256,1,1)
CreateEntity(2,MeshID(2),MaterialID(2),0,-3,50)
affiche3d()
EndProcedure
main()