Textured voxel demo

This code has been declared by its author to be Public Domain code.

Textured voxel demo by jfk EO-11110

2004

Get that original Apache feeling :)

; Voxel/Raycasting with heightmap, texture and "fog" - flight over landscape
; by CSP just4fun
Graphics 320,240,16,2
SetBuffer BackBuffer()

; can also use heightmap and texture files...
Global hm
hm=CreateImage(256,256)

Dim mount(1000,3)
For i=0 To 10
 mount(i,0)=Rand(0,256)
 mount(i,1)=Rand(0,256)
 mount(i,2)=Rand(30,127)
Next

Cls
Print "Creating Heightmap - please stand by"
Flip
SetBuffer ImageBuffer(hm)
For i=0 To 255
 For i2=0 To 10
  r=mount(i2,2)-i
  If r>0
   Color i+i,i+i,i+i
   Oval mount(i2,0)-r/2,mount(i2,1)-r/2,r,r,0
   Oval 1+mount(i2,0)-r/2,mount(i2,1)-r/2,r,r,0
   Oval mount(i2,0)-r/2,1+mount(i2,1)-r/2,r,r,0
  EndIf
 Next
Next
SetBuffer BackBuffer()

Cls
Print "Creating Terrain Texture - wait a second..."
Flip
Global mossy
mossy=CreateImage(256,256)

For i=0 To 1000
 mount(i,0)=Rand(0,256)
 mount(i,1)=Rand(0,256)
 mount(i,2)=Rand(0,20)
Next
SetBuffer ImageBuffer(mossy)

For i=0 To 50
 For i2=0 To 1000
  r=mount(i2,2)-i
  If r>0
   Color Rand(50)+i*4,Rand(50)+i*10,0
   Oval mount(i2,0)-r/2,mount(i2,1)-r/2,r,r,0
   Oval 1+mount(i2,0)-r/2,mount(i2,1)-r/2,r,r,0
   Oval mount(i2,0)-r/2,1+mount(i2,1)-r/2,r,r,0
  EndIf
 Next
Next

SetBuffer BackBuffer()

Global grw=GraphicsWidth()
Global grh=GraphicsHeight()
Global grwh=grw/2
Global grhh=grh/2
Global my
Global px#=8.0
Global pz#=8.0
Global a#

Color 127,127,127
MoveMouse grwh,0
;__________________________MAINLOOP_________________________
While KeyDown(1)=0
 Cls
 If KeyDown(200) Then ; up
  px=px+Sin(a)
  pz=pz+Cos(a)
 EndIf
 If KeyDown(208) Then ; down
  px=px-Sin(a)
  pz=pz-Cos(a)
 EndIf
 a=(a-mxs#) Mod 360 ; use mouse to steer
 raycast()
 ; Text 0,0, "x:"+px+ " z:"+pz
 Text 0,0,"Use Mouse + Arrows"
 Flip
 my=MouseY()
 If my>130 Then my=130
 mxs#=MouseXSpeed()/3.0 ; used by steer
 MoveMouse GraphicsWidth()/2,my
Wend
End
;________________________eo mainloop__________________________


Function raycast()
 For i=-grwh To grwh-1 Step 4
  row=grh+1
;  igrwh=i+grwh
  grwh_mi=grwh-i
  rayx#=px
  rayz#=pz
  stepx#=Sin(a+0.125*i)
  stepz#=Cos(a+0.125*i)
  count#=0

  LockBuffer BackBuffer()
  LockBuffer ImageBuffer(hm)
  LockBuffer ImageBuffer(mossy)
  While count<200 ; camerarange
   rayx#=rayx+stepx
   rayz#=rayz+stepz
   If rayx>-127 And rayx<127
    If rayz>-127 And rayz<127
     c#=ReadPixelFast(rayx+127,rayz+127,ImageBuffer(hm)) And $ff
   h#=((15000.0-my*100)/count)-((.1*my+30)*c)/count
   If h<row
    If c=0 Then 
     co=$9dd0 ; water
    Else
     ;co=((c Xor $ff)Shl 7)And $ff00 Or (c Shl 16)
     co=ReadPixelFast(rayx+127,rayz+127,ImageBuffer(mossy)) And $ffff Or (c Xor $FF)
    EndIf
    For ii= h To row-1
     x=grwh_mi
     y=ii
     If x>=0 And x<=grw And y>=0 And y<=grh
      WritePixelFast x,y,co,BackBuffer()
     EndIf
    Next
    row=h
   EndIf
   EndIf
   EndIf
   count=count+1
  Wend
  UnlockBuffer BackBuffer()
  UnlockBuffer ImageBuffer(hm)
  UnlockBuffer ImageBuffer(mossy)
 Next
End Function

Comments

bobbo

2004

What is it?

If r&gt;0

It does not compile under BlitzPlus...

Beaker

2004

replace:
>
with:
>
and
<
with:
<

bobbo

2004

Yes thank you, I figured it out too, it seems a bug of this forum to replace HTML codes for > and <.

Subirenihil

2006

???

Rook Zimbabwe

2006

Hmmm... interesting effect, but... Why does it just create every other line of the image?

Stevie G

2006

This gives me a mav at one of the writepixel commands?

DareDevil

2006

Hi all

I have modified your code for fast speed.

; Voxel/Raycasting with heightmap, texture and "fog" - flight over landscape
; by CSP just4fun
Graphics 320,240,16,2
SetBuffer BackBuffer()

; can also use heightmap and texture files...

Dim ARhm(256,256)
Global hm
hm=CreateImage(256,256)




Dim mount(1000,3)
For i=0 To 10
 mount(i,0)=Rand(0,256)
 mount(i,1)=Rand(0,256)
 mount(i,2)=Rand(30,127)
Next

Cls
Print "Creating Heightmap - please stand by"
Flip
SetBuffer ImageBuffer(hm)
For i=0 To 255
 For i2=0 To 10
  r=mount(i2,2)-i
  If r>0
   Color i+i,i+i,i+i
   Oval mount(i2,0)-r/2,mount(i2,1)-r/2,r,r,0
   Oval 1+mount(i2,0)-r/2,mount(i2,1)-r/2,r,r,0
   Oval mount(i2,0)-r/2,1+mount(i2,1)-r/2,r,r,0
  EndIf
 Next
Next
LockBuffer ImageBuffer(hm)
For y=0 To 255
	For x=0 To 255
		ARhm(x,y)=ReadPixelFast(x,y) And $ff
	Next
Next
UnlockBuffer ImageBuffer(hm)

SetBuffer BackBuffer()

Cls
Print "Creating Terrain Texture - wait a second..."
Flip
Dim ARmossy(256,256)
Global mossy
mossy=CreateImage(256,256)

For i=0 To 1000
 mount(i,0)=Rand(0,256)
 mount(i,1)=Rand(0,256)
 mount(i,2)=Rand(0,20)
Next
SetBuffer ImageBuffer(mossy)

For i=0 To 50
 For i2=0 To 1000
  r=mount(i2,2)-i
  If r>0
   Color Rand(50)+i*4,Rand(50)+i*10,0
   Oval mount(i2,0)-r/2,mount(i2,1)-r/2,r,r,0
   Oval 1+mount(i2,0)-r/2,mount(i2,1)-r/2,r,r,0
   Oval mount(i2,0)-r/2,1+mount(i2,1)-r/2,r,r,0
  EndIf
 Next
Next
LockBuffer ImageBuffer(mossy)
For y=0 To 255
	For x=0 To 255
		ARmossy(x,y)=ReadPixelFast(x,y) And $ffff
	Next
Next
UnlockBuffer ImageBuffer(mossy)

SetBuffer BackBuffer()

Global grw=GraphicsWidth()
Global grh=GraphicsHeight()
Global grwh=grw/2
Global grhh=grh/2
Global my
Global px#=8.0
Global pz#=8.0
Global a#

Color 127,127,127
MoveMouse grwh,0

Global Old_Time=0

;__________________________MAINLOOP_________________________
While KeyDown(1)=0
 Cls
 CurTime=1000/(MilliSecs()-Old_Time);
 Old_Time=MilliSecs()
 If KeyDown(200) Then ; up
  px=px+Sin(a)
  pz=pz+Cos(a)
 EndIf
 If KeyDown(208) Then ; down
  px=px-Sin(a)
  pz=pz-Cos(a)
 EndIf
 a=(a-mxs#) Mod 360 ; use mouse to steer
 raycast()
 ; Text 0,0, "x:"+px+ " z:"+pz
 Text 0,0,"Use Mouse + Arrows  Fps:" + CurTime
 Flip
 my=MouseY()
 If my>130 Then my=130
 mxs#=MouseXSpeed()/3.0 ; used by steer
 MoveMouse GraphicsWidth()/2,my
Wend
End
;________________________eo mainloop__________________________


Function raycast()
	;===>
	Local my1=(15000.0-my*100)
	Local my2=(.1*my+30)
	;===>
	SetBuffer BackBuffer()
	LockBuffer BackBuffer()
	;===>
	For i=-grwh To grwh-1 Step 1
		row=grh+1
		grwh_mi=grwh-i
		rayx#=px
		rayz#=pz
		stepx#=Sin(a+0.125*i)
		stepz#=Cos(a+0.125*i)
		count#=0
		While count<200 ; camerarange
			rayx#=rayx+stepx
			rayz#=rayz+stepz
			If rayx>-127 And rayx<127
				If rayz>-127 And rayz<127
					c#=ARhm(rayx+127,rayz+127)
					h#=(my1/count)-(my2*c)/count
					If h<row
						If c=0 Then 
							co=$9dd0 ; water
						Else
							co=ARmossy(rayx+127,rayz+127) Or (c Xor $FF)
						EndIf
						For ii= h To row-1
							x=grwh_mi
							y=ii
							If x>=0 And x<=grw And y>=0 And y<=grh
								WritePixelFast x,y,co
							EndIf
						Next
						row=h
					EndIf
				EndIf
			EndIf
			count=count+1
		Wend
	Next
	;===>
	UnlockBuffer BackBuffer()
	;===>
End Function

Warren

2006

I get the same MAV in DareDevil's version.

DareDevil

2006

i have test the release and not crash.

whats release blitz use?

bye

impixi

2006

I don't know why, but these days "writepixelfast" and "readpixelfast" cause MAVs for me. If I change them to their respective "writepixel" and "readpixel" equivalents the code runs without problems.

EDIT: Actually, the -"fast" commands cause MAVs only in windowed mode. If I change the code to run fullscreen then it runs without problems.

DareDevil

2006

change settings bios enable

agp fast access read!
agp fast access write!

bytecode77

2006

yeah, on my school pc, it is working properly. but at home MAV.

you have to determinate pixels out of the screen range

at 640x480 it is (0-639)x(0-479)

Zenith

2006

To fix the mav, one must only fix the boundary checks for the texture output. Line 154, change it to:

If x>=0 And x<grw And y>=0 And y<grh

In my opinion, it'd be faster to use writepixelfast WITHOUT the boundary checks, just know where x and y will lead.. ReadPixel would certainly have faster boundary checks, considering it's written below blitz.

impixi

2006

Here's a rough BlitzMax port + modification:

SuperStrict

Const WIN_WIDTH:Int = 256
Const WIN_HEIGHT:Int = 256

Graphics WIN_WIDTH, WIN_HEIGHT

Local vox:TVoxelView = New TVoxelView
'vox.init(WIN_WIDTH, WIN_HEIGHT, 200, "hmap.png", "ground.png")
vox.init(WIN_WIDTH, WIN_HEIGHT, 200, "", "")

Local px:Float = 8.0
Local pz:Float = 8.0
Local a:Float

MoveMouse (GraphicsWidth() / 2), 0
HideMouse

Local Old_Time:Int = 0
Local Cur_Time:Int

While Not KeyHit(KEY_ESCAPE)

	Local my:Int = MouseY()
 	If my > 130 Then my = 130

	Local mxs:Float = (MouseX() - GraphicsWidth() / 2) / 3.0
	
 	MoveMouse (vox.view.width / 2), my

	Cls
	
	Cur_Time = 1000 / (MilliSecs() - Old_Time)
 	Old_Time = MilliSecs()

	If KeyDown(KEY_UP) Or KeyDown(KEY_W)
  		px :+ Sin(a)
  		pz :+ Cos(a)
 	EndIf

 	If KeyDown(KEY_DOWN) Or KeyDown(KEY_S)
  		px :- Sin(a)
  		pz :- Cos(a)
 	EndIf

	If KeyDown(KEY_Q) 
		a :+ 2
 	EndIf

	If KeyDown(KEY_E) 
		a :- 2
 	EndIf

 	a = Float((a - mxs) Mod 360.0)
	
 	vox.raycast(px, pz, a, my)

	DrawPixmap vox.view, 0, 0
	
 	DrawText "WQSE and mouse to move. Fps:" + Cur_Time, 0, 0
	
 	Flip 0
	
Wend

End


'*********************


Type TVoxelView

	Field HeightMap:Byte[,]
	Field TexMap:Int[,]
	Field HMWidth:Int
	Field HMHeight:Int
	
	Field View:TPixmap
	Field CamRange:Int
	Field grwh:Int
	Field grhh:Int 
	
	Method init(vw:Int = 256, vh:Int = 256, cr:Int = 200, hm_url:String = "", tex_url:String = "")
	
		view = CreatePixmap(vw, vh, PF_RGB888)
		
		grwh = view.width / 2
		grhh = view.height / 2
		
		CamRange = cr
		
		loadHeightMap hm_url
		loadTexMap tex_url
	
	EndMethod

	Method loadHeightMap(url:String)
	
		Local hmap:TPixmap = LoadPixmap(url)
		
		If Not hmap 
			genHeightMap()
		Else
			If hmap.format <> PF_RGB888 Then hmap = ConvertPixmap(hmap, PF_RGB888)
			HMWidth = hmap.width
			HMHeight = hmap.height
			HeightMap = New Byte[HMWidth, HMHeight] 
		
			For Local x:Int = 0 To (HMWidth - 1)
				For Local z:Int = 0 To (HMHeight - 1)
					HeightMap[x, z] = ReadPixel(hmap, x, z)
				Next
			Next
		
		EndIf
		
		hmap = Null
		GCCollect()
		
	EndMethod

	Method loadTexMap(url:String)
			
		Local tmap:TPixmap = LoadPixmap(url)
		
		If Not tmap 
			genTexMap()
		Else
			If tmap.format <> PF_RGB888 Then tmap = ConvertPixmap(tmap, PF_RGB888)
		
			If tmap.width <> HMWidth And tmap.height <> HMHeight Then tmap = ResizePixmap(tmap, HMWidth, HMHeight) 

			TexMap = New Int[tmap.width, tmap.height]
		
			For Local x:Int = 0 To tmap.width - 1
				For Local z:Int = 0 To tmap.height - 1
					TexMap[x, z] = ReadPixel(tmap, x, z)
				Next
			Next
		
		EndIf
			
		tmap = Null
		GCCollect()
	
	EndMethod

	Method genHeightMap(w:Int = 256, h:Int = 256)
		
		Local map:Float[w, h]
		HeightMap = New Byte[w, h]
		
		Local maxhsize:Int = w * 0.25
		Local numhills:Int = 500
    	SeedRnd(MilliSecs())

    	For Local n:Int = 1 To numhills

	  		Local radius:Int = Rand(0, maxhsize)
			Local centrex:Int = Rand(0, w - 1)
			Local centrez:Int = Rand(0, h - 1)
		
      		Local startx:Int = centrex - radius
      		If startx < 0 startx = 0

      		Local endx:Int = centrex + radius
	  		If endx > w endx = w

      		Local startz:Int = centrez - radius
      		If startz < 0 startz = 0

      		Local endz:Int = centrez + radius
      		If endz > h endz = h

      		For Local x:Int = startx To (endx - 1)
       			For Local z:Int = startz To (endz - 1)
	   	  			Local y:Float = (radius * radius) - (((x - centrex) * (x - centrex)) + ((z - centrez) * (z - centrez)))
	      			If y > 0.0 map[x, z] :+ y
	    		Next
	  		Next
    
    	Next
  
   		Local minv:Float = 10^38, maxv:Float = 10^-38
  
  		For Local x:Int = 0 To (w - 1)
     		For Local z:Int = 0 To (h - 1)
 	   			If map[x, z] < minv minv = map[x, z] Else If map[x, z] > maxv maxv = map[x, z]
     		Next
   		Next

   		For Local x:Int = 0 To (w - 1)
     		For Local z:Int = 0 To (h - 1)
	   			map[x, z] = (map[x, z] - minv) / (maxv - minv)
	 		Next
  		Next	
 
	   	For Local x:Int = 0 To (w - 1)
      		For Local z:Int = 0 To (h - 1)
       			Local v:Int = Floor(map[x, z] * 255)
				HeightMap[x, z] = v
      		Next
    	Next

		HMWidth = w
		HMHeight = h
	
	EndMethod

	Method genTexMap()
		
		TexMap = New Int[HMWidth, HMHeight]
		
		Local a:Byte = 0
		
		For Local x:Int = 0 To (HMWidth - 1)
      		For Local z:Int = 0 To (HMHeight - 1)

       			Local v:Int = HeightMap[x, z]
				Local r:Byte = v
				Local g:Byte = v
				Local b:Byte = v
				
				If v < 64
					r = 0
					g = 0
					b = 150		
				Else 
					r = 0
					g = v
					b = 0
				EndIf
				
       			TexMap[x, z] = (a Shl 24 | r Shl 16 | g Shl 8 | b)
      		Next
    	Next
	
	EndMethod

	Method raycast(px:Float, pz:Float, a:Float, my:Int)

		'** Clear View
		For Local x:Int = 0 To View.width - 1
			For Local y:Int = 0 To View.height - 1
				WritePixel View, x, y, $000000ff			'Sky
			Next
		Next
		'***
	
		Local my1:Int = (15000.0 - (my * 100.0))
		Local my2:Int = ((0.1 * my) + 30)

		For Local i:Int = -grwh To (grwh - 1) Step 1
	
			Local row:Int = view.height + 1
			Local grwh_mi:Int = grwh - i
			Local rayx:Float = px
			Local rayz:Float = pz
			Local stepx:Float = Sin(a + (0.125 * Float(i)))
			Local stepz:Float = Cos(a + (0.125 * Float(i)))
		
			For Local count:Int = 1 To CamRange
	
				rayx :+ stepx
				rayz :+ stepz
			
				If (rayx > -127) And (rayx < 127)		
					If (rayz > -127) And (rayz < 127)	
				
						Local c:Int = HeightMap[(rayx + 127), (rayz + 127)]	
						Local h:Int = (my1 / count) - ((my2 * c) / count)
					
						If (h < row)

							Local co:Int = TexMap[(rayx + 127), (rayz + 127)] 
						
							For Local y:Int = h To (row - 1)
						
								Local x:Int = grwh_mi

								If (x >= 0) And (x < View.width) And (y >= 0) And (y < View.height)
									WritePixel View, x, y, co
								EndIf
							
							Next
						
							row = h
						
						EndIf
					EndIf
				EndIf
			
			Next
		
		Next

	EndMethod

EndType

Code Archives Forum