With Windows you can make sleep 1 close to 1 millisecond, it is by default about 15 milliseconds.
Code: Select all
Dim shared as any ptr RainIm
declare Sub Bmouse(mx As Integer,my As Integer,sz As Integer)
declare function settimer alias "timeBeginPeriod"(as Ulong=1) as long
declare function freetimer alias "timeEndPeriod" (as Ulong=1) as long
Sub Rain()
const max=1000
static as single xx(max),yy(max)
For i as long = 0 to max
xx(i) = rnd*1024
yy(i) = rnd*768
Put(xx(i),yy(i)),RainIm,alpha,rnd*200
Next
End Sub
screen 20,32
color ,rgb(0,150,255)
RainIm=ImageCreate(5,20)
Line RainIm,(0,0)-(5,20),rgb(50,50,55)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define inbox (mx>125) and (mx<475)' and (my>300) and (my<350)
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#macro display
fr=map(125,475,cx,10,160)
screenlock
cls
draw string(20,20),"Actual Framerate = " &fps
draw string(20,40),"Requested Framerate = " &fr
draw string(100,280),"10"
draw string(480,280),"160"
draw string(250,280),"<--slider-->"
angle+=.1
drawline(600,200,.2*sin(angle)-pi/2,300,4)
line(100,300)-(500,350),rgb(0,200,0),bf
circle(cx,cy),25,rgb(200,0,0),,,,f
bmouse(cx-5,cy-5,15)
rain
screenunlock
settimer
sleep regulate(fr,fps)
freetimer
#endmacro
#macro mouse
Dim As Long x=mx,y=my,dx,dy
While mb = 1
Display
Getmouse mx,my,,mb
If inbox Then
If mx<>x Or my<>y Then
dx = mx - x
dy = my - y
x = mx
y = my
cx=x+dx
if cx<125 then cx=125
if cx>475 then cx=475
End If
End If
Wend
#endmacro
sub drawline(x as long,y as long,angle as single,length as long,col as ulong)
var x2=x+length*cos(angle)
var y2=y-length*sin(angle)
line(x,y)-(x2,y2)
circle(x2,y2),10,rgb(200,100,0),,,,f
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
dim as long mx,my,mb
dim as long cx=125,cy=325,fps,fr
dim as single angle,pi=4*atn(1)
do
getmouse mx,my,,mb
display
if incircle(cx,cy,25,mx,my) and mb=1 then
mouse
end if
loop until len(inkey)
imagedestroy RainIm
Sub _line(x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer,l As Integer,col As Ulong,Byref xp As Integer=0,Byref yp As Integer=0)
Dim As Integer diffx=x2-x1,diffy=y2-y1,ln=Sqr(diffx*diffx+diffy*diffy)
If ln=0 Then ln=1e-6
Dim As Single nx=diffx/ln,ny=diffy/ln
xp=x1+l*nx:yp=y1+l*ny
Line(x1,y1)-(xp,yp),col
End Sub
Sub Bmouse(mx As Integer,my As Integer,sz As Integer)
Dim As Integer xp,yp
dim as ulong c=rgb(255,255,250)
_line(mx,my,mx+sz,my+.8*sz,sz,c,xp,yp)
_line(xp,yp,mx+sz/2,yp+.03*sz,.4*sz,c,xp,yp)
Var tx=xp,ty=yp
_line(mx,my,mx,my+1.2*sz,sz,c,xp,yp)
_line(xp,yp,mx+sz/2,yp-sz/2,.4*sz,c,xp,yp)
_line(xp,yp,mx+sz/2,yp+sz/2,sz,c,xp,yp)
_line(xp,yp,xp+sz/2,yp-.4*sz,.2*sz,c,xp,yp)
_line(xp,yp,tx,ty,.95*sz,c,xp,yp)
Paint(mx+.1*sz,my+.2*sz),c,c
End Sub