Salut,
pour la v5 j'ai rajouté les arbres
si ça rame sur votre config je vous conseil de baisser la résolution:
remplacer ligne 998
ex=DesktopWidth(0):ey=DesktopHeight(0)
par :
ex=1280:ey=720 (par exemple, mais ça dépend de votre écran)
vous pouvez augmenter le nombre d'arbre (dernier paramètre de la fonction "repart", procedure "selectterrain"
note : ça fait 6 mois que cette version est préte, mais à l'origine je voulais mettre mes fonctions 3D dans une userlib.
j'ai pas reussi à cause d'un probleme avec le passage de tableau en paramètre de procedure, je me suis donc résolu à donner l’intégralité du code source.
la v6 à déjà bien progressé...
adapté pour PB6.0
Désactivez le débogueur
Code : Tout sélectionner
; ----------------------------------------------------------------------------------------------------------
; Paysage V5 - pf Shadoko - 2018
; ----------------------------------------------------------------------------------------------------------
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
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
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 mul3d(p1,v)
p1\x*(v)
p1\y*(v)
p1\z*(v)
EndMacro
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.f Pscalaire3d(*p.f3,*q.f3)
ProcedureReturn *p\x * *q\x + *p\y * *q\y + *p\z * *q\z
EndProcedure
Procedure defmatrot2(*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 calcmatrot2(*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 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.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
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.f2(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 copyimagetotexture(im,tx)
Protected n=CreateTexture(tx,ImageWidth(im),ImageHeight(im))
If tx=-1:tx=n:EndIf
StartDrawing(TextureOutput(tx))
DrawingMode(#PB_2DDrawing_AllChannels)
DrawImage(ImageID(im),0,0)
StopDrawing()
ProcedureReturn tx
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 d.w(2),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)
d(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 d(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)
EndProcedure
Procedure grad2(Array d.w(2),Array s.w(2))
Protected i,j,dx,dy
dy = ArraySize(s(), 1)
dx = ArraySize(s(), 2)
Dim d(dy,dx)
For j=0 To dy
For i=0 To dx
d(j,i)= 4*s(j,i) -s(j,(i-1) & dx)-s(j,(i+1) & dx)-s((j-1) & dy,i)-s((j+1) & dy,i)
Next
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=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
;}================================================================================================
;{ tree
Structure sfeuillage
p.f3
d.f3
EndStructure
Global NewList lfeuillage.sfeuillage()
Global Dim f_model.PB_MeshVertexv(0,0)
Procedure ajbranche2(prec,delta,niv,sec,*p.f3,*d.f3,lgt.f,lgb.f,la.f,ecart.f,n0,branchfrac.f,vinf.f,p0=0)
Static pi,nf
Protected i,j, i0,i1, p1,n1 ,nb,secr
Protected.f dxs,dys,dzs,a,aa,w,lg, rayon,ec
Protected.f3 ps,ds,po,no,pp
Macro msommet2(mx,my,mz,u,v)
vec3d(ps,mx,my,mz)
calcmatrot2(po,ps)
no=po:Norme3D(no)
add3d(po,po,pp)
MeshVertex(po\x,po\y,po\z, u,v,0,no\x,no\y,no\z):pi+1
EndMacro
Macro msection2(n,v,r=0)
If n=0
msommet2(0,0,0,0,v)
Else
For i=0 To n
a=2*#PI*i/n
msommet2(0,Cos(a)* rayon,Sin(a) * rayon,i*2/n,v)
Next
EndIf
EndMacro
defmatrot2(*d,0)
rayon=la*Sqr(sec)
vec3d(pp,*p\x,*p\y,*p\z)
If niv=0:p0+1:pi=p0:msection2(n0,-lgt/lgb):lg=lgt:Else:lg=lgb:EndIf
vec3d(pp,*d\x,*d\y,*d\z)
mul3d(pp,lg)
add3d(pp,pp,*p)
n1=Max(rayon * prec,3)
If sec<delta:n1=0:EndIf
If n0>0
p1=pi
msection2(n1,niv)
Repeat
If (n1=0) Or (n1*(i0+1)-n0*i1 < n0*(i1+1)-n1*i0 And i0<n0)
MeshFace(p0+i0,p0+i0+1,p1+i1):i0+1
Else
MeshFace(p1+i1,p0+i0,p1+i1+1):i1+1
EndIf
Until i0=n0 And i1=n1
EndIf
If sec=0:ProcedureReturn:EndIf
Dim do.f3(10)
Dim sec(10)
If sec=1
AddElement(lfeuillage())
lfeuillage()\p=pp
vec3d(lfeuillage()\d,*d\x,*d\y+lgb *vinf,*d\z)
nb=2:ecart/2
Else
secr=sec
Repeat
sec(nb)=(branchfrac*sec)
sec(nb)=limite(sec(nb),1,secr)
If sec(nb)=sec:sec(nb)-1:EndIf
secr-sec(nb)
nb+1
Until secr=0
EndIf
aa=Random(360)
For i=0 To nb-1
ec=ecart*(1.0-sec(i)/sec)
a=Radian(i/nb*360+aa)
vec3d(ds,1,ec*Cos(a),ec*Sin(a))
calcmatrot2(do(i),ds)
do(i)\y+lgb *vinf
Norme3D(do(i))
Next
For i=0 To nb-1
ajbranche2(prec,delta,niv+1,sec(i),pp,do(i),0,lgb,la,ecart,n1,branchfrac,vinf,p1)
Next
EndProcedure
Procedure feuillage(_mesh,matiere,n,lof.f,angle.f,alea.f=0.15)
Protected i,j
Protected.f xo,yo,lng,lat,mx,loa
Protected.f3 nx,ny
Dim t.PB_MeshVertexv(0,0)
Dim f_model(n,n)
For j=0 To n
For i=0 To n
With f_model(i,j)
xo=1-i/n*2
yo=1-j/n*2
lng=ATan2(xo,yo)
mx=Max(Abs(xo),Abs(yo))
lat=mx*Radian(angle)
loa=lof*(1+POM(alea))
vec3d(\p,Cos(lat)*loa,-Cos(lng)* Sin(lat)*loa,Sin(lng)* Sin(lat)*loa)
If i=0 Or j=0:\n=\p:Else:sub3d(nx,\p,f_model(i-1,j)\p):sub3d(ny,\p,f_model(i,j-1)\p):pvectoriel3d(\n,ny,nx):EndIf:Norme3D(\n)
\u=(Cos(lng)* mx+1)/2
\v=(Sin(lng)* mx+1)/2
EndWith
Next
Next
AddSubMesh()
ForEach lfeuillage()
CopyArray(f_model(),t())
Select 0
Case 0
defmatrot2(lfeuillage()\d,POM(#PI))
For j=0 To n
For i=0 To n
With t(i,j)
calcmatrot2(\n,\n)
calcmatrot2(\p,\p)
add3d(\p,\p,lfeuillage()\p)
EndWith
Next
Next
Case 1
EndSelect
CreateDataMesh(-2,t())
Next
SetMeshMaterial(_mesh,MaterialID(matiere),SubMeshCount(_mesh)-1)
ClearList(lfeuillage())
EndProcedure
Procedure createtree2(mesh,_mesh, *p.f3,*d.f3 ,matecorce,matfeuillage,rnd,prec,delta,sec,tronclg.f,branchelg.f,la.f,ecart.f,branchfrac.f,vinf.f,f_seg,lof.f,laf.f,alea.f=0.2,tyf.b=0)
Protected m
RandomSeed(rnd)
If mesh<>-2:m=CreateMesh(mesh):If mesh=-1:mesh=m:EndIf:EndIf
AddSubMesh()
prec/delta
SetMeshMaterial(_mesh,MaterialID(matecorce),SubMeshCount(_mesh)-1)
ajbranche2(prec,delta,0,sec,*p,*d,tronclg,branchelg,la,ecart,Max(la*Sqr(sec)*prec,3),branchfrac,vinf,-1)
feuillage(_mesh,matfeuillage,f_seg/delta,lof,laf,alea)
If mesh<>-2:FinishMesh(1):EndIf
ProcedureReturn mesh
EndProcedure
Procedure addtree2(_mesh,*p.f3,*d.f3 ,rnd,prec,delta,sec,tronclg.f,branchelg.f,la.f,ecart.f,branchfrac.f,vinf.f)
If rnd>=0:RandomSeed(rnd):EndIf
prec/delta
Protected p=MeshVertexCount(_mesh,SubMeshCount(_mesh)-1):If p:p+1:EndIf
ajbranche2(prec,delta,0,sec,*p,*d,tronclg,branchelg,la,ecart,Max(la*Sqr(sec)*prec,3),branchfrac,vinf,p-1)
EndProcedure
;}
;######################################################################################################
Procedure texture(tex,dx,dy,rnd=0,f=0,lissage=0,embos=-10,grad.s="0,$000000/1,$ffffff",profil.s="0,0/1,1")
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,1)
If embos<>-10:Dim tt.w(0,0):embos(tt(),t(),embos,embos):CopyArray(tt(),t()):EndIf
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()
ProcedureReturn tex
EndProcedure
Macro disradial(x,y,rmax,p)
Define.f a,r
a=Random(6283)/1000
r=Pow(Random(100000)/100000,p)*rmax
x=Cos(a)*r
y=Sin(a)*r
EndMacro
Procedure matiereherbes(num,dx,dy,pal.s,c3,base.f,gr.f,nb)
c3 | $ff000000
Protected i,j,px1,py1,px2,py2,a.f,c,dx2=dx/2,dy2=dy/2,rx,ry,gg,im,mat,tex,n
Protected Dim pal.l(0)
GradientToArray(pal(),256,pal,0,1)
im=CreateImage(-1,dx,dy,32, #PB_Image_Transparent )
StartDrawing(ImageOutput(im))
Box(0, 0, dx,dy, pal(128))
StopDrawing()
StartVectorDrawing(ImageVectorOutput(im))
For i=0 To dx
c=pal(Random(255))
px2=dx2+POM(dx2*base):py2=dy
px1=px2+POM(dx2*(1-base)):py1=dy*0.5+POM(dy*0.2)
MovePathCursor(px2-0.1,py2):AddPathLine(px1,py1):AddPathLine(px2+0.1,py2):VectorSourceColor(c):FillPath(#PB_Path_Preserve):StrokePath(1)
If gr And i<nb:gg=gr*(1+POM(0.2)):AddPathEllipse(px1,py1+gg,gg*2,gg):VectorSourceColor(c3):FillPath():EndIf
Next
StopVectorDrawing()
n=copyimagetotexture(im,num):If num=-1:tex=n:Else:tex=num:EndIf
n=CreateMaterial(num,TextureID(tex)):If num=-1:mat=n:Else:mat=num:EndIf
MaterialFilteringMode(mat,#PB_Material_Anisotropic,4)
SetMaterialAttribute(mat,#PB_Material_AlphaReject,128)
MaterialCullingMode(mat, #PB_Material_NoCulling)
ProcedureReturn mat
EndProcedure
Procedure matierefeuillage(mat,dx,dy,gradient.s,base.f,gr.f,nb,type=0)
Protected i,j,px1,py1,px2,py2,a.f,c,dx2=dx/2,dy2=dy/2,rx,ry,im,tex,n
Protected Dim pal.l(100)
GradientToArray(pal(),256,gradient,0,1)
im=CreateImage(-1,dx,dy,32, #PB_Image_Transparent )
StartDrawing(ImageOutput(im))
Box(0, 0, dx,dy, pal(50))
StopDrawing()
StartVectorDrawing(ImageVectorOutput(im))
For i=0 To nb
disradial(rx,ry,dx2-gr,base)
AddPathCircle(dx2+rx,dy2+ry,gr):VectorSourceColor(pal(Random(255))):FillPath()
Next
StopVectorDrawing()
tex=copyimagetotexture(im,-1)
n=CreateMaterial(mat,TextureID(tex))
If mat=-1:mat=n:EndIf
SetMaterialAttribute(mat,#PB_Material_AlphaReject,128)
MaterialFilteringMode(mat,#PB_Material_Anisotropic,4)
MaterialCullingMode(mat, #PB_Material_NoCulling)
ProcedureReturn mat
EndProcedure
Procedure matiereecorce(mat,dx,dy,rnd=0,f=0,lissage=0,embos=-10,grad.s="0,$000000/1,$ffffff",profil.s="0,0/1,1",scalex.f=1,scaley.f=1)
Protected n,tex=texture(mat,dx,dy,rnd,f,lissage,embos,grad,profil)
n=CreateMaterial(mat,TextureID(tex)):If mat=-1:mat=n:EndIf
MaterialFilteringMode(mat,#PB_Material_Anisotropic,4)
ScaleMaterial(mat,scalex,scaley)
ProcedureReturn mat
EndProcedure
Structure ssol
col.l
obj.w
EndStructure
Structure sobjet
type.b
col.l
nb.w
mat1.i
mat2.i
Array p.f(10)
EndStructure
#tt=1<<6:#tt1=#tt-1:#tt2=#tt/2
#dd=9
#di=1<<#dd:#di1=#di-1:#dit=#di/#tt:#dit1=#dit-1
#dj=1<<#dd:#dj1=#dj-1:#djt=#dj/#tt:#djt1=#djt-1
#da=1024*2:#dat=#da/#tt:#dat1=#dat-1
#nblod=3
Global ex,ey,eau,nbsol
Global Dim h.w(0,0)
Global Dim h2.w(0,0)
Global Dim g.w(0,0)
Global Dim g2.w(0,0)
Global Dim c.w(#di,#dj)
Global Dim v.PB_MeshVertexV(#di,#dj)
Global Dim repartition.w(600,20,100)
Global Dim obj.sobjet(100)
Global Dim sol.ssol(100)
Enumeration:#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,dy, x1,y1,z1, x2,y2,z2, h,hh,l,nb
Protected.f3 p,d
Protected.PB_MeshVertexV vv
Dim t.PB_MeshVertexV(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):CreateDataMesh(-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):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))
For o=1 To 20
nb=obj(o)\nb
Select obj(o)\type
Case 1 ; ------------- herbes
If r>1:Continue:EndIf
h=TextureHeight(obj(o)\mat1)/128
AddSubMesh():SetMeshMaterial(n,MaterialID(obj(o)\mat1),SubMeshCount(n)-1)
nv=0
For j=0 To #tt1
For i=0 To #tt1
If sol(c(pi+i,pj+j))\obj=o And g2(pi+i,pj+j)<10
a=POM(#PI)
vv=v(pi+i,pj+j)
x=vv\p\x-decx
z=vv\p\z-decz
For k=1 To nb
a+#PI/nb:ca=Cos(a):sa=Sin(a):dy=vv\n\x*ca+vv\n\z*sa
x1=x+ca:z1=z+sa:y1=vv\p\y-dy
x2=x-ca:z2=z-sa:y2=vv\p\y+dy
hh=h*(1+POM(0.2))
MeshVertex(x1,y1+hh,z1,0,0,$ffffff,vv\n\x,vv\n\y,vv\n\z)
MeshVertex(x2,y2+hh,z2,1,0,$ffffff,vv\n\x,vv\n\y,vv\n\z)
MeshVertex(x1,y1 ,z1,0,1,$ffffff,vv\n\x,vv\n\y,vv\n\z)
MeshVertex(x2,y2 ,z2,1,1,$ffffff,vv\n\x,vv\n\y,vv\n\z)
MeshFace(nv+0,nv+1,nv+2)
MeshFace(nv+2,nv+1,nv+3)
nv+4
Next
EndIf
Next
Next
Case 2 ; ------------- arbres
If r>4:Continue:EndIf
RandomSeed(0)
With obj(o)
AddSubMesh():SetMeshMaterial(n,MaterialID(\mat1),SubMeshCount(n)-1)
For j=0 To #tt1
For i=0 To #tt1
If sol(c(pi+i,pj+j))\obj=o
d=v(pi+i,pj+j)\n
p=v(pi+i,pj+j)\p:p\x-decx:p\z-decz
addtree2(n,p,d, -1,30,r, Random(\p(6))+1, \p(0),\p(1),\p(2),\p(3),\p(4),\p(5))
EndIf
Next
Next
feuillage(n,\mat2,8/r,\p(1),\p(7),0.1)
EndWith
Case 3 ; ------------- buissons
If r>2:Continue:EndIf
RandomSeed(0)
With obj(o)
For j=0 To #tt1
For i=0 To #tt1
If sol(c(pi+i,pj+j))\obj=o
d=v(pi+i,pj+j)\n:mul3d(d,1+pom(0.3))
p=v(pi+i,pj+j)\p:p\x-decx:p\z-decz
AddElement(lfeuillage())
lfeuillage()\p=p
lfeuillage()\d=d
EndIf
Next
Next
ForEach lfeuillage():d=lfeuillage()\d:mul3d(d,-\p(0)*Cos(Radian(\p(2)))):add3d(lfeuillage()\p,lfeuillage()\p,d):Next
feuillage(n,\mat1,\p(3)/r,\p(0),\p(2),0.1)
EndWith
EndSelect
Next
FinishMesh(1)
EndProcedure
Procedure terrain(rep,liss,hmin,hmax,profil.s,plis=200)
Protected i,j,k,n,r ,h,g, c,hr,gr,rnd,sproba
Static rnds:rnds+1
heightmap(h() ,rnds,#di,#dj,rep-9+#dd):lisser2d(h() ,liss,liss):t2norme(h(),hmin+plis,hmax-plis,profil)
heightmap(h2(),rnds+1,#di,#dj,3):lisser2d(h2(),#di*0.1,#di*0.1):t2norme(h2(),-plis,plis)
For j=0 To #dj1:For i=0 To #dj1:h(i,j)+h2(i,j):Next:Next
embos(g(),h(),0,0)
grad2(g2(),h())
For j=0 To #dj1
For i=0 To #dj1
h=h(i,j):hr=h/8+100: If h<8:h+POM(8):EndIf
g=g(i,j):gr=Min(g,20)
rnd=Random(repartition(hr,gr,100))
sproba=0:For k=0 To 99:sproba+repartition(hr,gr,k):If sproba>=rnd:Break:EndIf:Next
c(i,j)=k
With v(i,j)
vec3d(\p,i,h/16,j)
vec3d(\n,h((i-1) & #di1,j)-h((i+1) & #di1,j),32,h(i,(j-1) & #dj1)-h(i,(j+1) & #dj1)):Norme3D(\n)
\u=i/8
\v=j/8
\color=sol(k)\col
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,80 *r):EndIf
Next
Next
Next
eau=Bool(hmin<0)
Dim sol(100)
Dim repartition.w(600,20,100)
nbsol=0
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
If eau:MoveEntity(#eau,pi*#tt+#da/2,-0.3,pj*#tt+#da/2,#PB_Absolute):EndIf
EndProcedure
Procedure DefGrass(num,nombre,mat)
With obj(num)
\type=1
\mat1=mat
\nb=nombre
EndWith
EndProcedure
Procedure Defbush(num,hauteur.f,largeur.f,angle.f,nseg,mat)
With obj(num)
\type=3
\mat1=mat
\p(0)=hauteur
\p(1)=largeur
\p(2)=angle
\p(3)=nseg
EndWith
EndProcedure
Procedure Deftree(num,age,tronclg.f,branchelg.f,la.f,ecart.f,branchfrac.f,vinf.f,fangle,mat1,mat2)
With obj(num)
\type=2
\mat1=mat1
\mat2=mat2
\p(0)=tronclg
\p(1)=branchelg
\p(2)=la
\p(3)=ecart
\p(4)=branchfrac
\p(5)=vinf
\p(6)=age
\p(7)=fangle
EndWith
EndProcedure
Procedure repart(altmin.w,altmax.w,pentemin.w,pentemax.w,couleur.l,numobj=0,proba=1000)
Protected i,j,k
For i=altmin To altmax
For j=pentemin To pentemax
repartition(i,j,nbsol)=proba
repartition(i,j,100)+proba
sol(nbsol)\col=couleur|$ff000000
sol(nbsol)\obj=numobj
Next
Next
nbsol+1
EndProcedure
Enumeration
#fleurblanche=1
#fleurbleu
#coqueliquot
#jonc
#roseau
#bruyere
#paquerette
#buis
#massif
#chene
#boulot
#pin
#saule
EndEnumeration
Procedure selectterrain(n)
repart(0,0,0,0,$888888,0,0)
Select n
Case 1
repart(102,400,0,10,$007722,#fleurblanche)
repart(102,400,10,14,$006858,#coqueliquot)
repart(102,200,0,4,$004400,#fleurbleu,50)
repart(101,400,14,19,$225555)
repart(0,101,0,20,$447788)
repart(0,400,20,20,$668888)
repart(0,99,0,20,$004433,0,80)
repart(101,150,1,3,$004400,#boulot,30)
repart(120,200,1,4,$004400,#chene,10)
repart(150,250,2,20,$225588,#pin,5)
repart(110,300,5,15,$003311,#buis,5)
repart(110,400,12,18,$224422,#massif,5)
terrain(0,1,00,2000,"0,0/0.4,0.2/0.7,0.4/1,1",0)
Case 2
repart(101,200,0,10,$184c4c)
repart(101,200,0,10,$184c4c,#bruyere)
repart(101,200,10,15,$004466)
repart(0,101,0,15,$447788)
repart(0,100,0,15,$336677,0,40)
repart(100,101,0,4,$004400,#jonc,40)
repart(0,200,15,20,$44aaaa)
repart(110,200,0,4,$004400,#chene,1)
repart(101,104,0,5,$004400,#boulot,50)
repart(105,250,0,20,$225588,#pin,3)
repart(110,300,5,10,$003311,#buis,10)
terrain(3,1,-300,700,"0,0.3/0.3,0.2/0.6,0.0/0.7,0.5/1,1")
Case 3
repart(0,101,0,20,$88ffff)
repart(101,300,19,20,$448888)
repart(102,400,0,19,$115522,#paquerette)
repart(102,400,0,5,$004400,#fleurbleu,20)
repart(105,200,0,6,$003311,#buis,20)
repart(105,160,0,5,$004400,#chene,2)
repart(105,150,0,20,$225588,#pin,3)
terrain(2,2,-200,600,"0,1/0.4,0/0.7,0.85/1,1",100)
Case 4
repart(101,400,0,19,$115522,#paquerette)
repart(101,200,0,10,$184c4c,#bruyere,100)
repart(102,400,0,5,$004400,#fleurbleu,10)
repart(102,400,6,10,$006858,#coqueliquot,100)
repart(101,250,0,4,$004422,#buis,20)
repart(110,400,10,18,$224422,#massif,5)
repart(0,101,0,10,$447788)
repart(0,400,15,20,$88aacc)
repart(110,150,0,4,$004400,#chene,10)
repart(100,104,0,5,$225588,#saule,20)
terrain(2+1,1,-400,1200/2,"0,0/0.4,0.2/0.45,0.4/0.7,0.55/0.8,1/1,0.9",200)
Case 5
repart(101,400,0,19,$5599cc)
repart(101,400,19,20,$88aadd)
repart(0,101,0,20,$226655)
repart(100,101,0,5,$004400,#jonc,400)
repart(105,150,0,10,$004422,#buis,5)
repart(110,400,10,18,$224422,#massif,10)
repart(100,104,0,10,$225588,#saule,20)
repart(120,180,2,20,$225588,#pin,5)
terrain(2,1,-200,1200,"0,0/0.5,0.2/0.52,0.3/0.58,0.33/0.6,0.5/0.62,0.51/0.64,0.6/0.69,0.62/0.71,0.75/0.75,0.78/0.76,0.85/1,1",100)
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
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) Or MouseButton(2))+Bool(KeyboardPushed(#PB_Key_Up) Or MouseButton(1)))*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()
If eau:CameraReflection(1,0,EntityID(#eau)):UpdateRenderTexture(#eau):EndIf
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()
ExamineDesktops()
ex=DesktopWidth(0):ey=DesktopHeight(0)
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, 0000):AmbientColor($444444)
CreateCamera(0, 0, 0, 100, 100)
CameraLookAt(0, 0, 0, 1)
;terrain
Add3DArchive(#PB_Compiler_Home + "examples/3d/Data/Textures", #PB_3DArchive_FileSystem):Parse3DScripts():LoadTexture(1,"soil_wall.jpg")
;texture(1,512*2,512*2,0,2,1,7,"0,$ff666666/1,$ffffffff","0,0/0.2,0/0.8,1/1,1")
CreateMaterial(1,TextureID(1))
MaterialFilteringMode(1,#PB_Material_Anisotropic,4)
SetMaterialColor(1,#PB_Material_AmbientColor|#PB_Material_DiffuseColor,-1)
;eau
CreateCamera(1,0,0,100,100)
CreateRenderTexture(#eau,CameraID(1),ex/1,ey/1,#PB_Texture_ManualUpdate)
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
Fog($ffaa77,100,0,#da*0.6)
CameraBackColor(0,$ffaa77):CameraRange(0,0.1,10000)
texture(#ciel,256,256,0,0,0,-10,"0,$ffff4400/0.5,$ffffffff/1,$ff888888")
CreateMaterial(#ciel,TextureID(#ciel)):ScaleMaterial(#ciel,2,2)
SetMaterialColor(#ciel,#PB_Material_SelfIlluminationColor,$ffffff):MaterialCullingMode(#ciel, #PB_Material_AntiClockWiseCull):ScrollMaterial(#ciel,0.02,0,#PB_Material_Animated)
CreatePlane(#ciel,100000,100000,1,1,320,320): CreateEntity(#ciel,MeshID(#ciel),MaterialID(#ciel),0,200,0)
;vegetation
DefGrass(#fleurblanche,1,Matiereherbes(21,256,64*1.5,"0,$003300/1,$006633",$ffffff, 0.8,1.5,30))
DefGrass(#fleurbleu,3,Matiereherbes(22,256,64*2,"0,$002200/1,$005500",$ff8844, 0.5,1,400))
DefGrass(#coqueliquot,1,Matiereherbes(23,256,64*2,"0,$003322/1,$006644",$0000ff, 0.7,3,25))
DefGrass(#jonc,3,Matiereherbes(25,256,128,"0,$002200/1,$335522",0, 0.2,0,0))
DefGrass(#roseau,3,Matiereherbes(26,256,256,"0,$002222/1,$66aaaa",0, 0.2,0,0))
DefGrass(#bruyere,1,Matiereherbes(27,256,64*2,"0,$003322/1,$224444",$880088, 0.5,1,250))
DefGrass(#paquerette,1,Matiereherbes(28,256,64*1,"0,$002200/1,$225533",$ffffff, 0.6,1,40))
deftree(#chene,24,2,2,0.08,1,0.4,0,60,matiereecorce(40,512,256,0,4,0,9,"0,$ff66bbcc/0.5,$ff000000/1"),matierefeuillage(41,256,256,"0,$006644/1,$002266", 0.7,3,2000))
deftree(#boulot,32,2,1.2,0.05,0.8,0.75,0.1,60,matiereecorce(50,64,512,0,2,0,-10,"0,$ff77bbbb/0.6,$ff66aaaa/1,$ff000000"),matierefeuillage(51,256,256,"0,$004488/1,$22bbaa", 1.2,2,4000))
deftree(#pin,16,2,1,0.06,1.5,0.8,0.4,60,matiereecorce(60,512,256,0,3,0,9,"0,$ff66aaee/0.8,$ff000000/1"),matierefeuillage(61,256,256,"0,$112211/1,$224422", 0.7,2,4000))
Deftree(#saule,16,0,1.,0.05,1.2,0.4,0,80,matiereecorce(70,32,512,0,3,0,-10,"0,$ff338888/0.6,$ff44aabb/1,$ff000000"),matierefeuillage(71,256,256,"0,$66aa88/1,$116622", 0.7,2,3000))
defbush(#buis,1,1,140,8,matierefeuillage(80,256,256,"0,$000000/1,$006633", 0.5,1,20000))
defbush(#massif,1,1,70,4,matierefeuillage(81,256,256,"0,$224422/0.8,$338833/1,$880088", 1,2,5000))
selectterrain(1)
affiche3d()
EndProcedure
main()
Bravo et merci pour le partage. 
Quelle imagination ...Encore du très bon travail ....Merci 
(ça fait trop je sais mais idée géniale non ?)