Just for fun, starfield with planets orbiting

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Gunslinger
Posts: 68
Joined: Mar 08, 2016 19:10
Location: The Netherlands

Just for fun, starfield with planets orbiting

Post by Gunslinger »

Code: Select all

const as double pi = 3.14159265359
const as double piDiv2 = pi/2
'dim as double posx,posy,posz
const scr_x = 1920					'screenres
const scr_y = 1080
const scr_z = 1000
const scr_xh = scr_x\2
const scr_yh = scr_y\2
const scr_zh = scr_z\2
const star_count = 999
const star_size_max = 3
const star_gravity_max = 50
const star_gravity_max_range_strengt = (star_size_max^2 + star_size_max^2) / (star_gravity_max^2)
const star_grid_x = scr_xh \ star_gravity_max + 3
const star_grid_y = scr_yh \ star_gravity_max + 3
const star_grid_z = scr_z \ star_gravity_max + 3
const star_grid_size = 50 ' 0 to xx = max planet in 1 grid space

type v3d
	as double x, y, z
end type

declare sub grid_add_bol(posx as double, posy as double, size as single, strength as double, c as ubyte)
declare function to_perspective(byval p as v3d) as v3d
declare function vLength(v as v3d) as single
declare function vNormalised(v as v3d) as v3d

type v3d_short
	as short x, y, z
end type

type grid_type
	as double value
	as boolean calculated = false
end type

type grid
	redim as grid_type grid(star_grid_size)
	as short grid_size_current = star_grid_size
	as short grid_size_max = star_grid_size
	declare constructor()
end type

constructor grid()
	redim preserve as grid_type grid(grid_size_max)
end constructor

type stars_type
	const count = star_count
	as grid gridXYZ(-star_grid_x to star_grid_x, -star_grid_y to star_grid_y, -2 to star_grid_z)
	as v3d p(star_count)
	'as v3d_short grid_p(star_count)
	as v3d v(star_count)
	as double size(star_count)
	as ubyte clr(star_count)
	as boolean active(star_count)
	declare function IndexByXYZgrid() as byte
	declare function UpdateInGravityRange() as byte
	declare constructor()
	declare sub reset_pos(n as integer)
end type

constructor stars_type()
	for i as long = 0 to star_count
		active(i) = true
		p(i).x = rnd * scr_x - scr_xh
		p(i).y = rnd * scr_y - scr_yh
		p(i).z = rnd * scr_z
		size(i) = star_size_max ' * rnd
		'v(i).x = (-rnd+.5) / 1
		'v(i).y = (-rnd+.5) / 1
		v(i).z = 2
		clr(i) = &B111 'fix(rnd * 7) + 1
	next
end constructor

sub stars_type.reset_pos(n as integer)
	p(n).x = rnd * scr_x - scr_xh
	p(n).y = rnd * scr_y - scr_yh
	p(n).z = rnd * scr_z
	v(n).x = (-rnd+.5) / 1
	v(n).y = (-rnd+.5) / 1
	'v(n).z = (-rnd+.5) / 1
	v(n).z =  5
end sub

function stars_type.IndexByXYZgrid() as byte
	' clear last time
	dim as long x, y, z, i1
	for x = -star_grid_x to star_grid_x
		for y = -star_grid_y to star_grid_y
			for z = -1 to star_grid_z
				gridXYZ(x, y, z ).grid_size_current = 0
			next
		next
	next
	'end clear
	
	'start count nummer of stars in a grid
	dim as v3d_short grid_pos
	'dim as grid_pos_x, grid_pos_y, grid_pos_z
	for i1 = 0 to count
		if active(i1) = true then
			grid_pos.x = int((p(i1).x / star_gravity_max)+.5)
			grid_pos.y = int((p(i1).y / star_gravity_max)+.5)
			grid_pos.z = int((p(i1).z / star_gravity_max)+.5)
			'grid_p(i) = grid_pos ' update to new no checks for now
			with gridXYZ(grid_pos.x, grid_pos.y, grid_pos.z)
				.grid( .grid_size_current).value = i1
				.grid( .grid_size_current).calculated = false
				.grid_size_current += 1
				if .grid_size_current > .grid_size_max then
					.grid_size_max += star_grid_size
					.constructor() 'redim the arry preserve
				end if
			end with
		end if
	next
	return 0
end function

function stars_type.UpdateInGravityRange() as byte
	dim as long x, y, z, i
	dim as long xx, yy, zz, ii
	dim as v3d p1, p2, pp1,pp2
	dim as double dist, bright, tmp
	dim as short minx, maxx, miny, maxy, minz, maxz
	dim as v3d po, ppo 'posities
	dim as v3d pv 'vectors
	
	for x = -star_grid_x to star_grid_x
		for y = -star_grid_y to star_grid_y
			for z = -1 to star_grid_z
				if gridXYZ(x, y, z ).grid_size_current > 0 then
					for i = 0 to gridXYZ(x, y, z ).grid_size_current - 1
						if gridXYZ(x, y, z ).grid(i).calculated = false andalso active(i) = true then 'look for all neibors now
							gridXYZ(x, y, z ).grid(i).calculated = true
							pp1 = p(gridXYZ(x, y, z ).grid(i).value)
							minx = x-1: maxx = x+1
							miny = y-1: maxy = y+1
							minz = z-1: maxz = z+1
							for xx = minx to maxx
								for yy = miny to maxy
									for zz = minz to maxz
										if gridXYZ(xx, yy, zz).grid_size_current > 0 then
											for ii = 0 to gridXYZ(xx, yy, zz ).grid_size_current - 1
												if gridXYZ(x, y, z).grid(i).value <> gridXYZ(xx, yy, zz).grid(ii).value  andalso active(ii) = true then 'the same points are never connected
													'gridXYZ(xx, yy, zz ).grid(ii).calculated = true
													pp2 = p(gridXYZ(xx, yy, zz).grid(ii).value)
													' calculate distens
													dist = sqr((pp1.x - pp2.x)^2 + (pp1.y - pp2.y)^2 + (pp1.z - pp2.z)^2)
													if dist < star_gravity_max  then 'andalso clr(gridXYZ(xx, yy, zz).grid(ii).value) = clr(gridXYZ(x, y, z ).grid(i).value)
														p1 = to_perspective(pp1)
														p2 = to_perspective(pp2)
														tmp = (p1.z + p2.z) /3
														if tmp > 1 then tmp = 1
														bright = (tmp*255) * (1-(dist / star_gravity_max))
														'bright = (1-(dist / star_gravity_max))*255
														line (p1.x + scr_xh, p1.y + scr_yh)-(p2.x + scr_xh, p2.y + scr_yh), rgba(bright, bright, bright, 127), ,&b1010101010101010
														'*-------update star vectors
														po.x = pp2.x - pp1.x
														po.y = pp2.y - pp1.y
														po.z = pp2.z - pp1.z
														'pv = 'vReal(po, star_gravity_max)
														pv = vNormalised(po)
														po = pp1
														po.x -= pv.x * (dist /5)
														po.y -= pv.y * (dist /5)
														po.z -= pv.z * (dist /5)
														ppo = to_perspective(po)
														line (ppo.x + scr_xh, ppo.y + scr_yh)-(p1.x + scr_xh, p1.y + scr_yh), rgba(0, bright, 0, 127) ', ,&b1010101010101010
														
														v(gridXYZ(x, y, z ).grid(i).value).x += pv.x * (30 / (dist^2))
														v(gridXYZ(x, y, z ).grid(i).value).y += pv.y * (30 / (dist^2))
														v(gridXYZ(x, y, z ).grid(i).value).z += pv.z * (30 / (dist^2))
													end if
												end if
											next ii
										end if
									next zz
								next yy
							next xx
						end if
					next i
				end if
			next z
		next y
	next x
	
	return 0
end function


dim shared as stars_type star
dim as double cc
dim as long i
dim as double x, y, z, size
dim as v3d p1

screenres scr_x,scr_y,32, 2,0
screenset 1, 0 


do
	for i = 0 to star.count
		if star.active(i) = true then
			star.p(i).x += star.v(i).x
			star.p(i).y += star.v(i).y
			star.p(i).z += star.v(i).z
			p1 = to_perspective(star.p(i))
			size = p1.z / 2
			if abs(p1.x)-size > scr_xh or abs(p1.y)-size > scr_yh then star.reset_pos(i): i -= 1:if i < 0 then i = 0
			if star.p(i).x > scr_xh or star.p(i).x < -scr_xh or star.p(i).y > scr_yh or star.p(i).y < -scr_yh then star.reset_pos(i): i -= 1:if i < 0 then i = 0
			if star.p(i).z >= scr_z or star.p(i).z <= 0 then star.reset_pos(i): i -= 1:if i < 0 then i = 0
		end if
	next i
	'cls
	star.IndexByXYZgrid()
	star.UpdateInGravityRange()
	
	for i = 0 to star.count
		if star.active(i) = true then
			size = star.p(i).z
			p1 = to_perspective(star.p(i))
			z = (p1.z - 1) /2
			if z >= 1 then z = 1
			grid_add_bol(p1.x + scr_xh, p1.y + scr_yh, (p1.z*star.size(i))+2, z/1.4+.1, star.clr(i))
		end if
	next
	'locate 1,1
	'print star_grid_x * 2, star_grid_y * 2, star_grid_z
	'print star.gridXYZ(0, 0, star_grid_z/2 ).grid_size_current
	
	flip
	cls
	screensync
loop while inkey <> chr(27)
sleep


sub grid_add_bol(posx as double, posy as double, size as single, strength as double, c as ubyte)
	if size <= 1 then return
	dim as integer posx_fix = int(posx)
	dim as integer posy_fix = int(posy)
	dim as single posx_frac = frac(posx)
	dim as single posy_frac = frac(posy)
	dim as double i
	dim as short x,y
	dim as single pre_x, pre_y, m = fix(size)
	dim as single sqr_size = size * size
	dim as ulong pointget
	
	dim as byte stepsize_x = 1, stepsize_y = 1
	if size > 25 then stepsize_y = (size \ 25) + 1: stepsize_x = (stepsize_y \2) +1
	
	for y = -m to m + 1 step stepsize_y
		for x = -m to m + 1 step stepsize_x
			pre_x =(x-posx_frac)
			pre_y =(y-posy_frac)
			i = pre_x * pre_x + pre_y * pre_y
			if i < sqr_size then
				i = sqr(i) / size
				i = sqr(1 - i*i)
				i = ((i * 192)+63) * strength ' to color byte
				pointget = point (x + posx_fix, y + posy_fix)
				pset (x + posx_fix, y + posy_fix), pointget or rgb(i*(c and 4)\4, i*(c and 2)\2, i*(c and 1))
				'pset (x + posx_fix, y + posy_fix), rgb(i*(c and 4)\4, i*(c and 2)\2, i*(c and 1))
			'else
				'pset (x+posx_fix,y+posy_fix), pointget or rgba(0,255,0,255)
			end if
		next
	next
end sub

function to_perspective(byval p as v3d) as v3d
	dim as v3d pr = any
	pr.z = scr_z / (scr_z - p.z) 'output 1 or more
	pr.x = (p.x * pr.z)
	pr.y = (p.y * pr.z)
	return pr
end function


'*----------------------------------- Vector code functions-------------

function vLength(v as v3d) as single
	return sqr(v.x*v.x + v.y*v.y + v.z*v.z)
end function

function vNormalised(v as v3d) as v3d
	dim as v3d temp
	dim as single length3D = vLength(v)
	temp.x = v.x / length3D
	temp.y = v.y / length3D
	temp.z = v.z / length3D
	return temp
end function

David Watson
Posts: 40
Joined: May 15, 2013 16:48
Location: England

Re: Just for fun, starfield with planets orbiting

Post by David Watson »

Astronomically good!
grindstone
Posts: 852
Joined: May 05, 2015 5:35
Location: Germany

Re: Just for fun, starfield with planets orbiting

Post by grindstone »

The screen freezes after about 24 seconds and I have to kill the process.
David Watson
Posts: 40
Joined: May 15, 2013 16:48
Location: England

Re: Just for fun, starfield with planets orbiting

Post by David Watson »

I left it running for three minutes with no freeze. CPU usage was 65% throughout.
fxm
Moderator
Posts: 11544
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Just for fun, starfield with planets orbiting

Post by fxm »

I confirm the freeze, but only in 32-bit.

(114) .constructor() 'redim the arry preserve
unsafe !
but not the problem.

[edit]
More precisely:
- freezes only with 'gas',
- works with 'gcc' and 'gas64'.
Last edited by fxm on Oct 15, 2022 14:51, edited 1 time in total.
Reason: Update.
dodicat
Posts: 7690
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Just for fun, starfield with planets orbiting

Post by dodicat »

Making the
function vLength(v as v3d) as double
(not single)
and also in vNormalised, do
dim as double length3D = vLength(v)
(not single)
seems to cure the problem.

All the v3d fields are double anyway.
dodicat
Posts: 7690
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Just for fun, starfield with planets orbiting

Post by dodicat »

Squadrons of unidentified craft passing close to a gas ball. Destination unknown.

Code: Select all


#cmdline "-gen gcc -O 2"

Type pt
    As Single x,y,z
End Type

Type angle
    As Single a(1 To 6)
    Declare Sub set(p As pt)
End Type

Sub angle.set(p As pt) 
    This= Type<angle>({Sin(p.x),Sin(p.y),Sin(p.z),Cos(p.x),Cos(p.y),Cos(p.z)}) 
End Sub

Type UnknownCraft
    As pt p(Any)
    As angle a
    As pt ctr
    As Ulong col
    As pt da
    As pt b
    Declare Constructor
    Declare Constructor(As Long,As Long,As Long,As Single,As pt,As Ulong,num As Long)
    Declare Sub fill(im As Any Ptr=0,zval As Single=0)
    Declare Function rotate() As UnknownCraft
End Type

Dim Shared As Long xres,yres
Dim Shared As Any Ptr SmIm

Type V3
    As Single x,y,z
    As Ulong col
End Type

Type _float 
    As Single x,y,Z
End Type

Type sphere As V3
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c) 
#define shade(c,n)  Rgb(Cptr(Ubyte Ptr,@c)[2]*n,Cptr(Ubyte Ptr,@c)[1]*n,Cptr(Ubyte Ptr,@c)[0]*n)      
#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
        While array(I)dot b1 X dot:I+=1:Wend
            While array(J)dot b2 X dot:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
            Wend
            If J > begin Then fname(array(),begin,J)
            If I < Finish Then fname(array(),I,Finish)
        End Sub
        #endmacro  
        
        #define range(f,l) Rnd*((l)-(f))+(f)
        #define Irange(f,l) Int(Rnd*((l+1)-(f)))+(f)
        
        SetQsort(V3,QsortvZ,down,.z)
        SetQsort(UnknownCraft,QsortZ,down,.ctr.z)
        
        Function onsphere(S As sphere,P As V3,x As Single,y As Single) As Long
            Return Sqr(x*(S.x-P.x)*(S.x-P.x)+y*(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z)) <= S.col Andalso _
            Sqr(x*(S.x-P.x)*(S.x-P.x)+y*(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z)) > (S.col)-2 '2.5
        End Function
        Dim Shared As v3 eyepoint      
        
        Sub addasphere(a() As V3,pt As V3,rad As Long,col As Ulong=0,x1 As Single,y1 As Single,flag As Integer=0)
            Dim As Long xx=Pt.x,yy=Pt.y,zz=Pt.z,r=rad,counter=Ubound(a)-1
            Dim As Long minx= xx-r-1,maxx=xx+r+1
            Dim As Long miny= yy-r-1,maxy=yy+r+1
            Dim As Single ddx,ddy,ddz
            Dim As sphere sp=Type<sphere>(xx,yy,zz,r)
            #define h Sin(counter)
            For x As Single= xx-r-1 To xx+r+1 Step 2
                For y As Single=yy-r-1 To yy+r+1 Step 2
                    For z As Single=zz-r-1 To zz+r+1 Step 2
                        If onsphere(sp,Type<V3>(x,y,z),x1,y1) Then
                            counter+=1
                            Redim Preserve a(Lbound(a) To counter)
                            If flag Then
                                Var xpos=map((minx),(maxx),x,0,xres/12)
                                Var ypos=map((miny),(maxy),y,0,yres/12)
                                col=Point(xpos,ypos,SmIm)
                            End If
                            a(counter)=Type<V3>(x+ddx+h,y+ddy+h,z+ddz+h,col)
                        End If
                    Next z
                Next y
            Next x
        End Sub
        
        Sub RotateArray(wa() As V3,result() As V3,ang As _float,centre As V3,flag As Long=0,s As Single=1)
            Static As Single dx,dy,dz,w
            Static As Single SinAX,SinAY,SinAZ,CosAX,CosAY,CosAZ
            SinAX=Sin(ang.x)
            SinAY=Sin(ang.y)
            SinAZ=Sin(ang.z)
            CosAX=Cos(ang.x)
            CosAY=Cos(ang.y)
            CosAZ=Cos(ang.z)
            For z As Long=Lbound(wa) To Ubound(wa)
                dx=wa(z).x-centre.x
                dy=wa(z).y-centre.y
                dz=wa(z).z-centre.z
                Result(z).x=(((Cosay*Cosaz)*dx+(-Cosax*Sinaz+Sinax*Sinay*Cosaz)*dy+(Sinax*Sinaz+Cosax*Sinay*Cosaz)*dz))+centre.x
                result(z).y=(((Cosay*Sinaz)*dx+(Cosax*Cosaz+Sinax*Sinay*Sinaz)*dy+(-Sinax*Cosaz+Cosax*Sinay*Sinaz)*dz))+centre.y
                result(z).z=(((-Sinay)*dx+(Sinax*Cosay)*dy+(Cosax*Cosay)*dz))+centre.z
                #macro perspective()
                w = 1 + (result(z).z/eyepoint.z)
                result(z).x = s*(result(z).x-eyepoint.x)/w+eyepoint.x 
                result(z).y = s*(result(z).y-eyepoint.y)/w+eyepoint.y 
                result(z).z = s*(result(z).z-eyepoint.z)/w+eyepoint.z
                #EndMacro
                If flag Then: perspective():End If
                result(z).col=wa(z).col
            Next z
        End Sub
        
        Function dot(v1 As v3,v2 As v3) Byref As Const Single 
            Static As Single res
            Dim As Single d1=Sqr(v1.x*v1.x + v1.y*v1.y+  v1.z*v1.z),d2=Sqr(v2.x*v2.x + v2.y*v2.y + v2.z*v2.z)
            Dim As Single v1x=v1.x/d1,v1y=v1.y/d1,v1z=v1.z/d1 'normalize
            Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
            Res= (v1x*v2x+v1y*v2y+v1z*v2z) 
            Return res
        End Function
        
        Function Rotate(c As pt,p As pt,a As angle,scale As pt=Type<pt>(1,1,1)) As pt
            Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
            Return Type<pt>((scale.x)*((a.a(5)*a.a(6))*dx+(-a.a(4)*a.a(3)+a.a(1)*a.a(2)*a.a(6))*dy+(a.a(1)*a.a(3)+a.a(4)*a.a(2)*a.a(6))*dz)+c.x,_
            (scale.y)*((a.a(5)*a.a(3))*dx+(a.a(4)*a.a(6)+a.a(1)*a.a(2)*a.a(3))*dy+(-a.a(1)*a.a(6)+a.a(4)*a.a(2)*a.a(3))*dz)+c.y,_
            (scale.z)*((-a.a(2))*dx+(a.a(1)*a.a(5))*dy+(a.a(4)*a.a(5))*dz)+c.z)',p.col)
        End Function
        
        Function perspective(p As pt,eyepoint As pt) As pt
            Dim As Single   w=1+(p.z/eyepoint.z)
            Return Type<pt>((p.x-eyepoint.x)/w+eyepoint.x,_
            (p.y-eyepoint.y)/w+eyepoint.y,_
            (p.z-eyepoint.z)/w+eyepoint.z)',p.col)
        End Function 
        
        Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
            Static As Double timervalue,_lastsleeptime,t3,frames
            Var t=Timer
            frames+=1
            If (t-t3)>=1 Then t3=t:fps=frames:frames=0
            Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
            If sleeptime<1 Then sleeptime=1
            _lastsleeptime=sleeptime
            timervalue=T
            Return sleeptime
        End Function
        
        Sub star(starX As Single,starY As Single,size As Single,num As Long=5,cut As Single=.4,s() As pt)
            Redim s(2*num)
            Var count=0,rad=0.0,_px=0.0,_py=0.0,pi=4*Atn(1)
            Var rot=0
            For z As Single=0+.28 +rot To 2*pi+.1+.28 +rot Step 2*pi/(2*num)
                count=count+1
                If count Mod 2=0 Then rad=size Else rad=cut*size
                _px=starx+rad*Cos(z)
                _py=stary+rad*Sin(z)
                s(count-1).x=_px
                s(count-1).y=_py
            Next z
        End Sub
        
        Function getctr(s As UnknownCraft) As pt
            Dim As Single cx,cy,cz
            Dim As Long sz=Ubound(s.p)+1
            For n As Long=Lbound(s.p) To Ubound(s.p)
                cx+=s.p(n).x
                cy+=s.p(n).y
                cz+=s.p(n).z
            Next
            Return Type(cx/sz,cy/sz,cz/sz)
        End Function
        
        
        Constructor UnknownCraft
        End Constructor
        
        Constructor UnknownCraft(x As Long,y As Long,z As Long,sz As Single,a As pt,colour As Ulong,n As Long)
        star(x,y,sz,n,range(.2,.6),p())
        For n As Long=Lbound(p) To Ubound(p)
            p(n).z=z
        Next
        da=a
        col=colour
        End Constructor
        
        Sub UnknownCraft.fill(im As Any Ptr=0,zval As Single=0)
            #define ub Ubound
            Static As Ubyte r,g,b
            r=Cast(Ubyte Ptr,@col)[2]
            g=Cast(Ubyte Ptr,@col)[1]
            b=Cast(Ubyte Ptr,@col)[0]
            Dim As Long Sy=1e6,By=-1e6,i,j,y,k
            Dim As Single a(Ub(p)+1,1),dx,dy
            For i =0 To Ub(p)
                a(i,0)=p(i).x
                a(i,1)=p(i).y
                If Sy>p(i).y Then Sy=p(i).y
                If By<p(i).y Then By=p(i).y
            Next i
            Dim As Single xi(Ub(a,1)),S(Ub(a,1))
            a(Ub(a,1),0) = a(0,0)
            a(Ub(a,1),1) = a(0,1)
            For i=0 To Ub(a,1)-1
                dy=a(i+1,1)-a(i,1)
                dx=a(i+1,0)-a(i,0)
                If dy=0 Then S(i)=1
                If dx=0 Then S(i)=0
                If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
            Next i
            For y=Sy-1 To By+1
                k=0
                For i=0 To Ub(a,1)-1
                    If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
                    (a(i,1)>y Andalso a(i+1,1)<=y) Then
                    xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
                    k+=1
                End If
            Next i
            For j=0 To k-2
                For i=0 To k-2
                    If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
                Next i
            Next j
            For i = 0 To k - 2 Step 2
                Line im,(xi(i),y)-(xi(i+1)+1,y),Rgb(zval*r,zval*g,zval*b)
            Next i
        Next y
    End Sub
    
    Function UnknownCraft.rotate() As UnknownCraft
        b.x+=da.x
        b.y+=da.y
        b.z+=da.z 
        a.set(b)
        Dim As UnknownCraft s=This
        ctr= getctr(s)
        For n As Long=Lbound(p) To Ubound(p)
            s.p(n)= ..Rotate(ctr,this.p(n),a)
            s.p(n)= perspective(s.p(n),Type(512,768\2,1500))
        Next
        Return s
    End Function
    
    #define rcolour Rgb(100+Rnd*155,100+Rnd*155,100+Rnd*155)
    Const back=Rgb(0,0,0)
    Const f=0.03
    #macro setP(z)
    p(0)=z
    p(1)=Point(x,y-1,i)
    p(2)=Point(x+1,y,i)
    p(3)=Point(x,y+1,i)
    p(4)=Point(x-1,y,i)
    #endmacro
    
    #macro setC
    r+=Cast(Ubyte Ptr,@p(n))[2]
    g+=Cast(Ubyte Ptr,@p(n))[1]
    b+=Cast(Ubyte Ptr,@p(n))[0]
    a+=Cast(Ubyte Ptr,@p(n))[3]
    #endmacro
    
    Sub inc(i As Long,Byref col As Ulong)
        Static As Long k=1
        Var r=Cast(Ubyte Ptr,@col)[2]
        Var g=Cast(Ubyte Ptr,@col)[1]
        Var b=Cast(Ubyte Ptr,@col)[0]
        Var a=Cast(Ubyte Ptr,@col)[3]
        Select Case i
        Case 0
            If r>255 Or r<0 Then k=-k
            r+=k
            col= Rgba(r,g,b,a)   
        Case 1
            If g>255 Or g<0 Then k=-k
            g+=k
            col= Rgba(r,g,b,a)
        Case 2
            If b>255 Or b<0 Then k=-k
            b+=k
            col= Rgba(r,g,b,a)
        Case 3
            If a>255 Or a<0 Then k=-k
            a+=k
            col= Rgba(r,g,b,a)   
        End Select
    End Sub
    
    Sub merge(Byref c As Ulong,x As Long,y As Long,i As Any Ptr)
        Static As Long p(0 To 4)
        Var r=0,g=0,b=0,a=0,z=0
        setP(c)
        For n As Long=0 To 4
            If p(n)<>back Then
                setC
                z+=1
            End If
        Next
        If z Then c=Rgba(r\z,g\z,b\z,a\z)
    End Sub
    
    Sub filter(i As Any Ptr,n As Long)
        Dim As Integer ix,iy
        Imageinfo i,ix,iy
        Dim As Long p(0 To 4)
        Dim As Long k,x,y,r,g,b,a
        For k =1 To n
            For x =1 To ix-2
                For y =1 To iy-2
                    r=0:g=0:b=0:a=0
                    setP(Point(x,y,i))
                    For n As Long=0 To 4
                        setC
                    Next
                    Pset i,(x,y),Rgba(r\5,g\5,b\5,a\5)
                Next y
            Next x
        Next k
    End Sub
    
    Sub nebula(c As Ulong,x As Long,y As Long,lim As Long,i As Any Ptr)
        #define Intrange(f,l) Int(Rnd*((l+1)-(f)))+(f)
        #define offscreenx(n) n<10 Or n> (xres -10 )
        #define offscreeny(n) n<10 Or n> (yres -10)
        #macro increment
        Select Case k
        Case 1:inc(0,c)
        Case 2:inc(1,c)
        Case 3:inc(2,c)
        Case 4:inc(3,c)
        End Select
        count+=1
        #endmacro
        Randomize 3+4
        Dim As Long count
        Do
            Var k=intrange(1,4)
            Select Case k
            Case 1
                Var k=intrange(1,4)
                increment
                If offscreeny((y-1))Then y=intrange(10,760)
                If Rnd<f Then  merge(c,x,y-1,i)
                Pset i,(x,y-1),c
                y=y-1
            Case 2 
                Var k=intrange(1,4) 
                increment
                If offscreenx((x+1)) Then x=intrange(10,1000)
                If Rnd<f Then merge(c,x+1,y,i)
                Pset i,(x+1,y),c
                x=x+1
            Case 3 
                Var k=intrange(1,4)
                increment
                If offscreeny((y+1)) Then y=intrange(10,760)
                If Rnd<f Then  merge(c,x,y+1,i)
                Pset i,(x,y+1),c
                y=y+1
            Case 4 
                Var k=intrange(1,4)
                increment
                If offscreenx((x-1)) Then x=intrange(10,1000)
                If Rnd<f Then  merge(c,x-1,y,i)
                Pset i,(x-1,y),c
                x=x-1
            End Select
        Loop Until count > lim
    End Sub
    
    Sub makesmallimage(SmIm As Any Ptr)
        Dim As Ulong Clr
        Randomize 2
        For n As Long=1 To 100
            Color Rgb(Rnd*255,Rnd*100,0)
            clr=Rgb(Rnd*255,Rnd*100,0)
            Var r=350+Rnd*50
            Var x=Rnd*xres/2
            Var y=Rnd*yres/5
            Var k=3
            Var r5=Rnd*150
            For m As Long=-k To k
                Var cc=Cptr(Ubyte Ptr,@clr)
                Var rd=map(-k,k,m,155,cc[2])
                Var gr=map(-k,k,m,155,cc[1])
                Var bl=map(-k,k,m,155,cc[0])
                Var colour=Rgb(rd,gr,bl)
                Var l=2*(Rnd-Rnd)
                Line SmIm,(r5+m+L,0)-(r5+m+L,200),colour
            Next m  
        Next
        Circle SmIm,(50,50),10,Rgb(255,0,0),,,,f
        filter(SmIm,5)
    End Sub 
    
    Sub planet(a() As v3,b() As v3,Ectr As v3,axis As v3)
        Const pi2=4*Atn(1)
        Static As _float ang=Type(0,.2,pi2/2)
        ang.x+=.001
        rotatearray(a(),b(),ang,Type(xres\2,yres\2,0))
        qsortvz(b(),Lbound(b),Ubound(b))
        Dim As Ulong colour
        Static As Long min=2147483647
        Static As Long max=-2147483647
        For n As Long=Lbound(b) To Ubound(b)
            If b(n).z<0  Then
                Var rad=0.0
                Var  dt= dot(Type(Ectr.x-b(n).x,Ectr.y-b(n).y,Ectr.z-b(n).z),Axis)
                If dt>0 Then
                    rad=2
                    Var fn=map(0,1,dt,1,0)
                    colour=shade(b(n).col,fn)
                Else
                    rad=map(-400,400,b(n).z,2.5,1)
                    If min>dt Then min=dt
                    If max<dt Then max=dt
                    Var cc=Cptr(Ubyte Ptr,@b(n).col)
                    Var  rd=map(min,max,dt,255,cc[2])
                    Var gr=map(min,max,dt,255,cc[1])
                    Var bl=map(min,max,dt,255,cc[0])
                    colour=Rgb(rd,gr,bl)
                End If
                Line(b(n).x-rad+300,b(n).y-rad)-(b(n).x+rad+300,b(n).y+rad),colour,bf
            End If
        Next n 
    End Sub
    
    Randomize 4
    Screeninfo xres,yres
    Screenres .9*xres,.9*yres,32,,64
    Width .9*xres\8,.9*yres\16
    Screeninfo xres,yres
    
    eyepoint=Type(xres/2,yres/2,800)
    SmIm=Imagecreate (xres/12,yres/12,0)
    makesmallimage(SmIm)     
    Redim  As V3 a(0)
    AddAsphere(a(),Type<V3>(xres/2,yres/2,0),150,Rgb(255,255,0),1,1,1)
    Redim As v3 b(Lbound(a) To Ubound(a))
    Dim As v3 Ectr=Type(xres/2,yres/2,0)
    Var Axis=Type<v3>(100-512,430-384,200)   
    
    Dim As Any Ptr i
    i=Imagecreate(xres,yres,back)
    Dim As Ulong c=Rgba(100,100,100,10)
    Locate 20,20
    Print "please wait while creating a universe . . ."
    nebula(c,xres\2,yres\2,3000000,i)
    filter(i,4)
    Dim As UnknownCraft temp
    For n As Long=1 To 100
        star(Rnd*xres,Rnd*yres,3,,,temp.p())
        temp.col=Rgb(255,255,255)
        temp.fill(i,15)
    Next 
    
    Dim As UnknownCraft s(1 To 3500)
    For n As Long=1 To Ubound(s)
        Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
        s(n)=UnknownCraft(range(-1000,(xres+1000)),range(-1000,(yres+1000)),Rnd*3000*2,10,tmp,rcolour,irange(3,9))
    Next
    
    Dim As UnknownCraft z(1 To Ubound(s))
    Dim As Long fps
    Dim As Single fn
    
    #define onscreen(Q) Q.ctr.x>0 And Q.ctr.x<xres And Q.ctr.y>0 And Q.ctr.y<yres
    Dim As Long min=1000000,max=-1000000,k=-1,__,flag,btn
    'dim as long mx,my,mw
    Do
        Getmouse __,__,__,btn
        Screenlock
        Cls
        Put(0,0),i,Alpha,150
        planet(a(),b(),ectr,axis)
        For n As Long=1 To Ubound(s)
            For m As Long=Lbound (s(n).p) To Ubound (s(n).p)
                s(n).p(m).z= s(n).p(m).z-15*k
            Next m
            z(n)=s(n).rotate
            If min>z(n).ctr.z Then min=z(n).ctr.z
            If max<z(n).ctr.z Then max=z(n).ctr.z
            
            If btn=1 And flag=0 Then k=-k:flag=1
            If k=1 Then
                If s(n).ctr.z<-1440 Or  onscreen(s(n))=0 Then
                    Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
                    s(n)=UnknownCraft(range(-1000,(xres+1000)),range(-1000,(yres+1000)),3000+Rnd*(3000),10,tmp,rcolour,irange(3,9))
                End If
            Else
                If s(n).ctr.z>3000  Or  onscreen(s(n))=0 Then
                    Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
                    s(n)=UnknownCraft(range(-1000,(xres+1000)),range(-1000,(yres+1000)),-1300-Rnd*(100),10,tmp,rcolour,irange(3,9))
                End If
            End If
            
        Next n
        flag=btn
        QsortZ(z(),1,Ubound(z))
        
        For n As Long=1 To Ubound(z)
            If onscreen(z(n)) Then
                fn=map(min,max,z(n).ctr.z,1,.2)
                z(n).fill(,fn)
            End If
        Next n
        Draw String(10,10), "fps " &fps
        Screenunlock
        Sleep regulate(40,fps)
    Loop Until Inkey=Chr(27)
    
    Sleep
    Imagedestroy i
    imagedestroy SmIm
    
     
deltarho[1859]
Posts: 3667
Joined: Jan 02, 2017 0:34
Location: UK
Contact:

Re: Just for fun, starfield with planets orbiting

Post by deltarho[1859] »

@dodicat

Good catch. :)

One wrinkle which I often get when pasting graphics applications from the forum is the graphics window gets split between my two monitor setup.

Bear with me, I am not a graphics guy, but the following is working for me.

The following function is by coderJeff which returns the graphics window handle.

Code: Select all

#include "fbgfx.bi"
#include "windows.bi"
 
Function getFBGfxHWND() As Hwnd
Dim As Integer gfxHWND
  ScreenControl fb.GET_WINDOW_HANDLE, gfxHWND
  Return cast( Hwnd, gfxHWND )
End Function
"windows.bi" has been used, else the compiler will baulk at Hwnd.

Just after "screenres scr_x,scr_y,32, 2,0" I have inserted

Code: Select all

SetWindowPos( getFBGfxHWND(), HWND_TOPMOST, 0, 0, 0, 0, 0 )

The graphics window is now in my primary monitor only according to

Code: Select all

const scr_x = 1920 'screenres
const scr_y = 1080

If I change them to, for example,

Code: Select all

const scr_x = 1000
const scr_y = 800
and use

Code: Select all

SetWindowPos( getFBGfxHWND(), HWND_TOPMOST, 100, 100, 0, 0, 0 )
I get a 1000x800 window with a top and left offset of 100.

dodicat's latest code also got split between my monitors - it doesn't now. I had to rename min and max - they were throwing up a duplicate definition.
deltarho[1859]
Posts: 3667
Joined: Jan 02, 2017 0:34
Location: UK
Contact:

Re: Just for fun, starfield with planets orbiting

Post by deltarho[1859] »

We don't need the graphics window handle or "windows.bi"

If we use #include "fbgfx.bi" and 'Using fb' then with the last example using

Code: Select all

const scr_x = 1000
const scr_y = 800
we can simply use

Code: Select all

ScreenRes 1000, 800, 32
ScreenControl SET_WINDOW_POS, 100, 100
Told you that I wasn't a graphics guy. :)

By the way, the graphics screen splitting occurs with a 'Build and Execute' from WinFBE on the secondary monitor, running an exe from a file manager on the secondary monitor or a shortcut on the secondary monitor. The above solution will have the graphics screen displayed on the primary monitor as if I didn't have a secondary monitor or had the secondary monitor turned off. :)
dodicat
Posts: 7690
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Just for fun, starfield with planets orbiting

Post by dodicat »

Gunslinger's code (on 32 bits) I find hard to debug.
Although making vLength double fixes the freeze, this function vNormalised (with singles) does not actually cause the freeze immediately, but rather further on in the loops, I think at
if gridXYZ(x, y, z ).grid_size_current > 0 then ...
gridXYZ(x, y, z ). seems to be the culprit somewhere, although it doesn't seem to go out of bounds.
Certainly 64 bit and 32 bit graphics behave differently, but even turning all graphics off still has the freeze on 32 bits.
Putting a counter in the innermost loop, just before ( pv = vNormalised(po)), it freezes at 245398 counts.
Killing the full screen and halving the screen dimensions make it easier to work with.
I don't have a dubugging app installed here (insight or SARG's).
It would be nice getting to the bottom of this freeze, but it seems tough to crack.
deltarho[1859]
Posts: 3667
Joined: Jan 02, 2017 0:34
Location: UK
Contact:

Re: Just for fun, starfield with planets orbiting

Post by deltarho[1859] »

In 32-bit I get a 'freeze' after 13 seconds. I guess the faster the CPU the quicker the 'freeze'.
dodicat wrote:Killing the full screen and halving the screen dimensions make it easier to work with.

Using the original code and reducing the screen dimensions eliminates the freezing – two minutes and no freeze.

I used

Code: Select all

Const scr_x = 1000
Const scr_y = 800

Original code remember.

I then used

Code: Select all

const scr_x = 1919
const scr_y = 1079
and got to five minutes without a freeze.

Now although I have solved the problem, not being a graphics guy, I cannot explain why

Code: Select all

const scr_x = 1920
const scr_y = 1080
would be an issue, but I bet dodicat can.
deltarho[1859]
Posts: 3667
Joined: Jan 02, 2017 0:34
Location: UK
Contact:

Re: Just for fun, starfield with planets orbiting

Post by deltarho[1859] »

I noticed that Randomize is not being used, so the Rnd sequence will be the same for each application session.

When using Randomize without a seed the seed will based on Timer. I am not getting a freeze now. My guess is that a freeze will occur, but when is anyone's guess. The freeze point will vary for each application session because Timer will be different.

If Randomize had been used, we could have gone a long time before anyone saw a freeze. :)

Added

Remembering that 0 <= Rnd <1 the odds against zero are pretty large, but what will happen if Rnd = 0 at some point? Barmy question? Probably.
deltarho[1859]
Posts: 3667
Joined: Jan 02, 2017 0:34
Location: UK
Contact:

Re: Just for fun, starfield with planets orbiting

Post by deltarho[1859] »

I should have mentioned that with the Randomize test

Code: Select all

const scr_x = 1920
const scr_y = 1080
was used.

Without using Randomize

Code: Select all

const scr_x = 1921
const scr_y = 1081
doesn't seem to be an issue, but I reckon that if we wait long enough it will be.

So using
const scr_x = 1920
const scr_y = 1080
seems to put us into a 'black hole' and I arrive at the singularity after 13 seconds using the default Rnd sequence. I reckon that with a different sequence, we still enter a 'black hole', but we will arrive at the singularity at different times.

I am confident that there is a simple reason for this issue, but I have no idea what it is. :)
fxm
Moderator
Posts: 11544
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Just for fun, starfield with planets orbiting

Post by fxm »

I think I found the bug:
In 'grid_add_bol()', 'm' becomes greater than 32766 (I found 35878), therefore the 'x' and 'y' iterators overflow (because declared as 'short').
Solution:
dim as long x,y
deltarho[1859]
Posts: 3667
Joined: Jan 02, 2017 0:34
Location: UK
Contact:

Re: Just for fun, starfield with planets orbiting

Post by deltarho[1859] »

Well done fxm.

I did three tests on the original code and added Randomize. All tests went beyond five minutes without a freeze. Of course, that does not prove that none of them would at some point.

The extraordinary thing about this bug is in getting a freeze when Rnd's default sequence is used.

Obviously, Gunslinger figured 'dim as short x, y' was good enough.
Post Reply