Hi,
the 1st number of a series of codes whose purpose is to make natural scenery.
for the v1 it is the minimum: mountains and lakes
(just 140 lines of code in addition to my library)
among the new functions of the 5.70, I use here:
- CreateDataMesh
- CameraReflection
for the V2 we will have unlimited terrain
Code: Select all
; ----------------------------------------------------------------------------------------------------------
; Paysage V1 - 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 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
;}
;######################################################################################################
Global lumnb,lum,ex,ey
Global di=512,dj=512
Procedure terrain(di=512,dj=512,liss=1)
Protected i,j,k,ii,jj,is,js, di1=di-1,dj1=dj-1, di2=di/2,dj2=dj/2, color, ntile=16
Protected h,g,cielco=$ff0000
Global Dim h.w(0,0)
Dim g.w(0,0)
Dim t.PB_MeshVertex(di,dj)
heightmap(h(),5,di,dj,3)
lisser2d(h(),liss,liss,2)
t2norme(h(),-300,1024,"0,0/0.3,0.2/0.7,0.5/1,1")
CopyArray(h(),g())
embos(g(),0,0)
t2norme(g(),0,255)
For j=0 To dj
For i=0 To di
h=h(i & di1,j & dj1)
g=g(i & di1,j & dj1)
With t(i,j)
\x=(i-di2)
\y=h/16
\z=(j-dj2)
\u=i/4
\v=j/4
color=$ffffff
If h<700+pom(100)
If g<70:color=iif(Random(1),$00cc22,$44cc88) :Else:color=iif(Random(8),$88aaaa,$aaaa88):EndIf
EndIf
If h<20:color=$00ccff:EndIf
If h<-20:color=$000000:EndIf
\color=color
EndWith
Next
Next
CreateDataMesh(1,t())
NormalizeMesh(1)
EndProcedure
Procedure affiche3d()
Static.f MouseX,Mousey,keyx,keyy,keyz, ysol,a, fdf,ymin=-1000
Protected i,event,transit=200
Repeat
ExamineMouse()
MouseX = -MouseDeltaX() * 0.05
MouseY = -MouseDeltaY() * 0.05
ExamineKeyboard()
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
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)
ysol=max(0.1,interpolarray2d(h(), CameraZ(0)+dj/2, CameraX(0)+di/2)/16+1.6)
MoveCamera(0,CameraX(0),ysol,CameraZ(0),#PB_Absolute)
CameraReflection(1,0,EntityID(2))
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,150,#PB_Sprite_AlphaBlending)
StartDrawing(SpriteOutput(0))
DrawingMode(#PB_2DDrawing_AllChannels)
DrawingFont(FontID(0))
Box(0,0,220,150,$44000000)
DrawingMode(#PB_2DDrawing_AllChannels|#PB_2DDrawing_Outlined)
Box(0,0,220,150,$ffffffff)
BackColor($44000000)
FrontColor($ffffffff)
dt("Moving:","")
dt("Arrow keys + Mouse","")
dt("","")
dt("Controls:","")
dt("[F12]","Wireframe")
dt("[Esc]","Quit")
StopDrawing()
EndProcedure
Procedure main()
Protected i,r.f=0.5
ExamineDesktops()
ex=DesktopWidth(0)
ey=DesktopHeight(0)
InitKeyboard():InitMouse():InitEngine3D():InitSprite()
OpenScreen(ex,ey,32,"")
LoadFont(0,"arial",14)
menu()
Add3DArchive(#PB_Compiler_Home + "examples/3d/Data/Textures/", #PB_3DArchive_FileSystem)
Parse3DScripts()
;-------------------- scene
AmbientColor($111111*8):CreateLight(0, $111111*8, 40000, 10000, 10000)
CreateCamera(0, 0, 0, 100, 100)
CameraLookAt(0, 0, 0, 1)
Fog($ff8888,100,0,800)
;terrain
LoadTexture(1,"dirt.jpg")
LoadTexture(4,"clouds.jpg")
terrain(di,dj)
CreateMaterial(1,TextureID(1))
SetMaterialColor(1, #PB_Material_AmbientColor,-1)
CreateEntity(1,MeshID(1),MaterialID(1))
;eau
CreateCamera(1,0,0,100,100)
CreateRenderTexture(2,CameraID(1),ex/1,ey/1)
CreateMaterial(2,TextureID(2))
SetMaterialAttribute(2,#PB_Material_ProjectiveTexturing,1)
CreateTexture(3,4,4):StartDrawing(TextureOutput(3)):DrawingMode(#PB_2DDrawing_AllChannels):Box(0,0,4,4,$bbffccaa):StopDrawing()
AddMaterialLayer(2,TextureID(3),#PB_Material_Modulate)
MaterialBlendingMode(2,#PB_Material_AlphaBlend)
CreatePlane(2,di,dj,16,16,1,1)
CreateEntity(2,MeshID(2),MaterialID(2))
;ciel
CameraBackColor(0,$ff8888):CameraRange(0,0.1,800)
CreateMaterial(4,TextureID(4))
SetMaterialColor(4,#PB_Material_SelfIlluminationColor,$ffffff):MaterialCullingMode(4, #PB_Material_AntiClockWiseCull)
CreatePlane(4,10000,10000,1,1,64,64): CreateEntity(4,MeshID(4),MaterialID(4),0,100,0)
affiche3d()
EndProcedure
main()
Reminds me of VistaPro on the Amiga (