Demo 3D - mountains v2

Everything related to 3D programming
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 283
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: 2067
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 6.01 ― Win 10, 21H2 ― Ryzen 9 3900X, 32 GB ― NVIDIA GeForce RTX 3080 ― Vivaldi 6.0 ― www.unionbytes.de
Lizard - Script language for symbolic calculations and moreTypeface - Sprite-based font include/module
User avatar
Caronte3D
Addict
Addict
Posts: 1027
Joined: Fri Jan 22, 2016 5:33 pm
Location: Some Universe

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: 2067
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 6.01 ― Win 10, 21H2 ― Ryzen 9 3900X, 32 GB ― NVIDIA GeForce RTX 3080 ― Vivaldi 6.0 ― www.unionbytes.de
Lizard - Script language for symbolic calculations and moreTypeface - Sprite-based font include/module
User avatar
DK_PETER
Addict
Addict
Posts: 898
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!
Current configurations:
Ubuntu 20.04/64 bit - Window 10 64 bit
Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
User avatar
Caronte3D
Addict
Addict
Posts: 1027
Joined: Fri Jan 22, 2016 5:33 pm
Location: Some Universe

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: 898
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 ?
Current configurations:
Ubuntu 20.04/64 bit - Window 10 64 bit
Intel 6800K, GeForce Gtx 1060, 32 gb ram.
Amd Ryzen 9 5950X, GeForce 3070, 128 gb ram.
User avatar
Caronte3D
Addict
Addict
Posts: 1027
Joined: Fri Jan 22, 2016 5:33 pm
Location: Some Universe

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: 283
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
MrBean
User
User
Posts: 17
Joined: Sat Dec 22, 2012 7:27 am

Re: Demo 3D - mountains v2

Post by MrBean »

extremely nice demos, thank you
i suggest to the users to replace line 644
Add3DArchive(#PB_Compiler_Home + "Examples\3D\Data\Scripts\MaterialScriptsGeneric", #PB_3DArchive_FileSystem )
with this one
Add3DArchive(".", #PB_3DArchive_FileSystem )
and then copy the shaders (the files in montagnes.zip ) to the directory of the demo source code

also i wish the purebasic examples to have an examples on how to use the shaders in the simplest way possible:
how to plot a point with a color in 2D and 3D context
how to plot a line
how to plot a circle
using shaders
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 283
Joined: Thu Jul 09, 2015 9:07 am

Re: Demo 3D - mountains v2

Post by pf shadoko »

thank you for the comments

@ MRbean:
why would you suggest changing the shader path?

shaders are not meant to draw lines or circles
we are talking about material shaders only
in this particular case (and also for my ocean v2 demo) they modify the vertex position

I have provided an example of using shaders in the following post:
viewtopic.php?f=36&t=76323
if you have any questions, do not hesitate
infratec
Always Here
Always Here
Posts: 6817
Joined: Sun Sep 07, 2008 12:45 pm
Location: Germany

Re: Demo 3D - mountains v2

Post by infratec »

pf shadoko wrote: Wed Aug 11, 2021 10:44 am @ MRbean:
why would you suggest changing the shader path?
I did the same, because then I can copy the textures beside the PB file and don't need to copy it to
\Program Files\...
Post Reply