Like Cassini, ancient code, but not Win 95.
Code: Select all
type tmp as axis
Type v3
As Single x,y,z
Declare Property length As Single
Declare Property unit As v3
Declare Function AxialRotate(As v3,As Single,As tmp) As v3
Declare Function PointRotate(As v3,As v3,As v3=Type<v3>(1,1,1)) As v3
Declare Function perspective(eyepoint As v3) As v3
#define vct Type<v3>
#define dot *
#define cross ^
End Type
#define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define rd .01745329
type axis extends v3
declare constructor
declare constructor(as v3)
end type
constructor axis
end constructor
constructor axis(v as v3)
var temp=v.unit
this.x=temp.x:this.y=temp.y:this.z=temp.z
end constructor
dim shared as integer xres,yres
Type rainbow
As Integer min,max,z
As Integer ba
As Integer xp,yp
Declare Function colours(As String,As Any Pointer=0) As Uinteger
End Type
Dim Shared As rainbow rb
Dim Shared As Integer cntx,cnty,number=1000
With rb
.min=50
.max=350
.ba=255
End With
Operator + (v1 As v3,v2 As v3) As v3
Return Type<v3>(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(v1 As v3,v2 As v3) As v3
Return Type<v3>(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (f As Single,v1 As v3) As v3
Return vct(f*v1.x,f*v1.y,f*v1.z)
End Operator
Operator *(v1 As v3,f As Single) As v3
Return f*v1
End Operator
Operator * (v1 As v3,v2 As v3) As Single 'dot product
Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z
End Operator
Operator ^ (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 Operator
operator /(v1 As v3,n as single) As v3
return type<v3>(v1.x/n,v1.y/n,v1.z/n)
end operator
Property v3.length As Single
Return Sqr(this.x*this.x+this.y*this.y+this.z*this.z)
End Property
Property v3.unit As v3
Dim n As Single=this.length
If n=0 Then n=1e-20
Return this/n
End Property
Function v3.AxialRotate(centre As v3,Angle As Single,norm As axis) As v3
Dim As v3 V=This-centre
Return (V*Cos(Angle)+(Norm cross V)*Sin(Angle)+Norm*(Norm dot V)*(1-Cos(Angle)))+centre
End Function
Function v3.perspective(eyepoint As v3) As v3
Dim As Single w=1+(this.z/eyepoint.z)
If w=0 Then w=1e-20
return eyepoint+(this-eyepoint)/w
End Function
#macro Nan()
#ifdef __FB_WIN32__
Declare Function ScaleWindow Alias "MoveWindow"(As Any Ptr,As Integer=0,As Integer=0,As Integer,As Integer,As Integer=1) As Integer
scope
dim as string s,t
#macro r_d(a)
s=string(ubound(a)," ")
for n as integer=1 to ubound(a)
s[n-1]=a(n)
next n
t+=s
#endmacro
screen 0
dim as integer desktopW,desktopH,xres,yres
screeninfo desktopW,desktopH
screenres DesktopW/1.8,DesktopH/1.8,32,,64 or 8
color rgb(200,200,200),rgb(0,0,200)
cls
screeninfo xres,yres
width xres\8,yres\16
Dim As Integer I
Screencontrol(2,I)
ScaleWindow(Cast(Any Ptr,I),0,0,desktopW,desktopH)
dim as ubyte a1(1 to 68)={65,32,102,97,116,97,108,32,101,120,99,101,112,116,105,111,110,32,79,69,32,104,97,_
115,32,111,99,99,117,114,114,101,100,32,97,116,32,48,48,50,56,58,67,48,48,49,49,_
69,51,54,32,105,110,32,86,88,68,32,86,77,77,40,48,49,41,32,43,10}
dim as ubyte a2(1 to 58) ={32,32,32,32,48,48,48,49,48,69,51,54,46,32,84,104,101,32,99,117,114,114,101,110,116,32,97,112,_
112,108,105,99,97,116,105,111,110,32,119,105,108,108,32,98,101,32,116,101,114,109,_
105,110,97,116,101,100,46,10}
dim as ubyte a3(1 to 2)= {10,10}
dim as ubyte a4(1 to 57)= {32,32,32,32,42,32,80,114,101,115,115,32,97,110,121,32,107,101,121,32,116,111,32,_
116,101,114,109,105,110,97,116,101,32,116,104,101,32,99,117,114,114,101,110,116,_
32,97,112,112,108,105,99,97,116,105,111,110,10}
dim as ubyte a5(1 to 69)= {32,32,32,32,42,32,80,114,101,115,115,32,67,84,82,76,32,43,32,65,76,84,32,43,32,68,_
69,76,32,97,103,97,105,110,32,116,111,32,114,101,115,116,97,114,116,32,121,111,_
117,114,32,99,111,109,112,117,116,101,114,46,89,111,117,32,119,105,108,108,10}
dim as ubyte a6(1 to 56)= { 32,32,32,32,32,32,108,111,111,115,101,32,97,110,121,32,117,110,115,97,118,101,100,_
32,105,110,102,111,114,109,97,116,105,111,110,32,105,110,32,97,108,108,32,97,112,_
112,108,105,99,97,116,105,111,110,115,46}
dim as ubyte a7(1 to 2)= {10,10}
dim as ubyte a8(1 to 56)= { 32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,_
80,114,101,115,115,32,97,110,121,32,107,101,121,32,116,111,32,99,111,110,116,105,_
110,117,101,32,95}
r_d(a1):r_d(a2):r_d(a3):r_d(a4):r_d(a5):r_d(a6):r_d(a7):r_d(a8)
locate 10,5
print t
sleep
end scope
#endif
#endmacro
Sub rotate(im As Any Ptr,angle As single,shiftx As Integer=0,shifty As Integer=0,sc As Single=1)
#define InRange() resultx>=0 And resultx<ddx And resulty>=0 And resulty<ddy And _
x+shiftx>=0 And x+shiftx<xres And y+shifty>=0 And y+shifty<yres
Dim As Integer pitch,pitchs,xres,yres
Dim As Any Ptr row
Dim As Ulong Ptr pixel,pixels
Dim As Integer ddx,ddy,resultx,resulty
Imageinfo im,ddx,ddy,,pitch,row
Screeninfo xres,yres,,,pitchS
Dim As Any Ptr rowS=Screenptr
Dim As long centreX=ddx\2,centreY=ddy\2
Dim As Single sx=Sin(angle*.0174533)
Dim As Single cx=Cos(angle*.0174533)
Dim As long mx=Iif(ddx>=ddy,ddx,ddy)
Var fx=sc*Sqr(2)/2,sc2=1/sc
dim as ulong empty = rgb(0,0,0)
dim as long starty=iif(centrey-fx*mx<0,0,centrey-fx*mx)
dim as long endy=iif(centrey+fx*mx>yres,yres,centrey+fx*mx)
dim as long startx=iif(centrex-mx*fx<0,0,centrex-mx*fx)
dim as long endx=iif(centrex+mx*fx>xres,xres,centrex+mx*fx)
For y As long=starty To endy Step 1
var sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
For x As long=startx To endx Step 1
resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
If InRange() Then
pixel=row+pitch*((resultY))+((resultX)) Shl 2
if *pixel <> empty then
pixels=rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2
*pixels=*pixel
end if
End If
Next x
Next y
End Sub
Sub _circle(cx As Integer,cy As Integer,radius As Integer,im As Uinteger Pointer=0)
#define incircle(cx,cy,radius,x,y) ((cx)-(x))*((cx)-(x)) +((cy)-y)*((cy)-y)<= (radius)*(radius)
#define distance(cx,cy,px,py) Sqr((cx-px)*(cx-px)+(cy-py)*(cy-py))
For y As Integer=cy-radius To cy+radius
For x As Integer=cx-radius To cx+radius
If incircle(cx,cy,radius,x,y) Then
rb.xp=x
rb.yp=y
rb.z=distance(cntx,cnty,x,y)
'circle im,(x,y),1,(rb.colours("outer",im)),,,,f
pset im,(x,y),(rb.colours("outer",im))
End If
Next x
Next y
End Sub
Function rainbow.colours(part As String="inner",im As Any Pointer=0) As Uinteger
Dim As Uinteger col
Dim As Integer diff=this.z-this.min
Dim As Integer gap=(this.max-this.min)/6
If part="outer" Then
If this.z>=this.min-2*gap And this.z<this.min Then
col=Point(this.xp,this.yp,im)
Return Rgba((255-(col Shr 16 And 255))*(diff+2*gap)/(2*gap)+(col Shr 16 And 255),_
-(diff+2*gap)*(col Shr 8 And 255)/(2*gap)+(col Shr 8 And 255),_
-(diff+2*gap)*(col And 255 )/(2*gap)+(col And 255 ),this.ba)
End If
If this.z>=this.min And this.z<this.min+gap Then _
Return Rgba(255,165*(diff)/(gap),0,this.ba)
If this.z>=this.min+gap And this.z<this.min+2*gap Then _
Return Rgba(255,90*(diff-gap)/gap+165,0,this.ba)
If this.z>=this.min+2*gap And this.z<this.min+3*gap Then _
Return Rgba(-255*(diff-2*gap)/gap+255,-127*(diff-2*gap)/gap+255,0,this.ba)
If this.z>=this.min+3*gap And this.z<this.min+4*gap Then _
Return Rgba(0,-128*(diff-3*gap)/gap+128,255*(diff-3*gap)/gap,this.ba)
If this.z>=this.min+4*gap And this.z<this.min+5*gap Then _
Return Rgba(75*(diff-4*gap)/gap,0,-125*(diff-4*gap)/gap+255,this.ba)
If this.z>=this.min+5*gap And this.z<this.min+6*gap Then _
Return Rgba(163*(diff-5*gap)/gap+75,130*(diff-5*gap)/gap,108*(diff-5*gap)/gap+130,this.ba)
If this.z>=this.min+6*gap And this.z<this.min+8*gap Then
col=Point(this.xp,this.yp,im)
Return Rgba((-238+(col Shr 16 And 255))*(diff-6*gap)/(2*gap)+238,_
(-130+(col Shr 8 And 255))*(diff-6*gap)/(2*gap)+130,_
(-238+(col And 255 ))*(diff-6*gap)/(2*gap)+238,this.ba)
End If
End If
End Function
Function Blur(Byref tim As Uinteger Pointer,rad As Single=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)
pixel=row+pitch*(_y)+4*(_x)
*pixel=(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 ymax
For x1 As Integer=-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
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
#endmacro
Dim As Integer _x,_y
Imageinfo tim,_x,_y
Dim As Uinteger Pointer im=Imagecreate(_x,_y)
Dim As Integer pitch
Dim As Any Pointer row
Dim As Uinteger Pointer pixel
Dim As Uinteger col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x,_y)
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)
Next x
Next y
Dim As Uinteger averagecolour
Dim As Integer ar,ag,ab
Dim As Integer xmin,xmax,ymin,ymax,inc
For y As Integer=0 To _y-1
For x As Integer=0 To _x-1
average()
NewPoints(x,y).col=averagecolour
Next x
Next y
Imageinfo im,,,,pitch,row
For y As Integer=0 To _y
For x As Integer=0 To _x
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),NewPoints(x,y).col)
Next x
Next y
Function= im
End Function
Function Regulate(Byval MyFps As long,Byref fps As long) As long
Static As Double timervalue,lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
'=================================================================================
#macro pentagon(starx,stary,size,col)
Scope
Var pi=4*Atn(1)
Var count=0,rad=0.0,_px=0.0,_py=0.0
For z As Single=0+.28 To 2*pi+.1+.28 Step 2*pi/10
count=count+1
If count Mod 2=0 Then rad=size Else rad=.4*size
_px=starx+rad*Cos(z)
_py=stary+rad*Sin(z)
If count=1 Then Pset im,(_px,_py)Else Line im,-(_px,_py),col
Next z
Paint im,(starx,stary),col,col
End Scope
#endmacro
#macro display()
static as single a,k=.5,sc=1
k+=.001
a+=k
if a>5*sc or a<-5*sc then k=-k
sc+=.005
Screenlock
Cls
rotate(im,sc*2*sin(a),0,0,sc)
Put(0,0),im2,trans
Draw String(10,10),"FPS " &fps
if sc>5 then goto fin
Screenunlock
Sleep snooze,1
#endmacro
#macro MakeImage()
#define incircle(cx,cy,radius,x,y) ((cx)-(x))*((cx)-(x)) +((cy)-y)*((cy)-y)<= (radius)*(radius)
For n As Integer=1 To 40
Var x=IntRange(0,xres),y=IntRange(0,yres)
If incircle(595,484,250,x,y)=0 Then
If y<.8*yres Then
Var sz=IntRange(2,7)
Var c=Rgb(IntRange(200,255),IntRange(200,255),IntRange(200,255))
pentagon(x,y,sz,c)
End If
End If
Next n
Dim As v3 t(1 To 501)
For a As Single=1 To 360 Step .25
For n As Integer=1 To 501
t(n).x=IntRange(153,253)
t(n).y=IntRange(500,520)
Var trace=t(n).AxialRotate(centre,a*rd,normal_line)
trace=trace.perspective(vct(xres/2,yres/2,600))
Pset im,(trace.x,trace.y),Rgb(IntRange(200,255),IntRange(200,255),IntRange(200,255))
Next n
Next a
_circle(595,(484),250,im)
dim as long clr
for n as single=xres/2-50 to xres/2+50 step .5
var xp=map((xres/2-50),(xres/2+50),n,(xres/2-10),(xres/2+10))
clr=map((xres/2-50),(xres/2+50),n,255,0)
var tp=map((xres/2-10),(xres/2+10),xp,0,6)
line im2,(n,yres)-(xp,yres/2+100-abs(10*cos(tp))),rgb(clr,clr/2,clr)
next
#endmacro
Screen 20,32,2,64
Screeninfo xres,yres
Dim As Any Pointer im=Imagecreate(xres,yres,Rgb(0,0,0)),im2=imagecreate(xres,yres)
cntx=xres/2-100:cnty=.25*yres
Dim As v3 centre=Type<v3>(595,434,0),pt(1 To number)
Dim As axis normal_line =vct(.5,1,.5)
MakeImage()
im=blur(im,2)
Dim As Integer fps,snooze
display()
locate 10,10
print "Press a key"
sleep
Do
snooze=regulate(60,fps)
display()
Loop Until Inkey=Chr(27)
FIN:
nan()
Imagedestroy im
imagedestroy im2