Demo 3D - mountains v2

Everything related to 3D programming
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 174
Joined: Thu Jul 09, 2015 9:07 am

Demo 3D - mountains v2

Post by pf shadoko »

[EDIT Aug 02, 2021]
a small update
I've improved the shaders, it should be nicer (and smoother on "small" machines)
(so you have to download the zip containing the shaders again)

Image

hello,

a little shader to make mountains
you'll see, it's amazingly realistic

copy the content of the zip into the "Examples\3D\Data\Scripts\MaterialScriptsGeneric" folder
http://cg.racine.free.fr/montagnes.zip
(to download it you have to copy the link in a new tab (I think it's linked to the fact that it's not https))

if it's slow, you can lower the level of detail:
line 647 :
replace
initterrain(1024,0.5)
with
initterrain(1024,1)

compiler en opengl

have a good trip

Code: Select all

CompilerIf Not Subsystem("OpenGL")
  CompilerError "enter 'OpenGL' into the 'Compiler options / Library Subsystem' field"
CompilerEndIf

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)
		EndIf		
	EndIf	
EndProcedure

Procedure renderTile()
	Protected i,j,xx,yy,	x=CameraX(0),y=CameraZ(0)
	
	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
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
	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,waterskyc,	valley.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	
	t_view	=1<<(ri-1)*6
	fogc=$666688:skyc=$ff7722:hrzc=$4488ff:sunc=$ffffff	
	waterc=$00113300
	waterskyc=$ffaa7766
	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=$5577aa:skyc=$335588:waterskyc=$ff446699: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":waterc=$443322:valley=-4:skytype=1
		Case 3:c1=$07004466:c2=$11004488:c3=$2288bbff:blur=0:r=1:prof="0,0.3/0.2,0/0.7,0.8/1,1"
		Case 4:c1=$07004433: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":valley=2
	EndSelect
	CreateCamera(0, 0, 0, 100, 100):MoveCamera(0,0,4,5):CameraLookAt(0,0,0,0):CameraBackColor(0,fogc)
	Fog(fogc,1,0,t_view)
	CreateLight(0, sunc, -10000*2, 10000,00)
	
	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,2):Noise2d(g(),1024,1024,1,5):outline2d(g(),0,1,"0,1/0.5,0/1,1"):add2D(h(),g(),0.8):textureArrayToColor(60,h(),"0,$00eeeeee/0.6/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	
	GetScriptMaterial(60,"sky"):MaterialTextureAliases(60,TextureID(60),0,0,0)
	MaterialCullingMode(60,#PB_Material_NoCulling)
	SetMaterialColor(60,#PB_Material_AmbientColor,skyc)
	SetMaterialColor(60,#PB_Material_DiffuseColor,hrzc)
    ScaleMaterial(60,0.5,0.5)
	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) 
	GetScriptMaterial(#eau,"water_s"):MaterialTextureAliases(#eau,TextureID(#eau),0,0,0)
	MaterialBlendingMode(#eau,#PB_Material_AlphaBlend)
	MaterialShininess(#eau,256)
	SetMaterialColor(#eau,#PB_Material_DiffuseColor,waterc)	
	SetMaterialColor(#eau,#PB_Material_SpecularColor,waterskyc)
	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);

   	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
	GetScriptMaterial(0,"terrain_t"):MaterialTextureAliases(0,TextureID(0),TextureID(1),TextureID(2),TextureID(3))
	MaterialShininess(0,64):SetMaterialColor(0,#PB_Material_SpecularColor,$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))
	LoadFont(0,"arial",11*100/DesktopScaledX(100))
    menu()
	
 	Add3DArchive(#PB_Compiler_Home + "Examples\3D\Data\Scripts\MaterialScriptsGeneric", #PB_3DArchive_FileSystem )
	Parse3DScripts()
	
	initterrain(1024,0.5)
	
	selectterrain(6)
	
	Protected.f MouseX,Mousey, mdx,mdy,amo=0.1,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()
        While WindowEvent():Wend
    Until KeyboardPushed(#PB_Key_Escape) Or MouseButton(3)
EndProcedure

test3d()
Last edited by pf shadoko on Mon Aug 02, 2021 10:04 am, edited 1 time in total.
User avatar
STARGÅTE
Addict
Addict
Posts: 1565
Joined: Thu Jan 10, 2008 1:30 pm
Location: Germany, Glienicke
Contact:

Re: Demo 3D - mountains (Shader GLSL)

Post by STARGÅTE »

Looks nice, but please add a CompierIf for the Subsystem:
I was struggled in DirectX.

Code: Select all

CompilerIf Not Subsystem("OpenGL")
  CompilerError "Only OpenGL supported"
CompilerEndIf
Edit: I am ask me, if I can use such code also for generating spherical planets? What do you think?
PB 5.73 ― Win 10, 20H2 ― Ryzen 9 3900X ― Radeon RX 5600 XT ITX ― Vivaldi 4.0 ― www.unionbytes.de
Lizard - Script language for symbolic calculations and moreTypeface - Sprite-based font include/module
User avatar
Caronte3D
Enthusiast
Enthusiast
Posts: 177
Joined: Fri Jan 22, 2016 5:33 pm
Location: Spain

Re: Demo 3D - mountains (Shader GLSL)

Post by Caronte3D »

how to compile in OpenGL? I want to try it
User avatar
STARGÅTE
Addict
Addict
Posts: 1565
Joined: Thu Jan 10, 2008 1:30 pm
Location: Germany, Glienicke
Contact:

Re: Demo 3D - mountains (Shader GLSL)

Post by STARGÅTE »

You have to type "OpenGL" into the "Library Subsystem" field:
Image
PB 5.73 ― Win 10, 20H2 ― Ryzen 9 3900X ― Radeon RX 5600 XT ITX ― Vivaldi 4.0 ― www.unionbytes.de
Lizard - Script language for symbolic calculations and moreTypeface - Sprite-based font include/module
User avatar
DK_PETER
Addict
Addict
Posts: 876
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Re: Demo 3D - mountains (Shader GLSL)

Post by DK_PETER »

Wow!
I wish I had the sparetime to work with shaders. Some day soon, maybe.
Great work!
“Tell me and I forget. Teach me and I remember. Involve me and I learn.”
— Benjamin Franklin
Current configurations:
Windows 10, Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Windows 10, Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
User avatar
Caronte3D
Enthusiast
Enthusiast
Posts: 177
Joined: Fri Jan 22, 2016 5:33 pm
Location: Spain

Re: Demo 3D - mountains (Shader GLSL)

Post by Caronte3D »

I get error at line 578

[20:34:52] [ERROR] test.pb (Linea: 578)
[20:34:52] [ERROR] Invalid memory access. (read error at address 60)
User avatar
DK_PETER
Addict
Addict
Posts: 876
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Re: Demo 3D - mountains (Shader GLSL)

Post by DK_PETER »

@Caronte3D

Did you extract the archive http://cg.racine.free.fr/montagnes.zip to:
...\Examples\3D\Data\Scripts\MaterialScriptsGeneric ?
“Tell me and I forget. Teach me and I remember. Involve me and I learn.”
— Benjamin Franklin
Current configurations:
Windows 10, Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Windows 10, Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
User avatar
Caronte3D
Enthusiast
Enthusiast
Posts: 177
Joined: Fri Jan 22, 2016 5:33 pm
Location: Spain

Re: Demo 3D - mountains (Shader GLSL)

Post by Caronte3D »

Ah! ok I was recreated this directory structure on another place, but no in the compiler home :lol: Works now. Very nice! :wink:
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 174
Joined: Thu Jul 09, 2015 9:07 am

Re: Demo 3D - mountains v2

Post by pf shadoko »

________________________________________________________________________________________________________ v2
a small update
I've improved the shaders, it should be nicer (and smoother on "small" machines)
see 1st post
Post Reply