Hi integer.
Don't know about the 32 bit OS.
Binary stars are ten a penny.
Binary planets are as yet an unknown entity, so this is purely a guess as to what they are like in the cosmos.
Code: Select all
Screen 20,32
Color ,Rgb(0,0,25)
Dim Shared As Integer xres,yres
Screeninfo xres,yres
#define shade(c,n) rgb(Cptr(Ubyte Ptr,@c)[2]*n,Cptr(Ubyte Ptr,@c)[1]*n,Cptr(Ubyte Ptr,@c)[0]*n)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
'<><><><><><><><><><><> Quick SORT <><><><><><><><><><>
#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As Long,Finish As Ulong)
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
'<><><>
Function Blur(Byref tim As Uinteger Pointer,rad As Integer=2) As Uinteger Pointer
Type p2
As Integer x,y
As Uinteger col
End Type
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel2=row2+pitch2*(_y)+4*(_x)
*pixel2=(colour)
#endmacro
#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 Integer=-ymin To 0
For x1 As Integer=-xmin To 0
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
#endmacro
Dim As Integer _x,_y
Imageinfo tim,_x,_y
Dim As Uinteger Pointer im=Imagecreate(_x,_y)
Dim As Integer pitch,pitch2
Dim As Any Pointer row,row2
Dim As Uinteger Pointer pixel,pixel2
Dim As Uinteger col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x,_y)
Dim As Uinteger averagecolour
Dim As Integer ar,ag,ab
Dim As Integer xmin,xmax,ymin,ymax,inc
Imageinfo im,,,,pitch2,row2
For y As Integer=0 To _y-1
For x As Integer=0 To _x-1
ppoint((x),(y),col)
NewPoints(x,y)=Type<p2>(x,y,col)
average()
NewPoints(x,y).col=Rgb(ar/(inc),ag/(inc),ab/(inc))
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),NewPoints(x,y).col)
Next x
Next y
Function= im
End Function
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
' ========= set up image ========
Dim Shared As v3 eyepoint
eyepoint=Type(xres/2,yres/2,800)
Dim Shared As Any Ptr im,bck
im=Imagecreate (xres/12,yres/12,0)
bck=Imagecreate (xres,yres,0)
Redim As V3 a(0)
Dim As Ulong Clr
Randomize 2
for n as long=1 to 500
print bin(7,4);
next
get(0,0)-(xres/12-1,yres/12-1),im
cls
im=Blur(im,1)
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
for x as long=0 to 200
dim as long xx=rnd*xres,yy =rnd*yres
if incircle(xx,yy,160,(xres/2),(yres/2))=0 then
pset bck,(xx,yy)
end if
next
'========== done ===========
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
Sub RotateArray(wa() As V3,result() As V3,angle 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(angle.x)
SinAY=Sin(angle.y)
SinAZ=Sin(angle.z)
CosAX=Cos(angle.x)
CosAY=Cos(angle.y)
CosAZ=Cos(angle.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
'if a point lies on a sphere
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.5
End Function
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 Long= xx-r-1 To xx+r+1 Step 2
For y As Long=yy-r-1 To yy+r+1 Step 2
For z As Long=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,im)
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
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Static As Double timervalue,_lastsleeptime,t3,frames,sleeptime
dim as double t=Timer
frames+=1
If (t-t3)>=1 Then t3=t:fps=frames:frames=0
sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=T
Return sleeptime
End Function
AddAsphere(a(),Type<V3>(xres/2,yres/2,0),150,Rgb(255,255,0),1,1,1)
SetQsort(V3,QsortZ,down,.z) 'Set Up the quicksort for UDT V3, on z
Redim As V3 b(Lbound(a) To Ubound(a)) 'feeder array
Dim As Single pi=4*Atn(1)
'RotateArray(a(),b(),Type<_float>(0,0,-pi/3.5),Type(xres/2,yres/2,0))
RotateArray(a(),b(),Type<_float>(0,0,-pi/2),Type(xres/2,yres/2,0))
For n As Long=Lbound(a) To Ubound(a)
'a(n)=b(n)
Next
dim as long fps
Dim As v3 Axis
Dim As Ulong colour
Dim As Ubyte rd,gr,bl
Dim As Ubyte Ptr cc
Dim As v3 Ectr=Type(xres/2,yres/2,0)
Dim As Single min=3,max=-3,dt,ang,rad
dim as long mx,my,mw,mb
Do
min=3
max=-3
ang+=.025
getmouse mx,my,mw,mb
Axis=type(mx-512,my-384,mw*5)
RotateArray(a(),b(),Type<_float>(0,ang,0),Type(xres/2,yres/2,0),1,1)
Screenlock
Cls
put(0,0),bck,pset
Draw String(10,10),"FPS =" & fps
draw string(10,30),"Mouse & wheel"
QsortZ(b(),Lbound(b),Ubound(b))
For n As Long=Lbound(b) To Ubound(b)
If b(n).z<0 Then
rad=map(-400,400,b(n).z,2.5,1)
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
colour=shade(b(n).col,.11)
Else
If min>dt Then min=dt
If max<dt Then max=dt
cc=Cptr(Ubyte Ptr,@b(n).col)
rd=map(min,max,dt,255,cc[2])
gr=map(min,max,dt,255,cc[1])
bl=map(min,max,dt,255,cc[0])
colour=Rgb(rd,gr,bl)
End If
if mb=1 then colour=shade(colour,.5)
Circle(b(n).x,b(n).y),rad,colour,,,,f
End If
Next n
Screenunlock
Sleep regulate(25,fps),1
Loop Until inkey=chr(27)
imagedestroy (im)
imagedestroy (bck)
Sleep
