Тема: Voxel (octotree)
Показать сообщение отдельно
Старый 07.10.2013, 19:43   #13
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

Ну ,вот , наконец-то что-то получилось ...
Ошибка крылась как всегда в моей невнимательности .
Правда с удалением пришлось повозиться.
Считаю вполне рабочий вариант
код:
SeedRnd MilliSecs()

Const Points = 22 ; колличество точек
Const ConstDepth = 6 ;глубина вложений

Type Octree
Field Child.Octree[7] , Parent.Octree;8 потомков и  родитель
Field xmin,ymin,zmin
;Field xcentr,ycentr,zcentr ; ????? ????
Field qred,qgreen,qblue,qalpha,qcolor
Field size , depth 
End Type

Global root.Octree , sel.Octree , parent.Octree
Global id,id2,id3,mx,my ;,CubDepth ,CubSize 
Global px,py,pz ,s ,mxx,myy , mmy
Global timeoutcreate# , timeintcreate , viewline 


Type Point
Field x,y,z
Field x2,y2,z2
Field vx,vy,vz
End Type 


Function CreateOctree.Octree(xmin,ymin,zmin ,size,depth,par.Octree)
	id2=id2+1
	this.Octree= New Octree
	this\xmin = xmin
	this\ymin = ymin
	this\zmin = zmin 
	this\size = size
	this\depth = depth 
	this\parent = par
	For ok = 0 To 7
		this\child[ok] = Null 
	Next 
	
	Return this
End Function




Function AddOctree.Octree( this.Octree,xmin,ymin,zmin ,size,ppx,ppy,ppz,depth)
If depth >0
	If PointInCube(xmin,ymin,zmin,xmin+size,ymin+size,zmin+size,ppx,ppy,ppz )
	
		newsize = (size Shr 1)
		
		If this = Null
			this = CreateOctree(xmin,ymin,zmin ,size,depth,this)
			AddOctree(this , xmin,ymin,zmin ,size,ppx,ppy,ppz , depth)
		Else 		
					
			newdepth = depth -1
			newxmin = xmin+newsize
			newymin = ymin+newsize
			newzmin = zmin+newsize
			this\Child[0] = AddOctree(this\Child[0], xmin,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
			this\Child[1] = AddOctree(this\Child[1], xmin,newymin  ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth )
			this\Child[2] = AddOctree(this\Child[2], newxmin ,newymin ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
			this\Child[3] = AddOctree(this\Child[3], newxmin ,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
			
			this\Child[4] = AddOctree(this\Child[4], xmin,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
			this\Child[5] = AddOctree(this\Child[5], xmin,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth )
			this\Child[6] = AddOctree(this\Child[6], newxmin ,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
			this\Child[7] = AddOctree(this\Child[7], newxmin ,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
			
		EndIf 
	EndIf
EndIf
	Return this
End Function

Function DelOctree.Octree( this.Octree,xmin,ymin,zmin ,size,ppx,ppy,ppz,depth)
If depth >0
	newsize = (size Shr 1)
	If  InCube(xmin,ymin,zmin,size) = False
		If this <> Null
			If this\Child[0] = Null And this\Child[1] = Null And this\Child[2] = Null And this\Child[3] = Null And this\Child[4] = Null And this\Child[5] = Null And this\Child[6] = Null And this\Child[7] = Null Then 
				If this <> root
					Delete this
					id2=id2-1
					
				EndIf 
			Else
			newdepth = depth -1
			newxmin = xmin+newsize
			newymin = ymin+newsize
			newzmin = zmin+newsize
			If this\Child[0] <> Null Then DelOctree(this\Child[0], xmin,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
			If this\Child[1] <> Null Then DelOctree(this\Child[1], xmin,newymin  ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth )
			If this\Child[2] <> Null Then DelOctree(this\Child[2], newxmin ,newymin ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
			If this\Child[3] <> Null Then DelOctree(this\Child[3], newxmin ,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
			
			If this\Child[4] <> Null Then DelOctree(this\Child[4], xmin,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
			If this\Child[5] <> Null Then DelOctree(this\Child[5], xmin,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth )
			If this\Child[6] <> Null Then DelOctree(this\Child[6], newxmin ,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
			If this\Child[7] <> Null Then DelOctree(this\Child[7], newxmin ,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 		
					Delete this
					id2=id2-1							
			EndIf 
		EndIf 
	Else 	
			newdepth = depth -1
			newxmin = xmin+newsize
			newymin = ymin+newsize
			newzmin = zmin+newsize
			If this\Child[0] <> Null Then DelOctree(this\Child[0], xmin,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
			If this\Child[1] <> Null Then DelOctree(this\Child[1], xmin,newymin  ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth )
			If this\Child[2] <> Null Then DelOctree(this\Child[2], newxmin ,newymin ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
			If this\Child[3] <> Null Then DelOctree(this\Child[3], newxmin ,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
			
			If this\Child[4] <> Null Then DelOctree(this\Child[4], xmin,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
			If this\Child[5] <> Null Then DelOctree(this\Child[5], xmin,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth )
			If this\Child[6] <> Null Then DelOctree(this\Child[6], newxmin ,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
			If this\Child[7] <> Null Then DelOctree(this\Child[7], newxmin ,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
	EndIf
EndIf
	Return this
End Function

Function InCube(Axmin,Aymin,Azmin,Asize)
	For pts.POINT = Each POINT
		If PointInCube(Axmin,Aymin,Azmin,Axmin+Asize,Aymin+Asize,Azmin+Asize,pts\x,pts\y,pts\z ) = True  Then 
		Return True 
		Exit 
		EndIf 
	Next 
	Return False 
End Function 

Graphics 800,600,32,2 
SetBuffer BackBuffer() 

 For p = 0 To Points 
	pt.POINT = New POINT
	pt\x = Int(Rnd(10,120))
	pt\y =  Int(Rnd(10,120))
	pt\z =  Int(Rnd(10,120))
	id3 = id3 +1
 Next 
;HidePointer
CubDepth = ConstDepth  ; 8 ;число вложений (глубина ) 
CubSize = 128 ; размеры квадранта 
v=1

root.Octree = CreateOctree(0,0,0,CubSize ,CubDepth ,Null)

While Not KeyHit(1) 
	start  = MilliSecs()
	mx = MouseX() 
	my = MouseY() 
	s = Abs(MouseZ())+5
	id=0
	Cls 
	If  KeyDown(30) And pz <CubSize Then pz=pz+1 ;   A key
	If  KeyDown(44) And pz > 0 Then pz=pz-5	   ;   Z key
	If KeyHit(2)  Then viewline = Not viewline 
	If KeyHit(57)  Then 

	EndIf 


For pt.POINT = Each POINT


	
	timestart = MilliSecs()	
	AddOctree(root, 0,0,0,CubSize,pt\x,pt\y,pt\z ,CubDepth)	
	DelOctree(root, 0,0,0,CubSize,pt\x,pt\y,pt\z ,CubDepth)	
	timeoutcreate = (MilliSecs()-timestart)
	

	If pt\x <= 10 Then 
	pt\x = Int(Rnd(10,120))
	pt\y =  Int(Rnd(10,120))
	pt\z =  Int(Rnd(10,120))
	v=1
	EndIf
	If pt\x >= 126 Then 
	
	pt\x = Int(Rnd(10,120))
	pt\y =  Int(Rnd(10,120))
	pt\z =  Int(Rnd(10,120))
	v=-1
	EndIf
        pt\x = pt\x +v	
	
Next 

RenderOctree(root,CubDepth )

For roots.OCTREE = Each OCTREE 
	If roots<>Null
		id=id+1
	EndIf 
Next 



Oval  400+(mx-my )-s,300+ ( my+mx )/2- pz -s,s*2,s*2,0
;--------------- INFO -----------------------------------
	Color 255,255,255
	Text 550,20,"Elements = "+id+"   id2  = "+id2+"   id3  = "+id3
;	Text 550,40,"Radius = "+s+"        - scroll mouse"
;	Text 550,60,"Position Z = "+pz+"         - press A or Z"
	Text 550,80,"Time AddClearOctree = "+timeoutcreate 
	Text 550,100,"Current FPS: " + CurFPS#  
;	Text 550,120,"ViewBoxes = "+viewline +"       - press ENTER"
;	Text 550,160,"View_2d_Boxes = "+show2d +"       - press key 1"
	CurFPS# = 1000.0 / (MilliSecs() - Start)
Flip 
Wend 
Delete Each OCTREE
Delete Each POINT
End  

Function RenderOctree(this.OCTREE,depth)
If this.OCTREE <> Null 
	If (depth >0)	
		If show2d = 0
			Color 128,128,128
		EndIf
		If viewline = 0			
			If depth = 7 Then Color 28,28,28
			If depth = 6 Then Color 128,128,1
			If depth = 5 Then Color 128,1,128
			If depth = 4 Then Color 1,128,128	
			If depth = 3 Then Color 1,1,128
			If depth = 2 Then Color 1,128,1
			If depth = 1 Then Color 128,1,1
			If depth = 0 Then Color 128,128,128
						
			x_min1 = 400+ (this\xmin - this\ymin)
			x_min2 = 400+ ((this\xmin+this\size) - this\ymin)
			x_min3 = 400+ ((this\xmin+this\size) - (this\ymin+this\size))
			x_min4 = 400+ ((this\xmin) - (this\ymin+this\size))
			
			y_min1 = 300+ (this\xmin + this\ymin)/2 -  this\zmin
			y_min2 = 300+ ((this\xmin+this\size) + this\ymin)/2 -  this\zmin
			y_min3 = 300+ ((this\xmin+this\size) + (this\ymin+this\size))/2 -  this\zmin 
			y_min4 = 300+ ((this\xmin) + (this\ymin+this\size))/2 -  this\zmin
				
				Line x_min1 , y_min1 , x_min2 , y_min2
				Line x_min2 , y_min2 , x_min3 , y_min3
				Line x_min3 , y_min3 , x_min4 , y_min4
				Line x_min4 , y_min4 , x_min1 , y_min1
					
				Line x_min1 , y_min1 -this\size , x_min2 , y_min2 -this\size
				Line x_min2 , y_min2 -this\size , x_min3 , y_min3 -this\size
				Line x_min3 , y_min3 -this\size , x_min4 , y_min4 -this\size
				Line x_min4 , y_min4 -this\size , x_min1 , y_min1 -this\size
				
				Line x_min1 , y_min1 , x_min1 , y_min1 -this\size
				Line x_min2 , y_min2 , x_min2 , y_min2 -this\size
				Line x_min3 , y_min3 , x_min3 , y_min3 -this\size
				Line x_min4 , y_min4 , x_min4 , y_min4 -this\size
		
		EndIf 
	;	Text this\xmin +this\depth*6, this\ymin +this\depth*6 , this\depth
			depth = depth - 1
			RenderOctree(this\Child[0],depth)
			RenderOctree(this\Child[1],depth)
			RenderOctree(this\Child[2],depth)
			RenderOctree(this\Child[3],depth)	
			RenderOctree(this\Child[4],depth)
			RenderOctree(this\Child[5],depth)
			RenderOctree(this\Child[6],depth)
			RenderOctree(this\Child[7],depth)	

	Else 	
		If viewline = 1	
			zz = this\depth
			If  zz > 200 Then zz = 200 
			If zz < 0 Then zz = 0
			
				Color 25+zz ,25+zz ,25+zz
			LockBuffer GraphicsBuffer()
			For nz = this\zmin To this\zmin+this\size 
				For ny = this\ymin To this\ymin+this\size 
					For nx = this\xmin To this\xmin+this\size 
						WritePixel 400+ (nx-ny) , 300+ (nx+ny)/2 - nz ,$333333, GraphicsBuffer()
					Next 	
				Next 		
			Next	
			UnlockBuffer GraphicsBuffer()
		EndIf 	
		
		If show2d = 0
			Color 128,128,128
			WritePixel this\xmin , this\ymin , $333333	
		EndIf 
	EndIf 
EndIf
End Function





Function PointInCube(pointXmin#,pointYmin#,pointZmin#,pointXmax#,pointYmax#,pointZmax#,pointX#,pointY#,pointZ )
	  If  pointX  >=pointXmin And pointX < pointXmax
	    If  pointY >= pointYmin And pointY < pointYmax
	      If  pointZ>= pointZmin And  pointZ< pointZmax
			Return True
	      End If 
	    End If
	  End If
	Return False 
End Function


собственно небольшое отклонение . Для чего это нужно , вот пример построение ландшафта при помощи квадро-дерева тут .
__________________
Мой проект здесь

Последний раз редактировалось polopok, 14.10.2013 в 20:16.
(Offline)
 
Ответить с цитированием