'Initialise graphics window
GraphicsWindow.Hide()
gw = 1000
gh = 750
KET = 20 ' to move all KE text up and down together
GraphicsWindow.CanResize = "False"
GraphicsWindow.Top = (Desktop.Height-gh)/2
GraphicsWindow.Left = (Desktop.Width-gw)/2
GraphicsWindow.Title = "PMT149 but with KE values for top and bottom halves"
GraphicsWindow.Width = gw
GraphicsWindow.Height = gh
GraphicsWindow.BackgroundColor = "LightBlue"
'Reduce gw for options
gw = gw-200
GraphicsWindow.MouseDown = OnMouseDown
Start:
' Gravity, friction and attraction to mouse
grav = 0.0 ' 0 for none
fric = 0 ' 0 for none
follow = 0 'attract to mouse
attract = 0 'attract balls to each other
dt = 1 'timestep (speed)
shape = 0 '0:ball,1 square
elastic = 1 '1 fully elastic collisions
Colour = "Yellow"
'Initialise some balls
radius = 10 'INITIAL BALL SIZE
diam = 2*radius
'THE NUMBER OF BALLS At start Nball
nball = Math.Floor(gw/diam)
istart = "True"
reset()
ireset = "False"
istart = "False"
iend = "False"
iselect = "False"
ioptions = "False"
'Show window - an MS comment
GraphicsWindow.Show()
'**********************************************************
'CUMULATORS for ke per area
AccKElow=0
AccKEHigh=0
TimeAverageKEHigh=0
TimeAverageKELow=0
PressureRatio=1
'CUMULATORS for Ke per particle
AccumKEPerPartHigh=0
AccumKEPerPartLow=0
AccumCount=0
AccumNHigh=0
AccumNLow=0
AvKEperPartHigh=0
AvKEperPartLow=0
'*****************************************************************
'Main loop
While ("True")
If (ioptions) Then
options()
ioptions = "False"
EndIf
energy = 0.0
isCollision = "False"
If (iselect) Then
For i = 1 To nball
x = Xpos[i]
y = Ypos[i]
dist = (xm-x)*(xm-x)+(ym-y)*(ym-y)
If (dist < radius*radius) Then
u = 0
v = 0
Xvel[i] = u
Yvel[i] = v
EndIf
EndFor
iselect = "False"
EndIf
'SET KE VARIABLES TO ZERO
KEHIGH=0
KELOW=0
kesum=0
NHigh=0
NLow=0
KEperparticleHigh=0
KEperparticleLow=0
For i = 1 To nball
update()
move()
u = Xvel[i]
v = Yvel[i]
energy = energy+(u*u+v*v)
'my total AT HEIGHT enrgy calc
energy = dt*dt*energy
energy = Math.Floor(energy)
GraphicsWindow.BrushColor = "LightBlue"
GraphicsWindow.FillRectangle(gw+1,KET+gh-230,200,165)
GraphicsWindow.BrushColor = "Black"
' GraphicsWindow.DrawText(gw+65,560,"Energy "+energy)
'*************************************************************************************
GraphicsWindow.DrawText(gw+65,KET+gh-230,"KE Per Area Top "+KEPrintHIGH)
GraphicsWindow.DrawText(gw+45,KET+gh-220,"KE per Area Bottom "+KEPrintLOW)
GraphicsWindow.DrawText(gw+10,KET+gh-180,"KE per particle Top "+KEperparticleHigh)
GraphicsWindow.DrawText(gw+10,KET+gh-160,"KE per particle Bott "+KEperparticleLow)
GraphicsWindow.DrawText(gw+0,KET+gh-140,"Time Av. KE per partic Top "+AvKEperPartHigh)
GraphicsWindow.DrawText(gw+0,KET+gh-120,"Time Av. KE per partic Bott "+AvKEperPartLow)
GraphicsWindow.DrawText(gw+0,KET+gh-100,"Time Av.'Temperature' Ratio "+TemperatureRatio)
GraphicsWindow.DrawText(gw+45,KET+gh-80,"KE Total "+KEPrintSum)
' *********************************************************************************************
If (ireset) Then
reset()
ireset = "False"
EndIf
If (istart) Then
Goto Start
EndIf
If (iend) Then
Program.End()
EndIf
' If (isCollision) Then
' Sound.PlayClick()
' EndIf
Program.Delay(10)
EndWhile
'Update ball positions
Sub update
u = Xvel[i]
v = Yvel[i]
u = Math.Min(100,Math.Max(u,-100))
v = Math.Min(100,Math.Max(v,-100))
x = Xpos[i]+dt*u
y = Ypos[i]+dt*v
bounce()
gravity()
collision()
attraction()
Xpos[i] = x
Ypos[i] = y
EndSub
'Check for edge bounces
Sub bounce
If (x < radius) Then
Xvel[i] = -Xvel[i]
x = radius
EndIf
If (x > gw-radius) Then
Xvel[i] = -Xvel[i]
x = gw-radius
EndIf
'TO MAKE BOX higher (off screen) add 1000 or whatever to y
If (y < radius) Then
Yvel[i] = -Yvel[i]
y = radius
EndIf
If (y > gh-radius) Then
Yvel[i] = -Yvel[i]
y = gh-radius
EndIf
EndSub
'Check for collisions
Sub collision
'Only check each pair once
For j = i+1 To nball
xi = x
yi = y
xj = Xpos[j]
yj = Ypos[j]
dx = xi-xj
dy = yi-yj
dist = Math.SquareRoot(dx*dx+dy*dy)
If (dist < diam) Then
isCollision = "True"
'Get ball vectors
ui = Xvel[i]
vi = Yvel[i]
uj = Xvel[j]
vj = Yvel[j]
'Move backwards (forwards if dt < 0) in time until balls are just touching
CoefA = (ui-uj)*(ui-uj)+(vi-vj)*(vi-vj)
CoefB = 2*((ui-uj)*(xi-xj)+(vi-vj)*(yi-yj))
CoefC = (xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)-diam*diam
If (CoefA = 0) Then
t = -CoefC/CoefB
Else
If (dt >= 0) Then
t = (-CoefB-Math.SquareRoot(CoefB*CoefB-4*CoefA*CoefC))/(2*CoefA)
Else
t = (-CoefB+Math.SquareRoot(CoefB*CoefB-4*CoefA*CoefC))/(2*CoefA)
EndIf
EndIF
xi = xi+t*ui
yi = yi+t*vi
xj = xj+t*uj
yj = yj+t*vj
'Centre of momentum coordinates
mx = (ui+uj)/2
my = (vi+vj)/2
ui = ui-mx
vi = vi-my
uj = uj-mx
vj = vj-my
'New centre to centre line
dx = xi-xj
dy = yi-yj
dist = Math.SquareRoot(dx*dx+dy*dy)
dx = dx/dist
dy = dy/dist
'Reflect balls velocity vectors in centre to centre line
OB = -(dx*ui+dy*vi)
ui = ui+2*OB*dx
vi = vi+2*OB*dy
OB = -(dx*uj+dy*vj)
uj = uj+2*OB*dx
vj = vj+2*OB*dy
'Back to moving coordinates with elastic velocity change
e = Math.SquareRoot(elastic)
ui = e*(ui+mx)
vi = e*(vi+my)
uj = e*(uj+mx)
vj = e*(vj+my)
'Move to new bounced position
xi = xi-t*ui
yi = yi-t*vi
xj = xj-t*uj
yj = yj-t*vj
'Set velocities
Xvel[i] = ui
Yvel[i] = vi
Xvel[j] = uj
Yvel[j] = vj
'Set position
Xpos[j] = xj
Ypos[j] = yj
x = xi
y = yi
EndIf
EndFor
EndSub
'Gravity and friction and follow mouse
Sub gravity
xm = GraphicsWindow.MouseX-x
ym = GraphicsWindow.MouseY-y
dist = xm*xm+ym*ym
dist = Math.Max(dist,radius*radius)
'dist = dist*Math.SquareRoot(dist)
u = Xvel[i]
v = Yvel[i]
fricscale = (1-fric/Math.SquareRoot(1+u*u+v*v))
Xvel[i] = follow*xm/dist+fricscale*u
Yvel[i] = follow*ym/dist+fricscale*v+grav
EndSub
'Attract-repell balls to each other
Sub attraction
If (attract <> 0) Then
For j = i+1 To nball
xm = Xpos[j]-x
ym = Ypos[j]-y
dist = xm*xm+ym*ym
dist = Math.Max(dist,radius*radius)
'dist = dist*Math.SquareRoot(dist)
Xvel[i] = attract*xm/dist+Xvel[i]
Yvel[i] = attract*ym/dist+Yvel[i]
Xvel[j] = attract*xm/dist+Xvel[j]
Yvel[j] = -attract*ym/dist+Yvel[j]
EndFor
EndIf
EndSub
'Move ball
Sub move
ball = balls[i]
Shapes.Move(ball,x-radius,y-radius)
'Draw a Horizontal dividing line for top and bottom halves
GraphicsWindow.DrawLine(00,gh/2,800,gh/2)
EndSub
'Update options display
Sub options
GraphicsWindow.PenColor = "Black"
GraphicsWindow.DrawLine(gw,0,gw,gh)
GraphicsWindow.BrushColor = "LightBlue"
GraphicsWindow.FillRectangle(gw+10,10,190,gh-20)
For i = 0 To 5
GraphicsWindow.DrawLine(gw+10,100*i+10,gw+190,100*i+10)
EndFor
GraphicsWindow.DrawLine(gw+100,10,gw+100,510)
'Change settings
Sub OnMouseDown
xm = GraphicsWindow.MouseX
ym = GraphicsWindow.MouseY
'Left column settings
If (xm > gw+15 And xm < gw+85) Then
If (ym > 60 And ym < 75) Then
grav = grav+0.01
EndIf
If (ym > 80 And ym < 95) Then
grav = grav-0.01
EndIf
If (ym > 160 And ym < 175) Then
fric = fric+0.001
EndIf
If (ym > 180 And ym < 195) Then
fric = fric-0.001
EndIf
If (ym > 260 And ym < 275) Then
follow = follow+1
EndIf
If (ym > 280 And ym < 295) Then
follow = follow-1
EndIf
If (ym > 360 And ym < 375) Then
radius = radius+1
diam = 2*radius
ireset = "True"
EndIf
If (ym > 380 And ym < 395) Then
radius = radius-1
radius = Math.Max(1,radius)
diam = 2*radius
ireset = "True"
EndIf
If (ym > 460 And ym < 475) Then
nball = nball+1
ireset = "True"
EndIf
If (ym > 480 And ym < 495) Then
nball = nball-1
nball = Math.Max(1,nball)
ireset = "True"
EndIf
If (ym > KET+gh-250 And ym < KET+gh-220) Then 'reset balls
istart = "True"
EndIf
'Resest the KE Accumulators
If (ym > KET+gh-40 And ym < KET+gh-10) Then
AccumClear()
EndIf
EndIf
'Right column settings
If (xm > gw+115 And xm < gw+185) Then
If (ym > 60 And ym < 75) Then
dt = dt+0.1
EndIf
If (ym > 80 And ym < 95) Then
dt = dt-0.1
EndIf
If (ym > 160 And ym < 175) Then
attract = attract+1
EndIf
If (ym > 180 And ym < 195) Then
attract = attract-1
EndIf
If (ym > 260 And ym < 275) Then
elastic = elastic+0.01
EndIf
If (ym > 280 And ym < 295) Then
elastic = elastic-0.01
EndIf
If (ym > 340 And ym < 355) Then
Colour = "Red"
ireset = "True"
EndIf
If (ym > 360 And ym < 375) Then
Colour = "Blue"
ireset = "True"
EndIf
If (ym > 380 And ym < 395) Then
Colour = "Yellow"
ireset = "True"
EndIf
If (ym > 440 And ym < 455) Then
Shape = 0
ireset = "True"
EndIf
If (ym > 460 And ym < 475) Then
Shape = 1
ireset = "True"
EndIf
If (ym > 580 And ym < 595) Then
iend = "True"
EndIf
EndIf
'Select a ball
If (xm < gw) Then
iselect = "True"
EndIf
ioptions = "True"
EndSub
'Reset new balls
Sub reset
mball = Array.GetItemCount(balls)
For i = 1 To mball
balls[i] = ""
If (istart Or i > nball) Then
Xpos[i] = ""
Ypos[i] = ""
Xvel[i] = ""
Yvel[i] = ""
EndIf
EndFor
GraphicsWindow.Clear()
options()
GraphicsWindow.BrushColor = Colour
For i = 1 To nball
If (shape = 0) Then
ball = Shapes.AddEllipse(diam,diam)
EndIf
If (shape = 1) Then
ball = Shapes.AddRectangle(diam,diam)
EndIf
balls[i] = ball
If (istart Or i > mball) Then
x = Math.GetRandomNumber(gw)
y = Math.GetRandomNumber(gh)
u = Math.GetRandomNumber(500)/100-3
v = Math.GetRandomNumber(500)/100-3
Xpos[i] = x
Ypos[i] = y
Xvel[i] = u
Yvel[i] = v
EndIf
EndFor
EndSub
Sub AccumClear
'CUMULATORS for ke per area
AccKElow=0
AccKEHigh=0
TimeAverageKEHigh=0
TimeAverageKELow=0
PressureRatio=1
'CUMULATORS for Ke per particle
AccumKEPerPartHigh=0
AccumKEPerPartLow=0
AccumCount=0
AccumNHigh=0
AccumNLow=0
AvKEperPartHigh=0
AvKEperPartLow=0
Program Listing: XKT572