Thanks hhr.
Code: Select all
Screen 19,,2
Screenset 1,0
Dim Shared As Integer xres,yres,border=50,gf=500
Screeninfo xres,yres
Function Regulate(Byval MyFps As Integer,Byref fps As Integer) As Integer
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
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
Type thing
As Single x,y,z 'position
As Single dx,dy 'velocity
As Uinteger col 'colour
As Integer radius
As Integer collide_distance
As Integer applyG
As Single fy =.01 'drag on y
As Single fx=.01 'drag on x
As Single gravity=.05
Declare Function DetectBallCollisions(Byref As thing) As Single
Declare Sub friction()
Declare Sub boundaries()
Declare Sub motion(() As thing,As Integer)
Declare Static Sub BallCollisions(() As thing)
Declare Static Sub initialize(() As thing)
Declare Sub Tie(() As thing,As Integer)
Declare Sub Draw()
End Type
Function incircle(x As Single,y As Single,r As Integer,mx As Integer,my As Integer) As Integer
Return ((mx-x)^2+(my-y)^2) < r
End Function
Function Distance(p1 As thing,p2 As thing) As Single
Return Sqr((p1.x-p2.x)*(p1.x-p2.x) + (p1.y-p2.y)*(p1.y-p2.y))
End Function
Sub lineto(x1 As Single,y1 As Single,x2 As Single,y2 As Single,L As Single,Byref ox As Single,Byref oy As Single)
Var dx=x2-x1,dy=y2-y1
ox=x1+dx*L
oy=y1+dy*L
End Sub
Sub thing.tie(points() As thing,n As Integer)
Dim As thing f1,f2
Dim As Single f=this.gravity/gf
Var d1=distance(points(n),points(n-1)),d2=distance(points(n),points(n+1))
Var diffx1=points(n).x-points(n-1).x,diffy1=points(n).y-points(n-1).y
Var diffx2=points(n).x-points(n+1).x,diffy2=points(n).y-points(n+1).y
diffx1=diffx1*d1*f
diffy1=diffy1*d1*f
diffx2=diffx2*d2*f
diffy2=diffy2*d2*f
dx-=(diffx1+diffx2)
dy-=(diffy1+diffy2)
End Sub
Function thing.DetectBallCollisions(Byref player As thing) As Single
Dim As Single xdiff = this.x-player.x
Dim As Single ydiff = this.y-player.y
If Abs(xdiff) > this.collide_distance*2 Then Return 0
If Abs(ydiff) > this.collide_distance*2 Then Return 0
Var L=Sqr(xdiff*xdiff+ydiff*ydiff)
If L<=this.collide_distance*2 Then Function=L
End Function
Sub thing.friction()
If dy > 0 Then dy -= fy Else dy += fy
If dx > 0 Then dx -= fx Else dx += fx
End Sub
Sub thing.boundaries()
If y>yres-radius-border Then y=yres-radius-border: dy=-dy
If y<radius+border Then y=radius+border :dy=-dy
If x<radius+border Then x=radius+border: dx=-dx
If x>xres-radius-border Then x=xres-radius-border:dx=-dx
End Sub
Sub thing.motion(p() As thing,n As Integer)
If n>1 And n<Ubound(p)-1 Then
x+=dx
y+=dy
If applyG Then dy+=gravity
End If
End Sub
Sub thing.draw()
Circle(x,y),radius,col,,,,f
End Sub
Sub thing.BallCollisions(points() As thing)
For n1 As Integer =1 To Ubound(points)-2
For n2 As Integer =n1+1 To Ubound(points)-1
Var L=points(n1).DetectBallCollisions(points(n2))
If L Then
Var impulsex=(points(n1).x-points(n2).x)
Var impulsey=(points(n1).y-points(n2).y)
Dim As Single ln=Sqr(impulsex*impulsex+impulsey*impulsey)
impulsex/=ln'normalize the impulse
impulsey/=ln
'In case of overlap circles, reset to non overlap positions
points(n1).x=points(n2).x+(points(n1).collide_distance*2)*impulsex
points(n1).y=points(n2).y+(points(n1).collide_distance*2)*impulsey
Var impactx=points(n1).dx-points(n2).dx
Var impacty=points(n1).dy-points(n2).dy
Var dot=impactx*impulsex+impacty*impulsey
points(n1).dx-=dot*impulsex
points(n1).dy-=dot*impulsey
points(n2).dx+=dot*impulsex
points(n2).dy+=dot*impulsey
End If
Next n2
Next n1
End Sub
Sub thing.initialize(b() As thing)
Dim As Integer ct
For x As Integer=border+15 To yres-border-15 Step 60
ct+=1
Redim Preserve b(0 To ct)
With b(ct)
.x=400
.y=x
.radius=20
.col=Int(Rnd*14)
.dx=0
.dy=0
.collide_distance=.radius
.applyG=1
End With
Next x
Redim Preserve b(Ubound(b)+1)
b(1).x=xres/2
b(1).y=.1*yres
b(1).applyg=0:b(Ubound(b)-1).applyg=0
b(0)=b(1):b(Ubound(b))=b(Ubound(b)-1)
b(Ubound(b)-1).radius=20'18
End Sub
Function ShortSpline(p() As thing,t As Single) As thing
#macro set(n)
0.5 *( (2 * P(2).n) +_
(-1*P(1).n + P(3).n) * t +_
(2*P(1).n - 5*P(2).n + 4*P(3).n - P(4).n) * t*t +_
(-1*P(1).n + 3*P(2).n- 3*P(3).n + P(4).n) * t*t*t)
#endmacro
Dim As thing G
G.x=set(x):G.y=set(y):G.z=set(z)
Return g
End Function
Sub GetSpline(v() As Thing,outarray() As Thing,colour As Uinteger,arraysize As Integer=1000)
Dim As Thing p(1 To 4)
Redim outarray(0)
Dim As Single stepsize=(Ubound(v)-1)/(arraysize)
If stepsize>1 Then stepsize=1
For n As Integer=Lbound(v)+1 To Ubound(v)-2
p(1)=v(n-1):p(2)=v(n):p(3)=v(n+1):p(4)=v(n+2)
For t As Single=0 To 1 Step stepsize
Redim Preserve outarray(1 To Ubound(outarray)+1)
outarray(Ubound(outarray))=ShortSpline(p(),t)
outarray(Ubound(outarray)).col=colour
Next t
Next n
End Sub
Sub DrawCurve(a() As thing,ydisp As Integer=0)
Pset(a(Lbound(a)).x,a(Lbound(a)).y+ydisp),a(Lbound(a)).col
For z As Integer=Lbound(a)+1 To Ubound(a)
Line-(a(z).x,a(z).y+ydisp),a(z).col
Next z
End Sub
#macro show()
GetSpline(b(),C(),0,500)
lineto(b(2).x,b(2).y,b(1).x,b(1).y,2,ox,oy)
b(0).x=ox:b(0).y=oy
#define ub2 Ubound(b)-2
#define ub1 Ubound(b)-1
lineto(b(ub2).x,b(ub2).y,b(ub1).x,b(ub1).y,2,ox,oy)
b(Ubound(b)).x=ox:b(Ubound(b)).y=oy
Cls
Line(border,border)-(xres-border+1,yres-border+1),4,b
Paint(0,0),3,4
Paint(border+1,border+1),15,4
Draw String (10,10), "fps= " & fps
Draw String (10,30), "Slackness = " &int(map(200,2000,gf,1,9))
drawCurVe(C())
acc=0
thing.BallCollisions(b())
For n As Integer=1 To Ubound(b)-1
b(n).motion(b(),n)
b(n).friction()
b(n).boundaries()
b(n).draw()
If n>1 And n<Ubound(b)-1 Then
b(n).tie(b(),n)
b(n).fx=speed
b(n).fy=speed
End If
acc+=Abs(b(n).dx)+Abs(b(n).dy)
Next n
speed=map(0,30,acc,0,.2)
Flip
#endmacro
Sub drawline(x As Integer,y As Integer,angle As Single,length As Double,Byref x2 As Single=0,Byref y2 As Single=0,flag As Integer=1)
angle=angle*Atn(1)/45
x2=x+length*Cos(angle)
y2=y-length*Sin(angle)
End Sub
#define irange(f,l) Int(Rnd*((l+1)-(f))+(f))
'======= RUN =========
Randomize 3
Redim As Thing b(0):Thing.initialize(b())
Redim As Thing C()
Dim As Single acc,speed,ox,oy,k=2
Dim As Integer fps
Dim As String i
Dim As Single angle,b1,b2,range=190,pi=4*Atn(1)
Do
angle=angle+(1/60)
If angle>=2*pi Then angle=0
i=Inkey
If Rnd >.99 Then k=irange(1,9)
gf=map(1,9,k,200,2000)
drawline(xres/2,.1*yres,270+Sin(angle)*range/(4*Atn(1)),380,b1,b2)
b(Ubound(b)-1).x=b1
b(Ubound(b)-1).y=b2
show()
Sleep regulate(60,fps),1
Loop Until i=Chr(27)
Sleep
I notice that the colours are very slightly opaque in Win 11.
I can see the background console through the fb screen 19, although very sightly.
