VERSION 5.00 Begin VB.Form frmMain Caption = "Form1" ClientHeight = 3090 ClientLeft = 60 ClientTop = 450 ClientWidth = 4680 LinkTopic = "Form1" ScaleHeight = 3090 ScaleWidth = 4680 StartUpPosition = 3 'Windows Default End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Var() As Any) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long) Private Type Vector X As Single Y As Single End Type Private Const PI As Single = 3.14159265358979 'Atn(1) * 4 Private Const World_Size = 200 Private Position(100) As Vector Private Vertex_List(100) As Vector Private Vertex_List2(100) As Vector Private Number_Of_Vertices(100) As Long Private Ncoll As Vector Private Dcoll As Single Private Running As Boolean Private Collided As Boolean Private Function Vector_New(ByVal X As Single, ByVal Y As Single) As Vector Vector_New.X = X Vector_New.Y = Y End Function Private Function Vector_Subtract(A As Vector, B As Vector) As Vector Vector_Subtract.X = A.X - B.X Vector_Subtract.Y = A.Y - B.Y End Function Private Function Vector_Multiply(A As Vector, B As Vector) As Single Vector_Multiply = A.X * B.X + A.Y * B.Y End Function Private Function Vector_Multiply2(A As Vector, Value As Single) As Vector Vector_Multiply2 = Vector_New(A.X * Value, A.Y * Value) End Function Private Function Vector_Multiply3(Value As Single, A As Vector) As Vector Vector_Multiply3 = Vector_New(A.X * Value, A.Y * Value) End Function Private Function Randomise(Min As Vector, Max As Vector) As Vector Randomise.X = Rnd * (Max.X - Min.X) + Min.X Randomise.Y = Rnd * (Max.Y - Min.Y) + Min.Y End Function Private Function IsArrayInitialised(ByVal Array_Pointer As Long) As Boolean Dim Destination_Pointer As Long IsArrayInitialised = False CopyMemory Destination_Pointer, ByVal Array_Pointer, 4 If Destination_Pointer = False Then IsArrayInitialised = False Else IsArrayInitialised = True End If End Function Private Sub Draw_Polygon(X As Single, Y As Single, Vertex_List() As Vector, Number_Of_Vertices As Long, Color As Long, Optional Rand As Boolean) Dim I As Long For I = 0 To Number_Of_Vertices - 1 If Rand = True Then Color = RGB(Rnd * 255, Rnd * 255, Rnd * 255) If I < (Number_Of_Vertices - 1) Then frmMain.Line (X + Vertex_List(I).X, Y + Vertex_List(I).Y)-(X + Vertex_List(I + 1).X, Y + Vertex_List(I + 1).Y), Color ElseIf I = (Number_Of_Vertices - 1) Then frmMain.Line (X + Vertex_List(Number_Of_Vertices - 1).X, Y + Vertex_List(Number_Of_Vertices - 1).Y)-(X + Vertex_List(0).X, Y + Vertex_List(0).Y), Color End If Next I End Sub Private Sub Build_Box(Vertex_List() As Vector, Number_Of_Vertices As Long, Width As Single, Height As Single) Dim Vertex_List() As Vector: ReDim Vertex_List(3) As Vector Vertex_List(0) = Vector_New(-Width / 2, -Height / 2) Vertex_List(1) = Vector_New(Width / 2, -Height / 2) Vertex_List(2) = Vector_New(Width / 2, Height / 2) Vertex_List(3) = Vector_New(-Width / 2, Height / 2) Number_Of_Vertices = 4 Dim I As Long For I = 0 To Number_Of_Vertices - 1 Vertex_List(I) = Vertex_List(I) Next I End Sub Private Sub Build_Blob(Number_Of_Vertices As Long, Radius As Single, Vertex_List() As Vector) Dim I As Long For I = 0 To Number_Of_Vertices - 1 Dim A As Single: A = 2 * PI * (I / Number_Of_Vertices - 1) Vertex_List(I) = Vector_Multiply2(Vector_New(Cos(A), Sin(A)), Radius) Next I End Sub Private Function Collide(A() As Vector, B() As Vector, Number_Of_VerticesA As Long, Number_Of_VerticesB As Long, Offset As Vector, N As Vector, T As Single) As Boolean If IsArrayInitialised(VarPtrArray(A())) = False And IsArrayInitialised(VarPtrArray(B())) = False Then Collide = False Exit Function End If Dim Axis(64) As Vector Dim TAxis(64) As Single Dim Number_Of_Axes As Long: Number_Of_Axes = 0 Dim I As Long, J As Long Dim E0 As Vector Dim E1 As Vector Dim E As Vector J = Number_Of_VerticesA - 1 For I = 0 To J E0 = A(J) E1 = A(I) E = Vector_Subtract(E1, E0) Axis(Number_Of_Axes).X = -E.Y Axis(Number_Of_Axes).Y = E.X If (Interval_Intersect(A(), B(), Number_Of_VerticesA, Number_Of_VerticesB, Axis(Number_Of_Axes), Offset, TAxis(Number_Of_Axes))) = False Then Collide = False Exit Function End If Number_Of_Axes = Number_Of_Axes + 1 J = I Next I J = Number_Of_VerticesB - 1 For I = 0 To J E0 = B(J) E1 = B(I) E = Vector_Subtract(E1, E0) Axis(Number_Of_Axes).X = -E.Y Axis(Number_Of_Axes).Y = E.X If (Interval_Intersect(A(), B(), Number_Of_VerticesA, Number_Of_VerticesB, Axis(Number_Of_Axes), Offset, TAxis(Number_Of_Axes))) = False Then Collide = False Exit Function End If Number_Of_Axes = Number_Of_Axes + 1 J = I Next I If (Find_Minimum_Translation_Distance(Axis(), TAxis(), Number_Of_Axes, N, T)) = False Then Collide = False Exit Function End If If Vector_Multiply(N, Offset) < 0 Then N.X = -N.X N.Y = -N.Y End If Collide = True End Function Private Sub Get_Interval(Vertex_List() As Vector, Number_Of_Vertices As Long, Axis As Vector, Min As Single, Max As Single) Min = Vector_Multiply(Vertex_List(0), Axis) Max = Vector_Multiply(Vertex_List(0), Axis) Dim I As Long For I = 1 To Number_Of_Vertices - 1 Dim D As Single: D = Vector_Multiply(Vertex_List(I), Axis) If (D < Min) Then Min = D ElseIf (D > Max) Then Max = D End If Next I End Sub Private Function Interval_Intersect(A() As Vector, B() As Vector, Number_Of_VerticesA As Long, Number_Of_VerticesB As Long, Axis As Vector, Offset As Vector, TAxis As Single) As Boolean Dim Min(1) As Single, Max(1) As Single Get_Interval A(), Number_Of_VerticesA, Axis, Min(0), Max(0) Get_Interval B(), Number_Of_VerticesB, Axis, Min(1), Max(1) Dim h As Single: h = Vector_Multiply(Offset, Axis) Min(0) = Min(0) + h Max(0) = Max(0) + h Dim D0 As Single: D0 = Min(0) - Max(1) Dim D1 As Single: D1 = Min(1) - Max(0) If ((D0 > 0) Or (D1 > 0)) Then Interval_Intersect = False Exit Function Else If D0 > D1 Then TAxis = D0 Else TAxis = D1 End If Interval_Intersect = True Exit Function End If End Function Private Function Normalize(A As Vector) As Single Dim Length As Single: Length = Sqr(A.X * A.X + A.Y * A.Y) If (Length = 0) Then Normalize = 0 Exit Function End If A = Vector_Multiply2(A, (1 / Length)) Normalize = Length End Function Private Function Find_Minimum_Translation_Distance(Axis() As Vector, TAxis() As Single, Number_Of_Axes As Long, N As Vector, T As Single) As Boolean Dim Mini As Long: Mini = -1 T = 0 N = Vector_New(0, 0) Dim I As Long For I = 0 To Number_Of_Axes - 1 Dim N2 As Single: N2 = Normalize(Axis(I)) TAxis(I) = TAxis(I) / N2 If TAxis(I) > T Or Mini = -1 Then Mini = I T = TAxis(I) N = Axis(I) End If Next I Find_Minimum_Translation_Distance = (Mini <> -1) End Function Private Function Collision_Response() As Boolean If Collided = True Then Position(0) = Vector_Subtract(Position(0), Vector_Multiply2(Ncoll, (Dcoll * 1.01))) Collision_Response = True End If End Function Private Sub Main() Randomize ScaleMode = 3 AutoRedraw = True Dim I As Long Position(0) = Randomise(Vector_New(World_Size * 0.25, World_Size * 0.25), Vector_New(World_Size * 0.75, World_Size * 0.75)) Position(1) = Randomise(Vector_New(World_Size * 0.25, World_Size * 0.25), Vector_New(World_Size * 0.75, World_Size * 0.75)) Number_Of_Vertices(0) = (Rnd * 6 Mod 6) + 3 Number_Of_Vertices(1) = (Rnd * 6 Mod 6) + 3 Dim Radius As Single: Radius = 30 Build_Blob Number_Of_Vertices(0), Radius, Vertex_List() Build_Blob Number_Of_Vertices(1), Radius, Vertex_List2() Running = True Game_Loop End Sub Private Sub Game_Loop() Do While Running = True DoEvents Cls Collided = Collide(Vertex_List(), Vertex_List2(), Number_Of_Vertices(0), Number_Of_Vertices(1), Vector_Subtract(Position(0), Position(1)), Ncoll, Dcoll) If Collided = True Then Collision_Response Draw_Polygon Position(0).X, Position(0).Y, Vertex_List(), Number_Of_Vertices(0), RGB(0, 0, 0), False Draw_Polygon Position(1).X, Position(1).Y, Vertex_List2(), Number_Of_Vertices(1), RGB(0, 0, 0), False Loop End Sub Private Sub Form_Activate() Main End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyLeft Then Position(0).X = Position(0).X - 2 If KeyCode = vbKeyUp Then Position(0).Y = Position(0).Y - 2 If KeyCode = vbKeyRight Then Position(0).X = Position(0).X + 2 If KeyCode = vbKeyDown Then Position(0).Y = Position(0).Y + 2 If KeyCode = vbKeyReturn Then If Collide(Vertex_List(), Vertex_List2(), Number_Of_Vertices(0), Number_Of_Vertices(1), Vector_Subtract(Position(0), Position(1)), Ncoll, Dcoll) = True Then Collision_Response End If End If End Sub Private Sub Form_Unload(Cancel As Integer) Running = False Unload Me End End Sub