; [depthMax = X*Y*Z]
; 1 = 2
; 2 = 4
; 3 = 8
; 4 = 16
; 5 = 32
; 6 = 64
; 7 = 128
; 8 = 256
; 9 = 512
; 10 = 1024
; 11 = 2048
Const depthMax = 6 ; [0 - 64 OR 64*64*64]
;Const depthMax = 8 ; [0 - 255 OR 255*255*255]
Const v = 100 , ConstCubSize =63 , s = 2
time = CreateTimer(60)
Global id , Objects
Global levelOctree
Type oct
Field pok.oct[8] , cvet , level;depth
Field parent.oct
Field name$ , group
End Type
Global ppp.oct = New oct
Global ccc.oct
Local ddd.oct
colors% = $ff0000
level% =4
Graphics 800,600,32,2
SetBuffer BackBuffer()
ppp\name = " ROOT"
map=LoadImage("D:\vitalii\blitz\hmap5.jpg")
DrawBlock map,0,0
LockBuffer BackBuffer()
For y0=0 To ConstCubSize ;Step 1
For x0=0 To ConstCubSize ;Step 1
rgb = ReadPixel(x0,y0) And $FFFFFF
; If rgb = $000000 rgb =$111111
rr= GetR(rgb )
gg= GetG(rgb )
bb= GetB(rgb )
z0=Int(Floor (( ((rr*v)/100) + ((gg*v)/100) +((bb*v)/100) )/ 90))
If z0 <=0 z0 =1
; z0 =1
; AddOctree(root, 0,0,0,CubSize,x0,y0,z0 ,CubDepth , rr ,gg ,bb)
z1 = 0
While z1 < z0
add(ppp,x0,y0,z1,1 ,rgb,0," SECOND")
z1=z1+1
Wend
Next
Next
UnlockBuffer BackBuffer()
Restore sold
For z= 0 To 9
For y = 0 To 2
For x = 0 To 6
Read dat
If dat >0 dat = $ff0000 Else dat = $000000
add(ppp,20+x,20+y,20+z,1 ,dat,1," SOLDER")
Next :Next :Next
For z= 0 To 4
For y = 0 To 4
For x = 0 To 4
add(ppp,50+x,50+y,50+z,1 ,$0000ff,2," CUBE")
Next :Next :Next
; add(ppp,62,60,63,4 ,$ff0000," SECOND") ; Add Octree
; add(ppp,32,60,63,3 ,$0000ff," SECOND")
While Not KeyHit(1)
Cls
DrawBlock map,65,65
mx = MouseX() : my=MouseY()
; ddd =get(ppp,62,255,255,3) ; Get Octree
render(ppp,64,64,64,depthMax,64 )
Color 255,255,255
AppTitle " id - "+id +" Object - "+Objects
;DebugLog "id - "+id +" Object - "+Objects
Flip
Wend
Delete Each oct
FreeTimer (time)
End
; __ FUNCTIONS__
Function render(ooo.oct,xmin,ymin,zmin,depth,size)
If ooo <> Null
If depth >= 0
newdepth = depth -1
newsize = (size Shr 1)
newxmin = xmin+newsize
newymin = ymin+newsize
newzmin = zmin+newsize
If ooo\cvet >$000000
x_min = (xmin - ymin)
y_min = (xmin + ymin)/2 - zmin
Color ooo\cvet Shr 16 And %11111111,ooo\cvet Shr 8 And %11111111,ooo\cvet And %11111111
; Oval 400+x_min*s-1,300+y_min*s-1,size*s+2,size*s+2,1
; Rect 400+x_min*s,300+y_min*s,size*s+1,size*s+1,1
WritePixel 400+x_min,300+y_min,ooo\cvet
; Color 255,255,255
Rect xmin-63,ymin-63,size,size,1
Else
Color 255,255,255
; Rect xmin-63,ymin-63,size,size,0
EndIf
If ooo\pok[0] <> Null render(ooo\pok[0] ,xmin,ymin,zmin,newdepth,newsize)
If ooo\pok[1] <> Null render(ooo\pok[1] ,newxmin,ymin,zmin,newdepth,newsize)
If ooo\pok[2] <> Null render(ooo\pok[2] ,xmin,newymin,zmin,newdepth,newsize)
If ooo\pok[3] <> Null render(ooo\pok[3] ,newxmin,newymin,zmin,newdepth,newsize)
If ooo\pok[4] <> Null render(ooo\pok[4] ,xmin,ymin,newzmin,newdepth,newsize)
If ooo\pok[5] <> Null render(ooo\pok[5] ,xmin,newymin,newzmin,newdepth,newsize)
If ooo\pok[6] <> Null render(ooo\pok[6] ,newxmin,ymin,newzmin,newdepth,newsize)
If ooo\pok[7] <> Null render(ooo\pok[7] ,newxmin,newymin,newzmin,newdepth,newsize)
EndIf
EndIf
End Function
Function get.oct(ooo.oct,x,y,z,levelOctree)
Local tx,ty,tz
depth = depthMax -1
tx = x Shr depth
ty = y Shr depth
tz = z Shr depth
;DebugLog " "+x+" "+y+" "+z+" "
;DebugLog " "+tx+" "+ty+" "+tz+" "
k= tx+ ty Shl 1 + tz Shl 2
ccc = ooo\pok[k]
If ccc = Null Then
Return Null
Else
If depth = levelOctree Return ccc
EndIf
While Not depth = 1
x = x - tx Shl depth
y = y - ty Shl depth
z = z - tz Shl depth
depth = depth -1
tx = x Shr depth
ty = y Shr depth
tz = z Shr depth
;DebugLog " "+x+" "+y+" "+z+" "
;DebugLog " "+tx+" "+ty+" "+tz+" "
k= tx+ ty Shl 1 + tz Shl 2
ccc = ccc\pok[k]
If ccc = Null Then
Return Null
Else
If depth = levelOctree Return ccc
EndIf
Wend
x = x - tx Shl depth
y = y - ty Shl depth
z = z - tz Shl depth
depth = depth -1
tx = x Shr depth
ty = y Shr depth
tz = z Shr depth
;DebugLog " "+x+" "+y+" "+z+" "
;DebugLog " "+tx+" "+ty+" "+tz+" "
k= tx+ ty Shl 1 + tz Shl 2
ccc = ccc\pok[k]
If ccc = Null Then Return Null
levelOctree = depth
Return ccc
End Function
Function add.oct(ooo.oct,x,y,z,levelOctree ,cvet,group ,name$ )
Local tx,ty,tz, ar.oct
ar = ooo
depth = depthMax -1
tx = x Shr depth
ty = y Shr depth
tz = z Shr depth
k= tx+ ty Shl 1 + tz Shl 2
ccc = ooo\pok[k]
If ccc = Null Then
ccc = New oct :id= id +1
ccc\name = " ROOT "+Str( depth)
ccc\group = group
ccc\parent = ar
ccc\level = depth
EndIf
ooo\pok[k] = ccc
ooo = ccc
ar = ooo
While Not depth = levelOctree ;depth > 1
x = x - tx Shl depth
y = y - ty Shl depth
z = z - tz Shl depth
depth = depth -1
tx = x Shr depth
ty = y Shr depth
tz = z Shr depth
k= tx+ ty Shl 1 + tz Shl 2
ccc = ooo\pok[k]
If ccc = Null Then
ccc = New oct :id= id +1
ccc\name = " ROOT " +Str( depth)
ccc\group = group
ccc\parent = ar
ccc\level = depth
EndIf
ooo\pok[k] = ccc
ooo = ccc
ar = ooo
Wend
ar = ooo
x = x - tx Shl depth
y = y - ty Shl depth
z = z - tz Shl depth
depth = depth -1
tx = x Shr depth
ty = y Shr depth
tz = z Shr depth
k= tx+ ty Shl 1 + tz Shl 2
ccc = ooo\pok[k]
If ccc = Null Then
ccc = New oct :id= id +1
ccc\name = name
ccc\group = group
ccc\level = depth
ccc\parent = ar
ccc\cvet = cvet
Objects = Objects +1
EndIf
ooo\pok[k] = ccc
End Function
Function GetR(RGB)
Return RGB Shr 16 And %11111111
End Function
; return Green value out of a RGB value
Function GetG(RGB)
Return RGB Shr 8 And %11111111
End Function
; return Blue value out of a RGB value
Function GetB(RGB)
Return RGB And %11111111
End Function
.sold
Data 0,0,0,0,0,0,0
Data 0,0,1,0,1,0,0
Data 0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0
Data 0,0,1,0,1,0,0
Data 0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0
Data 0,0,1,0,1,0,0
Data 0,0,0,0,0,0,0
Data 0,0,1,1,1,0,0
Data 1,0,1,1,1,0,1
Data 0,0,1,1,1,0,0
Data 0,0,1,1,1,0,0
Data 1,0,1,1,1,0,1
Data 0,0,1,1,1,0,0
Data 0,0,1,1,1,0,0
Data 1,1,1,1,1,1,1
Data 0,0,1,1,1,0,0
Data 0,0,0,0,0,0,0
Data 0,0,0,1,0,0,0
Data 0,0,0,0,0,0,0
Data 0,0,1,1,1,0,0
Data 0,0,1,1,1,0,0
Data 0,0,1,1,1,0,0
Data 0,0,1,1,1,0,0
Data 0,0,1,1,1,0,0
Data 0,0,1,1,1,0,0
Data 0,0,1,1,1,0,0
Data 0,0,1,1,1,0,0
Data 0,0,0,1,0,0,0