Using my normal regulator for sleep with an extra parameter and my normal regulator for while with a couple of extras, these can be used independently or together.
Together they can switch from sleep to while as per required framerate.
I haven't used a framecounter function, I have them inbuilt, but I have a framecounter rigged in the loop to test.
I notice that the rigged framecounter can lag at high fps (>2000 or so)
I have accounted for -ve or 0 required framerates, but left silly high values hanging.
Two graphics are included.
EDIT.. fixed a little error.
Code: Select all
Function readkey(x As Long,y As Long,st As String,message As String,clr As Ulong) As String
Static As String j,blink
Var c=Color
Var i=Inkey()
If Left(i,1)=Chr(08) Then j=Mid(j,1,Len(j)-1)
Select Case Left(i,1)
Case Chr(0) To Chr(254)
If Left(i,1)<>Chr(08) Then
j=j+Left(i,1)
End If
End Select
If Frac(Timer)>.5 Then blink=" " Else blink="_"
If Left(i,1)=Chr(27) Then j=""
If i<>Chr(13) Then
Locate x,y,0
Color clr
Print st & j & blink
Color c
Else
j=Rtrim(j,Chr(13))
message=j
j=""
End If
Return i
End Function
Function regulate Overload(MyFps As Long,Byref fps As Long) As Double
Dim As Double k=1/MyFps
Static As Double timervalue
Var c=timervalue
Do While (Timer - TimerValue) <= k
Loop
Var ans=(Timer-timervalue)
timervalue=Timer
fps=1/(timervalue-c)
If Abs(Myfps-fps)>MyFps\2 Then fps=60
Return ans*60
End Function
Function Regulate(Byval MyFps As Long,Byref fps As Long,Byref gap As Double) As Double
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 gap=sleeptime:sleeptime= 1
_lastsleeptime=sleeptime
timervalue=T
Return sleeptime
End Function
Sub ball()
Static As Double x= 10
Static As Double y = 10
Static As Double dx=.5
Static As Double dy =.5
x += dx : y += dy
If x<10 Or x>=630 Then dx = -dx
If y<10 Or y>=470 Then dy = -dy
Circle(x,y),10,4,,,,f
End Sub
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),20,6,,,,f
End Sub
Sub pendulum
#define dmod(x,y) (y)*Frac((x)/(y))
Const pi=4*Atn(1)
Static As Single angle
angle+=.005
angle=dmod(angle,2*pi)
drawline(400,100,.4*Sin(angle)-pi/2,300,4)
End Sub
Dim As String message="30"
Dim As Long fps
Dim As Long MyChoice,counter,flag
Dim As String LastChoice
Dim As Double gap,speed
gap=2
Screen 12
Var t=Timer
Do
counter+=1
Screenlock
Cls
If Timer-t>=1 Then
t=Timer
speed= counter 'lagging framecounter
counter=0
End If
readkey(4,2,Ucase("Input required framerate, ESC to finish "),message,3)
Color 7
Locate 7,2
Print "required framerate ";message
Locate 10,2
Print "actual framerate ";fps
Locate 13,2
Print "lagging framerate ";speed
Locate 16,2
Color 5
Print Iif(flag=true,"Regulate with sleep","Regulate with while")
ball
pendulum
Screenunlock
MyChoice=Valint(message)
If Mychoice<=0 Then message=LastChoice:Continue Do
If gap>1 Then
Sleep regulate(MyChoice,fps,gap) ,1
flag=true
Else
gap=regulate(MyChoice,fps)
flag=false
End If
LastChoice=message
Loop Until Multikey(1)'esc
