Flame Filter

[Conexion]

Got some inspiration from:
http://processing.org/learning/topics/firecube.html

I might go ahead and add the 3D rotating cube in the future, but for now I'm happy with my spinning circle/fireball. Learned a lot about the image buffer and screen buffer with this. Before I started using the buffers, this would run at 9 FPS on my pretty dang good machine (Two NVidia 9800's in SLI, Intel i7, 12GB DDR3 Ram, etc). Now it runs at 214 FPS (when I set fpsLimit to 1000).

Let me know what you think!

(As a side note, I'm thinking of making a palette gradient editor to better control my palette... I wanted to change it to a blue flame, but I couldn't find one I was happy with)

Code: Select all

' Flame Test by Conexion 
' With assistance from ##Freebasic
' Thanks for the extra help Mysoft! 

#Include "fbgfx.bi"
Randomize , 1

Dim As Integer ScrW = 800, ScrH = 600
Dim As UByte CharH = 8, CharW = 8

'Adjustables
Dim As Single fTrail = 1 / 4.1
Dim As Integer spnRadius = 80 ' Size of the spinner
Dim As Integer spnDegrees = 5 ' Degrees Clockwise

Const fpsLimit = 70
Const pi = 3.14159265 'Shouldn't need any more than that



ScreenRes ScrW, ScrH, 8, , fb.gfx_high_priority

'Set up the pallete
'xPal is the counter
'bPal adds extra blue/brightness
Dim As UByte xPal = 255 'Set it so when xPal +=1 happens, you get 0
Dim As UByte bPal = 0

Dim As Integer fadewhite = 170
Do
	xPal += 1
	If xPal < 64 Then
		Palette xPal, xPal*4, xPal, 0
	Else
		If xPal > 192 Then
			bPal += 4
		end If
		Palette xPal, 255, xPal, bPal
	end if
	
Loop Until xPal = 255

/'Palette test
For iii As Integer = 0 To 255
	Line (iii*2.5+10, 15)-(iii*2.5+30, 40), iii, bf
	Dim As Integer ir, ig, ib
	Palette Get iii, ir, ig, ib
Next
'/

'Set up the Image Buffer
Dim As fb.image Ptr ImgBuff = ImageCreate(ScrW, (ScrH + 4) / 2)


'Spinner Variables
Dim As Single spnOldX, spnOldY, spnX, spnY = spnRadius
Dim As Single spnAngle = spnDegrees * -0.017453 'Degrees to Rads
Dim As Integer spnVX = ScrW / 2, spnVY = ScrH / 4 ' Center the Spinner

'Precalculate the distance to each pixel we need to average
Dim As Integer calcDL = ScrW - 1
Dim As Integer calcD = ScrW
Dim As Integer calcDR = ScrW + 1
Dim As Integer calcDD = ScrW Shl 1

'Fire trail variables
Dim As Integer fX, fY, fZ, fColor

' FPS Vars
Dim As Integer fpsX, fpsY, fps, fpsNew, fpsSeconds
fpsX = (ScrW - len(fps)*CharW)
fpsY = (ScrH - CharH) - 32

Dim As Double fpsStart
Dim As Integer fpslSleep
Dim As Double fpslStart
Dim As Double fpslV = 1.0 / fpsLimit

Do
	' Start our timer
	fpslStart = Timer
	
	ScreenLock
	' Lets get the spinner down first!
	spnOldX = spnX
	spnOldY = spnY
	
	' Calculate the rotation coordinates 
	spnX = (spnOldX * Cos(spnAngle)) + (spnOldY * Sin(spnAngle))
	spnY = (spnOldY * Cos(spnAngle)) - (spnOldX * Sin(spnAngle))
	
	' Draw it, translated "V" distance. Also, half the arc/shape
	' for when we stretch the image on the Y-axis.
	Circle ImgBuff, (spnX + spnVX, spnY / 2 + spnVY), 8, 255,,,.5
	
	' The Screen Buffer
	Dim As UByte Ptr ScrBuff = ScreenPtr
	' The pixel part of ImgBuff
	Dim As UByte Ptr ImgPix = Cast(any Ptr, ImgBuff+1)
	
	' Random dots on the bottom line
	Dim As UByte Ptr BotLine = ImgPix
	BotLine += ScrW * CInt((ScrH-1)/2)
	
	dim as ubyte ptr SpecksPtr = cast(any ptr,ImgBuff+1)
	For ranLine As Integer = 0 To ScrW
		BotLine[ranLine] = (Rnd * 255)
		
		'Extra specks
		SpecksPtr[rnd*(scrw*(scrh/2-5))] = rnd*32
	Next
	
	' Circle Flares
	circle ImgBuff,(rnd*scrw,rnd*(scrh*3)),Rnd*20, Rnd*6, , (Rnd*pi)*2 ,Rnd*0.9,f
	circle ImgBuff,(rnd*scrw,rnd*(scrh*2)),Rnd*15, Rnd*10, , ,0.5,f
	
	' Output FPS with a shadow
	Draw String ImgBuff, (fpsX - 2, (fpsY - 2) / 2), Str(fps), 20
	Draw String ImgBuff, (fpsX - 2, (fpsY + 2) / 2), Str(fps), 20
	Draw String ImgBuff, (fpsX + 2, (fpsY - 2) / 2), Str(fps), 20
	Draw String ImgBuff, (fpsX + 2, (fpsY + 2) / 2), Str(fps), 20
	Draw String ImgBuff, (fpsX, fpsY / 2), Str(fpsNew), 254	

	' Filter Time!
	' Fire is calculated by adding the 3 pixels touching the bottom of any pixel
	' As well as one pixel two pixels down, then finding the average.
	' fX, fY, fZ, fColor
	'Dim As Integer calcDL = ScrW - 1
	'Dim As Integer calcD = ScrW
	'Dim As Integer calcDR = ScrW + 1
	'Dim As Integer calcDD = ScrW Shl 2 
	Dim As UByte Ptr fT = ImgPix
	
	For fY = 0 To (ScrH/2) - 1
		For fX = 0 To ScrW - 1
			fColor = (fT[calcDL] + fT[calcD] + fT[calcDR] + fT[calcDD]) * fTrail
			*fT = fColor
			fT += 1
		Next
	Next
	
	/' Draw ImgBuff at 2*Y
	for PY as integer = 0 to (Scrh/2)-1
		for PX as integer = 0 to ScrW-1
			*ScrBuff = *ImgPix
			ScrBuff[ScrW] = *ImgPix
			ScrBuff += 1
			ImgPix += 1
		next
		scrbuff += ScrW		
	Next'/
	
	'Mysoft's ASM routine is faster :p
	Asm
		mov edi,[ScrBuff]      ' Get Screen Buffer pointer
		mov esi,[ImgPix]       ' Get Image Buffer pointer
		mov eax,[ScrW]         ' Get screen Width
		mov ebx,[ScrH]         ' Get Screen height
		mov edx,eax            ' Make a copy of width
		shr eax,2              ' Convert pixels/line to dwords/line
		shr ebx,1              ' Only half of the screen will be read
		NextLine:              ' Starting another line
		mov ecx,eax            ' Loading pixels per line (in dwords)
		rep movsd              ' Copying those pixels
		sub esi,edx            ' We will repeat it again
		mov ecx,eax            ' So pixels per line again
		rep movsd              ' And copying those pixels (2:1)
		dec ebx                ' One line is done... Are there more?
		jnz NextLine           ' Yes? Then keep duplicating
	end Asm '
  
	ScreenUnLock
		
	' Adjust for our FPS limit
	fpslSleep = CInt((fpslStart + fpslV - Timer) * 1000.0)
	If fpslSleep > 1 Then
		Sleep fpslSleep, 1
	Else
		'Let's not be a memory hog
		Sleep 1
	end If
	
	' Calculate actual FPS
	fps += 1
	'fpsStart + 1 = One second going by
	If fpsStart + 1 < Timer Then
		fpsNew = fps
		fps = 0
		fpsSeconds += 1
		fpsStart = Timer
	end If
	
Loop Until InKey <> ""

ImageDestroy(ImgBuff)
End

Pages that were a ton of help:
- http://imortisoft.no-ip.org/b2b/?Issue_ ... _freeBASIC
- http://www.freebasic.net/wiki/wikka.php ... AndFontBuf

[squall4226]

I took a look at this, it is cool but I notice something interesting. My machine is meager compared to yours yet without fps limiting I get 221.

Well, I'm not familiar with the Pentium I7 family, but anyway you didn't specifically mention your clock rates. Not that they would be directly comparable to my machine, but they might give an idea. Well, FLOP/S would be better anyway.

Well, the GPU is pretty irrelevant in this case as well as the RAM. Multiple cores are unimportant too. I think.

AMD Athlon 3700+ @ 2.607GHZ(237*11) single core is what I got 221 just FYI. The rest of my system is ATI Radeon X850XT 256MB, 1GB DDR(2.5,3,3,8) @ 187 MHZ, CPU to NB and to SB both 935MHZ (187*5)

Well anyway, aside from the FLOPS of one single core of any individual processor, I am curious as to what else might affect this sort of operation. If how I'm thinking is right then the answer is not much. Since I am just getting into some more advanced graphical stuff I am curious.

~Blyss

[Conexion]

Interesting... I honestly have no clue how much the processor affects the speed of the program or much else for that matter. As far as my full specs go:

Intel i7
- 920 @ 2.67GHz ()
- 4 "real" cores (8 with multi-threading)

NVIDIA GeForce 9800 GT x 2 in SLI
- 512 MB each

12 GB DDR3 RAM
- NB: 2140 MHz
- DRAM: 534.5 MHz

http://valid.canardpc.com/show_oc.php?id=1561310

[tinram]

Cool conversion!

Hardly uses any of the processor (even on a P4) and much faster than Processing.

[squall4226]

Well, it certainly shows how multiple cores mean nothing to applications unaware of them. I have some relatively simple graphics functions in a program of mine and at 800x600 it caps at around 42 FPS lol. It is double buffered but its done with gfxlib primitives. Yesterday I converted all the PSETs to low level pixel writes and that helped immensely. But I'm still running at about 60% of my system capacity when based on my best guess what I'm doing could be achieved at 5% so before I make it more complicated I want to make it faster. I want it to run at 1280x720 at a minimum of 30fps after all, so there is much room for improvement.

Anyway, since your code is all software rendering, as well as mine is too, really nothing but the CPU should be affecting it too much. Of course data is moving to and from memory, but the amount is negligible compared to the bandwidth available to even my system of 5 years ago. Memory timings might play a small part and if I was feeling lucky I might play around with mine. I know they can go as tight as 2,3,3,7 but this system is on its last leg. It's been running a 20-25% overclock on stock cooling since I got it and that has taken a toll lol.

Anyway I took notice of this because one, I may have to borrow it for use in what I'm doing and because two its only a little more advanced that what I've done before and I could follow it and make sense of it. So I learned some things from it too.

~Blyss

[dodicat]

Interesting... I honestly have no clue how much the processor affects the speed of the program or much else for that matter. As far as my full specs go:

Intel i7
- 920 @ 2.67GHz ()
- 4 "real" cores (8 with multi-threading)

NVIDIA GeForce 9800 GT x 2 in SLI
- 512 MB each

12 GB DDR3 RAM
- NB: 2140 MHz
- DRAM: 534.5 MHz

http://valid.canardpc.com/show_oc.php?id=1561310

Hi Conexion
Pentium 3 (two of) each 1000Mhz
Windows 2000
GeForce FX 5200(128 Mb)

I'll have to wait until next Christmas now for a better model

I put a little cube in(It's ok, I had it made up before for something else)
I get about 33

Code: Select all

' Flame Test by Conexion 
' With assistance from ##Freebasic
' Thanks for the extra help Mysoft! 

#Include "fbgfx.bi"
Randomize , 1

Dim As Integer ScrW = 800, ScrH = 600
Dim As UByte CharH = 8, CharW = 8

'Adjustables
Dim As Single fTrail = 1 / 4.1
Dim As Integer spnRadius = 80 ' Size of the spinner
Dim As Integer spnDegrees = 5 ' Degrees Clockwise

Const fpsLimit = 70
Const pi = 3.14159265 'Shouldn't need any more than that



ScreenRes ScrW, ScrH, 8, , fb.gfx_high_priority

'Set up the pallete
'xPal is the counter
'bPal adds extra blue/brightness
Dim As UByte xPal = 255 'Set it so when xPal +=1 happens, you get 0
Dim As UByte bPal = 0

Dim As Integer fadewhite = 170
Do
        xPal += 1
        If xPal < 64 Then
                Palette xPal, xPal*4, xPal, 0
        Else
                If xPal > 192 Then
                        bPal += 4
                end If
                Palette xPal, 255, xPal, bPal
        end if
        
Loop Until xPal = 255

/'Palette test
For iii As Integer = 0 To 255
        Line (iii*2.5+10, 15)-(iii*2.5+30, 40), iii, bf
        Dim As Integer ir, ig, ib
        Palette Get iii, ir, ig, ib
Next
'/

'Set up the Image Buffer
Dim As fb.image Ptr ImgBuff = ImageCreate(ScrW, (ScrH + 4) / 2)


'Spinner Variables
Dim As Single spnOldX, spnOldY, spnX, spnY = spnRadius
Dim As Single spnAngle = spnDegrees * -0.017453 'Degrees to Rads
Dim As Integer spnVX = ScrW / 2, spnVY = ScrH / 4 ' Center the Spinner

'Precalculate the distance to each pixel we need to average
Dim As Integer calcDL = ScrW - 1
Dim As Integer calcD = ScrW
Dim As Integer calcDR = ScrW + 1
Dim As Integer calcDD = ScrW Shl 1

'Fire trail variables
Dim As Integer fX, fY, fZ, fColor

' FPS Vars
Dim As Integer fpsX, fpsY, fps, fpsNew, fpsSeconds
fpsX = (ScrW - len(fps)*CharW)
fpsY = (ScrH - CharH) - 32

Dim As Double fpsStart
Dim As Integer fpslSleep
Dim As Double fpslStart
Dim As Double fpslV = 1.0 / fpsLimit

'______________________________________________________
'START OF ROTATOR
Sub mv(m1() As Double,m2() As Double,ans() As Double) 
   Dim s As Double
    For i As Integer=1 To 3
        s=0
        For k As Integer = 1 To 3
            s=s+m1(i,k)*m2(k)
        Next k
        ans(i)=s
        Next i
    End Sub
Dim Shared np(1 To 6) As Double 'For a position rotation, no lines or circles
'np(1),np(2),np(3)-------np(4),np(5),np(6)  for line ends
'np(4),np(5)                    for circle centres 
' use linepointset,circlepointset to draw the pixels
        Sub rotate(Byval pivot_x As Double,_  'x pivot for rotation
                   Byval pivot_y As Double,_  'y pivot for rotation 
                   Byval pivot_z As Double,_  'z pivot for rotation
                   Byval first_x As Double,_  'x for line,or centre for circle
                   Byval first_y As Double,_  'y for line,or centre for circle
                   Byval first_z As Double,_  'z for line or circle
                   Byval second_x As Double, _'x for line,or radius for circle 
                   Byval second_y As Double, _'y for line,or aspect for circle
                   Byval second_z As Double,_ 'z for line, first arc position circle 
                   Byval second_arc As Double,_ 'second arc position circle,0 line
                   Byval angleX As Double, _   'angle to rotate round x axis
                   Byval angleY As Double,_    'angle to rotate round y axis
                   Byval angleZ As Double,_    'angle to rotate round z axis
                   Byval magnifier As Double,_ '1=no magnifacation
                   Byval dilator As Double,_   'times distance from pivot(1=no dilation)
                   Byval colour As Integer,_   'color for line or circle
                   Byval thickness As Double,_ 'thickness line or circle
                   Byref shape As String,_ 'line/circle/circlefill/box/boxfill/linepoint[set],circlepoint[set]"
                   Byref mode As String,_    '2d or 3d
                   Byval perspective As Double=0,_ 'add some 3d perspective 0 to 1 approx
                   image As Any Pointer=0)        'write to an image if required
  shape=Lcase$(shape)
  mode=Lcase$(mode)
  Dim th As Double
  th=thickness
  Dim As Double zval,pp   'used in get_perspective
  Dim sx As Double=second_x
Dim p As Double = 4*Atn(1)  '(pi)
Dim angleX_degrees As Double
Dim angleY_degrees As Double
Dim angleZ_degrees As Double

#Macro thickline(t)
Dim As Double s,h,c
Dim As Uinteger prime=rgb(255,255,255)
h=Sqr(((np(1))-(np(4)))^2+((np(2))-(np(5)))^2)
s=((np(5))-np(2))/h
c=(np(1)-(np(4)))/h
Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),prime
Line image, (np(4)-s*t/2,np(5)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(4)-s*t/2,np(5)-c*t/2),prime
Line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
Paint image,((np(4)+np(1))/2, (np(5)+np(2))/2),prime,prime

Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),colour
Line image, (np(4)-s*t/2,np(5)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(4)-s*t/2,np(5)-c*t/2),colour
Line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
Paint image,((np(4)+np(1))/2, (np(5)+np(2))/2), colour, colour
#EndMacro

#macro thickcircle(t)
Dim As Uinteger prime=rgb(255,255,255)
Dim As Double xp1,xp2,yp1,yp2
Dim arc1 As Double=second_z*p/180
Dim arc2 As Double=second_arc*p/180
arc1=2*p+(arc1-(anglez_degrees))
arc2=2*p+(arc2-(anglez_degrees))
sx=sx*magnifier
If arc1=arc2 Then
     Circle image,(np(4),np(5)),sx,prime,,,second_y
    Circle image,(np(4),np(5)),sx-t,prime,,,second_y
    Paint image,(np(4),np(5)+sx-t/2),prime,prime
    Paint image,(np(4)+sx-t/2,np(5)),prime,prime
    Circle image,(np(4),np(5)),sx,colour,,,second_y
    Circle image,(np(4),np(5)),sx-t,colour,,,second_y
    Paint image,(np(4),np(5)+sx-t/2),colour,colour
    Paint image,(np(4)+sx-t/2,np(5)),colour,colour
End If
if arc1<>arc2 Then
    xp1=np(4)+(sx-t/2)*Cos(.5*(arc2+arc1))
yp1=np(5)-(sx-t/2)*Sin(.5*(arc2+arc1))
Circle image,(np(4),np(5)),sx,prime,arc1,arc2,second_y
    Circle image,(np(4),np(5)),sx-t,prime,arc1,arc2,second_y
    Line image,(np(4)+sx*Cos(arc1),np(5)-sx*Sin(arc1))-(np(4)+(sx-t)*Cos(arc1),np(5)-(sx-t)*Sin(arc1)),prime
    Line image,(np(4)+sx*Cos(arc2),np(5)-sx*Sin(arc2))-(np(4)+(sx-t)*Cos(arc2),np(5)-(sx-t)*Sin(arc2)),prime
    'pset(xp1,yp1),rgb(255,255,255)
    Paint image,(xp1,yp1),prime,prime

   Circle image,(np(4),np(5)),sx,colour,arc1,arc2,second_y
    Circle image,(np(4),np(5)),sx-t,colour,arc1,arc2,second_y
    Line image,(np(4)+sx*Cos(arc1),np(5)-sx*Sin(arc1))-(np(4)+(sx-t)*Cos(arc1),np(5)-(sx-t)*Sin(arc1)),colour
    Line image,(np(4)+sx*Cos(arc2),np(5)-sx*Sin(arc2))-(np(4)+(sx-t)*Cos(arc2),np(5)-(sx-t)*Sin(arc2)),colour
    'pset(xp1,yp1),rgb(255,255,255)
    Paint image,(xp1,yp1),colour,colour
End If
#endmacro

#macro get_perspective(np3,np6)
For n As Integer=3 To 6 Step 3
zval =np(n)  'for perspective
pp=perspective*((zval+1000)/1000-1)
pp=(1-pp)
If n=3 Then 
np(n-2)=np(n-2)-pivot_x
np(n-1)=np(n-1)-pivot_y
np(n-2)=np(n-2)*pp
np(n-1)=np(n-1)*pp
np(n-2)=np(n-2)+pivot_x
np(n-1)=np(n-1)+pivot_y
Endif
If n=6 Then 
    np(n-2)=np(n-2)-pivot_x
    np(n-1)=np(n-1)-pivot_y
    np(n-2)=np(n-2)*pp
    np(n-1)=np(n-1)*pp
    np(n-2)=np(n-2)+pivot_x
    np(n-1)=np(n-1)+pivot_y
Endif
Next n
sx=(pp)*sx
#endmacro

Dim pivot_vector(1 To 3) As Double
Dim line_vector(1 To 3) As Double
magnifier=dilator*magnifier
If shape="circle" Then
angleX=angleX Mod 360:angleY=angleY Mod 360:angleZ=angleZ Mod 360
End If
angleX_degrees=(2*p/360)*angleX      
angleY_degrees=(2*p/360)*angleY
angleZ_degrees=(2*p/360)*angleZ
pivot_vector(1)=first_x-pivot_x
pivot_vector(2)=first_y-pivot_y
pivot_vector(3)=first_z-pivot_z
pivot_vector(1)=dilator*pivot_vector(1)
pivot_vector(2)=dilator*pivot_vector(2)
pivot_vector(3)=dilator*pivot_vector(3)

Dim Rx(1 To 3,1 To 3) As Double
Dim Ry(1 To 3,1 To 3) As Double
Dim Rz(1 To 3,1 To 3) As Double
'rotat1on matrices about the three axix
If mode="3d" Then
Rx(1,1)=1:Rx(1,2)=0:Rx(1,3)=0
Rx(2,1)=0:Rx(2,2)=Cos(angleX_degrees):Rx(2,3)=-Sin(angleX_degrees)
Rx(3,1)=0:Rx(3,2)=Sin(angleX_degrees):Rx(3,3)=Cos(angleX_degrees)

Ry(1,1)=Cos(angleY_degrees):Ry(1,2)=0:Ry(1,3)=Sin(angleY_degrees)
Ry(2,1)=0:Ry(2,2)=1:Ry(2,3)=0
Ry(3,1)=-Sin(angleY_degrees):Ry(3,2)=0:Ry(3,3)=Cos(angleY_degrees)
Endif

Rz(1,1)=Cos(angleZ_degrees):Rz(1,2)=-Sin(angleZ_degrees):Rz(1,3)=0
Rz(2,1)=Sin(angleZ_degrees):Rz(2,2)=Cos(angleZ_degrees):Rz(2,3)=0
Rz(3,1)=0:Rz(3,2)=0:Rz(3,3)=1

line_vector(1)=magnifier*(second_x-first_x)'*pp                   'get the vector
line_vector(2)=magnifier*(second_y-first_y)'*pp                   'get the vector
line_vector(3)=magnifier*(second_z-first_z)'*pp

Dim new_pos(1 To 3) As Double
Dim temp1(1 To 3) As Double
Dim temp2(1 To 3) As Double
If mode="3d" Then
mv Rx(),pivot_vector(),temp1()           
mv Ry(),temp1(),temp2()
mv Rz(),temp2(),new_pos()
Endif
If mode="2d" Then
    mv Rz(),pivot_vector(),new_pos()
    Endif
new_pos(1)=new_pos(1)+pivot_x
new_pos(2)=new_pos(2)+pivot_y
new_pos(3)=new_pos(3)+pivot_z


Dim new_one(1 To 3) As Double            'To hold the turned value
If mode="3d" Then
mv Rx(),line_vector(),temp1()              'rotate
mv Ry(),temp1(),temp2()
mv Rz(),temp2(),new_one()
Endif
If mode="2d" Then
    mv Rz(),line_vector(),new_one()
    Endif
new_one(1)=new_one(1)+first_x              'translate
new_one(2)=new_one(2)+first_y
new_one(3)=new_one(3)+first_z

Dim xx As Double   
Dim yy As Double
Dim zz As Double
xx=first_x-new_pos(1)
yy=first_y-new_pos(2)
zz=first_z-new_pos(3)
 np(1)=new_one(1)-xx  
 np(2)=new_one(2)-yy
 np(3)=new_one(3)-zz
 np(4)=first_x-xx
 np(5)=first_y-yy
 np(6)= first_z-zz
If perspective <> 0 Then 
get_perspective(np(3),np(6))
End If
Select Case shape
Case "line"
    If th<2 Then
 Line image,(np(4),np(5))-(np(1),np(2)),colour 
Else
 thickline(th)   
 End If
Case "circle"
    Dim arc1 As Double=second_z*p/180
Dim arc2 As Double=second_arc*p/180
    If arc1=arc2 Then
    If th<=2 Then
 Circle image,(np(4),np(5)),magnifier*sx,colour,,,second_y
Else
 thickcircle(th)
End If
Endif
If arc1<>arc2 Then 
If th<=2 Then
    Circle image,(np(4),np(5)),magnifier*sx,colour,arc1,arc2,second_y
Else
    thickcircle(th)
End If
End If
Case "circlefill"
    Dim As Double xp1,xp2,yp1,yp2
Dim As Uinteger prime=rgb(255,255,255)
Dim arc1 As Double=second_z*p/180
Dim arc2 As Double=second_arc*p/180
If arc1=arc2 Then Circle image,(np(4),np(5)),magnifier*sx,colour,,,second_y,F
If arc1<>arc2 Then
 xp1=np(4)+magnifier*sx*Cos(.5*(arc2+arc1))*3/4
yp1=np(5)-magnifier*sx*Sin(.5*(arc2+arc1))*3/4   
Circle image,(np(4),np(5)),magnifier*sx,prime,arc1,arc2,second_y
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc2),np(5)-magnifier*sx*Sin(arc2)),prime
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc1),np(5)-magnifier*sx*Sin(arc1)),prime
Paint image,(xp1,yp1),prime,prime

Circle image,(np(4),np(5)),magnifier*sx,colour,arc1,arc2,second_y
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc2),np(5)-magnifier*sx*Sin(arc2)),colour
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc1),np(5)-magnifier*sx*Sin(arc1)),colour
Paint image,(xp1,yp1),colour,colour
End If
 Case"box"
 
 Line image,(np(4),np(5))-(np(1),np(2)),colour,b
Case "boxfill"
 
 Line image,(np(4),np(5))-(np(1),np(2)),colour,bf
        Case "linepoint","circlepoint"
  'nothing drawn
Case "linepointset","circlepointset"
 If shape="linepointset" Then
 Pset image,(np(1),np(2)),colour
 Pset image,(np(4),np(5)),colour
 Endif
 If shape="circlepointset" Then
     Pset image,(np(4),np(5)),colour
 End If

        Case Else
 Print "unknown rotation shape"
End Select 
End Sub
'END OF ROTATOR

type point5d
    as double x,y,z,speed,dil
end type

Sub DIECAST(values as point5d)

    Dim i As String 'For inkey$
Dim As Double px,py,pz   'pivot to rotate around
Dim  As Double u1,u2,u3,v1,v2,v3,wx,wy,wz,nw 'stuff for cross products
dim as double xc,yc,zc 'x,y,z reference for c.o.g.
xc=values.x
yc=values.y
zc=values.z


Dim As Uinteger colour,markcolour
Dim mode As String 'mode
mode="3d"
Dim p As Double
p=.7            'perspective
Dim d As Double   'dilator
d=values.dil'1.3
static a1 As Double            'angle counter
static a2 As Double'=40
static a3 as double
static steps as integer
Dim f As Integer= 12'number of faces(cube + marks)
static as double cnp()
redim preserve cnp(1 to 8)
static as double cznp()
redim preserve cznp(1 to 4)
static as double cz()
redim preserve cz(1 to f,1 to f)
'Dim As Double cnp(1 To 8),cznp(1 To 4),cz(1 To f,1 To f) 'copy line end positions
static as integer paint_order()
reDim preserve paint_order(1 To f)
static as string action()
reDim preserve action(1 To f)
static as double copywx()
redim preserve copywx(1 To f)
static as double copywz()
reDim preserve copywz(1 To f)
static as double copywy()
redim preserve copywy(1 to f)
static As Integer k
dim as double sd 'spot dimension
sd=18
if steps=0 then
For n As Integer=1 To f:paint_order(n)=n:action(n)="line":Next n
    steps=1
    end if
        Dim As Double cx,cy    'centre of areas for painting
        'paint the cube faces
         #macro surface(sign,start_paint)  
        If sign*copywz(k)>start_paint Then
     If action(k)="line" Then    Paint(cx,cy),colour,colour
         action(k)="line"
     Else
         action(k)="linepoint"
        End If
        #endmacro
        'paint the spots
        #macro marksurface(sign,start_paint)
        If sign*copywz(k)>start_paint Then
     If action(k)="line" Then    Paint(cx,cy),markcolour,markcolour
         action(k)="line"
     Else
         action(k)="linepoint"
        End If
        #endmacro
 #macro zsort(n) 
 ' a quick bubblesort on z axis to get new paint order
For p1 As Integer = 1 To n - 1
    For p2 As Integer  = p1 + 1 To n          
        If (cz(p1,p1)) <= (cz(p2,p2)) Then 'Goto skip
        Swap cz(p1,p1),cz(p2,p2)
        Swap paint_order(p1),paint_order(p2)
        Endif
        skip: Next p2
    Next p1
 #endmacro
 #macro crossproduct(of_two_sides)
 'get vectors to origin
 u1=cnp(1)-cnp(3)
 u2=cnp(2)-cnp(4)
 u3=cznp(1)-cznp(2)
 v1=cnp(5)-cnp(7)
 v2=cnp(6)-cnp(8)
 v3=cznp(3)-cznp(4)
 'get the cross product 
 wx=(u2*v3-v2*u3)
 wy=-(u1*v3-v1*u3)
 wz=(u1*v2-v1*u2)
 nw=Sqr(wx^2+wy^2+wz^2)
 'normalized cross product components
 wx=wx/nw
 wy=wy/nw
 wz=wz/nw
 #endmacro
 #macro edge(number,centroids)
 Select Case number
 'define two edges for cross product
 Case 1
   cnp(1)=np(1)
   cnp(2)=np(2)
   cnp(3)=np(4)
   cnp(4)=np(5)
   cznp(1)=np(3)
   cznp(2)=np(6)
 Case 2
   cnp(5)=np(1)
   cnp(6)=np(2)
   cnp(7)=np(4)
   cnp(8)=np(5)
   cznp(3)=np(3)
   cznp(4)=np(6)
   end select
   'get the centroids, painting order depends on z centroid
cx=(cnp(1)+cnp(3)+cnp(5)+cnp(7))/4
cy=(cnp(2)+cnp(4)+cnp(6)+cnp(8))/4
if centroids=1 then
cz(paint_order(count),paint_order(count))=(cznp(1)+cznp(2)+cznp(3)+cznp(4))/4 
end if
 #endmacro
 'draw the spots then paint
 #macro mark(aspect,mx,my,mz,sgnsurface,sgnshade)
 markcolour=rgb(100-50*(1-copywx(k)),100-50*(1-copywx(k)),100-50*(1-copywx(k)))
 if aspect="xy" then
 rotate(px,py,pz,mx-sd,my,mz,mx,my-sd,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top /
 edge(1,0)
 rotate(px,py,pz,mx,my-sd,mz,mx+sd,my,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top \
 edge(2,0)
 crossproduct(0)
 rotate(px,py,pz,mx+sd,my,mz,mx,my+sd,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base /
 edge(2,0)
 rotate(px,py,pz,mx,my+sd,mz,mx-sd,my,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base \
end if
if aspect="yz" then
 rotate(px,py,pz,mx,my,mz-sd,mx,my-sd,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top /
 edge(1,0)
 rotate(px,py,pz,mx,my-sd,mz,mx,my,mz+sd,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top \
 edge(2,0)
 crossproduct(0)
 rotate(px,py,pz,mx,my,mz+sd,mx,my+sd,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base /
 edge(2,0)
 rotate(px,py,pz,mx,my+sd,mz,mx,my,mz-sd,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base \
    end if
if aspect="xz" then
  rotate(px,py,pz,mx,my,mz+sd,mx+sd,my,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top /
 edge(1,0)
 rotate(px,py,pz,mx+sd,my,mz,mx,my,mz-sd,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top \
 edge(2,0)
 crossproduct(0)
 rotate(px,py,pz,mx,my,mz-sd,mx-sd,my,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base /
 edge(2,0)
 rotate(px,py,pz,mx-sd,my,mz,mx,my,mz+sd,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base \  
    end if
 copywz(k)=wz
copywx(k)=sgnshade*wx
marksurface(sgnsurface,.03)
 #endmacro
 
 #macro getcentroids(fx1,fy1,fz1,fx2,fy2,fz2,sx1,sy1,sz1,sx2,sy2,sz2)
 rotate(px,py,pz,fx1,fy1,fz1,fx2,fy2,fz2,.0,a1,a2,a3,1,d,colour,1,"linepoint",mode,p)
 edge(1,1)
 rotate(px,py,pz,sx1,sy1,sz1,sx2,sy2,sz2,.0,a1,a2,a3,1,d,colour,1,"linepoint",mode,p)
edge(2,1)
 #endmacro
 
 #macro getface(colour_shader)
 colour=rgb(238-50*(1-copywx(k)),217-50*(1-copywx(k)),150-50*(1-copywx(k)))
 #endmacro
 ' ****************** DIE MOTION *******************
 

 p=.7
 
 px=xc
 py=yc
 pz=zc
 

       a1=a1+.9*values.speed'(.9*spin)*.1
       a2=a2+values.speed'spin*.1
       'draw string(20,20),str(copywx(k))
    

        For count As Integer=1 To f
            k=paint_order(count)
        Select Case k
'THE SIX FACES
  Case 1
      getface(0)
      'back
      'base 
rotate(px,py,pz,xc-100,yc+100,zc+100,xc+100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(1,1)
'left side
rotate(px,py,pz,xc-100,yc-100,zc+100,xc-100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(2,1)
crossproduct(0)
'right side
rotate(px,py,pz,xc+100,yc+100,zc+100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
'edge(2)
'top 
rotate(px,py,pz,xc+100,yc-100,zc+100,xc-100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(2,1)

copywz(k)=wz
copywx(k)=wx
copywy(k)=wy
surface(-1,.02)
case 7
    '1
getcentroids(xc-100,yc+100,zc+101,xc+100,yc+100,zc+101,xc+100,yc-100,zc+101,xc-100,yc-100,zc+101)
    'back mark(1)
  mark("xy",xc,yc,zc+101,-1,1)  

Case 2
    getface(0)
    'front
'base 
rotate(px,py,pz,xc-100,yc+100,zc-100,xc+100,yc+100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(1,1)
'left side 
rotate(px,py,pz,xc-100,yc-100,zc-100,xc-100,yc+100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(2,1)
crossproduct(0)
'right side 
rotate(px,py,pz,xc+100,yc+100,zc-100,xc+100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
'top 
rotate(px,py,pz,xc+100,yc-100,zc-100,xc-100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(2,1)
copywz(k)=wz
copywx(k)=-wx
surface(1,.02)
case 8
    '6
getcentroids(xc-100,yc+100,zc-101,xc+100,yc+100,zc-101,xc+100,yc-100,zc-101,xc-100,yc-100,zc-101)
    mark("xy",xc-50,yc-50,zc-101,1,-1)
     mark("xy",xc-50,yc,zc-101,1,-1)
      mark("xy",xc-50,yc+50,zc-101,1,-1)
      
     mark("xy",xc+50,yc-50,zc-101,1,-1)
     mark("xy",xc+50,yc,zc-101,1,-1)
      mark("xy",xc+50,yc+50,zc-101,1,-1) 
Case 3
    getface(0)
    'left side
    'base
    rotate(px,py,pz,xc-100,yc+100,zc-100,xc-100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
    edge(1,1)
    'front
    rotate(px,py,pz,xc-100,yc+100,zc-100,xc-100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
    edge(2,1)
    crossproduct(0)
    'back
    rotate(px,py,pz,xc-100,yc+100,zc+100,xc-100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
    'top
    rotate(px,py,pz,xc-100,yc-100,zc-100,xc-100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
    edge(2,1)
copywz(k)=wz
copywx(k)=-wx
surface(1,.02)
case 9
    '2
 getcentroids( xc-101,yc+100,zc-100,xc-101,yc+100,zc+100,xc-101,yc-100,zc-100,xc-101,yc-100,zc+100)
 mark("yz",xc-101,yc-50,zc-50,-1,1)
 mark("yz",xc-101,yc+50,zc+50,-1,1) 
Case 4
    getface(0)
 'right side
 'base
 rotate(px,py,pz,xc+100,yc+100,zc-100,xc+100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(1,1)
 'front
 rotate(px,py,pz,xc+100,yc+100,zc-100,xc+100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
 crossproduct(0)
 'back
 rotate(px,py,pz,xc+100,yc+100,zc+100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 'top
 rotate(px,py,pz,xc+100,yc-100,zc-100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
copywz(k)=wz
copywx(k)=wx
 surface(-1,.02)
case 10
 '4
 getcentroids(xc+101,yc+100,zc-100,xc+101,yc+100,zc+100,xc+101,yc-100,zc-100,xc+101,yc-100,zc+100)
 mark("yz",xc+101,yc-50,zc-50,1,-1)
 mark("yz",xc+101,yc+50,zc+50,1,-1) 
 mark("yz",xc+101,yc-50,zc+50,1,-1)
 mark("yz",xc+101,yc+50,zc-50,1,-1)
Case 5
  getface(0)
 'topside
 'front
 rotate(px,py,pz,xc-100,yc-100,zc-100,xc+100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(1,1)
 'left
 rotate(px,py,pz,xc-100,yc-100,zc-100,xc-100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
 crossproduct(0)
 'right
 rotate(px,py,pz,xc+100,yc-100,zc-100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 'back
 rotate(px,py,pz,xc-100,yc-100,zc+100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
copywz(k)=wz
copywx(k)=wx
 surface(-1,.02)
case 11
 '3
 getcentroids(xc-100,yc-101,zc-100,xc+100,yc-101,zc-100,xc-100,yc-101,zc+100,xc+100,yc-101,zc+100)
 mark("xz",xc,yc-101,zc,1,-1)
 mark("xz",xc+50,yc-101,zc+50,1,-1)
 mark("xz",xc-50,yc-101,zc-50,1,-1)
Case 6
    'colour=rgb(200-50*(1-copywx(k)),200-50*(1-copywx(k)),200-50*(1-copywx(k)))
    getface(0)
 'bottomside
 'front
 rotate(px,py,pz,xc-100,yc+100,zc-100,xc+100,yc+100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(1,1)
 'left
 rotate(px,py,pz,xc-100,yc+100,zc-100,xc-100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
 crossproduct(0)
 'right
 rotate(px,py,pz,xc+100,yc+100,zc-100,xc+100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 'back
 rotate(px,py,pz,xc-100,yc+100,zc+100,xc+100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
copywz(k)=wz
copywx(k)=-wx
 surface(1,.02)
case 12
 '5
 getcentroids(xc-100,yc+101,zc-100,xc+100,yc+101,zc-100,xc-100,yc+101,zc+100,xc+100,yc+101,zc+100)
 mark("xz",xc,yc+101,zc,-1,1)
 mark("xz",xc+50,yc+101,zc+50,-1,1)
 mark("xz",xc-50,yc+101,zc-50,-1,1)
 mark("xz",xc+50,yc+101,zc-50,-1,1)
 mark("xz",xc-50,yc+101,zc+50,-1,1)
 
End Select
Next count
For n As Integer=1 To f:paint_order(n)=n:Next n
zsort(f)
If a1>360 Then a1=0
If a2>360 Then a2=0
if a3>360 then a3=0

End Sub
dim info as point5d
info.x=400
info.y=250
info.z=0
info.speed=1
info.dil=.75
Do
        ' Start our timer
        fpslStart = Timer
        
        ScreenLock
        ' Lets get the spinner down first!
        spnOldX = spnX
        spnOldY = spnY
        
        ' Calculate the rotation coordinates 
        spnX = (spnOldX * Cos(spnAngle)) + (spnOldY * Sin(spnAngle))
        spnY = (spnOldY * Cos(spnAngle)) - (spnOldX * Sin(spnAngle))
        
        ' Draw it, translated "V" distance. Also, half the arc/shape
        ' for when we stretch the image on the Y-axis.
        Circle ImgBuff, (spnX + spnVX, spnY / 2 + spnVY), 8, 255,,,.5
        
        ' The Screen Buffer
        Dim As UByte Ptr ScrBuff = ScreenPtr
        ' The pixel part of ImgBuff
        Dim As UByte Ptr ImgPix = Cast(any Ptr, ImgBuff+1)
        
        ' Random dots on the bottom line
        Dim As UByte Ptr BotLine = ImgPix
        BotLine += ScrW * CInt((ScrH-1)/2)
        
        dim as ubyte ptr SpecksPtr = cast(any ptr,ImgBuff+1)
        For ranLine As Integer = 0 To ScrW
                BotLine[ranLine] = (Rnd * 255)
                
                'Extra specks
                SpecksPtr[rnd*(scrw*(scrh/2-5))] = rnd*32
        Next
        
        ' Circle Flares
        circle ImgBuff,(rnd*scrw,rnd*(scrh*3)),Rnd*20, Rnd*6, , (Rnd*pi)*2 ,Rnd*0.9,f
        circle ImgBuff,(rnd*scrw,rnd*(scrh*2)),Rnd*15, Rnd*10, , ,0.5,f
        
        ' Output FPS with a shadow
        Draw String ImgBuff, (fpsX - 2, (fpsY - 2) / 2), Str(fps), 20
        Draw String ImgBuff, (fpsX - 2, (fpsY + 2) / 2), Str(fps), 20
        Draw String ImgBuff, (fpsX + 2, (fpsY - 2) / 2), Str(fps), 20
        Draw String ImgBuff, (fpsX + 2, (fpsY + 2) / 2), Str(fps), 20
        Draw String ImgBuff, (fpsX, fpsY / 2), Str(fpsNew), 254        

        ' Filter Time!
        ' Fire is calculated by adding the 3 pixels touching the bottom of any pixel
        ' As well as one pixel two pixels down, then finding the average.
        ' fX, fY, fZ, fColor
        'Dim As Integer calcDL = ScrW - 1
        'Dim As Integer calcD = ScrW
        'Dim As Integer calcDR = ScrW + 1
        'Dim As Integer calcDD = ScrW Shl 2 
        Dim As UByte Ptr fT = ImgPix
        
        For fY = 0 To (ScrH/2) - 1
                For fX = 0 To ScrW - 1
                        fColor = (fT[calcDL] + fT[calcD] + fT[calcDR] + fT[calcDD]) * fTrail
                        *fT = fColor
                        fT += 1
                Next
        Next
        
        /' Draw ImgBuff at 2*Y
        for PY as integer = 0 to (Scrh/2)-1
                for PX as integer = 0 to ScrW-1
                        *ScrBuff = *ImgPix
                        ScrBuff[ScrW] = *ImgPix
                        ScrBuff += 1
                        ImgPix += 1
                next
                scrbuff += ScrW                
        Next'/
        
        'Mysoft's ASM routine is faster :p
        Asm
                mov edi,[ScrBuff]      ' Get Screen Buffer pointer
                mov esi,[ImgPix]       ' Get Image Buffer pointer
                mov eax,[ScrW]         ' Get screen Width
                mov ebx,[ScrH]         ' Get Screen height
                mov edx,eax            ' Make a copy of width
                shr eax,2              ' Convert pixels/line to dwords/line
                shr ebx,1              ' Only half of the screen will be read
                NextLine:              ' Starting another line
                mov ecx,eax            ' Loading pixels per line (in dwords)
                rep movsd              ' Copying those pixels
                sub esi,edx            ' We will repeat it again
                mov ecx,eax            ' So pixels per line again
                rep movsd              ' And copying those pixels (2:1)
                dec ebx                ' One line is done... Are there more?
                jnz NextLine           ' Yes? Then keep duplicating
        end Asm '
  diecast(info)
        ScreenUnLock
                
        ' Adjust for our FPS limit
        fpslSleep = CInt((fpslStart + fpslV - Timer) * 1000.0)
        If fpslSleep > 1 Then
                Sleep fpslSleep, 1
        Else
                'Let's not be a memory hog
                Sleep 1
        end If
        
        ' Calculate actual FPS
        fps += 1
        'fpsStart + 1 = One second going by
        If fpsStart + 1 < Timer Then
                fpsNew = fps
                fps = 0
                fpsSeconds += 1
                fpsStart = Timer
        end If
        
Loop Until InKey <> ""

ImageDestroy(ImgBuff)
End