本帖最后由 LonghronShen 于 2012-6-22 22:41 编辑
都占坑了啊，那我也来一个
先做出基础题。
算法：
ImportsMicrosoft.Xna.Framework
ImportsSystem.Runtime.CompilerServices
 
ModuleModuleMain
 
    Public Class Ball
 
        Public Property Center() As Vector3
        Public Property R() As Double
        Public Property Mass() As Double
 
        Public ReadOnly Property IsLegal() As Boolean
            Get
                With Me.Center
                    Dim parts = {.X,.Y, .Z}
                    For Each p In parts
                        If Single.IsInfinity(p)Or Single.IsNaN(p)Then
                            Return False
                        End If
                    Next
                End With
                Return Me.R <>0
            End Get
        End Property
 
        Public Sub New()
            Me.Center =Vector3.Zero
            Me.R = 0
        End Sub
 
        Public Sub New(ByVal p As Vector3, ByVal r As Double, ByVal m As Double)
            Me.Center = p
            Me.R = r
            Me.Mass = m
        End Sub
 
        Public Sub New(ByVal p As Vector4)
            Me.Center = New Vector3(p.X,p.Y, p.Z)
            Me.R = p.W
        End Sub
 
        Public Sub New(ByVal ParamArray p() As Double)
            If p.Length >= 4 Then
                Me.Center = New Vector3(p(0), p(1), p(2))
                Me.R = p(3)
                If p.Length >=5 Then
                    Me.Mass =p(4)
                End If
            Else
                Throw New ArgumentException("Too few arguments for Ball contructor.")
            End If
        End Sub
 
    End Class
 
    Public Function CreateVector4FromString(ByVal s As String, ByVal ParamArray sp() As String) As Vector4
        Dim parts = s.Split(sp,StringSplitOptions.RemoveEmptyEntries)
        If parts.Length >= 4 Then
            Return New Vector4(parts(0), parts(1), parts(2), parts(3))
        Else
            Throw New ArgumentException("Wrong format for Vector4.")
        End If
    End Function
 
    Public Function CreateVector3FromString(ByVal s As String, ByVal ParamArray sp() As String) As Vector3
        Dim parts = s.Split(sp,StringSplitOptions.RemoveEmptyEntries)
        If parts.Length >= 3 Then
            Return New Vector3(parts(0), parts(1), parts(2))
        Else
            Throw New ArgumentException("Wrong format for Vector3.")
        End If
    End Function
 
    Public Function Root(ByVal f As Func(Of Double, Double), ByVal f_ As Func(Of Double, Double), Optional ByVal x As Double = 0) As Double
        If f(x) = 0 Then Return x
        Dim stw As New Stopwatch()
        stw.Start()
        Dim x0 = x
        Do
            x0 = x
            Dim vf = f(x0)
            Dim vf_ = f_(x0)
            x = x - vf/ vf_
        Loop While Math.Abs((x - x0))>= 0.00001 Andstw.Elapsed.TotalSeconds < 20
        stw.Stop()
        If stw.Elapsed.TotalSeconds >20 Then
            Throw New ArgumentException("Timeout when finding the root.")
        End If
        Return x
    End Function
 
    Public Function GenericCast(Of U, V)(ByVal obj As U) As V
        Try
            Return CType(DirectCast(obj, Object), V)
        Catch ex As InvalidCastException
            Return DirectCast(CompilerServices.Conversions.ChangeType(obj,GetType(V)), V)
        End Try
    End Function
 
    <Extension()>_
    Public Function OfType(Of U, V)(ByVal [Me] As IEnumerable(OfU)) As IEnumerable(OfV)
        Dim lst As New List(Of V)
        For Each item In [Me]
            lst.Add(GenericCast(OfU, V)(item))
        Next
        Return lst
    End Function
 
    Public Sub Pause()
        Console.WriteLine("Press any key to continue.")
        Console.ReadKey(True)
    End Sub
 
    Sub Main()
        While True
            Try
                Console.WriteLine("Please input data for the first ball.")
                Console.WriteLine("x, y, z, r,[m]")
                Dim b1 = New Ball(Console.ReadLine().Split(",").OfType(Of Double)().ToArray())
                If b1.IsLegal =False Then
                    Throw New ArgumentException("The data for the first ball is illegal.")
                End If
 
                Console.WriteLine("Please input data for the second ball.")
                Console.WriteLine("x, y, z, r,[m]")
                Dim b2 = New Ball(Console.ReadLine().Split(",").OfType(Of Double)().ToArray())
                If b2.IsLegal =False Then
                    Throw New ArgumentException("The data forthe second ball is illegal.")
                End If
 
                Console.WriteLine("Please input the velocity for the first ball.")
                Console.WriteLine("Vector3: x, y,z")
                Dim v1 =CreateVector3FromString(Console.ReadLine(), ",")
 
                Console.WriteLine("Please input the velocity for the second ball.")
                Console.WriteLine("Vector3: x, y,z")
                Dim v2 = CreateVector3FromString(Console.ReadLine(),",")
 
                Dim dis =
                    Function(t As Double)
                        Return Vector3.Distance(
                            New Vector3(b1.Center.X+ v1.X * t,
                                       b1.Center.Y + v1.Y * t,
                                       b1.Center.Z + v1.Z * t),
                            New Vector3(b2.Center.X+ v2.X * t,
                                       b2.Center.Y + v2.Y * t,
                                       b2.Center.Z + v2.Z * t))
                    End Function
                Dim _dis =
                    Function(t As Double)
                        Dim g_ = Function(_t As Double)
                                    Return 2 * (Vector3.Distance(v1,v2) ^ 2) * _t +
                                       2 * ((b1.Center.X- b2.Center.X) * (v1.X - v2.X) +
                                             (b1.Center.Y- b2.Center.Y) * (v1.Y - v2.Y) +
                                             (b1.Center.Z- b2.Center.Z) * (v1.Z - v2.Z))
                                 End Function
                        Return 0.5 * Math.Pow(dis(t)^ 2, -0.5) * g_(t)
                    End Function
 
                Dim time = Root(dis,_dis)
                If dis(time)<= Math.Abs(b1.R + b2.R) Then
                    Dim oldColor =Console.ForegroundColor
                   Console.ForegroundColor = ConsoleColor.Red
                    Console.WriteLine("The two balls will collide with each other.")
                   Console.ForegroundColor = oldColor                    
                Else
                   Console.WriteLine("The two balls will not collide with eachother.")
                End If
 
                Call Pause()
            Catch ex As Exception
                Console.WriteLine(ex.Message& vbCrLf & ex.StackTrace.ToString())
                Call Pause()
                Console.Clear()
                Continue While
            End Try
        End While
    End Sub
 
End Module