Hi basiccoder2.
fbide can use any fb version, all you have to do is point to the compiler under view/settings/freebasic.
fbide is the only one I have used since about 2006, although I have experimented with some others.
Hi Lothar Schirm.
Code: Select all
#cmdline "-gen gcc -Wc -O2"
Type AxialAngle
As Single Sin,Cos
End Type
Type v3
As Single x,y,z
As Ulong col
End Type
Type satellite
As v3 position
As Single speed
As v3 axis
As Long rad
As Ulong colour
As String Name
End Type
Screen 20,32
Dim Shared As Long xres,yres
Screeninfo xres,yres
Dim Shared As Any Ptr SmIm
SmIm=Imagecreate (xres/12,yres/12,0)
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)
Sub QsortvZ(array() As V3,begin As Long,Finish As Long)
Dim As Long i=begin,j=finish
Dim As V3 x =array(((I+J)\2))
While I <= J
While array(I).z > X .z:I+=1:Wend
While array(J).z < X .z:J-=1:Wend
If I<=J Then Swap array(I),array(J): I+=1:J-=1
Wend
If J > begin Then QsortvZ(array(),begin,J)
If I < Finish Then QsortvZ(array(),I,Finish)
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 Filter(Byref tim As Ulong Pointer,_
Byval rad As Single,_
Byval destroy As Long=1,_
Byval fade As Long=0) As Ulong Pointer
' #define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
If fade<0 Then fade=0:If fade>100 Then fade=100
Type p2
As Long x,y
As Ulong col
End Type
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As Long=-ymin To ymax
For x1 As Long=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
If fade=0 Then
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
Else
averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
End If
#endmacro
Dim As Single fd=map(0,100,fade,1,0)
Dim As Integer _x,_y
Imageinfo tim,_x,_y
Dim As Ulong Pointer im=Imagecreate(_x,_y)
Dim As Ulong col
Dim As p2 NewPoints(_x-1,_y-1)
For y As Long=0 To (_y)-1
For x As Long=0 To (_x)-1
col=Point(x,y,tim)
NewPoints(x,y)=Type<p2>(x,y,col)
Next x
Next y
Dim As Ulong averagecolour
Dim As Long ar,ag,ab
Dim As Long xmin,xmax,ymin,ymax,inc
For y As Long=0 To _y-1
For x As Long=0 To _x-1
average()
Pset im,((NewPoints(x,y).x),(NewPoints(x,y).y)),averagecolour
Next x
Next y
If destroy Then Imagedestroy tim: tim = 0
Function= im
End Function
Function mono(c As Uinteger) As Uinteger
Var v=.299*((c Shr 16)And 255)+.587*((c Shr 8)And 255)+.114*(c And 255)
Return Rgb(v,v,v)
End Function
Sub RotateArray(wa() As V3,result() As V3,ang As _float,centre As V3,flag As Long=0,s As Single=1)
Static As v3 eyepoint=Type<v3>(400,300,1000)
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 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
Sub makesmallimage(Byref 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=0
Var gr=map(-k,k,m,155,cc[1])
Var bl=200
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
For k As Long=1 To 20
Circle SmIm,(Rnd*xres/12,Rnd*yres/12),6,Rgb(Rnd*200,100+Rnd*155,0),,,Rnd*2,f
Next k
Smim=filter(SmIm,2)
End Sub
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 planet(a() As v3,b() As v3,Ectr As v3,axis As v3,m as long)
Const pi2=4*Atn(1)
Static As _float ang=Type(0,.2,pi2/2)
ang.x+=.01
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)
if m=1 then colour=mono(shade(b(n).col,fn)) else 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])
if m=1 then colour=mono(Rgb(rd,gr,bl))else colour=Rgb(rd,gr,bl)
End If
Line(b(n).x-rad+00,b(n).y-rad)-(b(n).x+rad+00,b(n).y+rad),colour,bf
End If
Next n
End Sub
makesmallimage(SmIm)
Redim Shared As V3 a(0)
AddAsphere(a(),Type<V3>(xres/2,yres/2,0),110,Rgb(255,255,0),1,1,1)
Redim Shared As v3 b(Lbound(a) To Ubound(a))
Dim Shared As v3 Ectr:Ectr=Type(xres/2,yres/2,0)
Dim Shared As v3 Axis=Type<v3>(100-512,430-384,200)
Function cross(v1 As v3,v2 As v3) As v3 'cross product
Return Type<v3>(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)
End Function
Function shortline(fp As v3,p As v3,length As Long) As v3
Dim As Single diffx=p.x-fp.x,diffy=p.y-fp.y,diffz=p.z-fp.z
Dim As Single L=Sqr(diffx*diffx+diffy*diffy+diffz*diffz)
Return Type<v3>(fp.x+length*diffx/L,fp.y+length*diffy/L,fp.z+length*diffz/L)
End Function
Function setAxialangle(angle As Single) As AxialAngle
Return Type(Sin(angle),Cos(angle))
End Function
Function normalize(v As V3) As V3
Dim As Single L= Sqr(v.x*v.x+v.y*v.y+v.z*v.z)
Return Type(v.x/L,v.y/L,v.z/L)
End Function
Function AxialRotate(centre As v3,Pt As V3,Angle As AxialAngle,norm As v3,T As Single=1) Byref As v3
#define crossP(v1,v2,N) Type<v3>( N*(v1.y*v2.z-v2.y*v1.z),N*(-(v1.x*v2.z-v2.x*v1.z)),N*(v1.x*v2.y-v2.x*v1.y))
#define plus(v1,v2) Type<v3>(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
#define dotP(v1,v2) (v1.x*v2.x + v1.y*v2.y + v1.z*v2.z)
#define mlt(f,v1) Type<v3>(f*v1.x,f*v1.y,f*v1.z)
Static As v3 result
Dim As V3 V=Type(T*(Pt.x-centre.x),T*(Pt.y-centre.y),T*(Pt.z-centre.z))
Dim As V3 T1=crossP(norm,V,Angle.sin)
Dim As Single tmpS=dotP(Norm,V)
Dim As V3 tmpV=mlt(tmpS,norm)
tmpV=mlt((1-Angle.cos),tmpV)
T1=plus(T1,tmpV)
Dim As V3 tt=mlt(Angle.cos,V)
result=plus(tt,T1)
result=plus(result,centre)
Return result
End Function
Function perspective(p As V3,eyepoint As V3) As V3
Dim As Single w=1+(p.z/eyepoint.z)
Return Type((p.x-eyepoint.x)/w+eyepoint.x,_
(p.y-eyepoint.y)/w+eyepoint.y,_
(p.z-eyepoint.z)/w+eyepoint.z)
End Function
Sub Qsort(array() As satellite,begin As Long,Finish As Long)
Dim As Long i=begin,j=finish
Dim As V3 x =array(((I+J)\2)).position
While I <= J
While array(I).position.z > X .z:I+=1:Wend
While array(J).position.z < X .z:J-=1:Wend
If I<=J Then Swap array(I),array(J): I+=1:J-=1
Wend
If J >begin Then Qsort(array(),begin,J)
If I <Finish Then Qsort(array(),I,Finish)
End Sub
Sub setsatellites(s() As satellite,x As Long,y As Long)
For n As Long= Lbound(s) To Ubound(s)
With s(n)
.axis=Type(Rnd-Rnd,Rnd-Rnd,Rnd-Rnd)
.axis=normalize(.axis)
Dim As v3 c=cross(.axis,Type(0,1,0))
c.x=x/2+c.x:c.y=y/2+c.y
Var z=150+Rnd*200
Dim As v3 p=shortline(Type(x/2,y/2,0),Type(c.x,c.y,c.z),z)
.position=p
.speed=200/(z)
.rad=1
.colour=Rgb(100+Rnd*155,100+Rnd*155,100+Rnd*155)
.name="Orbit speed " + Str(Int(.speed*100))
End With
s(Ubound(s)).position=Type(x/2,y/2,0)
s(Ubound(s)).rad=100
s(Ubound(s)).colour=Rgb(0,0,250)
s(Ubound(s)).name="Planet X"
Next n
End Sub
Sub ORB(cx As Long,_ 'CENTRES
cy As Long,_
radius As Long,_
c As Ulong,_ 'COLOUR
offsetX As Single=0,_ 'Bright spot (0 to about .9)
offsetY As Single=0,_
e As Single=0,_ 'eccentricity
resolution As Long=16,_ 'number of circles drawn
im As Any Pointer=0)
Dim As Single ox,oy,nx,ny
ox=cx+offsetX*radius
oy=cy+offsetY*radius
Dim As Ubyte red=Cptr(Ubyte Ptr,@c)[2]
Dim As Ubyte green=Cptr(Ubyte Ptr,@c)[1]
Dim As Ubyte blue=Cptr(Ubyte Ptr,@c)[0]
For d As Single = radius To 0 Step -radius/resolution
nx=(cx-ox)*(d-radius)/radius + cx 'linear mappings for moving centre
ny=(cy-oy)*(d-radius)/radius + cy
Var f=map(radius,0,d,.2,.8)
Var clr=Rgb(f*red,f*green,f*blue)
Var m=map(0,xres,nx,1,0)
Circle im,(nx,ny),d,shade(clr,m),,,e,F
Next d
End Sub
Sub show(s As satellite,x As Long,y As Long,i As Any Ptr=0,E As Any Ptr,m as long=0)
Var rad=map(-300,300,s.position.z,12,3)
If s.rad=100 Then
planet(a(),b(),ectr,axis,m)
Else
orb(s.position.x,s.position.y,rad+s.rad,s.colour,-.6,0,0)
End If
Pset i,(s.position.x,s.position.y),Rgb(50,50,50)
If s.position.z<0 Then Pset E,(s.position.x,s.position.y),Rgb(50,50,50)
End Sub
Sub move(s As satellite,Byref rot As satellite,x As Long,y As Long)
Static As Single a
a+=.001
rot=s
Dim As AxialAngle Aa=setAxialAngle((s.speed*a)/1)
rot.position=AxialRotate(Type(x/2,y/2,0),s.position,Aa,s.Axis)
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) 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
Function fbmain() As Long Export
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
Dim As Long x,y
Screeninfo x,y
Dim As Any Ptr im=Imagecreate(x,y),E =Imagecreate(x,y)
Dim As satellite s(1 To 10)
Dim As satellite rot(1 To 10)
setsatellites(s(),x,y)
Dim As Long fps
Dim As Long mx,my,mb
Do
Getmouse mx,my,,mb
For n As Long=Lbound(s) To Ubound(s)
move(s(n),rot(n),x,y)
Next
Qsort(rot(),Lbound(rot),Ubound(rot))
Screenlock
Cls
Draw String (20,20),"FPS = " &fps
if mb=1 then Draw String (20,40),"Post PlanetX Global Warming"
Put(0,0),im,trans
For n As Long=Lbound(s) To Ubound(s)
rot(n).position=perspective(rot(n).position,Type(x/2,y/2,800))
show(rot(n),x,y,im,E,mb)
If incircle( rot(n).position.x, rot(n).position.y,50,mx,my) Then
Draw String( rot(n).position.x, rot(n).position.y),rot(n).name
End If
Next
Put(0,0),E,trans
Screenunlock
Sleep regulate(60,fps),1
Loop Until Len(Inkey)
Imagedestroy im
Imagedestroy E
Return 0
End Function
fbmain
