Извините, ничего не найдено.

Не расстраивайся! Лучше выпей чайку!
Регистрация
Справка
Календарь

Вернуться   www.boolean.name > Программирование игр для компьютеров > Blitz3D > 2D-программирование

2D-программирование Вопросы, касающиеся двумерного программирования

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

Итак , пробую связать воксели в изометрии .
Код правда сырой ,да и при большей глубине(depth) уж сильно тормозит
код:
Global id,level ,mx,my ,QDepth  
Global px#,py,pz ,s

Type QUADTREE
Field Child.QUADTREE[7] ;8 потомков
Field xmin,ymin,zmin ; начальные координаты квадранта
Field xmax,ymax,zmax ; оконечные координаты квадранта 
Field id ,vis , lock;  ;vis - visible , lock - bloked
End Type

Function Quadtree.QUADTREE(xmin,ymin,zmin,xmax,ymax,zmax,depth)
this.QUADTREE = New QUADTREE
this\xmin = xmin
this\xmax = xmax
this\ymin = ymin
this\ymax = ymax
this\zmin = zmin
this\zmax = zmax

id = id + 1
this\id = id
this\vis = False
this\lock= False

If (depth > 1)
; =============================================
xmod = (xmin+xmax) / 2
ymod = (ymin+ymax) / 2
zmod = (zmin+zmax) / 2

depth = depth - 1
this\Child[0] = Quadtree(xmin,ymin,zmin  ,xmod,ymod,zmod ,depth) 
this\Child[1] = Quadtree(xmin,ymod,zmin  ,xmod,ymax,zmod ,depth)
this\Child[2] = Quadtree(xmod,ymod,zmin  ,xmax,ymax,zmod ,depth) 
this\Child[3] = Quadtree(xmod,ymin,zmin  ,xmax,ymod,zmod ,depth) 

this\Child[4] = Quadtree(xmin,ymin,zmod  ,xmod,ymod,zmax,depth) 
this\Child[5] = Quadtree(xmin,ymod,zmod  ,xmod,ymax,zmax,depth)
this\Child[6] = Quadtree(xmod,ymod,zmod  ,xmax,ymax,zmax,depth) 
this\Child[7] = Quadtree(xmod,ymin,zmod  ,xmax,ymod,zmax,depth) 

EndIf
Return this
End Function

; =========================================
Function RenderQuadtree(this.QUADTREE,depth)

If (depth > 1)
	xmod = (xmin+xmax) / 2
	ymod = (ymin+ymax) / 2
	zmod = (zmin+zmax) / 2
		
		Color 88,88,88
			Rect this\xmin, this\ymin,this\xmax-this\xmin,this\ymax-this\ymin ,0
			

			
			
		depth = depth - 1
		RenderQuadtree(this\Child[0],depth)
		RenderQuadtree(this\Child[1],depth)
		RenderQuadtree(this\Child[2],depth)
		RenderQuadtree(this\Child[3],depth)
		
		RenderQuadtree(this\Child[4],depth)
		RenderQuadtree(this\Child[5],depth)
		RenderQuadtree(this\Child[6],depth)
		RenderQuadtree(this\Child[7],depth)
		
		If this\vis=True 
			Rect this\xmin+2, this\ymin+2,this\xmax-this\xmin-4,this\ymax-this\ymin-4 ,1
			
			xdot = (this\xmax+this\xmin)/2
			ydot = (this\ymax+this\ymin)/2
			zdot = (this\zmax+this\zmin)/2
			Color 40+zdot,40+zdot,40+zdot
			Oval 400+ (xdot -ydot*px) -13*(depth), 300+ (xdot +ydot*px )/2-zdot -13*(depth) , 26*(depth+depth),26*(depth+depth),1
			
		;	For y=this\ymin To this\ymax Step 5
		;		For x=this\xmin To this\xmax Step 5
		;		 For z=this\zmin To this\zmax Step 5
		;			Color 255,255,255
		;			Plot 400+x-y,400+(x+ y)/2-z	
		;		 Next
		;		Next
		;	Next 
			
		EndIf 
		
		

End If 

End Function

Function CalcQuadtree(this.QUADTREE,depth)

If (depth > 1)
		depth = depth - 1
		CalcQuadtree(this\Child[0],depth)
		CalcQuadtree(this\Child[1],depth)
		CalcQuadtree(this\Child[2],depth)
		CalcQuadtree(this\Child[3],depth)
		
		CalcQuadtree(this\Child[4],depth)
		CalcQuadtree(this\Child[5],depth)
		CalcQuadtree(this\Child[6],depth)
		CalcQuadtree(this\Child[7],depth)
		
		If this\Child[0]\lock= 1  And  this\Child[1]\lock= 1  And this\Child[2]\lock= 1 And  this\Child[3]\lock= 1 And  this\Child[4]\lock= 1  And  this\Child[5]\lock= 1  And this\Child[6]\lock= 1 And  this\Child[7]\lock= 1 Then		
			
			this\vis=True
			this\lock=True
			this\Child[0]\vis= False
			this\Child[1]\vis= False
			this\Child[2]\vis= False
			this\Child[3]\vis= False
			
			this\Child[4]\vis= False
			this\Child[5]\vis= False
			this\Child[6]\vis= False
			this\Child[7]\vis= False
		 
		EndIf

	If  depth =s  Then  ;depth =s  And pz > zmin And pz< zmax
	  If  mx >=this\xmin And mx < this\xmax
	    If  my >=this\ymin And my < this\ymax
	      If pz >=this\zmin And pz < this\zmax
	
			For y=this\ymin To this\ymax Step 3
			   For x=this\xmin To this\xmax Step 3
				 For z=this\zmin To this\zmax Step 3
					Color 255,5,5
					Plot 400+x-y*px,300+(x+ y*px)/2-z	
				 Next
			   Next
			Next 
			
;			xdot = (this\xmax+this\xmin)/2
;			ydot = (this\ymax+this\ymin)/2
;			zdot = (this\zmax+this\zmin)/2
;			Color 255,255,255
;			Oval 400+ xdot -ydot -6, 400+ (xdot +ydot )/2-zdot -6 , 12,12,1
	
		Rect this\xmin, this\ymin,this\xmax-this\xmin,this\ymax-this\ymin ,1
		Rect 250, 175 - this\zmin,25,this\zmax-this\zmin ,1
		Text 400,40, this\id +" visible = "+this\vis+"  Lock = "+this\lock
		If MouseDown(1) Or KeyDown(157) And this\lock= False Then ;
			this\lock=True 
			 this\vis=True 
		EndIf 
		If MouseDown(2) And this\lock= True Then ;
			this\lock=False 
			 this\vis=False 
		EndIf 
	      End If 
	    End If
	  End If
	End If		

End If 

End Function

Function EraseQuadtree(this.QUADTREE,depth)

If (depth > 1)
		depth = depth - 1
		EraseQuadtree(this\Child[0],depth)
		EraseQuadtree(this\Child[1],depth)
		EraseQuadtree(this\Child[2],depth)
		EraseQuadtree(this\Child[3],depth)

		EraseQuadtree(this\Child[4],depth)
		EraseQuadtree(this\Child[5],depth)
		EraseQuadtree(this\Child[6],depth)
		EraseQuadtree(this\Child[7],depth)
		
			this\lock=False 
			 this\vis=False 	
End If 

End Function

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

QuadDepth = 5;число вложений (глубина ) : Level 's
QuadSize = 200 ; размеры квадранта 


root.QUADTREE = Quadtree(0,0,0,QuadSize,QuadSize,QuadSize,QuadDepth)
px=1
While Not KeyHit(1) 
mx = MouseX() 
my = MouseY() 
s = Abs(MouseZ())+1

Cls 
Select True 
Case KeyHit(200) : py=py-0.1 ;Up
Case KeyHit(208) : py=py+0.1;Down
Case KeyHit(203) : px=px-0.1; Left
Case KeyHit(205) : px=px+0.1; Right
Case KeyDown(30) : pz=pz+1*15;   A key
Case KeyDown(44) : pz=pz-1*15;   Z key
Case KeyDown(57) : EraseQuadtree(root,QuadDepth)
End Select 
;	If px<0 Then px=1 
;	 If px>=180 Then px=180
	If py<0 Then py=1 
	 If py>=180 Then py=180
	If pz<0 Then mz=1 
	 If pz>=180 Then pz=180

Color 255,255,255
Rect root\xmin,root\ymin,root\xmax,root\ymax,0
Rect 250,0,25,root\ymax,0


RenderQuadtree(root,QuadDepth)
CalcQuadtree(root,QuadDepth)

Text 400,20,"S = "+s
Text 400,60,"px = "+px+"  py = "+my+"  pz = "+pz
Flip 
Wend 
End
__________________
Мой проект здесь

Последний раз редактировалось polopok, 08.05.2013 в 10:37.
(Offline)
 
Ответить с цитированием
Старый 05.05.2013, 11:27   #2
Nikich
Бывалый
 
Регистрация: 21.12.2011
Сообщений: 843
Написано 149 полезных сообщений
(для 269 пользователей)
Ответ: Voxel (octotree)

Приложи демку, хочется взглянуть на результат.
(Offline)
 
Ответить с цитированием
Старый 05.05.2013, 12:26   #3
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

Да собственно ни о каком достаточном результате ,говорить рано ,а потому и нет смысла делать даже демку . Код г. или полное г. тормоза жуткие ,рейкастинга нет ,даже его подобия . Всё в лоб.
Это скорее пробный вариант ,как говориться быстрый результат ,есть стимул для продолжения!
__________________
Мой проект здесь
(Offline)
 
Ответить с цитированием
Старый 06.05.2013, 03:53   #4
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

решил попробывать без Z координаты с ограничением зоны видимости и изменяемой детализацией от камеры .

КОД:

;==================================================================
;==================================================================


; Definit le Frustum 
Global p1x#,p1y#
Global p2x#,p2y#

; Enfants du Quadtree
Const CHILD00 = 0
Const CHILD01 = 1
Const CHILD11 = 2
Const CHILD10 = 3

; CAMERA
Type CAMERA
  Field x#,y#      ; Position de la camera
  Field fov#      ; Angle de vue
End Type

; creation d'une camera
Function Camera.CAMERA(x,y,fov)
  this.CAMERA = New CAMERA
  this\x = x : this\y = y : this\fov = fov
  Return this
End Function

; Renvoie True si un point est dans le plan Left du Frustum
Function PointInFrustumL(this.CAMERA,x,y)
  Return ( -(x - this\x) * (p1y - this\y) + (y - this\y) * (p1x - this\x) >= 0)
End Function

; Renvoie True si un point est dans le plan Right du Frustum
Function PointInFrustumR(this.CAMERA,x,y)
  Return ( -(x - this\x) * (p2y - this\y) + (y - this\y) * (p2x - this\x) <= 0)
End Function

; Renvoie True si un point est dans le plan Front du Frustum (pas utilise' ici)
Function PointInFrustumF(this.CAMERA,x,y)
  Return ( -(x - this\x) * (p3y - this\y) + (y - this\y) * (p3x - this\x) >= 0)
End Function

; QUADTREE
Type QUADTREE
  Field Child.QUADTREE[3]  ; Les 4 enfants du quadtree
  Field xmin#,ymin#      ; Coordonne'es du sommet haut gauche
  Field xmax#,ymax#    ; Coordonne'es du sommet bas droite
  Field dist%
  Field qred,qgreen,qblue,qcolor
End Type

; Creation d'un quadtree de profondeur depth
; et associe' a` un carre' de cote's xmax-xmin, ymax-ymin
Function Quadtree.QUADTREE(xmin,ymin,xmax,ymax,depth)
  this.QUADTREE = New QUADTREE
  this\xmin = xmin
  this\xmax = xmax
  this\ymin = ymin
  this\ymax = ymax
  this\dist = 1
;  this\qred = Rand(0,255)
;  this\qgreen = Rand(0,255)
;  this\qblue = Rand(0,255)
qcolor = CombineARGB#(0,Rand(0,255),Rand(0,255),Rand(0,255))	
  this\qcolor = Int( qcolor)
  If (depth > 0)
    ; On cre'e 4 enfants
    xmoy = (xmin+xmax) / 2
    ymoy = (ymin+ymax) / 2
    depth = depth - 1
    this\Child[CHILD00] = Quadtree(xmin,ymin,xmoy,ymoy,depth) ; Haut gauche
    this\Child[CHILD01] = Quadtree(xmin,ymoy,xmoy,ymax,depth) ; Bas gauche
    this\Child[CHILD11] = Quadtree(xmoy,ymoy,xmax,ymax,depth) ; Bas droite
    this\Child[CHILD10] = Quadtree(xmoy,ymin,xmax,ymoy,depth) ; Haut droite
  EndIf
  Return this
End Function 

; On teste si un des 4 sommets du carre' associe' au quadtree
; est visible par la camera
Function QuadInFrustum(this.QUADTREE,cam.CAMERA)
  Local nbPlansInterieur



  ; Plan de gauche
  nbPlansInterieur = 0
  nbPlansInterieur = nbPlansInterieur + PointInFrustumL(cam,this\xmin,this\ymin)
  nbPlansInterieur = nbPlansInterieur + PointInFrustumL(cam,this\xmin,this\ymax)
  nbPlansInterieur = nbPlansInterieur + PointInFrustumL(cam,this\xmax,this\ymin)
  nbPlansInterieur = nbPlansInterieur + PointInFrustumL(cam,this\xmax,this\ymax)
  If nbPlansInterieur = 0 Return False

  ; Plan de droite
  nbPlansInterieur = 0
  nbPlansInterieur = nbPlansInterieur + PointInFrustumR(cam,this\xmin,this\ymin)
  nbPlansInterieur = nbPlansInterieur + PointInFrustumR(cam,this\xmin,this\ymax)
  nbPlansInterieur = nbPlansInterieur + PointInFrustumR(cam,this\xmax,this\ymin)
  nbPlansInterieur = nbPlansInterieur + PointInFrustumR(cam,this\xmax,this\ymax)
  If nbPlansInterieur = 0 Return False

  Return True
End Function 

; Rendu du Quadtree
Function RenderQuadtree(this.QUADTREE,cam.CAMERA,depth)

this\dist = (Dist#( cam\x, cam\y, this\xmin, this\ymin )/100)
If this\dist<1 Then this\dist=1

  If QuadInFrustum(this,cam)
    If (depth > this\dist)
      Color 128,128,128
  ;    Line (this\xmin+this\xmax)/2,this\ymin,(this\xmin+this\xmax)/2,this\ymax
  ;    Line this\xmin,(this\ymin+this\ymax)/2,this\xmax,(this\ymin+this\ymax)/2



      depth = depth - 1
      
      RenderQuadtree(this\Child[CHILD00],cam,depth)
      RenderQuadtree(this\Child[CHILD01],cam,depth)
      RenderQuadtree(this\Child[CHILD11],cam,depth)
      RenderQuadtree(this\Child[CHILD10],cam,depth)
    Else
LockBuffer BackBuffer()
     ; Color this\qred,this\qgreen,this\qblue
	For b= this\ymin To this\ymax ;Step 1
	For a= this\xmin To this\xmax ;Step 1
	
   		WritePixelFast a,b, this\qcolor  , BackBuffer()	 ;this\qcolor

	Next
	Next
UnlockBuffer BackBuffer()
    EndIf 
  EndIf 
End Function 

;==============================================================================================
; EXAMPLE
;==============================================================================================

AppTitle "Simple Quadtree Demo - Seyhajin"
Graphics 512,512,0,2
SetBuffer BackBuffer()

; Variables de configuration
QuadDepth = 10        ; Profondeur du quadtree (nb de fois qu'on decoupe le plan)
QuadSize = 512        ; Taille initiale du quadtree
CamSpeed# = 2      ; Vitesse de deplacement de la camera
CamFOV# = 60.0 / 2.0    ; Angle de vue de la camera (default = 90)
ViewLine = 300        ; Taille de la ligne des plans 300 

; Creation de la camera
cam.CAMERA = Camera(QuadSize/2,QuadSize/2,CamFOV)
; Creation du Quadtree principale
root.QUADTREE = Quadtree(0,0,QuadSize,QuadSize,QuadDepth)

;----------------------------------
; BOUCLE PRINCIPALE
;----------------------------------
While Not KeyHit(1)
  Cls

  ; Update Camera position
  If KeyDown(200) ; Up
    cam\y = cam\y - CamSpeed#
  ElseIf KeyDown(208) ; Down
    cam\y = cam\y + CamSpeed#
  EndIf
  If KeyDown(203) ; Left
    cam\x = cam\x - CamSpeed#
  ElseIf KeyDown(205) ; Right
    cam\x = cam\x + CamSpeed#
  EndIf

  ; Rendu du quadtree
  Color 255,255,255
  Rect root\xmin,root\ymin,root\xmax,root\ymax,1
  RenderQuadtree(root,cam,QuadDepth)
  

  ; Dessine la pyramide de vue (Frustum)
  x# = MouseX() - cam\x
  y# = MouseY() - cam\y
  angle# = 180+ATan2(-y#,-x#)
  Color 255,255,0
  Line cam\x,cam\y,cam\x+(ViewLine)*Cos(angle#),cam\y+(ViewLine)*Sin(angle#)
  Color 255,0,0
  ; Plan gauche
  p1x = cam\x+ViewLine*Cos(angle#-CamFOV)
  p1y = cam\y+ViewLine*Sin(angle#-CamFOV)
  Line cam\x,cam\y,p1x,p1y
  ; Plan droit
  p2x = cam\x+ViewLine*Cos(angle#+CamFOV)
  p2y = cam\y+ViewLine*Sin(angle#+CamFOV)
  Line cam\x,cam\y,p2x,p2y
  ; Dessine la camera
  Color 0,0,255
  Oval cam\x-3,cam\y-3,6,6,True

d =Dist#( cam\x, cam\y, mx, my )
Text 400,400,(d/100)
  Flip
Wend

Delete Each CAMERA
Delete Each QUADTREE

End

Function Dist#( X1#, Y1#, X2#, Y2# )
	Return Abs(( (X1 - X2)*(X1 - X2) + (Y1 - Y2)*(Y1 - Y2) )^0.5)
End Function

; combine Alpha, Red, Green, Blue values to a RGB value
Function CombineARGB#(aa#,rr%,gg%,bb%)	
	;Return aa*$1000000+rr*$10000+gg*$100+bb	
	Return $ff000000 Or rr Shl 16 Or gg Shl 8 Or bb 
End Function
__________________
Мой проект здесь
(Offline)
 
Ответить с цитированием
Старый 06.05.2013, 16:00   #5
Кирпи4
Социал-сычевист
 
Аватар для Кирпи4
 
Регистрация: 24.06.2011
Сообщений: 597
Написано 332 полезных сообщений
(для 1,300 пользователей)
Ответ: Voxel (octotree)

Нехорошо присваивать себе коды французов, ой нехорошо...
__________________


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

А я и не утверждал что это мой код ,я взял его за основу и лишь добавил свои детали.
__________________
Мой проект здесь
(Offline)
 
Ответить с цитированием
Старый 08.05.2013, 10:35   #7
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

Несколько изменённый код первого поста .
Мышью теперь в красном ромбе создавать ,а не в квадрате , при том что менять координату z ,как и прежде клавишами A/Z.
Мышь в изометрии http://forum.boolean.name/showthread.php?t=18164

Код :
Global id,level ,mx,my ,QDepth  
Global px,py,pz ,s ,mxx,myy

Type OCTREE
Field Child.OCTREE[8] ;8 потомков
Field xmin,ymin,zmin ; начальные координаты куба
Field xmax,ymax,zmax ; оконечные координаты куба
Field xcentr,ycentr,zcentr ; центр куба
Field qred,qgreen,qblue,qalpha,qcolor
Field id ,vis , lock;  ;vis - visible
End Type

Function Octree.OCTREE(xmin,ymin,zmin,xmax,ymax,zmax,depth)
	xcentr = (xmin+xmax) / 2
	ycentr = (ymin+ymax) / 2
	zcentr = (zmin+zmax) / 2

this.OCTREE = New OCTREE
	this\xmin = xmin
	this\xmax = xmax
	this\ymin = ymin
	this\ymax = ymax
	this\zmin = zmin
	this\zmax = zmax
	this\xcentr = xcentr
	this\ycentr = ycentr
	this\zcentr = zcentr
	
	
	id = id + 1
	this\id = id
	this\vis = False
	this\lock= False

If (depth > 0)

	depth = depth - 1
	this\Child[1] = Octree(xmin,ymin,zmin  ,xcentr,ycentr,zcentr ,depth) 
	this\Child[2] = Octree(xmin,ycentr,zmin  ,xcentr,ymax,zcentr ,depth)
	this\Child[3] = Octree(xcentr,ycentr,zmin  ,xmax,ymax,zcentr ,depth) 
	this\Child[4] = Octree(xcentr,ymin,zmin  ,xmax,ycentr,zcentr ,depth) 
	this\Child[5] = Octree(xmin,ymin,zcentr  ,xcentr,ycentr,zmax,depth) 
	this\Child[6] = Octree(xmin,ycentr,zcentr  ,xcentr,ymax,zmax,depth)
	this\Child[7] = Octree(xcentr,ycentr,zcentr  ,xmax,ymax,zmax,depth) 
	this\Child[8] = Octree(xcentr,ymin,zcentr  ,xmax,ycentr,zmax,depth) 

EndIf
	Return this
End Function

; ====================      =====================
Function RenderOctree(this.OCTREE,depth)

If (depth > 0)
	xcentr = (xmin+xmax) / 2
	ycentr = (ymin+ymax) / 2
	zcentr = (zmin+zmax) / 2
		
		Color 88,88,88
			Rect this\xmin, this\ymin,this\xmax-this\xmin,this\ymax-this\ymin ,0
					
		depth = depth - 1

		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)
		RenderOctree(this\Child[8],depth)	
		
		If this\vis=True 
			Rect this\xmin+2, this\ymin+2,this\xmax-this\xmin-4,this\ymax-this\ymin-4 ,1
			
			xdot = (this\xmax+this\xmin)/2
			ydot = (this\ymax+this\ymin)/2
			zdot = (this\zmax+this\zmin)/2
		LockBuffer BackBuffer()	
			For y=this\ymin To this\ymax Step 1
			   For x=this\xmin To this\xmax Step 1
				 For z=this\zmin To this\zmax Step 1
					WritePixel 400+x-y,400+(x+ y)/2-z, $ffffff ,	BackBuffer()
			;		Plot 400+x-y,400+(x+ y)/2-z	
				 Next
			   Next
			Next 		
		;	Oval 400+ xdot -ydot -(6) , 400+ (xdot +ydot )/2-zdot -(6) ,(12+depth*2),(12),1
		UnlockBuffer BackBuffer()	

			
		EndIf 
Else			
		If this\vis=True 
			Rect this\xmin+2, this\ymin+2,this\xmax-this\xmin-4,this\ymax-this\ymin-4 ,1
			
			xdot = (this\xmax+this\xmin)/2
			ydot = (this\ymax+this\ymin)/2
			zdot = (this\zmax+this\zmin)/2

			Oval 400+ xdot -ydot -(6) , 400+ (xdot +ydot )/2-zdot -(6) ,(12),(12),1
		EndIf 		
End If 

End Function

Function CalcOctree(this.OCTREE,depth)
If PointInCube(this\xmin,this\ymin,this\zmin,this\xmax,this\ymax,this\zmax,mxx,myy,pz )=True 
	If (depth > 0)
		depth = depth - 1

		CalcOctree(this\Child[1],depth)
		CalcOctree(this\Child[2],depth)
		CalcOctree(this\Child[3],depth)
		CalcOctree(this\Child[4],depth)
		CalcOctree(this\Child[5],depth)
		CalcOctree(this\Child[6],depth)
		CalcOctree(this\Child[7],depth)
		CalcOctree(this\Child[8],depth)		
		
  If this\Child[1]\lock= 1 And this\Child[2]\lock= 1 And  this\Child[3]\lock= 1 And this\Child[4]\lock= 1  And  this\Child[5]\lock= 1  And this\Child[6]\lock= 1 And  this\Child[7]\lock= 1 And  this\Child[8]\lock= 1 Then		
			this\vis=True
			this\lock=True
			
			this\Child[1]\vis= False
			this\Child[2]\vis= False
			this\Child[3]\vis= False
			this\Child[4]\vis= False
			this\Child[5]\vis= False
			this\Child[6]\vis= False
			this\Child[7]\vis= False
			this\Child[8]\vis= False
		EndIf

Else 	
		LockBuffer BackBuffer()
			For y=this\ymin To this\ymax Step 2
			   For x=this\xmin To this\xmax Step 2
				 For z=this\zmin To this\zmax Step 2
	;			;	
					WritePixelFast 400+x-y,400+(x+ y)/2-z, $ff0000 ,	BackBuffer()	
	;				
				 Next
			   Next
			Next 	
			
		UnlockBuffer BackBuffer()		
		Color 255,5,5

	
		Rect this\xmin, this\ymin,this\xmax-this\xmin,this\ymax-this\ymin ,1
		Rect 250, 175 - this\zmin,25,this\zmax-this\zmin ,1
		Text 400,40, this\id +" visible = "+this\vis+"  Lock = "+this\lock
		If MouseDown(1) Or KeyDown(157) And this\lock= False Then ;
			this\lock=True 
			 this\vis=True 
		EndIf 
		If MouseDown(2) And this\lock= True Then ;
			this\lock=False 
			 this\vis=False 
		EndIf 

	End If		

End If 

End Function

Function EraseOctree(this.OCTREE,depth)

If (depth > 0)
		depth = depth - 1

		EraseOctree(this\Child[1],depth)
		EraseOctree(this\Child[2],depth)
		EraseOctree(this\Child[3],depth)
		EraseOctree(this\Child[4],depth)
		EraseOctree(this\Child[5],depth)
		EraseOctree(this\Child[6],depth)
		EraseOctree(this\Child[7],depth)
		EraseOctree(this\Child[8],depth)		
		
			this\lock=False 
			 this\vis=False 	
End If 

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

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

QuadDepth = 4;число вложений (глубина ) 
QuadSize = 200 ; размеры квадранта 

; ???????? ????????? ?????????
root.OCTREE = Octree(0,0,0,QuadSize,QuadSize,QuadSize,QuadDepth)

While Not KeyHit(1) 
mx = MouseX() 
my = MouseY() 
s = Abs(MouseZ())
Cls 
Select True 
Case KeyDown(200) : py=py-1*20; Up
Case KeyDown(208) : py=py+1*20; Down
Case KeyDown(203) : px=px-1*20; Left
Case KeyDown(205) : px=px+1*20; Right
Case KeyDown(57) : EraseOctree(root,QuadDepth)
End Select 
If  KeyHit(30) And pz <180 Then pz=pz+10 ;   A key
If  KeyHit(44) And pz > 0 Then pz=pz-10	
	
	If px<0 Then px=0
	 If px>=180 Then px=180
	If py<0 Then py=0
	 If py>=180 Then py=180
	
myy = (2*(my-400) -(mx-400))/2 + pz;-s
mxx = ((mx-400)+myy);-;s


Color 255,255,255
Rect root\xmin,root\ymin,root\xmax,root\ymax,0
Rect 250,0,25,root\ymax,0


	Line 400+ (root\xmin-root\ymin) , 400+ (root\xmin+root\ymin)/2- root\zmin , 400+ (root\xmin-root\ymax),400+ (root\xmin+root\ymax)/2- root\zmin
	Line  400+ (root\xmin-root\ymax),400+ (root\xmin+root\ymax)/2- root\zmin,400+ (root\xmax-root\ymax) , 400+ (root\xmax+root\ymax)/2- root\zmin 
	Line  400+ (root\xmax-root\ymax) , 400+ (root\xmax+root\ymax)/2- root\zmin ,400+ (root\xmax-root\ymin),400+ (root\xmax+root\ymin)/2- root\zmin
	Line  400+ (root\xmax-root\ymin),400+ (root\xmax+root\ymin)/2- root\zmin , 400+ (root\xmin-root\ymin) , 400+ (root\xmin+root\ymin)/2- root\zmin 
Color 255,5,5	
	Line 400+ (root\xmin-root\ymin) , 400+ (root\xmin+root\ymin)/2- pz , 400+ (root\xmin-root\ymax),400+ (root\xmin+root\ymax)/2-pz
	Line  400+ (root\xmax-root\ymin),400+ (root\xmax+root\ymin)/2- pz , 400+ (root\xmin-root\ymin) , 400+ (root\xmin+root\ymin)/2- pz
Color 255,255,255	
RenderOctree(root,QuadDepth)
CalcOctree(root,QuadDepth)
Color 255,5,5
	Line  400+ (root\xmin-root\ymax),400+ (root\xmin+root\ymax)/2- pz,400+ (root\xmax-root\ymax) , 400+ (root\xmax+root\ymax)/2-pz
	Line  400+ (root\xmax-root\ymax) , 400+ (root\xmax+root\ymax)/2- pz ,400+ (root\xmax-root\ymin),400+ (root\xmax+root\ymin)/2-pz
Text 400,20,"S = "+s+"   col-vo elements = "+id
Text 300,180-pz,"  Z = "+pz
Flip 
Wend 
End  

; combine Alpha, Red, Green, Blue values to a RGB value
Function CombineARGB#(aa#,rr%,gg%,bb%)	
	;Return aa*$1000000+rr*$10000+gg*$100+bb	
	Return $ff000000 Or rr Shl 16 Or gg Shl 8 Or bb 
End Function
__________________
Мой проект здесь
(Offline)
 
Ответить с цитированием
Старый 10.05.2013, 05:43   #8
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

Итак , продолжаем. Пришлось изменить код ,так как , в первом варианте я делил весь объём куба на меньшие ,а потому память слала далеко-далеко ,когда глубина вложений превышала 7. Теперь изначально есть корневой куб ,а 4-ре его потомка = Null . При нажатии ЛМ (левой кнопки мыши) проверяется в котором потомке находиться мышь(объект) и затем делится рекурсивно если потомок = Null или не Null . И вот тут я запутался с родителями-потомками . Представляю сырой вариант ниже.

Код:

Global id,mx,my ,QDepth  
Global px,py,pz ,s ,mxx,myy



Type OCTREE
Field Child.OCTREE[8] ;8 потомков
Field xmin,ymin,zmin ; начальные координаты куба
Field xmax,ymax,zmax ; оконечные координаты куба
Field xcentr,ycentr,zcentr ; центр куба
Field qred,qgreen,qblue,qalpha,qcolor
End Type

Function Octree.OCTREE(xmin,ymin,zmin,xmax,ymax,zmax,depth)
	xcentr = (xmin+xmax) / 2
	ycentr = (ymin+ymax) / 2
	zcentr = (zmin+zmax) / 2

this.OCTREE = New OCTREE
	this\xmin = xmin
	this\xmax = xmax
	this\ymin = ymin
	this\ymax = ymax
	this\zmin = zmin
	this\zmax = zmax
	this\xcentr = xcentr
	this\ycentr = ycentr
	this\zcentr = zcentr
		
	id = id + 1


	For c = 1 To 8
		this\Child[c] = Null 
		
		If this\Child[c] <> Null 
			Delete this\Child[c] 
			this\Child[c] = Null 
		EndIf
	Next 


	Return this
End Function


; ====================      =====================
Function RenderOctree(this.OCTREE,depth)

If this.OCTREE <> Null
If PointInCube(this\xmin,this\ymin,this\zmin,this\xmax,this\ymax,this\zmax,mx,my,pz ) 	= True
	If (depth > 0)			
	
		      Color 128,128,128
		      Line (this\xmin+this\xmax)/2,this\ymin,(this\xmin+this\xmax)/2,this\ymax
		      Line this\xmin,(this\ymin+this\ymax)/2,this\xmax,(this\ymin+this\ymax)/2
				
			depth = depth - 1
	
			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)
			RenderOctree(this\Child[8],depth)	
			
			Text this\xmin+3,this\ymin+3,"+"
			      Color 6,6,196
      Rect this\xmin+1,this\ymin+1,this\xmax-this\xmin-1,this\ymax-this\ymin-1,0
	Else
      Color 196,6,6
      Rect this\xmin+1,this\ymin+1,this\xmax-this\xmin-1,this\ymax-this\ymin-1,1
	End If 
End If 
End If
End Function

; ====================      =====================
Function AddToOctree.OCTREE(xmin,ymin,zmin,xmax,ymax,zmax,depth)
If PointInCube(xmin,ymin,zmin,xmax,ymax,zmax,mx,my,pz ) 	= True 
	xcentr = (xmin+xmax) / 2
	ycentr = (ymin+ymax) / 2
	zcentr = (zmin+zmax) / 2
	
this.OCTREE = New OCTREE
	this\xmin = xmin
	this\xmax = xmax
	this\ymin = ymin
	this\ymax = ymax
	this\zmin = zmin
	this\zmax = zmax
	this\xcentr = xcentr
	this\ycentr = ycentr
	this\zcentr = zcentr
		
	id = id + 1	

If (depth >= 0)	

	depth = depth - 1

	this\Child[1] = AddToOctree(xmin,ymin,zmin  ,xcentr,ycentr,zcentr ,depth) 
	this\Child[2] = AddToOctree(xmin,ycentr,zmin  ,xcentr,ymax,zcentr ,depth)
	this\Child[3] = AddToOctree(xcentr,ycentr,zmin  ,xmax,ymax,zcentr ,depth) 
	this\Child[4] = AddToOctree(xcentr,ymin,zmin  ,xmax,ycentr,zcentr ,depth) 
	this\Child[5] = AddToOctree(xmin,ymin,zcentr  ,xcentr,ycentr,zmax,depth) 
	this\Child[6] = AddToOctree(xmin,ycentr,zcentr  ,xcentr,ymax,zmax,depth)
	this\Child[7] = AddToOctree(xcentr,ycentr,zcentr  ,xmax,ymax,zmax,depth) 
	this\Child[8] = AddToOctree(xcentr,ymin,zcentr  ,xmax,ycentr,zmax,depth) 

EndIf
EndIf
	Return this
End Function





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

QuadDepth =4    ; 8 ;число вложений (глубина ) 
QuadSize = 512 ; размеры квадранта 

timestart = MilliSecs()
root.OCTREE = Octree(0,0,0,QuadSize,QuadSize,QuadSize,QuadDepth)
timeout = (MilliSecs()-timestart)
While Not KeyHit(1) 
mx = MouseX() 
my = MouseY() 
s = Abs(MouseZ())
Cls 
Select True 
Case KeyDown(200) : py=py-1*20; Up
Case KeyDown(208) : py=py+1*20; Down
Case KeyDown(203) : px=px-1*20; Left
Case KeyDown(205) : px=px+1*20; Right
Case KeyDown(57) 
End Select 
If  KeyHit(30) And pz <180 Then pz=pz+10 ;   A key
If  KeyHit(44) And pz > 0 Then pz=pz-10	

		If MouseDown(1) Or KeyDown(157)  Then ;
		For c = 1 To 8
		;If PointInCube(root\xmin,root\ymin,root\zmin,root\xmax,root\ymax,root\zmax,mx,my,pz ) 	= True 
		If root\Child[c]  = Null
			;root.OCTREE = AddToOctree(root\xmin,root\ymin,root\zmin,root\xmax,root\ymax,root\zmax,QuadDepth)
		Text 200,200,"YES !!!"	+c
			root\Child[c] = AddToOctree(root\xmin,root\ymin,root\zmin,root\xmax,root\ymax,root\zmax,QuadDepth)
		Else 	
			;root.OCTREE =	AddToOctree(root\xmin,root\ymin,root\zmin,root\xmax,root\ymax,root\zmax,QuadDepth)
			root\Child[c] = AddToOctree(root\xmin,root\ymin,root\zmin,root\xmax,root\ymax,root\zmax,QuadDepth)
		EndIf 
		;EndIf 
		Next 
		EndIf 
		If MouseDown(2)  Then ;

		EndIf 
		
	
myy = (2*(my-400) -(mx-400))/2 + pz;-s
mxx = ((mx-400)+myy);-;s


RenderStaticLine(root)	
RenderOctree(root,QuadDepth)

Color 255,255,255
Oval 400+ mxx -myy -(6) , 400+ (mxx +myy )/2-pz-(6) ,(12),(12),0

Color 255,5,5
;	Line  400+ (root\xmin-root\ymax),400+ (root\xmin+root\ymax)/2- pz,400+ (root\xmax-root\ymax) , 400+ (root\xmax+root\ymax)/2-pz
;	Line  400+ (root\xmax-root\ymax) , 400+ (root\xmax+root\ymax)/2- pz ,400+ (root\xmax-root\ymin),400+ (root\xmax+root\ymin)/2-pz
Text 550,20,"S = "+s+"   col-vo elements = "+id
Text 550,180-pz,"  Z = "+pz+"     timeout  "+timeout 
Flip 
Wend 
Delete Each OCTREE
End  

Function RenderStaticLine(this.OCTREE)
If this.OCTREE <> Null
Color 255,255,255
	Line 400+ (this\xmin-this\ymin) , 400+ (this\xmin+this\ymin)/2- this\zmin , 400+ (this\xmin-this\ymax),400+ (this\xmin+this\ymax)/2- this\zmin
	Line  400+ (this\xmin-this\ymax),400+ (this\xmin+this\ymax)/2- this\zmin,400+ (this\xmax-this\ymax) , 400+ (this\xmax+this\ymax)/2- this\zmin 
	Line  400+ (this\xmax-this\ymax) , 400+ (this\xmax+this\ymax)/2- this\zmin ,400+ (this\xmax-this\ymin),400+ (this\xmax+this\ymin)/2- this\zmin
	Line  400+ (this\xmax-this\ymin),400+ (this\xmax+this\ymin)/2- this\zmin , 400+ (this\xmin-this\ymin) , 400+ (this\xmin+this\ymin)/2- this\zmin 
Color 255,5,5	
	Line 400+ (this\xmin-this\ymin) , 400+ (this\xmin+this\ymin)/2- pz , 400+ (this\xmin-this\ymax),400+ (this\xmin+this\ymax)/2-pz
	Line  400+ (this\xmax-this\ymin),400+ (this\xmax+this\ymin)/2- pz , 400+ (this\xmin-this\ymin) , 400+ (this\xmin+this\ymin)/2- pz
Color 255,255,255	
End If
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



Function CombineARGB#(aa#,rr%,gg%,bb%)	
	;Return aa*$1000000+rr*$10000+gg*$100+bb	
	Return $ff000000 Or rr Shl 16 Or gg Shl 8 Or bb 
End Function


Изменённый код:

Global id,mx,my ,QuadDepth 
Global px,py,pz ,s ,mxx,myy



Type OCTREE
Field Child.OCTREE[8] ;8 потомков
Field xmin,ymin,zmin ; начальные координаты куба
Field xmax,ymax,zmax ; оконечные координаты куба
Field xcentr,ycentr,zcentr ; центр куба
Field qred,qgreen,qblue,qalpha,qcolor
Field depth 
End Type

Function Octree.OCTREE(xmin,ymin,zmin,xmax,ymax,zmax,depth)
	xcentr = (xmin+xmax) / 2
	ycentr = (ymin+ymax) / 2
	zcentr = (zmin+zmax) / 2

this.OCTREE = New OCTREE
	this\xmin = xmin
	this\xmax = xmax
	this\ymin = ymin
	this\ymax = ymax
	this\zmin = zmin
	this\zmax = zmax
	this\xcentr = xcentr
	this\ycentr = ycentr
	this\zcentr = zcentr
	this\depth = depth 	
	id = id + 1

If (depth = QuadDepth )
	depth = depth - 1
	
	this\Child[1] = Octree(xmin,ymin,zmin  ,xcentr,ycentr,zcentr ,depth) 
	this\Child[2] = Octree(xmin,ycentr,zmin  ,xcentr,ymax,zcentr ,depth)
	this\Child[3] = Octree(xcentr,ycentr,zmin  ,xmax,ymax,zcentr ,depth) 
	this\Child[4] = Octree(xcentr,ymin,zmin  ,xmax,ycentr,zcentr ,depth) 
	this\Child[5] = Octree(xmin,ymin,zcentr  ,xcentr,ycentr,zmax,depth) 
	this\Child[6] = Octree(xmin,ycentr,zcentr  ,xcentr,ymax,zmax,depth)
	this\Child[7] = Octree(xcentr,ycentr,zcentr  ,xmax,ymax,zmax,depth) 
	this\Child[8] = Octree(xcentr,ymin,zcentr  ,xmax,ycentr,zmax,depth) 

End If
	Return this
End Function


; ====================      =====================
Function RenderOctree(this.OCTREE,depth)

If this.OCTREE <> Null
;If PointInCube(this\xmin,this\ymin,this\zmin,this\xmax,this\ymax,this\zmax,mx,my,pz ) 	= True
	If (depth >= 0)			
	
		      Color 28,28,28
		      Line (this\xmin+this\xmax)/2,this\ymin,(this\xmin+this\xmax)/2,this\ymax
		      Line this\xmin,(this\ymin+this\ymax)/2,this\xmax,(this\ymin+this\ymax)/2
				
			depth = depth - 1
	
			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)
			RenderOctree(this\Child[8],depth)	
			
		Color 6,6,196
		Rect this\xmin+1,this\ymin+1,this\xmax-this\xmin-2,this\ymax-this\ymin-2,0
		Color 128,128,128
		Text this\xmin+this\depth*4,this\ymin+this\depth*4,"+  " +this\depth
	Else
		Color 196,6,6
		Rect this\xmin+2,this\ymin+2,this\xmax-this\xmin-3,this\ymax-this\ymin-3,1
		Color 128,128,128
		Text this\xmin+this\depth*4,this\ymin+this\depth*4,"+  " +this\depth
	End If 
End If 
;End If
End Function

; ====================      =====================
Function AddToOctree.OCTREE(xmin,ymin,zmin,xmax,ymax,zmax,depth)
If PointInCube(xmin,ymin,zmin,xmax,ymax,zmax,mx,my,pz ) 	= True 
	xcentr = (xmin+xmax) / 2
	ycentr = (ymin+ymax) / 2
	zcentr = (zmin+zmax) / 2
	
this.OCTREE = New OCTREE
	this\xmin = xmin
	this\xmax = xmax
	this\ymin = ymin
	this\ymax = ymax
	this\zmin = zmin
	this\zmax = zmax
	this\xcentr = xcentr
	this\ycentr = ycentr
	this\zcentr = zcentr
	this\depth = depth 		
;	id = id + 1	

If (depth > 0)	

	depth = depth - 1

	this\Child[1] = AddToOctree(xmin,ymin,zmin  ,xcentr,ycentr,zcentr ,depth) 
	this\Child[2] = AddToOctree(xmin,ycentr,zmin  ,xcentr,ymax,zcentr ,depth)
	this\Child[3] = AddToOctree(xcentr,ycentr,zmin  ,xmax,ymax,zcentr ,depth) 
	this\Child[4] = AddToOctree(xcentr,ymin,zmin  ,xmax,ycentr,zcentr ,depth) 
	this\Child[5] = AddToOctree(xmin,ymin,zcentr  ,xcentr,ycentr,zmax,depth) 
	this\Child[6] = AddToOctree(xmin,ycentr,zcentr  ,xcentr,ymax,zmax,depth)
	this\Child[7] = AddToOctree(xcentr,ycentr,zcentr  ,xmax,ymax,zmax,depth) 
	this\Child[8] = AddToOctree(xcentr,ymin,zcentr  ,xmax,ycentr,zmax,depth) 

EndIf
EndIf
	Return this
End Function





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

QuadDepth =5    ; 8 ;число вложений (глубина ) 
QuadSize = 512 ; размеры квадранта 

timestart = MilliSecs()
root.OCTREE = Octree(0,0,0,QuadSize,QuadSize,QuadSize,QuadDepth)
timeout = (MilliSecs()-timestart)
While Not KeyHit(1) 
mx = MouseX() 
my = MouseY() 
s = Abs(MouseZ())
Cls 
Select True 
Case KeyDown(200) : py=py-1*20; Up
Case KeyDown(208) : py=py+1*20; Down
Case KeyDown(203) : px=px-1*20; Left
Case KeyDown(205) : px=px+1*20; Right
Case KeyDown(57) 
End Select 
If  KeyHit(30) And pz <180 Then pz=pz+10 ;   A key
If  KeyHit(44) And pz > 0 Then pz=pz-10	

		If MouseDown(1) Or KeyDown(157)  Then ;
		If root.OCTREE <> Null
		;If root\Child[c] <> Null
		For c = 1 To 8
		If PointInCube(root\Child[c]\xmin,root\Child[c]\ymin,root\Child[c]\zmin,root\Child[c]\xmax,root\Child[c]\ymax,root\Child[c]\zmax,mx,my,pz ) 	= True 
		
			;root.OCTREE = AddToOctree(root\xmin,root\ymin,root\zmin,root\xmax,root\ymax,root\zmax,QuadDepth)
		Text 200,200,"YES !!!     "	+c
			root\Child[c] = AddToOctree(root\xmin,root\ymin,root\zmin,root\xmax,root\ymax,root\zmax,QuadDepth)
		;Else 	
			;root.OCTREE =	AddToOctree(root\xmin,root\ymin,root\zmin,root\xmax,root\ymax,root\zmax,QuadDepth)
			;root\Child[c] = AddToOctree(root\xmin,root\ymin,root\zmin,root\xmax,root\ymax,root\zmax,QuadDepth)
		EndIf 
		
		Next 
		EndIf 
		;EndIf 
		EndIf 
		If MouseDown(2)  Then ;

		EndIf 
		
	
myy = (2*(my-400) -(mx-400))/2 + pz;-s
mxx = ((mx-400)+myy);-;s


;RenderStaticLine(root)	
RenderOctree(root,QuadDepth)

Color 255,255,255
Oval 400+ mxx -myy -(6) , 400+ (mxx +myy )/2-pz-(6) ,(12),(12),0

Color 255,5,5
;	Line  400+ (root\xmin-root\ymax),400+ (root\xmin+root\ymax)/2- pz,400+ (root\xmax-root\ymax) , 400+ (root\xmax+root\ymax)/2-pz
;	Line  400+ (root\xmax-root\ymax) , 400+ (root\xmax+root\ymax)/2- pz ,400+ (root\xmax-root\ymin),400+ (root\xmax+root\ymin)/2-pz
Text 550,20,"S = "+s+"   col-vo elements = "+id
Text 550,180-pz,"  Z = "+pz+"     timeout  "+timeout 
Flip 
Wend 
Delete Each OCTREE
End  

Function RenderStaticLine(this.OCTREE)
If this.OCTREE <> Null
Color 255,255,255
	Line 400+ (this\xmin-this\ymin) , 400+ (this\xmin+this\ymin)/2- this\zmin , 400+ (this\xmin-this\ymax),400+ (this\xmin+this\ymax)/2- this\zmin
	Line  400+ (this\xmin-this\ymax),400+ (this\xmin+this\ymax)/2- this\zmin,400+ (this\xmax-this\ymax) , 400+ (this\xmax+this\ymax)/2- this\zmin 
	Line  400+ (this\xmax-this\ymax) , 400+ (this\xmax+this\ymax)/2- this\zmin ,400+ (this\xmax-this\ymin),400+ (this\xmax+this\ymin)/2- this\zmin
	Line  400+ (this\xmax-this\ymin),400+ (this\xmax+this\ymin)/2- this\zmin , 400+ (this\xmin-this\ymin) , 400+ (this\xmin+this\ymin)/2- this\zmin 
Color 255,5,5	
	Line 400+ (this\xmin-this\ymin) , 400+ (this\xmin+this\ymin)/2- pz , 400+ (this\xmin-this\ymax),400+ (this\xmin+this\ymax)/2-pz
	Line  400+ (this\xmax-this\ymin),400+ (this\xmax+this\ymin)/2- pz , 400+ (this\xmin-this\ymin) , 400+ (this\xmin+this\ymin)/2- pz
Color 255,255,255	
End If
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



Function CombineARGB#(aa#,rr%,gg%,bb%)	
	;Return aa*$1000000+rr*$10000+gg*$100+bb	
	Return $ff000000 Or rr Shl 16 Or gg Shl 8 Or bb 
End Function
__________________
Мой проект здесь

Последний раз редактировалось polopok, 10.05.2013 в 07:39.
(Offline)
 
Ответить с цитированием
Старый 13.05.2013, 08:45   #9
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

Итак ,кажись получилось разобраться с родителями-потомками ,дабы не запутаться написал пример без Z координаты .
Если у кого есть идеи улучшения ,буду рад ознакомиться.

Global id,mx,my ,CubDepth 
Global px,py,pz ,s ,mxx,myy



Type OCTREE
Field Child.OCTREE[8] ;8 потомков
Field xmin,ymin,zmin
Field xcentr,ycentr,zcentr ; центр куба
Field qred,qgreen,qblue,qalpha,qcolor
Field size , depth , block=False
End Type

;Global root.OCTREE

Function RootOctree.OCTREE(xmin,ymin,zmin ,size,depth)
	
		
	newsize = size / 2
	
	this.OCTREE = New OCTREE
	this\xmin = xmin
	this\ymin = ymin
	this\zmin = 0
	this\size = size
	this\depth = depth 
	
	
	id = id + 1
	If depth = CubDepth 
	depth = depth - 1
		this\Child[0] = Null
		this\Child[1] = Null
		this\Child[2] = Null
		this\Child[3] = Null

	EndIf 
	Return this
End Function




Function AddOctree.OCTREE( this.OCTREE,xmin,ymin,zmin ,size,depth)

If PointInCube(xmin,ymin,zmin,xmin+size,ymin+size,zmin+size,mx,my,0 )	
newsize = size / 2
		If depth >0
			depth = depth - 1
If this <> Null

	For cub = 0 To 3
	If this\Child[cub] <> Null 

		If PointInCube( this\Child[cub]\xmin,this\Child[cub]\ymin,this\Child[cub]\zmin,this\Child[cub]\xmin+this\Child[cub]\size,this\Child[cub]\ymin+this\Child[cub]\size,this\Child[cub]\zmin+this\Child[cub]\size,mx,my,0 )	
			AddOctree(this\Child[cub], this\Child[cub]\xmin ,this\Child[cub]\ymin ,0,newsize, depth)	
		EndIf
	
	EndIf
	Next

	If this\Child[0] = Null 
	If this\Child[1] = Null
	If this\Child[2] = Null
	If this\Child[3] = Null
		
		
		this0.OCTREE = New OCTREE
		this0\xmin = xmin + newsize
		this0\ymin = ymin
		this0\size = newsize
		this0\depth = depth		

		this1.OCTREE = New OCTREE
		this1\xmin = xmin 
		this1\ymin = ymin + newsize
		this1\size = newsize
		this1\depth = depth			
		
		this2.OCTREE = New OCTREE
		this2\xmin = xmin 
		this2\ymin = ymin
		this2\size = newsize
		this2\depth = depth				
			
		this3.OCTREE = New OCTREE
		this3\xmin = xmin + newsize
		this3\ymin = ymin + newsize
		this3\size = newsize
		this3\depth = depth				
			
			
			
		id = id + 4
		
		this\Child[0] = this0
		this\Child[1] =  this1
		this\Child[2] =  this2
		this\Child[3] =  this3
					
	EndIf
	EndIf
	EndIf
	EndIf
	

		
		EndIf
	EndIf	
EndIf
	Return this
End Function



Graphics 800,600,32,2 
SetBuffer BackBuffer() 
;HidePointer
CubDepth =6   ; 8 ;число вложений (глубина ) 
CubSize = 512 ; размеры квадранта 

root.OCTREE = RootOctree(0,0,0,CubSize ,CubDepth )
While Not KeyHit(1) 
mx = MouseX() 
my = MouseY() 
s = Abs(MouseZ())
Cls 

		If MouseDown(1) Or KeyDown(157)  Then ;
		timestart = MilliSecs()	
			; FindChildOctree(root)
			AddOctree(root, 0,0,0,CubSize ,CubDepth)
		timeout = (MilliSecs()-timestart)	
		EndIf 
		

RenderOctree(root,CubDepth )

Color 255,255,255
;Rect 0 , 0  , CubSize , CubSize ,0	
Text 550,20,"S = "+s+"   col-vo elements = "+id
Text 550,180-pz,"  Z = "+pz+"     timeout  "+timeout 
Flip 
Wend 
Delete Each OCTREE
End  

Function RenderOctree(this.OCTREE,depth)
If this.OCTREE <> Null 
	If (depth > 0)			
		
		
		Color 128,128,128
		Rect this\xmin , this\ymin , this\size , this\size , 0
		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)	
		 
	Else 	
				Color 128,128,128
		Rect this\xmin , this\ymin , this\size , this\size , 1				
	End If 
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


Вот несколько улучшил код ...
но всё-же ,далеко до "идеала"

Global id,mx,my ,CubDepth 
Global px,py,pz ,s ,mxx,myy



Type OCTREE
Field Child.OCTREE[8] ;8 потомков
Field xmin,ymin,zmin
Field xcentr,ycentr,zcentr ; центр куба
Field qred,qgreen,qblue,qalpha,qcolor
Field size , depth , block=False
End Type

;Global root.OCTREE

Function RootOctree.OCTREE(xmin,ymin,zmin ,size,depth)
	
		
	newsize = size / 2
	
	this.OCTREE = New OCTREE
	this\xmin = xmin
	this\ymin = ymin
	this\zmin = 0
	this\size = size
	this\depth = depth 
	
	
	id = id + 1
	If depth = CubDepth 
	depth = depth - 1
		this\Child[0] = Null
		this\Child[1] = Null
		this\Child[2] = Null
		this\Child[3] = Null

	EndIf 
	Return this
End Function




Function AddOctree.OCTREE( this.OCTREE,xmin,ymin,zmin ,size,depth)

If PointInCube(xmin,ymin,zmin,xmin+size,ymin+size,zmin+size,mx,my,0 )	
newsize = size / 2
		If depth >0
			depth = depth - 1
If this <> Null

	For cub = 0 To 3
	If this\Child[cub] <> Null 

		If PointInCube( this\Child[cub]\xmin,this\Child[cub]\ymin,this\Child[cub]\zmin,this\Child[cub]\xmin+this\Child[cub]\size,this\Child[cub]\ymin+this\Child[cub]\size,this\Child[cub]\zmin+this\Child[cub]\size,mx,my,0 )	
			AddOctree(this\Child[cub], this\Child[cub]\xmin ,this\Child[cub]\ymin ,0,newsize, depth)	
		EndIf
	
	EndIf
	Next
	
	For cub = 0 To 3
	
	If this\Child[cub ] = Null

	Select cub	
		Case 0
		this0.OCTREE = New OCTREE
		this0\xmin = xmin + newsize
		this0\ymin = ymin
		this0\size = newsize
		this0\depth = depth		
		this\Child[0] = this0
		Case 1
		this1.OCTREE = New OCTREE
		this1\xmin = xmin 
		this1\ymin = ymin + newsize
		this1\size = newsize
		this1\depth = depth			
		this\Child[1] =  this1
		Case 2
		this2.OCTREE = New OCTREE
		this2\xmin = xmin 
		this2\ymin = ymin
		this2\size = newsize
		this2\depth = depth				
		this\Child[2] =  this2
		Case 3	
		this3.OCTREE = New OCTREE
		this3\xmin = xmin + newsize
		this3\ymin = ymin + newsize
		this3\size = newsize
		this3\depth = depth			
		this\Child[3] =  this3	
		End Select 	
			
			
		id = id + 1
		
		
		AddOctree( this,xmin,ymin,zmin ,size,depth)
		
	EndIf
	Next 

		
		EndIf
	EndIf	
EndIf
End Function



Graphics 800,600,32,2 
SetBuffer BackBuffer() 
;HidePointer
CubDepth =8   ; 8 ;число вложений (глубина ) 
CubSize = 512 ; размеры квадранта 

root.OCTREE = RootOctree(0,0,0,CubSize ,CubDepth )
While Not KeyHit(1) 
mx = MouseX() 
my = MouseY() 
s = Abs(MouseZ())
Cls 

		If MouseDown(1) Or KeyDown(157)  Then ;
		timestart = MilliSecs()	
			; FindChildOctree(root)
			AddOctree(root, 0,0,0,CubSize ,CubDepth)
		timeout = (MilliSecs()-timestart)	
		EndIf 
		

RenderOctree(root,CubDepth )

Color 255,255,255
;Rect 0 , 0  , CubSize , CubSize ,0	
Text 550,20,"S = "+s+"   col-vo elements = "+id
Text 550,180-pz,"  Z = "+pz+"     timeout  "+timeout 
Flip 
Wend 
Delete Each OCTREE
End  

Function RenderOctree(this.OCTREE,depth)
If this.OCTREE <> Null 
	If (depth > 0)			
		
		
		Color 128,128,128
		Rect this\xmin , this\ymin , this\size , this\size , 0
		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)	
		 
	Else 	
				Color 128,128,128
		Rect this\xmin , this\ymin , this\size , this\size , 1				
	End If 
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, 13.05.2013 в 10:50.
(Offline)
 
Ответить с цитированием
Старый 16.05.2013, 11:33   #10
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

Итак, опять доработки. Теперь ещё меньше разбиений ,улучшен алгоритм добавления вокселя.

Global id,mx,my ,CubDepth 
Global px,py,pz ,s ,mxx,myy



Type OCTREE
Field Child.OCTREE[8] ;8 потомков
Field xmin,ymin,zmin
;Field xcentr,ycentr,zcentr ; центр куба
Field qred,qgreen,qblue,qalpha,qcolor
Field size , depth , block=False
End Type


Function RootOctree.OCTREE(xmin,ymin,zmin ,size,depth)

	newsize = size / 2
	
	this.OCTREE = New OCTREE
	this\xmin = xmin
	this\ymin = ymin
	this\zmin = zmin 
	this\size = size
	this\depth = depth 
	
	id = id + 1
	If depth = CubDepth 
		newdepth = depth -1
	this\Child[0] = RootOctree(xmin,ymin,zmin  ,newsize  ,newdepth ) 
	this\Child[1] = RootOctree(xmin,ymin+newsize ,zmin  ,newsize  ,newdepth )
	this\Child[2] = RootOctree(xmin+newsize,ymin+newsize,zmin  ,newsize  ,newdepth ) 
	this\Child[3] = RootOctree(xmin+newsize,ymin,zmin  ,newsize  ,newdepth ) 
	
	this\Child[4] = RootOctree(xmin,ymin,zmin+newsize,newsize ,newdepth ) 
	this\Child[5] = RootOctree(xmin,ymin+newsize,zmin+newsize,newsize ,newdepth )
	this\Child[6] = RootOctree(xmin+newsize,ymin+newsize,zmin+newsize,newsize ,newdepth ) 
	this\Child[7] = RootOctree(xmin+newsize,ymin,zmin+newsize,newsize ,newdepth ) 
	EndIf 
	Return this
End Function




Function AddOctree.OCTREE( this.OCTREE,xmin,ymin,zmin ,size,depth)

If PointInCube(xmin,ymin,zmin,xmin+size,ymin+size,zmin+size,mx,my,pz )	

newsize = size / 2

	
	If this = Null
		
	this.OCTREE = New OCTREE
	this\xmin = xmin
	this\ymin = ymin
	this\zmin = zmin 
	this\size = size
	this\depth = depth 
	
	id = id + 1
	
	Else 
	EndIf 
			
	If depth >0		
		newdepth = depth -1
	this\Child[0] = AddOctree(this\Child[0], xmin,ymin,zmin  ,newsize  ,newdepth ) 
	this\Child[1] = AddOctree(this\Child[1], xmin,ymin+newsize ,zmin  ,newsize  ,newdepth )
	this\Child[2] = AddOctree(this\Child[2], xmin+newsize,ymin+newsize,zmin  ,newsize  ,newdepth ) 
	this\Child[3] = AddOctree(this\Child[3], xmin+newsize,ymin,zmin  ,newsize  ,newdepth ) 
	
	this\Child[4] = AddOctree(this\Child[4], xmin,ymin,zmin+newsize,newsize ,newdepth ) 
	this\Child[5] = AddOctree(this\Child[5], xmin,ymin+newsize,zmin+newsize,newsize ,newdepth )
	this\Child[6] = AddOctree(this\Child[6], xmin+newsize,ymin+newsize,zmin+newsize,newsize ,newdepth ) 
	this\Child[7] = AddOctree(this\Child[7], xmin+newsize,ymin,zmin+newsize,newsize ,newdepth ) 
	;EndIf 

	EndIf
EndIf
	Return this
End Function

Function  PoinInCircle(ox , oy ,r)
	If Int((mx - ox)^2 + (my - oy)^2) <= r^2 Then
		mx = ox : my = oy
	EndIf 
End Function

Graphics 800,600,32,2 
SetBuffer BackBuffer() 
;HidePointer
CubDepth =6  ; 8 ;число вложений (глубина ) 
CubSize = 512 ; размеры квадранта 

root.OCTREE = RootOctree(0,0,0,CubSize ,CubDepth )
While Not KeyHit(1) 
timestartvis = MilliSecs()
mx = MouseX() 
my = MouseY() 
s = Abs(MouseZ())+5
Cls 
If  KeyDown(30) And pz <180 Then pz=pz+1 ;   A key
If  KeyDown(44) And pz > 0 Then pz=pz-1	   ;   Z key

myy = (2*(my-300) -(mx-400))/2 + pz;-s
mxx = ((mx-400)+myy);-;s

		If MouseDown(1) Or KeyDown(57)  Then ;
		timestart = MilliSecs()	
				AddOctree(root, 0,0,0,CubSize ,CubDepth)
		timeout = (MilliSecs()-timestart)	
		EndIf 
		

RenderOctree(root,CubDepth )

Oval  400+(mx-my )-s,300+ ( my+mx )/2- pz -s,s*2,s*2,0
; INFO
	Color 255,255,255
	Text 550,20,"S = "+s+"   Kolichestvo elementov = "+id
	Text 550,180,"  Z = "+pz+"     Time Create "+timeout 
timeoutvis = (MilliSecs()-timestartvis)	
	Text 550,200,"     Time Visualization "+timeout 
Flip 
Wend 
Delete Each OCTREE
End  

Function RenderOctree(this.OCTREE,depth)
If this.OCTREE <> Null 
	If (depth > 0)			
		
		
		Color 128,128,128
		Rect this\xmin , this\ymin , this\size , this\size , 0
		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)	
			
		 
	If depth=0
		Color 228,28,28
;	Rect 400+ this\xmin-this\ymin , 300+ (this\ymin+ this\xmin)/2 -this\zmin  , this\size , this\size , 0
	;	Line 400+ (this\xmin-this\ymin), 300+ (this\ymin+ this\xmin)/2 +this\zmin  ,  400+ ((this\xmin+this\size )-this\ymin), 300+ ((this\xmin+this\size )+ this\xmin)/2 +this\zmin
	
	EndIf 			
	Else 	
		Color 228,28,28
		Rect 400+ (this\xmin-this\ymin) , 300+ (this\ymin+ this\xmin)/2 -this\zmin  , this\size , this\size , 0	
				Color 128,128,128
		Rect this\xmin , this\ymin , this\size , this\size , 1	
	
	End If 
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
__________________
Мой проект здесь
(Offline)
 
Ответить с цитированием
Старый 17.05.2013, 10:47   #11
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

Сново ,немного говно кода .
Теперь ещё задействовано колёсико мыши .
В этой разработке использовал данные из этой статьи , конечно переделал по своему, но вдруг кому будет интересно.
Так же Octree

Global id,id2,mx,my ,CubDepth ,CubSize 
Global px,py,pz ,s ,mxx,myy , mmy
Global x1,y1,x2,y2


Type OCTREE
Field Child.OCTREE[8] ;8 потомков
Field xmin,ymin,zmin
;Field xcentr,ycentr,zcentr 
Field qred,qgreen,qblue,qalpha,qcolor
Field size , depth 
End Type

Type NODE
Field x,y,z
End Type 


Function RootOctree.OCTREE(xmin,ymin,zmin ,size,depth)

	newsize = size / 2
	
	this.OCTREE = New OCTREE
	this\xmin = xmin
	this\ymin = ymin
	this\zmin = zmin 
	this\size = size
	this\depth = depth 
	
	id = id + 1
	If depth = CubDepth 
		newdepth = depth -1
	this\Child[0] = RootOctree(xmin,ymin,zmin  ,newsize  ,newdepth ) 
	this\Child[1] = RootOctree(xmin,ymin+newsize ,zmin  ,newsize  ,newdepth )
	this\Child[2] = RootOctree(xmin+newsize,ymin+newsize,zmin  ,newsize  ,newdepth ) 
	this\Child[3] = RootOctree(xmin+newsize,ymin,zmin  ,newsize  ,newdepth ) 
	
	this\Child[4] = RootOctree(xmin,ymin,zmin+newsize,newsize ,newdepth ) 
	this\Child[5] = RootOctree(xmin,ymin+newsize,zmin+newsize,newsize ,newdepth )
	this\Child[6] = RootOctree(xmin+newsize,ymin+newsize,zmin+newsize,newsize ,newdepth ) 
	this\Child[7] = RootOctree(xmin+newsize,ymin,zmin+newsize,newsize ,newdepth ) 
	EndIf 
	Return this
End Function




Function AddOctree.OCTREE( this.OCTREE,xmin,ymin,zmin ,size,ppx,ppy,ppz,depth)

If PointInCube(xmin,ymin,zmin,xmin+size,ymin+size,zmin+size,ppx,ppy,ppz )	

newsize = size / 2

	
	If this = Null
		
	this.OCTREE = New OCTREE
	this\xmin = xmin
	this\ymin = ymin
	this\zmin = zmin 
	this\size = size
	this\depth = depth 
	
	id = id + 1
	
	Else 

			
	If depth >=0		
		newdepth = depth -1
	this\Child[0] = AddOctree(this\Child[0], xmin,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
	this\Child[1] = AddOctree(this\Child[1], xmin,ymin+newsize ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth )
	this\Child[2] = AddOctree(this\Child[2], xmin+newsize,ymin+newsize,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
	this\Child[3] = AddOctree(this\Child[3], xmin+newsize,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
	
	this\Child[4] = AddOctree(this\Child[4], xmin,ymin,zmin+newsize,newsize ,ppx,ppy,ppz,newdepth ) 
	this\Child[5] = AddOctree(this\Child[5], xmin,ymin+newsize,zmin+newsize,newsize ,ppx,ppy,ppz,newdepth )
	this\Child[6] = AddOctree(this\Child[6], xmin+newsize,ymin+newsize,zmin+newsize,newsize ,ppx,ppy,ppz,newdepth ) 
	this\Child[7] = AddOctree(this\Child[7], xmin+newsize,ymin,zmin+newsize,newsize ,ppx,ppy,ppz,newdepth ) 
	EndIf 

	EndIf
EndIf
	Return this
End Function

Function  PoinInCircle(ox , oy ,r)
	If Int((mx - ox)^2 + (my - oy)^2) <= r^2 Then
		mx = ox : my = oy
	EndIf 
End Function

Graphics 800,600,32,2 
SetBuffer BackBuffer() 
;HidePointer
CubDepth =6  ; 8 ;число вложений (глубина ) 
CubSize = 512 ; размеры квадранта 

root.OCTREE = RootOctree(0,0,0,CubSize ,CubDepth )
While Not KeyHit(1) 
timestartvis = MilliSecs()
mx = MouseX() 
my = MouseY() 
s = Abs(MouseZ())+5
Cls 
If  KeyDown(30) And pz <180 Then pz=pz+1 ;   A key
If  KeyDown(44) And pz > 0 Then pz=pz-5	   ;   Z key
If KeyHit(57)  Then 
EraseOctree(root) 
 id=0 :id2=0
 root.OCTREE = RootOctree(0,0,0,CubSize ,CubDepth )
Delete Each NODE
EndIf 


;myy = (2*(my-300) -(mx-400))/2 + pz;-s
;mxx = ((mx-400)+myy);-;s

For nod.NODE = Each NODE	
	If nod <> Null
	AddOctree(root, 0,0,0,CubSize ,nod\x,nod\y,nod\z,CubDepth)
	EndIf 
Next

RenderOctree(root,CubDepth )
Paint()

;Oval mx -3 , my-3,6,6,0
Oval  400+(mx-my )-s,300+ ( my+mx )/2- pz -s,s*2,s*2,0
; INFO
	Color 255,255,255
	Text 550,20,"S = "+s+"   Kolichestvo elementov = "+id+"   id2  = "+id2
	Text 550,180,"  Z = "+pz+"     Time Create "+timeout 
timeoutvis = (MilliSecs()-timestartvis)	
	Text 550,200,"     Time Visualization "+timeout 
Flip 
Wend 
Delete Each OCTREE
Delete Each NODE
End  

Function Paint.NODE()
If MouseHit(1) Then
	For nx = mx+s To mx-s Step -5
		For ny = my+s To my-s Step -5	 
			For nz = pz+s To pz-s Step -5

				this.NODE = New NODE
				this\x = nx
				this\y = ny
				this\z = pz
		
			id2 = id2+1
			Next 
		Next 	
	Next 
	Else 
		Rect mx-s , my-s , s*2,s*2,0
	EndIf 
	Return this
End Function



Function RenderOctree(this.OCTREE,depth)
If this.OCTREE <> Null 
	If (depth > 0)			
		
		
		Color 128,128,128
		Rect this\xmin , this\ymin , this\size , this\size , 0
		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 	
	zz = this\zmin
	If  zz > 200 Then zz = 200 
	If zz < 0 Then zz = 0
	
		Color 25+zz ,25+zz ,25+zz
		Rect 400+ (this\xmin-this\ymin) , 300+ (this\ymin+ this\xmin)/2 -this\zmin  , this\size , this\size , 1	
		Color 128,128,128
		Rect this\xmin , this\ymin , this\size , this\size , 1	
	
	End If 
EndIf
End Function

Function EraseOctree(this.OCTREE)
Delete Each OCTREE
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


А теперь несколько упорядоченный говно-код с элементами извращениями ...
Global id,mx,my ,CubDepth ,CubSize ,viewline , show2d , image
Global px,py,pz ,s ,mxx,myy , mmy
Global timeoutcreate# , timeintcreate 


Type OCTREE
	Field Child.OCTREE[8] ;8 потомков
	Field xmin,ymin,zmin
	;Field xcentr,ycentr,zcentr ; 
	Field octRed,octGreen,octBlue,octAlpha,octColor
	Field size , depth 
End Type


Global root.OCTREE

Function RootOctree.OCTREE(xmin,ymin,zmin ,size,depth)
	newsize = size / 2
	
	this.OCTREE = New OCTREE
	this\xmin = xmin
	this\ymin = ymin
	this\zmin = zmin 
	this\size = size
	this\depth = depth 
	id = id + 1
	Return this
End Function




Function AddOctree.OCTREE( this.OCTREE,xmin,ymin,zmin ,size,ppx,ppy,ppz,depth)
If PointInCube(xmin,ymin,zmin,xmin+size,ymin+size,zmin+size,ppx,ppy,ppz )	
	newsize = size / 2
	
	If this = Null
		this.OCTREE = New OCTREE
		this\xmin = xmin
		this\ymin = ymin
		this\zmin = zmin 
		this\size = size
		this\depth = depth 
		id = id + 1
	Else 		
		If depth >0		
		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  PoinInCircle(ox , oy , oz ,r)
	If Int(((mx - ox)^2 + (my - oy)^2+ (pz - oz)^2)^0.5) <= r  Then Return True Else Return False 
	;If Int(((mx - ox)^2 + (my - oy)^2+ (pz - oz)^2)^0.5) < r And Int(((mx - ox)^2 + (my - oy)^2+ (pz - oz)^2)^0.5) > r-2 Then Return True Else Return False 
End Function

Graphics 800,600,32,2 
SetBuffer BackBuffer() 
	Dim Pix(GraphicsWidth(),GraphicsHeight())
	image = CreateImage (800,600)
	;HidePointer
	CubDepth =7  ; 8 ;число вложений (глубина ) 
	CubSize = 256 ; размеры квадранта 
	pz = 50 
	root.OCTREE = RootOctree(0,0,0,CubSize ,CubDepth )

While Not KeyHit(1) 
	Start = MilliSecs()
	mx = MouseX() 
	my = MouseY() 
	s = Abs(MouseZ())+1

	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(28)  Then viewline = 1- viewline  ; ENTER
	If KeyHit(2)  Then  show2d = 1- show2d ; 1
	If KeyHit(57)  Then 
		EraseOctree(root) 
 		id=0 
		 root.OCTREE = RootOctree(0,0,0,CubSize ,CubDepth )
	EndIf 

;myy = (2*(my-300) -(mx-400))/2 + pz;-s
;mxx = ((mx-400)+myy);-;s

	
	Paint()
	DrawImage image,0,0
	
	Color 128,128,128
	Rect 0,0,CubSize ,CubSize ,0
	Color 0,255,0
	Oval mx - s, my-s,s*2,s*2,0
	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  = "+
	Text 550,40,"Radius = "+s+"        - scroll mouse"
	Text 550,60,"Position Z = "+pz+"         - press A or Z"
	Text 550,80,"Time AddOctree = "+timeoutcreate 
	timeoutvis = (MilliSecs()-timeinvis)	
	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
FreeImage image 
End  

Function Paint()
	If MouseDown(1) 
		timeintcreate = MilliSecs()
			For ny = my+s To my-s Step -1
				For nx = mx+s To mx-s Step -1
					For nz = pz+s To pz-s  Step -1
						 If PoinInCircle(nx , ny , nz ,s)
							AddOctree(root, 0,0,0,CubSize ,nx,ny,nz,CubDepth )
						EndIf 
					Next 	
				Next 		
			Next	
	
		timeoutcreate# =  (MilliSecs()-timeincreate)/100000	
;	End If
;	If MouseHit(1) 
		SetBuffer ImageBuffer(image)
			Cls
			RenderOctree(root,CubDepth )
		SetBuffer BackBuffer()
	EndIf 
End Function



Function RenderOctree(this.OCTREE,depth)
If this.OCTREE <> Null 
	If (depth >0)	
		If show2d = 0
			Color 128,128,128
		;	Rect this\xmin , this\ymin , this\size , this\size , 0	
		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\zmin
			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 EraseOctree(this.OCTREE)
	Delete Each OCTREE
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, 17.05.2013 в 22:08.
(Offline)
 
Ответить с цитированием
Старый 06.10.2013, 04:52   #12
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

Вот ,после долгого отсутствия ...
Накатал новый пример ...
собственно здесь создаются две структуры ,самого октри и точек . В зависимости от перемещения точек меняется структура октри .

код:
SeedRnd MilliSecs()

Global id,id2,id3,mx,my ,CubDepth ,CubSize 
Global px,py,pz ,s ,mxx,myy , mmy
Global timeoutcreate# , timeintcreate


Type OCTREE
Field Child.OCTREE[7] ;8 потомков
Field xmin,ymin,zmin
;Field xcentr,ycentr,zcentr ; ????? ????
Field qred,qgreen,qblue,qalpha,qcolor
Field size , depth , parent
End Type

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

;Global root.OCTREE

Function RootOctree.OCTREE(xmin,ymin,zmin ,size,depth)

	newsize = size / 2
	
	this.OCTREE = New OCTREE
	this\xmin = xmin
	this\ymin = ymin
	this\zmin = zmin 
	this\size = size
	this\depth = depth 
	id2=id2+1
	
	Return this
End Function




Function AddClearOctree.OCTREE( this.OCTREE,xmin,ymin,zmin ,size,ppx,ppy,ppz,depth)

If PointInCube(xmin,ymin,zmin,xmin+size,ymin+size,zmin+size,ppx,ppy,ppz )

	newsize = size / 2
	
	If this = Null
		this.OCTREE = New OCTREE
		this\xmin = xmin
		this\ymin = ymin
		this\zmin = zmin 
		this\size = size
		this\depth = depth 
		id2=id2+1
		;this\parent = this 
	Else 		
		If depth >0		
		newdepth = depth -1
		newxmin = xmin+newsize
		newymin = ymin+newsize
		newzmin = zmin+newsize
		this\Child[0] = AddClearOctree(this\Child[0], xmin,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
		this\Child[1] = AddClearOctree(this\Child[1], xmin,newymin  ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth )
		this\Child[2] = AddClearOctree(this\Child[2], newxmin ,newymin ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
		this\Child[3] = AddClearOctree(this\Child[3], newxmin ,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
		
		this\Child[4] = AddClearOctree(this\Child[4], xmin,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
		this\Child[5] = AddClearOctree(this\Child[5], xmin,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth )
		this\Child[6] = AddClearOctree(this\Child[6], newxmin ,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
		this\Child[7] = AddClearOctree(this\Child[7], newxmin ,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
		
		EndIf 
	EndIf
Else 
	newsize = size / 2
	
	If this <> Null
	
	
		If depth < CubDepth -1		
		newdepth = depth -1
		newxmin = xmin+newsize
		newymin = ymin+newsize
		newzmin = zmin+newsize
		this\Child[0] = AddClearOctree(this\Child[0], xmin,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
		this\Child[1] = AddClearOctree(this\Child[1], xmin,newymin  ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth )
		this\Child[2] = AddClearOctree(this\Child[2], newxmin ,newymin ,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
		this\Child[3] = AddClearOctree(this\Child[3], newxmin ,ymin,zmin  ,newsize  ,ppx,ppy,ppz,newdepth ) 
		
		this\Child[4] = AddClearOctree(this\Child[4], xmin,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
		this\Child[5] = AddClearOctree(this\Child[5], xmin,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth )
		this\Child[6] = AddClearOctree(this\Child[6], newxmin ,newymin ,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 
		this\Child[7] = AddClearOctree(this\Child[7], newxmin ,ymin,newzmin ,newsize ,ppx,ppy,ppz,newdepth ) 

		Delete this
		this = Null 
		id2=id2-1

		EndIf 

	EndIf

EndIf
	Return this
End Function




Function  PoinInCircle(ox , oy ,r)
	If Int((mx - ox)^2 + (my - oy)^2) <= r^2 Then
		mx = ox : my = oy
	EndIf 
End Function

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

 For p = 0 To 2
	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 =5  ; 8 ;число вложений (глубина ) 
CubSize = 128 ; размеры квадранта 
v=1
root.OCTREE = RootOctree(0,0,0,CubSize ,CubDepth )

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(57)  Then 

	EndIf 


For pt.POINT = Each POINT

	If pt\x <= 0 Then 
	v=1
	pt\x=Int(Rnd(10,120))
	pt\y=Int(Rnd(10,120))
	pt\z=Int(Rnd(10,120))
	EndIf
	If pt\x >= 128 Then 
	v=-1
	pt\x=Int(Rnd(10,120))
	pt\y=Int(Rnd(10,120))
	pt\z=Int(Rnd(10,120))
	EndIf
        pt\x = pt\x +v	
	
If PointInCube(0,0,0,CubSize,CubSize,CubSize,pt\x,pt\y,pt\z )	
	timestart = MilliSecs()	
	AddClearOctree(root, 0,0,0,CubSize,pt\x,pt\y,pt\z ,CubDepth)	
		
	timeoutcreate = (MilliSecs()-timestart)
EndIf 

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 50,10,"Total MEMORY : "+ TotalVidMem () + "байт.     MEMORY  : " + AvailVidMem()
	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\zmin
			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 EraseOctree(this.OCTREE)
	For this.OCTREE = Each OCTREE
	Delete this
	Next
End Function

Function ClearOctree.OCTREE( this.OCTREE,xmin,ymin,zmin ,size,depth)
	newsize = size / 2

	If this <> Null
	
		If depth >0 		
		newdepth = depth -1
		newxmin = xmin+newsize
		newymin = ymin+newsize
		newzmin = zmin+newsize
		this\Child[0] = ClearOctree(this\Child[0], xmin,ymin,zmin  ,newsize  ,newdepth ) 
		this\Child[1] = ClearOctree(this\Child[1], xmin,newymin  ,zmin  ,newsize  ,newdepth )
		this\Child[2] = ClearOctree(this\Child[2], newxmin ,newymin ,zmin  ,newsize  ,newdepth ) 
		this\Child[3] = ClearOctree(this\Child[3], newxmin ,ymin,zmin  ,newsize  ,newdepth ) 
		
		this\Child[4] = ClearOctree(this\Child[4], xmin,ymin,newzmin ,newsize ,newdepth ) 
		this\Child[5] = ClearOctree(this\Child[5], xmin,newymin ,newzmin ,newsize ,newdepth )
		this\Child[6] = ClearOctree(this\Child[6], newxmin ,newymin ,newzmin ,newsize ,newdepth ) 
		this\Child[7] = ClearOctree(this\Child[7], newxmin ,ymin,newzmin ,newsize ,newdepth ) 
		
		EndIf 
		Delete this
		id2=id2-1
	EndIf
	Return this
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
__________________
Мой проект здесь
(Offline)
 
Ответить с цитированием
Старый 07.10.2013, 15: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 в 16:16.
(Offline)
 
Ответить с цитированием
Старый 10.10.2013, 08:24   #14
Reizel
Задрот
 
Аватар для Reizel
 
Регистрация: 24.07.2009
Адрес: Ивановская область, г. Кинешма
Сообщений: 1,569
Написано 407 полезных сообщений
(для 863 пользователей)
Ответ: Voxel (octotree)

ты б лучше свои размышления в виде статейки like habrahabr выложил, я б с удовольствием почитал, нежели код..
__________________
(Offline)
 
Ответить с цитированием
Старый 13.10.2013, 08:09   #15
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: Voxel (octotree)

Не которое отклонение от темы , создавать новую не считаю нужным .
Проверьте ,код на тормазнутость ,пожалуйста .

Проверка попадают ли точки в зону видимости



Graphics 800,600,32,2 
SetBuffer BackBuffer() 
q = 500
cc = q*q
Dim fx(cc) :Dim fy(cc)
x=200 :y=200

For b= 0 To q 
	 For a= 0 To q 
	c = a*b
		If Rand(0,4)=0 Then 
		fx(c)=100+a 
		fy(c)=50+b
		col =col +1
		EndIf
	Next
Next

While Not KeyHit(1) 
  mx# = MouseX()
  my# = MouseY()
If KeyDown(205) Then x=x+10
If KeyDown(203) Then x=x-10
If KeyDown(208) Then y=y+10
If KeyDown(200) Then y=y-10
If MouseDown(1) Then x=mx : y=my

Cls 
Color 50,55,50
Line x,y,mx,my

LockBuffer BackBuffer()	
For c= 0 To cc 
 
	d# = Dist#( x, y, mx, my )
	If d = 0 Then d# = 0.0000001
	dx# = (x-mx)/d
	dy# = (y-my)/d
	
	d2# =  Dist#( x, y, fx(c), fy(c))
	If d2 = 0 Then d2# = 0.0000001
	dxv#= (x- fx(c))/d2
	dyv# = (y-fy(c))/d2
	
	ac# = ACos(dx*dxv+dy*dyv)
	
	
	If ac <=30 Then WritePixel fx(c),fy(c),$666666,BackBuffer() Else  WritePixel fx(c),fy(c),$fff,BackBuffer() ; угол обзора 60 градусов

Next
UnlockBuffer BackBuffer()	
Text 20,20 ,"Total points "+col 
Flip 
Wend 
End  

Function Dist#( X1#, Y1#, X2#, Y2# )
	Return Abs(( (X1 - X2)*(X1 - X2) + (Y1 - Y2)*(Y1 - Y2) )^0.5)
End Function

Function Q(ax,ay,bx,by,cx,cy) ;(cx,cy) - координаты точки
If (cy-ay)*(bx-ax)-(cx-ax)*(by-ay)=0 Then Return True Else Return False 
End Function
__________________
Мой проект здесь
(Offline)
 
Ответить с цитированием
Ответ


Опции темы

Ваши права в разделе
Вы не можете создавать темы
Вы не можете отвечать на сообщения
Вы не можете прикреплять файлы
Вы не можете редактировать сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.


Часовой пояс GMT +1, время: 14:57.


vBulletin® Version 3.6.5.
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Перевод: zCarot
Style crйe par Allan - vBulletin-Ressources.com