Demo 3D - Mountain v3

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

Demo 3D - Mountain v3

Post by pf shadoko »

I didn't get tired for v3, I just added some mist (more or less successful)
but this time there's no need to copy scripts anymore, everything is in the code
(important for those like me, too lazy to test a code that needs more effort than a copy/paste)
there are 6 sets : F1 -> F6

Code: Select all

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)
			;Debug ""+ri+"  "+tx+"  "+ty+"        "+*mem\i
		EndIf		
	EndIf	
EndProcedure

Procedure renderTile()
	Protected i,j,xx,yy,	x=CameraX(0),y=CameraZ(0)
	;CreateLine3D(0,x,0,y,$ff,x,200,y,$ff)
	
	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
	;Protected k,nbe:For k=0 To ri:For j=0 To 5:For i=0 To 5:nbe+Bool(IsEntity(mem(k,i,j))):Next:Next:Next:Debug nbe
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
	t_view	=1<<(ri-1)*6
	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,	valley.f,foga.f,fogy.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	
	fogc=$ffcccc:foga=500:fogy=50:skyc=$ff7722:hrzc=$4488ff:sunc=$ffffff	
	waterc=$00113300
	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=$888888:fogy=120:skyc=$335588: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":fogy=250:foga=1000:waterc=$443322:valley=-4:skytype=1
		Case 3:c1=$07004466:c2=$11004488:c3=$2288bbff:blur=0:r=0:prof="0,0/0.3,0.3/0.5,0.8/1,1":valley=1
		Case 4:c1=$07007766: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":fogy=50:valley=2
	EndSelect
	CreateCamera(0, 0, 0, 100, 100):MoveCamera(0,0,4,5):CameraLookAt(0,0,0,0):CameraBackColor(0,fogc):CameraRange(0,1,100000)
	Fog(fogc,1,0,t_view)
	CreateLight(0, sunc, -10000*2*2, 10000,0)
	
	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,3):Noise2d(g(),1024,1024,1,6):outline2d(g(),0,1,"0,1/0.5,0/1,1"):add2D(h(),g(),0.8):textureArrayToColor(60,h(),"0,$00eeeeee/0.5/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	
	CreateShaderMaterial(60,#PB_Material_SkyShader):MaterialShaderTexture(60,TextureID(60),0,0,0)
	MaterialShaderParameter(60,1,"speed",4,0.5,0,0,0)
	MaterialShaderParameter(60,1,"height",1,1000,0,0,0)
	MaterialShaderParameter(60,1,"scale",1,16000,0,0,0)
	MaterialCullingMode(60,#PB_Material_NoCulling)
	SetMaterialColor(60,1,skyc)
	SetMaterialColor(60,2,hrzc)
     ;ScaleMaterial(60,0.05,0.05)
	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) 
	CreateShader(1,"%%%#version 130%%uniform mat4 P0;//+0%varying vec2 ouv;%varying vec4 opos_w;%%varying float vdist;%varying vec2 vuv;%%void main()%{%ouv=(gl_TextureMatrix[0]*gl_MultiTexCoord0).xy;%opos_w=P0*gl_Vertex;%gl_Position=ftransform();%vdist=gl_Position.z;%}%%%%%%%%%%%",
	             "%%%#version 130%%varying vec2 ouv;%varying vec4 opos_w;%varying float vdist;%varying vec2 vuv;%uniform vec4 P30;//+30%uniform vec3 fog;//0.000 0.0005 200%uniform float P36;//+36%uniform vec4 P40;//+40%uniform vec4 P43;//+43%uniform vec4 P69;//+69%uniform vec4 P70;//+70%uniform vec4 P76;//+76%uniform float P86;//+86%uniform vec4 water_params;//0 0 40 0.025%%uniform sampler2D normalMap;//0%%void main()%{%float f;%vec4 fc;%if(P76.y<0)%{f=min(vdist*water_params.w,1);fc=vec4(P69.rgb,1);}%else%{f=min(vdist*mix(fog.x,fog.y,(min(P76.y,fog.z)-min(opos_w.y,fog.z))/(P76.y-opos_w.y)),1);fc=P30;}%if(f==1){gl_FragColor=fc;return;}%%vec2 duv=vec2(P86*0.01,0);%vec3 normal=normalize(texture(normalMap,ouv+duv).xyz+texture(normalMap,ouv+0.5-duv).xyz-1).xzy;%vec3 lightdir=normalize(P43.xyz-opos_w.xyz);lightdir.y*=sign(P76.y);%vec3 viewdir=normalize(P76.xyz-opos_w.xyz);%float cfresnel=1-abs(dot(viewdir,normal));%vec4 color=mix(P69,P70,cfresnel*cfresnel);%color+=P40*pow(max(dot(normalize(lightdir+viewdir),normal),0),P36);%%gl_FragColor=mix(color,fc,f);%}%%%%%%%%%%%")
	CreateShaderMaterial(#eau,1):MaterialShaderTexture(#eau,TextureID(#eau),0,0,0)
	MaterialShaderParameter(#eau,1,"fog",#PB_Shader_Vector3,   1/t_view, 1/foga, fogY, 0)
	MaterialBlendingMode(#eau,#PB_Material_AlphaBlend)
	MaterialShininess(#eau,256)
	SetMaterialColor(#eau,2,waterc)	
	SetMaterialColor(#eau,4,$ff000000+ColorBlend(skyc,fogc,0.8))
	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);
   	; 	Dim h(t_size-1,t_size-1):For i=0 To 10000:h(Random(t_size),Random(t_size))=pom(1):Next:outline2d(h(),0,1)

   	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
   	CreateShader(0,"%%#version 130%%uniform mat4 P0;//+0%uniform mat4 P16;//+16%uniform sampler2D alt;//0%uniform float height;//64%uniform float heightdec;//230%uniform float lng;//512%uniform float r;//8%%varying vec4 vposw;%varying vec2 vuv0;%varying vec2 vuv1;%varying float vdist;%%void main()//0%{%vposw=P0*gl_Vertex;%vuv0=(vposw.xz/r+0.25)/lng;%vuv1=(vposw.xz+0.25)/lng;%float tx0=texture(alt,vuv0).w-0.5;%float tx1=texture(alt,vuv1).w-0.5;%vposw.y=(tx0*r+tx1)*height+heightdec;%gl_Position=P16*vposw;%vdist=abs(gl_Position.z);%}%%%%",
   	             "%%#version 130%%varying vec4 vposw;%varying vec2 vuv0;%varying vec2 vuv1;%varying float vdist;%uniform vec4 P30;//+30%uniform vec4 P31;//+31%uniform vec4 P35;//+35%uniform float P36;//+36%uniform vec4 P43;//+43%uniform vec4 P67;//+67%uniform vec4 P69;//+69%uniform vec4 P70;//+70%uniform vec4 P76;//+76%uniform vec3 fog;//0.000 0.0005 200%%uniform sampler2D alt;//0%uniform sampler2D color;//1%uniform sampler2D tcolor;//2%uniform sampler2D tnorm;//3%%uniform float height2;//8%uniform vec4 water_params;//0 0 20 0.050%%void main()%{%float f;vec4 fc;vec4 coloratt=vec4(1);%if(vposw.y<0)%{%if(P76.y>=0)f=min(vdist*-vposw.y/(P76.y-vposw.y)*water_params.w,1);else f=min(vdist*water_params.w,1);%fc=P35;if(f==1){gl_FragColor=fc;return;}%coloratt=vec4(0.8,0.8,0.8,0);%}%else%{%//f=min(vdist*P31.w,1);%f=(min(P76.y,fog.z)-min(vposw.y,fog.z))/(P76.y-vposw.y);%f=min(vdist*mix(fog.x,fog.y,f),1);%fc=P30;if(f==1){gl_FragColor=fc;return;}%}%%vec3 vlightdir=normalize(P43.xyz-vposw.xyz);%vec3 vviewdir=normalize(P76.xyz-vposw.xyz);%%vec4 tx1=texture(alt,vuv0)+texture(alt,vuv1)-1;tx1.xy*=height2;%vec4 tx2=texture(tnorm,vuv1*64)-0.5;tx2.xy*=(2+length(tx1.xy)*8);%vec3 nor=normalize(tx1.xzy+tx2.xzy);%vec4 vcolor=texture(color,vuv0)+texture(color,vuv1);%vec4 fcolor=vec4(texture(tcolor,vuv1*64).rgb,1)*vcolor*coloratt;%float dif=max(dot(vlightdir,nor),0);%float spe=pow(max(dot(normalize(vlightdir+vviewdir),nor),0),P36);%gl_FragColor=fcolor*(P67+P69*dif)+fcolor.a*P70*spe;%gl_FragColor=mix(gl_FragColor,fc,f);%}%%%%")  	
   	CreateShaderMaterial(0,0):MaterialShaderTexture(0,TextureID(0),TextureID(1),TextureID(2),TextureID(3))
   	MaterialShaderParameter(0,1,"fog",#PB_Shader_Vector3,   1/t_view, 1/foga, fogY, 0)

	MaterialShininess(0,64,$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))
	;OpenScreen(ex,ey,32,"")
	LoadFont(0,"arial",11*1/DesktopScaledX(1))
    menu()
	
		initterrain(1024,0.5)
	
	selectterrain(6)
	
	Protected.f MouseX,Mousey, mdx,mdy,amo=0.04,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()
		If IsWindow(0):While WindowEvent():Wend:EndIf
    Until KeyboardPushed(#PB_Key_Escape) Or MouseButton(3)
EndProcedure

test3d()
Last edited by pf shadoko on Sat Apr 01, 2023 5:21 pm, edited 2 times in total.
dige
Addict
Addict
Posts: 1247
Joined: Wed Apr 30, 2003 8:15 am
Location: Germany
Contact:

Re: Demo 3D - Mountain v3

Post by dige »

:shock: Boah, my jaw just dropped

Great stuff!!! :D
"Daddy, I'll run faster, then it is not so far..."
BarryG
Addict
Addict
Posts: 3292
Joined: Thu Apr 18, 2019 8:17 am

Re: Demo 3D - Mountain v3

Post by BarryG »

Unbelievable! So good! Thanks for sharing.
User avatar
Caronte3D
Addict
Addict
Posts: 1027
Joined: Fri Jan 22, 2016 5:33 pm
Location: Some Universe

Re: Demo 3D - Mountain v3

Post by Caronte3D »

:shock: Another awesome example of an sadly forgoter area of PB (3D engine).
I hope some day we get the current version of Ogre3D inside PB.
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 285
Joined: Thu Jul 09, 2015 9:07 am

Re: Demo 3D - Mountain v3

Post by pf shadoko »

it's in progress, but shhh !
that said, the biggest problem with 3D is not the ogre version, but the documentation
User avatar
Caronte3D
Addict
Addict
Posts: 1027
Joined: Fri Jan 22, 2016 5:33 pm
Location: Some Universe

Re: Demo 3D - Mountain v3

Post by Caronte3D »

pf shadoko wrote: Mon Mar 20, 2023 10:51 am it's in progress, but shhh !
Image
User avatar
Andre
PureBasic Team
PureBasic Team
Posts: 2056
Joined: Fri Apr 25, 2003 6:14 pm
Location: Germany (Saxony, Deutscheinsiedel)
Contact:

Re: Demo 3D - Mountain v3

Post by Andre »

Impressive! :)
Bye,
...André
(PureBasicTeam::Docs & Support - PureArea.net | Order:: PureBasic | PureVisionXP)
User avatar
DK_PETER
Addict
Addict
Posts: 898
Joined: Sat Feb 19, 2011 10:06 am
Location: Denmark
Contact:

Re: Demo 3D - Mountain v3

Post by DK_PETER »

Damn! Pure magic!
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
luis
Addict
Addict
Posts: 3876
Joined: Wed Aug 31, 2005 11:09 pm
Location: Italy

Re: Demo 3D - Mountain v3

Post by luis »

These are the thinnest mountains I ever seen. :shock:

Image

Image
"Have you tried turning it off and on again ?"
A little PureBasic review
User avatar
idle
Always Here
Always Here
Posts: 5042
Joined: Fri Sep 21, 2007 5:52 am
Location: New Zealand

Re: Demo 3D - Mountain v3

Post by idle »

wow that looks great. thanks for sharing
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 285
Joined: Thu Jul 09, 2015 9:07 am

Re: Demo 3D - Mountain v3

Post by pf shadoko »

@luis :
can you give me the log file :InitEngine3D(#PB_Engine3D_DebugLog)
(and put it in code section, it will take less space)
Saboteur
Enthusiast
Enthusiast
Posts: 271
Joined: Fri Apr 25, 2003 7:09 pm
Location: (Madrid) Spain
Contact:

Re: Demo 3D - Mountain v3

Post by Saboteur »

I have same problem, but on Linux, with an Intel card.
[:: PB Registered ::]

Win10 Intel core i5-3330 8GB RAM Nvidia GTX 1050Ti
User avatar
luis
Addict
Addict
Posts: 3876
Joined: Wed Aug 31, 2005 11:09 pm
Location: Italy

Re: Demo 3D - Mountain v3

Post by luis »

pf shadoko wrote: Tue Mar 21, 2023 7:18 am can you give me the log file :InitEngine3D(#PB_Engine3D_DebugLog)
Hi, here it is.

http://freeshell.de/luis/purebasic/Ogre.zip
"Have you tried turning it off and on again ?"
A little PureBasic review
User avatar
Kiffi
Addict
Addict
Posts: 1353
Joined: Tue Mar 02, 2004 1:20 pm
Location: Amphibios 9

Re: Demo 3D - Mountain v3

Post by Kiffi »

Amazing!
Hygge
User avatar
pf shadoko
Enthusiast
Enthusiast
Posts: 285
Joined: Thu Jul 09, 2015 9:07 am

Re: Demo 3D - Mountain v3

Post by pf shadoko »

@luis and Saboteur

I forgot to specify the version in the shader, maybe that's it
can you try again and tell me if it's ok ?
Post Reply