Private Type VECTOR
x As Double
Y As Double
End Type
Private Type NewLine
a As VECTOR
b As VECTOR
MinX As Double
MinY As Double
MaxX As Double
MaxY As Double
End Type
Dim Vor As Long
Dim Vox As Long
Dim Lines() As NewLine
Dim PI As Double
Dim Eject As Boolean
Dim DirX As VECTOR
Dim InitDir As VECTOR
Private Sub DrawLine(ByRef a As VECTOR, ByRef b As VECTOR)
Line (a.x, a.Y)-(b.x, b.Y)
End Sub
Function ToDeg(ByVal a As Double) As Double
ToDeg = a * (180 / PI)
End Function
Private Function Subtract(ByRef a As VECTOR, ByRef b As VECTOR) As VECTOR
Subtract.x = a.x - b.x
Subtract.Y = a.Y - b.Y
End Function
Private Function Normalize(ByRef a As VECTOR) As VECTOR
On Error GoTo catcher
Normalize.x = a.x / Length(a)
Normalize.Y = a.Y / Length(a)
Exit Function
catcher:
Normalize.x = 0
Normalize.Y = 0
End Function
Private Function Length(ByRef a As VECTOR) As Double
Length = a.x ^ 2 + a.Y ^ 2
Length = Length ^ 0.5
End Function
Private Function Dot(ByRef a As VECTOR, ByRef b As VECTOR) As Double
On Error GoTo reeeh
Dot = (a.x * b.x) + (a.Y * b.Y)
Dot = Dot / (Length(a) * Length(b))
Exit Function
reeeh:
Dot = 0
End Function
Private Function Mul(ByRef a As VECTOR, ByVal b As Double) As VECTOR
Mul.x = a.x * b
Mul.Y = a.Y * b
End Function
Function Delta(ByVal a As Double, ByVal b As Double) As Double
Delta = a - b
End Function
Function Clamp(ByVal a As Double, ByVal b As Double, ByVal c As Double) As Double
Clamp = a
If Clamp < b Then Clamp = b
If Clamp > c Then Clamp = c
End Function
Private Sub Check1_Click()
Cls
AutoRedraw = Not AutoRedraw
Command1_Click
End Sub
Private Sub Command1_Click()
Eject = True
Form_Activate
End Sub
Private Sub Command2_Click()
Eject = True
Form_Load
Command1_Click
End Sub
Private Sub Form_Activate()
Eject = False
Dim lastimpact As VECTOR
Dim x As Double
Dim Y As Double
Dim x1 As Double
Dim y1 As Double
Dim firstbounce As Boolean
Randomize
Cls
Y = Height / 30
x = 1
moveamt = 1
lastx = x
lasty = Y
DirX = InitDir
lastimpact.x = 1
lastimpact.Y = Y
ForeColor = vbBlack
For i = 1 To UBound(Lines)
DrawWidth = 10
Call DrawLine(Lines(i).a, Lines(i).b)
Next i
DrawWidth = 1
ForeColor = vbRed
PT = Point(0, 0)
Dim eaz As Integer
Do While True
meep:
eaz = eaz + 1
Dim impact As VECTOR
impact.x = x
impact.Y = Y
DoEvents
x1 = x + DirX.x * moveamt
y1 = Y + DirX.Y * moveamt
PT = Point(x1, y1) <> vbBlack
If Not PT Then
Dim pos As VECTOR
pos.x = x1
pos.Y = y1
pos = Normalize(Subtract(pos, lastimpact))
'Pos is the normal of the segment between the current point and where
'it last bounced
'DirX is the current directional vector that desribes the segment
'In the end, I was searching for the entirely wrong thing.
'What I was searching for was the programming term for the object,
'when what I really needed was Projecting Vectors and a few other
'related things.
'Many thanks to 8lank and Cakes for pointing me in the right direction.
i = IsOnLineLong(impact)
If i >= 1 Then
Dim wall As VECTOR
Dim vel As VECTOR
Dim lnm As VECTOR
Dim a As VECTOR
Dim b As VECTOR
Dim proj1 As VECTOR
Dim proj2 As VECTOR
Dim dp1 As Double
Dim dp2 As Double
vel = Subtract(impact, lastimpact)
a.x = Lines(i).MinX
a.Y = Lines(i).MinY
b.x = Lines(i).MaxX
b.Y = Lines(i).MaxY
wall = Subtract(b, a)
lnm.x = wall.Y
lnm.Y = -wall.x
dp1 = Dot(vel, wall)
proj1 = Mul(wall, dp1)
dp2 = Dot(vel, lnm)
proj2 = Mul(Normalize(lnm), dp2)
DirX = Subtract(Normalize(Subtract(proj1, Mul(proj2, -1))), pos)
DirX.x = Clamp(DirX.x, -1, 1)
DirX.Y = Clamp(DirX.Y, -1, 1)
If Length(Subtract(impact, lastimpact)) < 1 Then
'Got stuck
DirX = Mul(DirX, -1)
End If
lastimpact.x = x
lastimpact.Y = Y
End If
End If
x = x + DirX.x * moveamt
Y = Y + DirX.Y * moveamt
Line (lastx, lasty)-(x, Y)
lastx = x
lasty = Y
If x < 0 Or x > Width / 15 Or Y < 0 Or Y > Height / 15 Or Eject Then
Eject = True
Exit Do
End If
If eaz < 400 Then
GoTo meep
Else
eaz = 0
End If
Loop
End Sub
Private Sub Form_Load()
ReDim Lines(0 To 0)
PI = Atn(1) * 4
DirX.x = 1
DirX.Y = -1 + Rnd * 2
InitDir = DirX
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
Vor = x
Vox = Y
Circle (Vor, Vox), 1
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
On Error GoTo catch
If Delta(Vor, x) = 0 Or Delta(Vox, Y) = 0 Then
Exit Sub
End If
ReDim Preserve Lines(0 To UBound(Lines) + 1)
Lines(UBound(Lines)).a.x = Vor
Lines(UBound(Lines)).a.Y = Vox
Lines(UBound(Lines)).b.x = x
Lines(UBound(Lines)).b.Y = Y
If Vor < x Then
Lines(UBound(Lines)).MinX = Vor
Lines(UBound(Lines)).MaxX = x
Else
Lines(UBound(Lines)).MinX = x
Lines(UBound(Lines)).MaxX = Vor
End If
If Vox < Y Then
Lines(UBound(Lines)).MinY = Vox
Lines(UBound(Lines)).MaxY = Y
Else
Lines(UBound(Lines)).MinY = Y
Lines(UBound(Lines)).MaxY = Vox
End If
Circle (x, Y), 1
Line (Vor, Vox)-(x, Y)
Exit Sub
catch:
ReDim Preserve Lines(0 To UBound(Lines) - 1)
End Sub
Private Function IsOnLineQuick(ByRef PT As VECTOR, ByVal i As Long) As Boolean
IsOnLineQuick = False
If Clamp(PT.x, Lines(i).MinX, Lines(i).MaxX) = PT.x And Clamp(PT.Y, Lines(i).MinY, Lines(i).MaxY) Then
IsOnLineQuick = True
End If
End Function
Private Function IsOnLineLong(ByRef PT As VECTOR) As Long
Dim i As Long
For i = 1 To UBound(Lines)
If IsOnLineQuick(PT, i) Then
'Could be on the line, filter out ones that it can't be on.
'Simple InBox test
'If the dot product of the current point between the minumum and maximum
'of the tested line is within a tenth of 1 ( when it's usually within .0001 when corect )
', then it's corect. This is similar to the function guesser that TI8*'s have
'That shows an r=X, and the closer X is to 1, the generally closer it is
'I just guessed at this method and was surprised it even worked ^_^
If (Dot(PT, Lines(i).a) + 0.1) \ 1 = 1 Then
If (Dot(PT, Lines(i).b) + 0.1) \ 1 = 1 Then
IsOnLineLong = i
Exit For
End If
End If
End If
Next i
End Function
Private Sub Form_Unload(Cancel As Integer)
Eject = True
End Sub